module Formalization.Polynomial where

import      Lvl
open import Data.ListSized
open import Numeral.Natural as ℕ using (ℕ)
open import Type

private variable ℓ ℓₑ : Lvl.Level
private variable T : Type{ℓ}
private variable n n₁ n₂ : ℕ

-- TODO: Some of the operations should work with arbitrary Rg structures, not just ℕ, and some other stuff should work with more assumptions. Currently, one of the function that needs to be modified is 𝐷 and normalize for this to work because their implementations depend on ℕ.
-- TODO: Composition of polynomials, power operation

module _ where
  -- A polynomial of a finite degree represented as a list of its coefficients.
  -- Examples:
  --   (a₀⋅x⁰ + a₁⋅x¹ + a₂⋅x² + a₃⋅x³ + a₄⋅x⁴) of degree 4 is [a₀,a₁,a₂,a₃,a₄]
  --   (5 + 7⋅x + x³) of maximal degree 3 is [5,7,0,1]
  Polynomial : ℕ → Type
  Polynomial(n) = List(ℕ)(ℕ.𝐒(n))

  open import Data.ListSized.Functions
  import      Functional as Fn
  open import Logic.Propositional
  open import Logic.Predicate
  import      Numeral.Natural.Function as ℕ
  open import Numeral.Natural.Function.Proofs
  import      Numeral.Natural.Oper as ℕ
  open import Numeral.Natural.Relation.Order
  open import Numeral.Natural.Relation.Order.Proofs
  open import Relator.Equals
  open import Relator.Equals.Proofs.Equiv{T = ℕ}

  -- Constant polynomial.
  -- Semantically, this corresponds to a constant.
  const : ℕ → Polynomial(n)
  const {n} a = a ⊰ repeat ℕ.𝟎 n

  -- Zero polynomial.
  -- Semantically, this corresponds to zero.
  𝟎 : Polynomial(n)
  𝟎 {n} = const{n} ℕ.𝟎

  -- Unit polynomial.
  -- Semantically, this corresponds to one.
  𝟏 : Polynomial(n)
  𝟏 {n} = const{n}(ℕ.𝐒(ℕ.𝟎))

  -- Increases the degree of the polynomial by adding a zero term at the beginning.
  -- Semantically, this corresponds to multiplying the whole polynomial by the variable.
  -- Example: (var⋅ [a₀,a₁,a₂] = [0,a₀,a₁,a₂])
  --   x ⋅ (a₀⋅x⁰ + a₁⋅x¹ + a₂⋅x²)
  --   = a₀⋅x¹ + a₁⋅x² + a₂⋅x³
  var⋅_ : Polynomial(n) → Polynomial(ℕ.𝐒(n))
  var⋅_ = ℕ.𝟎 ⊰_

  -- Single variable polynomial.
  var : Polynomial(ℕ.𝐒(n))
  var = var⋅ 𝟏

  -- Polynomial addition.
  -- Adds the powers component-wise.
  -- Examples: ([a₀,a₁,a₂] + [b₀,b₁,b₂] = [a₀b₀ , a₁+b₁ , a₂+b₂])
  --   (a₀⋅x⁰ + a₁⋅x¹ + a₂⋅x²) + (b₀⋅x⁰ + b₁⋅x¹ + b₂⋅x²)
  --   = (a₀+b₀)⋅x⁰ + (a₁+b₁)⋅x¹ + (a₂+b₂)⋅x²
  --   of maximal degree 2 is [a₀+b₀ , a₁+b₁ , a₂+b₂]
  _+_ : Polynomial(n₁) → Polynomial(n₂) → Polynomial(ℕ.max n₁ n₂)
  _+_ = map₂(ℕ._+_) Fn.id Fn.id

  -- Polymonial scalar multiplication.
  -- Multiplies every component by a factor.
  -- Example: (n ⋅ [a₀,a₁,a₂] = [n⋅a₀ , n⋅a₁ , n⋅a₂])
  --   n ⋅ (a₀⋅x⁰ + a₁⋅x¹ + a₂⋅x²)
  --   = (n⋅a₀)⋅x⁰ + (n⋅a₁)⋅x¹ + (n⋅a₂)⋅x²
  _⋅_ : ℕ → Polynomial(n) → Polynomial(n)
  n ⋅ as = map (n ℕ.⋅_) as

  -- Increases the degree of the polynomial by adding zero terms at the end.
  -- Semantically, this corresponds to adding terms multiplied by zero.
  -- Example: (pad [a₀,a₁,a₂] = [a₀,a₁,a₂,0,0])
  --   a₀⋅x⁰ + a₁⋅x¹ + a₂⋅x²
  --   = a₀⋅x⁰ + a₁⋅x¹ + a₂⋅x² + 0⋅x³ + 0⋅x⁴
  pad : ⦃ _ : (n₁ ≤ n₂)⦄ → Polynomial(n₁) → Polynomial(n₂)
  pad {n₁ = ℕ.𝟎}     {n₂ = ℕ.𝟎}     ⦃ min ⦄  (a ⊰ ∅)  = singleton a
  pad {n₁ = ℕ.𝟎}     {n₂ = ℕ.𝐒(n₂)} ⦃ min ⦄  (a ⊰ ∅)  = a ⊰ 𝟎
  pad {n₁ = ℕ.𝐒(n₁)} {n₂ = ℕ.𝐒(n₂)} ⦃ succ p ⦄ (a ⊰ as) = a ⊰ pad ⦃ p ⦄ as

  -- Polynomial multiplication.
  -- Proof of step:
  --   ∑(0‥𝐒(n₁))(i ↦ aᵢ⋅xⁱ) ⋅ ∑(0‥𝐒(n₂))(i ↦ bᵢ⋅xⁱ)
  --   = (a + ∑(1‥𝐒(n₁))(i ↦ aᵢ⋅xⁱ)) ⋅ (b + ∑(1‥𝐒(n₂))(i ↦ bᵢ⋅xⁱ))
  --   = (a ⋅ b) + (a ⋅ ∑(1‥𝐒(n₂))(i ↦ bᵢ⋅xⁱ)) + (∑(1‥𝐒(n₁))(i ↦ aᵢ⋅xⁱ) ⋅ b) + (∑(1‥𝐒(n₁))(i ↦ aᵢ⋅xⁱ) ⋅ ∑(1‥𝐒(n₂))(i ↦ bᵢ⋅xⁱ))
  --   = (a⋅b) + (a ⋅ ∑(1‥𝐒(n₂))(i ↦ bᵢ⋅xⁱ)) + (∑(1‥𝐒(n₁))(i ↦ aᵢ⋅xⁱ) ⋅ b⋅x) + (∑(1‥𝐒(n₁))(i ↦ aᵢ⋅xⁱ) ⋅ ∑(1‥𝐒(n₂))(i ↦ bᵢ⋅xⁱ))
  --   = (a⋅b) + (a ⋅ ∑(0‥n₂)(i ↦ bᵢ⋅xⁱ)⋅x) + (∑(0‥n₁)(i ↦ aᵢ⋅xⁱ)⋅x ⋅ b) + (∑(1‥𝐒(n₁))(i ↦ aᵢ⋅xⁱ) ⋅ ∑(1‥𝐒(n₂))(i ↦ bᵢ⋅xⁱ))
  --   = (a⋅b) + (a ⋅ ∑(0‥n₂)(i ↦ bᵢ⋅xⁱ))⋅x + (∑(0‥n₁)(i ↦ aᵢ⋅xⁱ) ⋅ b)⋅x + (∑(0‥n₁)(i ↦ aᵢ⋅xⁱ) ⋅ ∑(0‥n₂)(i ↦ bᵢ⋅xⁱ))⋅x²
  --   = (a⋅b) + ((a ⋅ ∑(0‥n₂)(i ↦ bᵢ⋅xⁱ)) + (∑(0‥n₁)(i ↦ aᵢ⋅xⁱ) ⋅ b) + (∑(0‥n₁)(i ↦ aᵢ⋅xⁱ) ⋅ ∑(0‥n₂)(i ↦ bᵢ⋅xⁱ))⋅x)⋅x
  --   Also see `eval-preserves-multiplication`.
  _⨯_ : Polynomial(n₁) → Polynomial(n₂) → Polynomial(n₁ ℕ.+ n₂)
  _⨯_                  as@(_ ⊰ _)       (b ⊰ ∅)          = b ⋅ as
  _⨯_                  (a ⊰ ∅)          bs@(_ ⊰ _ ⊰ _)   = a ⋅ bs
  _⨯_ {ℕ.𝐒 n₁}{ℕ.𝐒 n₂} (a ⊰ as@(_ ⊰ _)) (b ⊰ bs@(_ ⊰ _)) = (a ℕ.⋅ b) ⊰ lr where
    l : Polynomial(n₁ ℕ.+ n₂)
    l = pad ⦃ max-order-[+] ⦄ ((b ⋅ as) + (a ⋅ bs))

    r : Polynomial(ℕ.𝐒(n₁ ℕ.+ n₂))
    r = var⋅ (as ⨯ bs)

    lr : Polynomial(ℕ.𝐒(n₁ ℕ.+ n₂))
    lr = [≡]-substitutionᵣ ([↔]-to-[→] max-defᵣ [≤]-of-[𝐒]) {Polynomial} (l + r)

  normalize : Polynomial(n) → ∃(Polynomial)
  normalize {ℕ.𝟎}   (x ⊰ ∅)      = [∃]-intro ℕ.𝟎 ⦃ x ⊰ ∅ ⦄
  normalize {ℕ.𝐒 n} (ℕ.𝟎 ⊰ p) with normalize{n} p
  ... | [∃]-intro ℕ.𝟎 ⦃ singleton ℕ.𝟎 ⦄ = [∃]-intro ℕ.𝟎      ⦃ singleton ℕ.𝟎 ⦄
  {-# CATCHALL #-}
  ... | [∃]-intro m   ⦃ a ⦄             = [∃]-intro (ℕ.𝐒(m)) ⦃ ℕ.𝟎 ⊰ a ⦄
  normalize {ℕ.𝐒 n} (ℕ.𝐒(x) ⊰ p) = [∃]-map ℕ.𝐒 (ℕ.𝐒(x) ⊰_) (normalize{n} p)

  degree : Polynomial(n) → ℕ
  degree = [∃]-witness Fn.∘ normalize

  𝐷 : Polynomial(n) → Polynomial(ℕ.𝐏(n))
  𝐷 {ℕ.𝟎}   = Fn.id
  𝐷 {ℕ.𝐒 n} = map₂₌(ℕ._⋅_) (accumulateIterate n ℕ.𝐒(ℕ.𝐒(ℕ.𝟎))) Fn.∘ tail

  import Numeral.Natural.Oper.FlooredDivision as ℕ
  ∫ : Polynomial(n) → Polynomial(ℕ.𝐒(n))
  ∫ {n} p = var⋅(map₂₌(ℕ._⌊/⌋₀_) p (accumulateIterate n ℕ.𝐒(ℕ.𝐒(ℕ.𝟎))))

module Semantics where
  open import Data.ListSized.Functions
  open import Logic.Propositional
  open import Numeral.Finite as 𝕟 using (𝕟)
  import      Numeral.Natural.Oper as ℕ
  open import Numeral.Natural.Oper.Proofs
  open import Numeral.Natural.Relation.Order
  open import Relator.Equals.Proofs.Equiv{T = ℕ}
  open import Structure.Function.Multi
  open import Structure.Operator
  open import Structure.Operator.Proofs.Util
  open import Structure.Operator.Properties
  open import Structure.Relator.Properties
  open import Structure.Setoid
  open import Syntax.Function
  open import Syntax.Transitivity

  eval : Polynomial(n) → (ℕ → ℕ)
  eval (singleton a)    _ = a
  eval (a ⊰ al@(_ ⊰ _)) x = a ℕ.+ (x ℕ.⋅ (eval al x))

  module Proofs where
    eval-of-[⊰] : ∀{x}{a}{al : Polynomial(n)} → (eval (a ⊰ al) x ≡ a ℕ.+ (x ℕ.⋅ (eval al x)))
    eval-of-[⊰] {ℕ.𝟎}   {x} {a} {b ⊰ ∅}      = reflexivity(_≡_)
    eval-of-[⊰] {ℕ.𝐒 n} {x} {a} {b ⊰ c ⊰ al} = reflexivity(_≡_)

    eval-preserves-var⋅ : ∀{x}{a : Polynomial(n)} → (eval (var⋅ a) x ≡ x ℕ.⋅ (eval a x))
    eval-preserves-var⋅ {n}{x}{a} = eval-of-[⊰] {n}{x}{ℕ.𝟎}{a}

    eval-preserves-zero : ∀{x} → (eval{n} 𝟎 x ≡ ℕ.𝟎)
    eval-preserves-zero {ℕ.𝟎}   {x} = reflexivity(_≡_)
    eval-preserves-zero {ℕ.𝐒 n} {x} =
      eval(𝟎 {ℕ.𝐒 n}) x              🝖[ _≡_ ]-[]
      eval(ℕ.𝟎 ⊰ 𝟎 {n}) x            🝖[ _≡_ ]-[]
      ℕ.𝟎 ℕ.+ (x ℕ.⋅ eval (𝟎 {n}) x) 🝖[ _≡_ ]-[]
      x ℕ.⋅ eval (𝟎 {n}) x           🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._⋅_)(x) (eval-preserves-zero{n}{x}) ]
      x ℕ.⋅ ℕ.𝟎                      🝖[ _≡_ ]-[ absorberᵣ(ℕ._⋅_)(ℕ.𝟎) {x} ]
      ℕ.𝟎                            🝖-end

    eval-preserves-const : ∀{x}{a} → (eval{n} (const a) x ≡ a)
    eval-preserves-const {ℕ.𝟎}   {x}{a} = reflexivity(_≡_)
    eval-preserves-const {ℕ.𝐒 n} {x}{a} =
      eval{ℕ.𝐒 n} (const a) x                  🝖[ _≡_ ]-[]
      eval(a ⊰ repeat ℕ.𝟎 (ℕ.𝐒 n)) x           🝖[ _≡_ ]-[ eval-of-[⊰] {x = x}{a}{repeat ℕ.𝟎 (ℕ.𝐒 n)} ]
      a ℕ.+ (x ℕ.⋅ eval(repeat ℕ.𝟎 (ℕ.𝐒 n)) x) 🝖[ _≡_ ]-[]
      a ℕ.+ (x ℕ.⋅ eval{n} 𝟎 x)                🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a) (eval-preserves-zero{ℕ.𝐒 n}{x = x}) ]
      a ℕ.+ (x ℕ.⋅ ℕ.𝟎)                        🝖[ _≡_ ]-[]
      a ℕ.+ ℕ.𝟎                                🝖[ _≡_ ]-[ identityᵣ(ℕ._+_)(ℕ.𝟎) ]
      a                                        🝖-end

    eval-preserves-one : ∀{x} → (eval{n} 𝟏 x ≡ ℕ.𝐒(ℕ.𝟎))
    eval-preserves-one {n}{x} = eval-preserves-const {n}{x}{ℕ.𝐒(ℕ.𝟎)}

    eval-preserves-var : ∀{x}{a : Polynomial(n)} → (eval (var{n}) x ≡ x)
    eval-preserves-var {n}{x}{a} =
      eval (var{n}) x      🝖[ _≡_ ]-[ eval-preserves-var⋅{n}{x}{𝟏} ]
      x ℕ.⋅ eval (𝟏 {n}) x 🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._⋅_)(x) (eval-preserves-one {n}{x}) ]
      x ℕ.⋅ ℕ.𝐒(ℕ.𝟎)       🝖[ _≡_ ]-[ identityᵣ(ℕ._⋅_)(ℕ.𝐒(ℕ.𝟎)) {x} ]
      x                    🝖-end

    eval-preserves-addition : ∀{x}{a : Polynomial(n₁)}{b : Polynomial(n₂)} → (eval (a + b) x ≡ (eval a x) ℕ.+ (eval b x))
    eval-preserves-addition {x = x} {singleton a}    {singleton b}    = reflexivity(_≡_)
    eval-preserves-addition {x = x} {singleton a}    {b ⊰ bs@(_ ⊰ _)} = associativity(ℕ._+_) {a}{b}
    eval-preserves-addition {x = x} {a ⊰ as@(_ ⊰ _)} {singleton b}    =
      eval ((a ⊰ as) + (singleton b)) x            🝖[ _≡_ ]-[]
      (a ℕ.+ b) ℕ.+ (x ℕ.⋅ (eval as x))            🝖[ _≡_ ]-[ associativity(ℕ._+_) {a}{b} ]
      a ℕ.+ (b ℕ.+ (x ℕ.⋅ (eval as x)))            🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a) (commutativity(ℕ._+_) {x = b}) ]
      a ℕ.+ ((x ℕ.⋅ (eval as x)) ℕ.+ b)            🝖[ _≡_ ]-[ associativity(ℕ._+_) {a}{x ℕ.⋅ eval as x} ]-sym
      (a ℕ.+ (x ℕ.⋅ (eval as x))) ℕ.+ b            🝖[ _≡_ ]-[]
      (eval (a ⊰ as) x) ℕ.+ (eval (singleton b) x) 🝖-end
    eval-preserves-addition {x = x} {a ⊰ as@(_ ⊰ _)} {b ⊰ bs@(_ ⊰ _)} =
      eval ((a ⊰ as) + (b ⊰ bs)) x                                  🝖[ _≡_ ]-[]
      eval ((a ℕ.+ b) ⊰ (as + bs)) x                                🝖[ _≡_ ]-[]
      (a ℕ.+ b) ℕ.+ (x ℕ.⋅ (eval (as + bs) x))                      🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.+ b) (congruence₂ᵣ(ℕ._⋅_)(x) (eval-preserves-addition {x = x}{as}{bs})) ]
      (a ℕ.+ b) ℕ.+ (x ℕ.⋅ ((eval as x) ℕ.+ (eval bs x)))           🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.+ b) (distributivityₗ(ℕ._⋅_)(ℕ._+_) {x}{eval as x}{eval bs x}) ]
      (a ℕ.+ b) ℕ.+ ((x ℕ.⋅ (eval as x)) ℕ.+ (x ℕ.⋅ (eval bs x)))   🝖[ _≡_ ]-[ One.associate-commute4 {a = a}{b = b}{c = x ℕ.⋅ (eval as x)}{d = x ℕ.⋅ (eval bs x)} (commutativity(ℕ._+_) {b}) ]
      (a ℕ.+ (x ℕ.⋅ (eval as x))) ℕ.+ (b ℕ.+ (x ℕ.⋅ (eval bs x)))   🝖[ _≡_ ]-[]
      (eval (a ⊰ as) x) ℕ.+ (eval (b ⊰ bs) x)                       🝖-end

    eval-preserves-scalar-multiplication : ∀{x}{a}{b : Polynomial(n)} → (eval (a ⋅ b) x ≡ a ℕ.⋅ (eval b x))
    eval-preserves-scalar-multiplication {ℕ.𝟎}   {x} {a} {b ⊰ ∅} = reflexivity(_≡_)
    eval-preserves-scalar-multiplication {ℕ.𝐒 n} {x} {a} {b ⊰ bs@(_ ⊰ _)} =
      eval (a ⋅ (b ⊰ bs)) x                     🝖[ _≡_ ]-[]
      eval ((a ℕ.⋅ b) ⊰ (a ⋅ bs)) x             🝖[ _≡_ ]-[]
      (a ℕ.⋅ b) ℕ.+ (x ℕ.⋅ (eval (a ⋅ bs) x))   🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.⋅ b) (congruence₂ᵣ(ℕ._⋅_)(x) (eval-preserves-scalar-multiplication {n} {x}{a}{bs})) ]
      (a ℕ.⋅ b) ℕ.+ (x ℕ.⋅ (a ℕ.⋅ (eval bs x))) 🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.⋅ b) (One.commuteₗ-assocᵣ {a = x}{b = a}{c = eval bs x}) ]
      (a ℕ.⋅ b) ℕ.+ (a ℕ.⋅ (x ℕ.⋅ (eval bs x))) 🝖[ _≡_ ]-[ distributivityₗ(ℕ._⋅_)(ℕ._+_) {x = a}{y = b}{z = x ℕ.⋅ (eval bs x)} ]-sym
      a ℕ.⋅ (b ℕ.+ (x ℕ.⋅ (eval bs x)))         🝖[ _≡_ ]-[]
      a ℕ.⋅ eval (b ⊰ bs) x                     🝖-end

    eval-preserves-pad : ∀{x}{a : Polynomial(n₁)} ⦃ ord : (n₁ ≤ n₂) ⦄ → (eval (pad ⦃ ord ⦄ a) x ≡ eval a x)
    eval-preserves-pad {ℕ.𝟎}    {ℕ.𝟎}    {x} {a ⊰ ∅}          ⦃ ord@min ⦄  = reflexivity(_≡_)
    eval-preserves-pad {ℕ.𝟎}    {ℕ.𝐒 n₂} {x} {a ⊰ ∅}          ⦃ ord@min ⦄  =
      eval (pad ⦃ ord ⦄ (a ⊰ ∅)) x  🝖[ _≡_ ]-[]
      a ℕ.+ (x ℕ.⋅ eval (𝟎 {n₂}) x) 🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a) (congruence₂ᵣ(ℕ._⋅_)(x) (eval-preserves-zero{n₂}{x})) ]
      a ℕ.+ (x ℕ.⋅ ℕ.𝟎)             🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a) (absorberᵣ(ℕ._⋅_)(ℕ.𝟎) {x}) ]
      a ℕ.+ ℕ.𝟎                     🝖[ _≡_ ]-[ identityᵣ(ℕ._+_)(ℕ.𝟎) ]
      a                             🝖[ _≡_ ]-[]
      eval (a ⊰ ∅) x                🝖-end
    eval-preserves-pad {ℕ.𝐒 n₁} {ℕ.𝐒 n₂} {x} {a ⊰ as@(_ ⊰ _)} ⦃ ord@(succ p) ⦄ =
      eval (pad ⦃ ord ⦄ (a ⊰ as)) x       🝖[ _≡_ ]-[]
      eval (a ⊰ pad ⦃ _ ⦄ as) x           🝖[ _≡_ ]-[ eval-of-[⊰] {n₂}{x}{a}{pad ⦃ p ⦄ as} ]
      a ℕ.+ (x ℕ.⋅ eval (pad ⦃ _ ⦄ as) x) 🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a) (congruence₂ᵣ(ℕ._⋅_)(x) (eval-preserves-pad {n₁}{n₂}{x}{as} ⦃ p ⦄)) ]
      a ℕ.+ (x ℕ.⋅ eval as x)       🝖[ _≡_ ]-[ eval-of-[⊰] {n₁}{x}{a}{as} ]-sym
      eval (a ⊰ as) x               🝖-end

    eval-preserves-multiplication : ∀{x}{a : Polynomial(n₁)}{b : Polynomial(n₂)} → (eval (a ⨯ b) x ≡ (eval a x) ℕ.⋅ (eval b x))
    eval-preserves-multiplication {n₁}    {ℕ.𝟎}   {x} {a ⊰ as}         {b ⊰ ∅}          =
      eval ((a ⊰ as) ⨯ (b ⊰ ∅)) x          🝖[ _≡_ ]-[]
      eval (b ⋅ (a ⊰ as)) x                🝖[ _≡_ ]-[ eval-preserves-scalar-multiplication {x = x}{b}{a ⊰ as} ]
      b ℕ.⋅ eval (a ⊰ as) x                🝖[ _≡_ ]-[ commutativity(ℕ._⋅_) {b}{eval(a ⊰ as) x} ]
      eval (a ⊰ as) x ℕ.⋅ b                🝖[ _≡_ ]-[]
      (eval (a ⊰ as) x ℕ.⋅ eval (b ⊰ ∅) x) 🝖-end
    eval-preserves-multiplication {ℕ.𝟎}   {ℕ.𝐒 n₂}{x} {a ⊰ ∅}          {b ⊰ bs@(_ ⊰ _)} =
      eval ((a ⊰ ∅) ⨯ (b ⊰ bs)) x        🝖[ _≡_ ]-[]
      eval (a ⋅ (b ⊰ bs)) x              🝖[ _≡_ ]-[ eval-preserves-scalar-multiplication {x = x}{a}{b ⊰ bs} ]
      a ℕ.⋅ (b ℕ.+ (x ℕ.⋅ eval bs x))    🝖[ _≡_ ]-[]
      eval (a ⊰ ∅) x ℕ.⋅ eval (b ⊰ bs) x 🝖-end
    eval-preserves-multiplication {ℕ.𝐒 n₁}{ℕ.𝐒 n₂}{x} {a ⊰ as@(_ ⊰ _)} {b ⊰ bs@(_ ⊰ _)} =
      eval((a ℕ.⋅ b) ⊰ lr) x                                                                                🝖[ _≡_ ]-[ eval-of-[⊰] {x = x}{a = a ℕ.⋅ b}{al = lr} ]
      (a ℕ.⋅ b) ℕ.+ (x ℕ.⋅ eval lr x)                                                                                🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.⋅ b) (congruence₂ᵣ(ℕ._⋅_)(x) eval-lr) ]
      (a ℕ.⋅ b) ℕ.+ (x ℕ.⋅ (((b ℕ.⋅ eval as x) ℕ.+ (a ℕ.⋅ eval bs x)) ℕ.+ (x ℕ.⋅ (eval as x ℕ.⋅ eval bs x))))                   🝖[ _≡_ ]-[ alg{a}{b}{x}{eval as x}{eval bs x} ]
      (a ℕ.+ (x ℕ.⋅ eval as x)) ℕ.⋅ (b ℕ.+ (x ℕ.⋅ eval bs x))                                                                   🝖[ _≡_ ]-[ congruence₂(ℕ._⋅_) (eval-of-[⊰] {x = x}{a = a}{al = as}) (eval-of-[⊰] {x = x}{a = b}{al = bs}) ]
      (eval(a ⊰ as) x ℕ.⋅ eval(b ⊰ bs) x)                                                                                🝖-end
      where
        open import Numeral.Natural.Function
        open import Numeral.Natural.Function.Proofs
        open import Numeral.Natural.Relation.Order.Proofs
        open import Relator.Equals using ([≡]-intro)

        l : Polynomial(n₁ ℕ.+ n₂)
        l = pad ⦃ max-order-[+] ⦄ ((b ⋅ as) + (a ⋅ bs))

        r : Polynomial(ℕ.𝐒(n₁ ℕ.+ n₂))
        r = var⋅ (as ⨯ bs)

        lr : Polynomial(ℕ.𝐒(n₁ ℕ.+ n₂))
        lr = [≡]-substitutionᵣ ([↔]-to-[→] max-defᵣ [≤]-of-[𝐒]) {Polynomial} (l + r)

        eval-l : (eval l x ≡ (b ℕ.⋅ eval as x) ℕ.+ (a ℕ.⋅ eval bs x))
        eval-l =
          eval l x                                             🝖[ _≡_ ]-[]
          eval (pad ⦃ max-order-[+] ⦄ ((b ⋅ as) + (a ⋅ bs))) x 🝖[ _≡_ ]-[ eval-preserves-pad {x = x}{(b ⋅ as) + (a ⋅ bs)} ⦃ max-order-[+] ⦄ ]
          eval ((b ⋅ as) + (a ⋅ bs)) x                         🝖[ _≡_ ]-[ eval-preserves-addition {x = x}{b ⋅ as}{a ⋅ bs} ]
          eval (b ⋅ as) x ℕ.+ eval (a ⋅ bs) x                  🝖[ _≡_ ]-[ congruence₂(ℕ._+_) (eval-preserves-scalar-multiplication {x = x}{b}{as}) (eval-preserves-scalar-multiplication {x = x}{a}{bs}) ]
          (b ℕ.⋅ eval as x) ℕ.+ (a ℕ.⋅ eval bs x)              🝖-end

        eval-r : (eval r x ≡ x ℕ.⋅ (eval as x ℕ.⋅ eval bs x))
        eval-r =
          eval r x                        🝖[ _≡_ ]-[]
          eval (var⋅ (as ⨯ bs)) x         🝖[ _≡_ ]-[ eval-preserves-var⋅ {x = x}{as ⨯ bs} ]
          x ℕ.⋅ eval (as ⨯ bs) x          🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._⋅_)(x) (eval-preserves-multiplication {x = x}{as}{bs}) ]
          x ℕ.⋅ (eval as x ℕ.⋅ eval bs x) 🝖-end

        eval-substitution : ∀{m n}{a : Polynomial(m)}{eq : (m ≡ n)}{x} → (eval ([≡]-substitutionᵣ eq {Polynomial} a) x ≡ eval a x)
        eval-substitution {eq = [≡]-intro} = [≡]-intro

        eval-lr : (eval lr x ≡ ((b ℕ.⋅ eval as x) ℕ.+ (a ℕ.⋅ eval bs x)) ℕ.+ (x ℕ.⋅ (eval as x ℕ.⋅ eval bs x)))
        eval-lr =
          eval lr x                                                                       🝖[ _≡_ ]-[ eval-substitution{a = l + r}{[↔]-to-[→] max-defᵣ [≤]-of-[𝐒]}{x = x} ]
          eval (l + r) x                                                                  🝖[ _≡_ ]-[ eval-preserves-addition{x = x}{l}{r} ]
          eval l x ℕ.+ eval r x                                                           🝖[ _≡_ ]-[ congruence₂(ℕ._+_) eval-l eval-r ]
          ((b ℕ.⋅ eval as x) ℕ.+ (a ℕ.⋅ eval bs x)) ℕ.+ (x ℕ.⋅ (eval as x ℕ.⋅ eval bs x)) 🝖-end

        alg : ∀{a b x q r} → ((a ℕ.⋅ b) ℕ.+ (x ℕ.⋅ (((b ℕ.⋅ q) ℕ.+ (a ℕ.⋅ r)) ℕ.+ (x ℕ.⋅ (q ℕ.⋅ r)))) ≡ (a ℕ.+ (x ℕ.⋅ q)) ℕ.⋅ (b ℕ.+ (x ℕ.⋅ r)))
        alg {a}{b}{x}{q}{r} =
          (a ℕ.⋅ b) ℕ.+ (x ℕ.⋅ (((b ℕ.⋅ q) ℕ.+ (a ℕ.⋅ r)) ℕ.+ (x ℕ.⋅ (q ℕ.⋅ r))))                   🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.⋅ b) (distributivityₗ(ℕ._⋅_)(ℕ._+_) {x}{(b ℕ.⋅ q) ℕ.+ (a ℕ.⋅ r)}{x ℕ.⋅ (q ℕ.⋅ r)}) ]
          (a ℕ.⋅ b) ℕ.+ ((x ℕ.⋅ ((b ℕ.⋅ q) ℕ.+ (a ℕ.⋅ r))) ℕ.+ (x ℕ.⋅ (x ℕ.⋅ (q ℕ.⋅ r))))           🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.⋅ b) (congruence₂(ℕ._+_) (distributivityₗ(ℕ._⋅_)(ℕ._+_) {x}{b ℕ.⋅ q}{a ℕ.⋅ r}) (symmetry(_≡_) (associativity(ℕ._⋅_) {x}{x}{q ℕ.⋅ r}))) ]
          (a ℕ.⋅ b) ℕ.+ (((x ℕ.⋅ (b ℕ.⋅ q)) ℕ.+ (x ℕ.⋅ (a ℕ.⋅ r))) ℕ.+ ((x ℕ.⋅ x) ℕ.⋅ (q ℕ.⋅ r)))   🝖[ _≡_ ]-[ congruence₂ᵣ(ℕ._+_)(a ℕ.⋅ b) (congruence₂(ℕ._+_) (congruence₂(ℕ._+_) (One.commuteᵣ-assocᵣ {_▫_ = ℕ._⋅_}{a = x}{b}{q}) (One.commuteₗ-assocᵣ {_▫_ = ℕ._⋅_}{a = x}{a}{r})) (One.associate-commute4-c {_▫_ = ℕ._⋅_}{a = x}{x}{q}{r})) ]
          (a ℕ.⋅ b) ℕ.+ ((((x ℕ.⋅ q) ℕ.⋅ b) ℕ.+ (a ℕ.⋅ (x ℕ.⋅ r))) ℕ.+ ((x ℕ.⋅ q) ℕ.⋅ (x ℕ.⋅ r)))   🝖[ _≡_ ]-[ One.associate4-231-222 {_▫_ = ℕ._+_} {a = a ℕ.⋅ b}{(x ℕ.⋅ q) ℕ.⋅ b}{a ℕ.⋅ (x ℕ.⋅ r)}{(x ℕ.⋅ q) ℕ.⋅ (x ℕ.⋅ r)} ]
          ((a ℕ.⋅ b) ℕ.+ ((x ℕ.⋅ q) ℕ.⋅ b)) ℕ.+ ((a ℕ.⋅ (x ℕ.⋅ r)) ℕ.+ ((x ℕ.⋅ q) ℕ.⋅ (x ℕ.⋅ r)))   🝖[ _≡_ ]-[ OneTypeTwoOp.cross-distribute{a = a}{x ℕ.⋅ q}{b}{x ℕ.⋅ r} ]-sym
          (a ℕ.+ (x ℕ.⋅ q)) ℕ.⋅ (b ℕ.+ (x ℕ.⋅ r))                                                   🝖-end


module Issue690a where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

-- A negative type.
data T : Set → Set where
  c : T (T ℕ)

-- From Andreas (2012-09-07) message on Agda mailing list "Forget
-- Hurken's paradox ..."
--
-- Trying to make sense of T in terms of inductive types, explaining
-- indices via equalities, one arrives at
--
--  data T (X : Set) : Set where
--    c : (X ≡ T ℕ) → T X
--
-- which has a non-positive occurrence of T in (X ≡ T ℕ).
--
-- An argument for the existence of T would have to argue for the
-- existence this least fixed point:
--
--  lfp \lambda T X → (X ≡ T ℕ)

-- ASR (14 August 2014): In Coq'Art, § 14.1.2.1, the type T is
-- rejected due to the head type constrains.


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

module SetQuotientTest where

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Foundations.Logic renaming (inl to inlᵖ; inr to inrᵖ)
open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥)
open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.NatPlusOne using (HasFromNat; 1+_; ℕ₊₁; ℕ₊₁→ℕ)
open import Cubical.HITs.Ints.QuoInt using (HasFromNat; signed) renaming
  ( abs to absᶻ
  ; pos to pos
  ; neg to neg
  )
open import Cubical.HITs.Ints.QuoInt hiding (_+_; -_; +-assoc; +-comm)
open import Cubical.HITs.Rationals.QuoQ using
    ( ℚ
    ; onCommonDenom
    ; onCommonDenomSym
    ; eq/
    ; _//_
    ; _∼_
    ; isSetℚ
    )
    renaming
    ( [_] to [_]ᶠ
    ; ℕ₊₁→ℤ to [1+_ⁿ]ᶻ
    )
open import Cubical.HITs.SetQuotients as SetQuotient using () renaming (_/_ to _//_)

postulate
  _<ᶻ_ : ℤ → ℤ → hProp ℓ-zero

_<'_ : ℤ × ℕ₊₁ → ℤ × ℕ₊₁ → hProp ℓ-zero
(aᶻ , aⁿ) <' (bᶻ , bⁿ) =
  let aⁿᶻ = [1+ aⁿ ⁿ]ᶻ
      bⁿᶻ = [1+ bⁿ ⁿ]ᶻ
  in (aᶻ * bⁿᶻ) <ᶻ (bᶻ * aⁿᶻ)

postulate
  <'-respects-∼ˡ : ∀ a b x → a ∼ b → a <' x ≡ b <' x
  <'-respects-∼ʳ : ∀ x a b → a ∼ b → x <' a ≡ x <' b

_<_ : ℚ → ℚ → hProp ℓ-zero
a < b = SetQuotient.rec2 {R = _∼_} {B = hProp ℓ-zero} isSetHProp _<'_ <'-respects-∼ˡ <'-respects-∼ʳ a b

isProp⊎ˡ : ∀{ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → isProp A → isProp B → (A → ¬ᵗ B) → isProp (A ⊎ B)
isProp⊎ˡ pA pB A⇒¬B (inl x) (inl y) = cong inl (pA x y)
isProp⊎ˡ pA pB A⇒¬B (inr x) (inr y) = cong inr (pB x y)
isProp⊎ˡ pA pB A⇒¬B (inl x) (inr y) = ⊥-elim (A⇒¬B x y)
isProp⊎ˡ pA pB A⇒¬B (inr x) (inl y) = ⊥-elim (A⇒¬B y x)

⊎ᵖ-syntax : ∀{ℓ ℓ'} (P : hProp ℓ) (Q : hProp ℓ') → {[ P ] → [ ¬ Q ]} → hProp _
⊎ᵖ-syntax P Q {P⇒¬Q} = ([ P ] ⊎ [ Q ]) , isProp⊎ˡ (isProp[] P) (isProp[] Q) P⇒¬Q

syntax ⊎ᵖ-syntax P Q {P⇒¬Q} = [ P⇒¬Q ] P ⊎ᵖ Q

postulate
  <-asym : ∀ x y → [ x < y ] → [ ¬(y < x) ]

_#_ : ℚ → ℚ → hProp ℓ-zero
x # y = [ <-asym x y ] (x < y) ⊎ᵖ (y < x)

_⁻¹''' : (x : ℚ) → [ x # 0 ] → ℚ
_⁻¹''' = SetQuotient.elim {R = _∼_} {B = λ x → [ x # 0 ] → ℚ} φ _⁻¹'' ⁻¹''-respects-∼ where
  φ : ∀ x → isSet ([ x # 0 ] → ℚ)
  φ x = isSetΠ (λ _ → isSetℚ)
  _⁻¹''  : (a : ℤ × ℕ₊₁) → [ [ a ]ᶠ # 0 ] → ℚ
  x ⁻¹'' = {!!}
  ⁻¹''-respects-∼ : (a b : ℤ × ℕ₊₁) (r : a ∼ b)
                  → PathP (λ i → [ eq/ a b r i # 0 ] → ℚ) (a ⁻¹'') (b ⁻¹'')
  ⁻¹''-respects-∼ a b r = {!!}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Almost commutative rings
------------------------------------------------------------------------

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

module Tactic.RingSolver.Core.AlmostCommutativeRing where

open import Level
open import Relation.Binary
open import Algebra.Core using (Op₁; Op₂)
open import Algebra.Structures using (IsCommutativeSemiring)
open import Algebra.Definitions
open import Algebra.Bundles using (RawRing; CommutativeRing; CommutativeSemiring)
import Algebra.Morphism as Morphism
open import Function
open import Level
open import Data.Maybe.Base as Maybe using (Maybe; just; nothing)

record IsAlmostCommutativeRing
         {a ℓ} {A : Set a} (_≈_ : Rel A ℓ)
         (_+_ _*_ : A → A → A) (-_ : A → A) (0# 1# : A) : Set (a ⊔ ℓ) where
  field
    isCommutativeSemiring : IsCommutativeSemiring _≈_ _+_ _*_ 0# 1#
    -‿cong                : -_ Preserves _≈_ ⟶ _≈_
    -‿*-distribˡ          : ∀ x y → ((- x) * y)     ≈ (- (x * y))
    -‿+-comm              : ∀ x y → ((- x) + (- y)) ≈ (- (x + y))

  open IsCommutativeSemiring isCommutativeSemiring public

import Algebra.Operations.Ring as Exp

record AlmostCommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  infixr 8 _^_
  field
    Carrier                 : Set c
    _≈_                     : Rel Carrier ℓ
    _+_                     : Op₂ Carrier
    _*_                     : Op₂ Carrier
    -_                      : Op₁ Carrier
    0#                      : Carrier
    0≟_                     : (x : Carrier) → Maybe (0# ≈ x)
    1#                      : Carrier
    isAlmostCommutativeRing :
      IsAlmostCommutativeRing _≈_ _+_ _*_ -_ 0# 1#

  open IsAlmostCommutativeRing isAlmostCommutativeRing hiding (refl) public
  open import Data.Nat.Base as ℕ using (ℕ)

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

  open CommutativeSemiring commutativeSemiring public
    using ( +-semigroup; +-monoid; +-commutativeMonoid
          ; *-semigroup; *-monoid; *-commutativeMonoid
          ; semiring
          )

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

  _^_ : Carrier → ℕ → Carrier
  _^_ = Exp._^_ rawRing
  {-# NOINLINE _^_ #-}

  refl : ∀ {x} → x ≈ x
  refl = IsAlmostCommutativeRing.refl isAlmostCommutativeRing

record _-Raw-AlmostCommutative⟶_
         {r₁ r₂ r₃ r₄}
         (From : RawRing r₁ r₂)
         (To : AlmostCommutativeRing r₃ r₄) : Set (r₁ ⊔ r₂ ⊔ r₃ ⊔ r₄) where
  private
    module F = RawRing From
    module T = AlmostCommutativeRing To
  open Morphism.Definitions F.Carrier T.Carrier T._≈_
  field
    ⟦_⟧    : Morphism
    +-homo : Homomorphic₂ ⟦_⟧ F._+_ T._+_
    *-homo : Homomorphic₂ ⟦_⟧ F._*_ T._*_
    -‿homo : Homomorphic₁ ⟦_⟧ F.-_  T.-_
    0-homo : Homomorphic₀ ⟦_⟧ F.0#  T.0#
    1-homo : Homomorphic₀ ⟦_⟧ F.1#  T.1#

-raw-almostCommutative⟶
  : ∀ {r₁ r₂} (R : AlmostCommutativeRing r₁ r₂) →
    AlmostCommutativeRing.rawRing R -Raw-AlmostCommutative⟶ R
-raw-almostCommutative⟶ R = record
  { ⟦_⟧    = id
  ; +-homo = λ _ _ → refl
  ; *-homo = λ _ _ → refl
  ; -‿homo = λ _ → refl
  ; 0-homo = refl
  ; 1-homo = refl
  }
  where open AlmostCommutativeRing R

-- A homomorphism induces a notion of equivalence on the raw ring.

Induced-equivalence :
  ∀ {c₁ c₂ c₃ ℓ} {Coeff : RawRing c₁ c₂} {R : AlmostCommutativeRing c₃ ℓ} →
  Coeff -Raw-AlmostCommutative⟶ R → Rel (RawRing.Carrier Coeff) ℓ
Induced-equivalence {R = R} morphism a b = ⟦ a ⟧ ≈ ⟦ b ⟧
  where
  open AlmostCommutativeRing R
  open _-Raw-AlmostCommutative⟶_ morphism

------------------------------------------------------------------------
-- Conversions

-- Commutative rings are almost commutative rings.

fromCommutativeRing : ∀ {r₁ r₂} (CR : CommutativeRing r₁ r₂) →
                      (open CommutativeRing CR) →
                      (∀ x → Maybe (0# ≈ x)) →
                      AlmostCommutativeRing _ _
fromCommutativeRing CR 0≟_ = record
  { isAlmostCommutativeRing = record
      { isCommutativeSemiring = isCommutativeSemiring
      ; -‿cong                = -‿cong
      ; -‿*-distribˡ          = -‿*-distribˡ
      ; -‿+-comm              = ⁻¹-∙-comm
      }
  ; 0≟_ = 0≟_
  }
  where
  open CommutativeRing CR
  open import Algebra.Properties.Ring ring
  open import Algebra.Properties.AbelianGroup +-abelianGroup

fromCommutativeSemiring : ∀ {r₁ r₂} (CS : CommutativeSemiring r₁ r₂)
                          (open CommutativeSemiring CS) →
                          (∀ x → Maybe (0# ≈ x)) →
                          AlmostCommutativeRing _ _
fromCommutativeSemiring CS 0≟_ = record
  { -_                      = id
  ; isAlmostCommutativeRing = record
      { isCommutativeSemiring = isCommutativeSemiring
      ; -‿cong                = id
      ; -‿*-distribˡ          = λ _ _ → refl
      ; -‿+-comm              = λ _ _ → refl
      }
  ; 0≟_ = 0≟_
  }
  where open CommutativeSemiring CS


module Rewrite where

open import Common.Equality

data _≈_ {A : Set}(x : A) : A → Set where
  refl : ∀ {y} → x ≈ y

lem : ∀ {A} (x y : A) → x ≈ y
lem x y = refl

thm : {A : Set}(P : A → Set)(x y : A) → P x → P y
thm P x y px rewrite lem x y = {!!}


module Data.Star.Indexed where

open import Relation.Binary
open import Function
open import Level

infixr 10 _◅_
data Star {i a t}(I : Set i){A : I → Set a}
     (T : ∀ n m → REL (A n) (A m) t) : ∀ {n m : I} → REL (A n) (A m) (i ⊔ a ⊔ t) where
  ε   : ∀ {i}{x : A i} → Star I T x x
  _◅_ : ∀ {n m k : I}{x : A n}{y : A m}{z : A k} → T n m x y → Star I T y z → Star I T x z


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

open import LogicalFormulae
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Categories.Definition

module Categories.Functor.Definition where

record Functor {a b c d : _} (C : Category {a} {b}) (D : Category {c} {d}) : Set (a ⊔ b ⊔ c ⊔ d) where
  field
    onObj : Category.objects C → Category.objects D
    onArrow : {S T : Category.objects C} → Category.arrows C S T → Category.arrows D (onObj S) (onObj T)
    mapId : {T : Category.objects C} → onArrow (Category.id C T) ≡ Category.id D (onObj T)
    mapCompose : {X Y Z : Category.objects C} → (f : Category.arrows C X Y) (g : Category.arrows C Y Z) → onArrow (Category._∘_ C g f) ≡ Category._∘_ D (onArrow g) (onArrow f)


{-# OPTIONS --cubical #-}
module Multidimensional.Data.DirNum where

open import Multidimensional.Data.DirNum.Base public

open import Multidimensional.Data.DirNum.Properties public


{-

This file contains basic theory about subgroups.

The definition is the same as the first definition of subgroups in:

https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#subgroups-sip

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.Subgroup where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.GroupoidLaws hiding (assoc)
open import Cubical.Data.Sigma
open import Cubical.HITs.PropositionalTruncation

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties

private
  variable
    ℓ : Level

-- We assume an ambient group
module _ (G' : Group ℓ) where

  open GroupStr (snd G')
  private G = ⟨ G' ⟩

  record isSubgroup (H : ℙ G) : Type ℓ where
    field
      id-closed  : (1g ∈ H)
      op-closed  : {x y : G} → x ∈ H → y ∈ H → x · y ∈ H
      inv-closed : {x : G} → x ∈ H → inv x ∈ H

  open isSubgroup

  Subgroup : Type (ℓ-suc ℓ)
  Subgroup = Σ[ H ∈ ℙ G ] isSubgroup H

  isPropIsSubgroup : (H : ℙ G) → isProp (isSubgroup H)
  id-closed (isPropIsSubgroup H h1 h2 i) =
    ∈-isProp H 1g (h1 .id-closed) (h2 .id-closed) i
  op-closed (isPropIsSubgroup H h1 h2 i) Hx Hy =
    ∈-isProp H _ (h1 .op-closed Hx Hy) (h2 .op-closed Hx Hy) i
  inv-closed (isPropIsSubgroup H h1 h2 i) Hx =
    ∈-isProp H _ (h1 .inv-closed Hx) (h2 .inv-closed Hx) i

  isSetSubgroup : isSet Subgroup
  isSetSubgroup = isSetΣ isSetℙ λ x → isProp→isSet (isPropIsSubgroup x)

  Subgroup→Group : Subgroup → Group ℓ
  Subgroup→Group (H , Hh) = makeGroup-right 1HG _·HG_ invHG isSetHG assocHG ridHG invrHG
    where
    HG = Σ[ x ∈ G ] ⟨ H x ⟩
    isSetHG = isSetΣ is-set (λ x → isProp→isSet (H x .snd))

    1HG : HG
    1HG = (1g , (id-closed Hh))

    _·HG_ : HG → HG → HG
    (x , Hx) ·HG (y , Hy) = (x · y) , (op-closed Hh Hx Hy)

    invHG : HG → HG
    invHG (x , Hx) = inv x , inv-closed Hh Hx

    assocHG : (x y z : HG) → x ·HG (y ·HG z) ≡ (x ·HG y) ·HG z
    assocHG (x , Hx) (y , Hy) (z , Hz) =
      ΣPathP (·Assoc x y z , isProp→PathP (λ i → H (·Assoc x y z i) .snd) _ _)

    ridHG : (x : HG) → x ·HG 1HG ≡ x
    ridHG (x , Hx) = ΣPathP (·IdR x , isProp→PathP (λ i → H (·IdR x i) .snd) _ _)

    invrHG : (x : HG) → x ·HG invHG x ≡ 1HG
    invrHG (x , Hx) = ΣPathP (·InvR x , isProp→PathP (λ i → H (·InvR x i) .snd) _ _)

⟪_⟫ : {G' : Group ℓ} → Subgroup G' → ℙ (G' .fst)
⟪ H , _ ⟫ = H

module _ {G' : Group ℓ} where

  open GroupStr (snd G')
  open isSubgroup
  open GroupTheory G'
  private G = ⟨ G' ⟩

  isNormal : Subgroup G' → Type ℓ
  isNormal H = (g h : G) → h ∈ ⟪ H ⟫ → g · h · inv g ∈ ⟪ H ⟫

  isPropIsNormal : (H : Subgroup G') → isProp (isNormal H)
  isPropIsNormal H = isPropΠ3 λ g h _ → ∈-isProp ⟪ H ⟫ (g · h · inv g)

  ·CommNormalSubgroup : (H : Subgroup G') (Hnormal : isNormal H) {x y : G}
                      → x · y ∈ ⟪ H ⟫ → y · x ∈ ⟪ H ⟫
  ·CommNormalSubgroup H Hnormal {x = x} {y = y} Hxy =
    subst-∈ ⟪ H ⟫ rem (Hnormal (inv x) (x · y) Hxy)
      where
      rem : inv x · (x · y) · inv (inv x) ≡ y · x
      rem = inv x · (x · y) · inv (inv x) ≡⟨ ·Assoc _ _ _ ⟩
            (inv x · x · y) · inv (inv x) ≡⟨ (λ i → ·Assoc (inv x) x y i · invInv x i) ⟩
            ((inv x · x) · y) · x         ≡⟨ cong (λ z → (z · y) · x) (·InvL x) ⟩
            (1g · y) · x                  ≡⟨ cong (_· x) (·IdL y) ⟩
            y · x                         ∎

  -- Examples of subgroups

  -- We can view all of G as a subset of itself
  groupSubset : ℙ G
  groupSubset x = (x ≡ x) , is-set x x

  isSubgroupGroup : isSubgroup G' groupSubset
  id-closed isSubgroupGroup = refl
  op-closed isSubgroupGroup _ _ = refl
  inv-closed isSubgroupGroup _ = refl

  groupSubgroup : Subgroup G'
  groupSubgroup = groupSubset , isSubgroupGroup

  -- The trivial subgroup
  trivialSubset : ℙ G
  trivialSubset x = (x ≡ 1g) , is-set x 1g

  isSubgroupTrivialGroup : isSubgroup G' trivialSubset
  id-closed isSubgroupTrivialGroup = refl
  op-closed isSubgroupTrivialGroup hx hy = cong (_· _) hx ∙∙ ·IdL _ ∙∙ hy
  inv-closed isSubgroupTrivialGroup hx = cong inv hx ∙ inv1g

  trivialSubgroup : Subgroup G'
  trivialSubgroup = trivialSubset , isSubgroupTrivialGroup

  isNormalTrivialSubgroup : isNormal trivialSubgroup
  isNormalTrivialSubgroup g h h≡1 =
    (g · h · inv g)  ≡⟨ (λ i → g · h≡1 i · inv g) ⟩
    (g · 1g · inv g) ≡⟨ ·Assoc _ _ _ ∙ cong (_· inv g) (·IdR g) ⟩
    (g · inv g)      ≡⟨ ·InvR g ⟩
    1g ∎

NormalSubgroup : (G : Group ℓ) → Type _
NormalSubgroup G = Σ[ G ∈ Subgroup G ] isNormal G

-- Can one get this to work with different universes for G and H?
module _ {G H : Group ℓ} (ϕ : GroupHom G H) where

  open isSubgroup
  open GroupTheory

  private
    module G = GroupStr (snd G)
    module H = GroupStr (snd H)
    f = ϕ .fst
    module ϕ = IsGroupHom (ϕ .snd)

  imSubset : ℙ ⟨ H ⟩
  imSubset x = isInIm ϕ x , isPropIsInIm ϕ x

  isSubgroupIm : isSubgroup H imSubset
  id-closed isSubgroupIm = ∣ G.1g , ϕ.pres1 ∣₁
  op-closed isSubgroupIm =
    map2 λ { (x , hx) (y , hy) → x G.· y , ϕ.pres· x y ∙ λ i → hx i H.· hy i }
  inv-closed isSubgroupIm = map λ { (x , hx) → G.inv x , ϕ.presinv x ∙ cong H.inv hx }

  imSubgroup : Subgroup H
  imSubgroup = imSubset , isSubgroupIm

  imGroup : Group ℓ
  imGroup = Subgroup→Group _ imSubgroup

  isNormalIm : ((x y : ⟨ H ⟩) → x H.· y ≡ y H.· x)
            → isNormal imSubgroup
  isNormalIm comm x y =
    map λ {(g , p)
      → g ,
      (ϕ .fst g                  ≡⟨ p ⟩
      y                          ≡⟨ sym (H.·IdR y) ⟩
      (y H.· H.1g)               ≡⟨ cong (y H.·_) (sym (H.·InvR x)) ⟩
      (y H.· (x H.· H.inv x))    ≡⟨ H.·Assoc y x (H.inv x) ⟩
      ((y H.· x) H.· H.inv x)    ≡⟨ cong (H._· H.inv x) (comm y x) ⟩
      ((x H.· y) H.· H.inv x)    ≡⟨ sym (H.·Assoc x y (H.inv x)) ⟩
      x H.· y H.· H.inv x        ∎ )}

  kerSubset : ℙ ⟨ G ⟩
  kerSubset x = isInKer ϕ x , isPropIsInKer ϕ x

  isSubgroupKer : isSubgroup G kerSubset
  id-closed isSubgroupKer = ϕ.pres1
  op-closed isSubgroupKer {x} {y} hx hy =
    ϕ.pres· x y ∙∙ (λ i → hx i H.· hy i) ∙∙ H.·IdR _
  inv-closed isSubgroupKer hx = ϕ.presinv _ ∙∙ cong H.inv hx ∙∙ inv1g H

  kerSubgroup : Subgroup G
  kerSubgroup = kerSubset , isSubgroupKer

  isNormalKer : isNormal kerSubgroup
  isNormalKer x y hy =
    f (x G.· y G.· G.inv x)         ≡⟨ ϕ.pres· _ _ ⟩
    f x H.· f (y G.· G.inv x)       ≡⟨ cong (f x H.·_) (ϕ.pres· _ _) ⟩
    f x H.· f y H.· f (G.inv x)     ≡⟨ (λ i → f x H.· hy i H.· f (G.inv x)) ⟩
    f x H.· (H.1g H.· f (G.inv x))  ≡⟨ cong (f x H.·_) (H.·IdL _) ⟩
    f x H.· f (G.inv x)             ≡⟨ cong (f x H.·_) (ϕ.presinv x) ⟩
    f x H.· H.inv (f x)             ≡⟨ H.·InvR _ ⟩
    H.1g                            ∎


module bools where

open import lib

----------------------------------------------------------------------
-- these problems are about the nand operator, also known as the Scheffer stroke
----------------------------------------------------------------------
nand-not : ∀ (b : 𝔹) → ~ b ≡ b nand b
nand-not tt = refl
nand-not ff = refl

nand-or : ∀ (b1 b2 : 𝔹) → b1 || b2 ≡ (b1 nand b1) nand (b2 nand b2)
nand-or tt tt = refl
nand-or tt ff = refl
nand-or ff tt = refl
nand-or ff ff = refl

nand-and : ∀ (b1 b2 : 𝔹) → b1 && b2 ≡ (b1 nand b2) nand (b1 nand b2)
nand-and tt tt = refl
nand-and tt ff = refl
nand-and ff tt = refl
nand-and ff ff = refl

nand-imp : ∀ (b1 b2 : 𝔹) → b1 imp b2 ≡ b1 nand (b2 nand b2)
nand-imp tt tt = refl
nand-imp tt ff = refl
nand-imp ff tt = refl
nand-imp ff ff = refl

ite-not : ∀(A : Set)(x : 𝔹)(y : A)(z : A) → if x then y else z ≡ if ~ x then z else y
ite-not A tt y z = refl
ite-not A ff y z = refl

&&-distrib : ∀ x y z → x && (y || z) ≡ (x && y) || (x && z)
&&-distrib tt tt tt = refl
&&-distrib tt tt ff = refl
&&-distrib tt ff tt = refl
&&-distrib tt ff ff = refl
&&-distrib ff tt tt = refl
&&-distrib ff tt ff = refl
&&-distrib ff ff tt = refl
&&-distrib ff ff ff = refl

combK : ∀ x y → x imp (y imp x) ≡ tt
combK tt tt = refl
combK tt ff = refl
combK ff tt = refl
combK ff ff = refl

combS : ∀ x y z → (x imp (y imp z)) ≡ tt → (x imp y) ≡ tt → x ≡ tt → z ≡ tt
combS tt tt tt x₁ x₂ x₃ = refl


------------------------------------------------------------------------------
-- Properties of the Collatz function
------------------------------------------------------------------------------

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

module FOTC.Program.Collatz.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.PropertiesATP using ( ∸-N )
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP using ( 2-N )
open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Data.Nat
open import FOTC.Program.Collatz.Data.Nat.PropertiesATP

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

helper : ∀ {n} → N n → collatz (2' ^ succ₁ n) ≡ collatz (2' ^ n)
helper nzero = prf
  where postulate prf : collatz (2' ^ succ₁ zero) ≡ collatz (2' ^ zero)
        {-# ATP prove prf #-}
helper (nsucc {n} Nn) = prf
  where postulate prf : collatz (2' ^ succ₁ (succ₁ n)) ≡ collatz (2' ^ succ₁ n)
        {-# ATP prove prf +∸2 ^-N 2-N 2^x≢0 2^[x+1]≢1 div-2^[x+1]-2≡2^x
                      x-Even→SSx-Even ∸-N ∸-Even 2^[x+1]-Even 2-Even
        #-}

collatz-2^x : ∀ {n} → N n → collatz (2' ^ n) ≡ 1'
collatz-2^x nzero = prf
  where postulate prf : collatz (2' ^ 0') ≡ 1'
        {-# ATP prove prf #-}

collatz-2^x (nsucc {n} Nn) = prf (collatz-2^x Nn)
  where postulate prf : collatz (2' ^ n) ≡ 1' → collatz (2' ^ succ₁ n) ≡ 1'
        {-# ATP prove prf helper #-}


module Prelude.Int.Properties where

open import Prelude.Unit
open import Prelude.Nat
open import Prelude.Nat.Properties
open import Prelude.Number
open import Prelude.Equality
open import Prelude.Int.Core
open import Prelude.Smashed
open import Prelude.Ord
open import Prelude.Semiring
open import Prelude.Function

--- Specification functions ---
---   sucInt   a   =  1 + a
---   predInt  a   = -1 + a
---   sucsInt  n a = pos n + a
---   predsInt n a = neg n + a
---   diffNat  a b = a -NZ b

sucInt : Int → Int
sucInt (pos n)          = pos (suc n)
sucInt (negsuc zero)    = pos zero
sucInt (negsuc (suc n)) = negsuc n

predInt : Int → Int
predInt (pos zero)    = negsuc zero
predInt (pos (suc n)) = pos n
predInt (negsuc n)    = negsuc (suc n)

sucsInt : Nat → Int → Int
sucsInt zero    b = b
sucsInt (suc a) b = sucInt (sucsInt a b)

predsInt : Nat → Int → Int
predsInt zero    b = b
predsInt (suc a) b = predInt (predsInt a b)

diffNat : Nat → Nat → Int
diffNat a       zero    = pos a
diffNat zero    (suc b) = negsuc b
diffNat (suc a) (suc b) = diffNat a b

--- Injectivity proofs ---

pos-inj : ∀ {a b} → pos a ≡ pos b → a ≡ b
pos-inj refl = refl

negsuc-inj : ∀ {a b} → negsuc a ≡ negsuc b → a ≡ b
negsuc-inj refl = refl

neg-inj : ∀ {a b} → neg a ≡ neg b → a ≡ b
neg-inj {zero}  {zero}  eq = refl
neg-inj {zero}  {suc b} ()
neg-inj {suc a} {zero}  ()
neg-inj {suc a} {suc b} eq = suc $≡ negsuc-inj eq

negate-inj : {a b : Int} → negate a ≡ negate b → a ≡ b
negate-inj {pos    a}    {pos    b}    eq = pos $≡ neg-inj eq
negate-inj {pos  zero}   {negsuc b}    ()
negate-inj {pos (suc a)} {negsuc b}    ()
negate-inj {negsuc a}    {pos zero}    ()
negate-inj {negsuc a}    {pos (suc _)} ()
negate-inj {negsuc a}    {negsuc b}    eq = negsuc $≡ suc-inj (pos-inj eq)

sucInt-inj : ∀ a b → sucInt a ≡ sucInt b → a ≡ b
sucInt-inj (pos a)          (pos a)          refl = refl
sucInt-inj (pos a)          (negsuc zero)    ()
sucInt-inj (pos a)          (negsuc (suc b)) ()
sucInt-inj (negsuc zero)    (pos b) ()
sucInt-inj (negsuc (suc a)) (pos b) ()
sucInt-inj (negsuc zero)    (negsuc zero)    eq = refl
sucInt-inj (negsuc zero)    (negsuc (suc b)) ()
sucInt-inj (negsuc (suc a)) (negsuc zero)    ()
sucInt-inj (negsuc (suc a)) (negsuc (suc a)) refl = refl

predInt-inj : ∀ a b → predInt a ≡ predInt b → a ≡ b
predInt-inj (pos zero)    (pos zero)    eq = refl
predInt-inj (pos zero)    (pos (suc b)) ()
predInt-inj (pos (suc a)) (pos zero)    ()
predInt-inj (pos (suc a)) (pos (suc a)) refl = refl
predInt-inj (pos zero)    (negsuc b)    ()
predInt-inj (pos (suc a)) (negsuc b)    ()
predInt-inj (negsuc a)    (pos zero)    ()
predInt-inj (negsuc a)    (pos (suc b)) ()
predInt-inj (negsuc a)    (negsuc a)    refl = refl

--- sucInt and predInt are inverses --

sucInt-predInt : ∀ a → sucInt (predInt a) ≡ a
sucInt-predInt (pos zero)    = refl
sucInt-predInt (pos (suc n)) = refl
sucInt-predInt (negsuc n)    = refl

predInt-sucInt : ∀ a → predInt (sucInt a) ≡ a
predInt-sucInt (pos n)          = refl
predInt-sucInt (negsuc zero)    = refl
predInt-sucInt (negsuc (suc n)) = refl

--- Commutativity of _+_ is easy

addInt-commute : (a b : Int) → a + b ≡ b + a
addInt-commute (pos    a) (pos    b) = pos $≡ add-commute a b
addInt-commute (pos    a) (negsuc b) = refl
addInt-commute (negsuc a) (pos    b) = refl
addInt-commute (negsuc a) (negsuc b) = negsuc ∘ suc $≡ add-commute a b

--- Proving _-NZ_ == diffNat

-NZ-suc : ∀ a b → suc a -NZ suc b ≡ a -NZ b
-NZ-suc a b rewrite smashed {x = compare (suc a) (suc b)} {suc-comparison (compare a b)}
            with    compare a b
... | less    (diff! k) = refl
... | equal   eq        = refl
... | greater (diff! k) = refl

-NZ-spec : ∀ a b → a -NZ b ≡ diffNat a b
-NZ-spec zero    zero    = refl
-NZ-spec (suc a) zero    = refl
-NZ-spec zero    (suc b) = refl
-NZ-spec (suc a) (suc b) = -NZ-suc a b ⟨≡⟩ -NZ-spec a b

--- diffNat distributes over suc in both arguments...

diffNat-suc-l : ∀ a b → diffNat (suc a) b ≡ sucInt (diffNat a b)
diffNat-suc-l a       0             = refl
diffNat-suc-l 0       1             = refl
diffNat-suc-l 0       (suc (suc b)) = refl
diffNat-suc-l (suc a) (suc b)       = diffNat-suc-l a b

diffNat-suc-r : ∀ a b → diffNat a (suc b) ≡ predInt (diffNat a b)
diffNat-suc-r zero    zero    = refl
diffNat-suc-r zero    (suc b) = refl
diffNat-suc-r (suc a) zero    = refl
diffNat-suc-r (suc a) (suc b) = diffNat-suc-r a b

--- ...and thus so does _-NZ_

-NZ-suc-l : ∀ a b → suc a -NZ b ≡ sucInt (a -NZ b)
-NZ-suc-l a b = -NZ-spec (suc a) b ⟨≡⟩ diffNat-suc-l a b ⟨≡⟩ʳ sucInt $≡ -NZ-spec a b

-NZ-suc-r : ∀ a b → a -NZ suc b ≡ predInt (a -NZ b)
-NZ-suc-r a b = -NZ-spec a (suc b) ⟨≡⟩ diffNat-suc-r a b ⟨≡⟩ʳ predInt $≡ -NZ-spec a b

--- We need some lemmas about how sucInt and predInt relates to _+_.
--- These are special cases of the computation rules below, so we make them private.

private
  sucInt-spec : ∀ a → 1 + a ≡ sucInt a
  sucInt-spec (pos n)          = refl
  sucInt-spec (negsuc zero)    = refl
  sucInt-spec (negsuc (suc n)) = refl

  predInt-spec : ∀ a → -1 + a ≡ predInt a
  predInt-spec (pos zero)    = refl
  predInt-spec (pos (suc n)) = -NZ-spec (suc n) 1
  predInt-spec (negsuc n)    = refl

  addInt-suc : ∀ a b → pos (suc a) + b ≡ sucInt (pos a + b)
  addInt-suc a (pos    b) = refl
  addInt-suc a (negsuc b) = -NZ-suc-l a (suc b)

  addInt-negsuc : ∀ a b → negsuc (suc a) + b ≡ predInt (negsuc a + b)
  addInt-negsuc a (pos b)    = -NZ-suc-r b (suc a)
  addInt-negsuc a (negsuc b) = refl

--- Now we can prove some "computation" rules for _+_

addInt-zero-l : (a : Int) → 0 + a ≡ a
addInt-zero-l (pos a)    = refl
addInt-zero-l (negsuc a) = -NZ-spec 0 (suc a)

addInt-zero-r : (a : Int) → a + 0 ≡ a
addInt-zero-r (pos a)    = pos $≡ add-zero-r a
addInt-zero-r (negsuc a) = -NZ-spec 0 (suc a)

addInt-sucInt-l : ∀ a b → sucInt a + b ≡ sucInt (a + b)
addInt-sucInt-l (pos a)          b = addInt-suc a b
addInt-sucInt-l (negsuc zero)    b = addInt-zero-l b ⟨≡⟩ʳ sucInt $≡ predInt-spec b ⟨≡⟩ sucInt-predInt b
addInt-sucInt-l (negsuc (suc a)) b = sucInt-predInt (negsuc a + b) ʳ⟨≡⟩ʳ sucInt $≡ addInt-negsuc a b

addInt-predInt-l : ∀ a b → predInt a + b ≡ predInt (a + b)
addInt-predInt-l (pos zero)    b = predInt-spec b ⟨≡⟩ʳ predInt $≡ addInt-zero-l b
addInt-predInt-l (pos (suc a)) b = predInt-sucInt (pos a + b) ʳ⟨≡⟩ʳ predInt $≡ addInt-suc a b
addInt-predInt-l (negsuc a)    b = addInt-negsuc a b

--- Adding a non-negative number is equivalent to sucsInt and adding a negative number
--- to predsInt.

addInt-pos : ∀ a b → pos a + b ≡ sucsInt a b
addInt-pos zero    b = addInt-zero-l b
addInt-pos (suc a) b = addInt-suc a b ⟨≡⟩ sucInt $≡ addInt-pos a b

addInt-neg : ∀ a b → neg a + b ≡ predsInt a b
addInt-neg zero          b = addInt-zero-l b
addInt-neg (suc zero)    b = addInt-predInt-l 0 b ⟨≡⟩ predInt $≡ addInt-zero-l b -- predInt-spec b
addInt-neg (suc (suc a)) b = addInt-predInt-l (negsuc a) b ⟨≡⟩ predInt $≡ addInt-neg (suc a) b

--- sucsInt and predsInt have the appropriate associativity properties

private
  sucsInt-assoc : ∀ a b c → sucsInt a (b + c) ≡ sucsInt a b + c
  sucsInt-assoc zero    b c = refl
  sucsInt-assoc (suc a) b c = sucInt $≡ sucsInt-assoc a b c ⟨≡⟩ʳ
                              addInt-sucInt-l (sucsInt a b) c

  predsInt-assoc : ∀ a b c → predsInt a (b + c) ≡ predsInt a b + c
  predsInt-assoc zero    b c = refl
  predsInt-assoc (suc a) b c = predInt $≡ predsInt-assoc a b c ⟨≡⟩ʳ
                               addInt-predInt-l (predsInt a b) c

--- Finally we can prove associativity of _+_

addInt-assoc : (a b c : Int) → a + (b + c) ≡ (a + b) + c
addInt-assoc (pos    a) b c = addInt-pos a (b + c)       ⟨≡⟩ sucsInt-assoc a b c        ⟨≡⟩ʳ _+ c $≡ addInt-pos a b
addInt-assoc (negsuc a) b c = addInt-neg (suc a) (b + c) ⟨≡⟩ predsInt-assoc (suc a) b c ⟨≡⟩ʳ _+ c $≡ addInt-neg (suc a) b

--- Injectivity of _+_

private
  sucsInt-inj : ∀ a b c → sucsInt a b ≡ sucsInt a c → b ≡ c
  sucsInt-inj zero    b c eq = eq
  sucsInt-inj (suc a) b c eq = sucsInt-inj a b c (sucInt-inj _ _ eq)

  predsInt-inj : ∀ a b c → predsInt a b ≡ predsInt a c → b ≡ c
  predsInt-inj zero    b c eq = eq
  predsInt-inj (suc a) b c eq = predsInt-inj a b c (predInt-inj _ _ eq)

addInt-inj₂ : (a b c : Int) → a + b ≡ a + c → b ≡ c
addInt-inj₂ (pos a)    b c eq = sucsInt-inj  a b c                  (addInt-pos a b       ʳ⟨≡⟩ eq ⟨≡⟩ addInt-pos a c)
addInt-inj₂ (negsuc a) b c eq = predsInt-inj a b c (predInt-inj _ _ (addInt-neg (suc a) b ʳ⟨≡⟩ eq ⟨≡⟩ addInt-neg (suc a) c))

addInt-inj₁ : (a b c : Int) → a + c ≡ b + c → a ≡ b
addInt-inj₁ a b c eq = addInt-inj₂ c a b (addInt-commute c a ⟨≡⟩ eq ⟨≡⟩ addInt-commute b c)

--- Properties of negate ---

negate-idempotent : (a : Int) → negate (negate a) ≡ a
negate-idempotent (pos zero)    = refl
negate-idempotent (pos (suc n)) = refl
negate-idempotent (negsuc n)    = refl

private
  neg-add : ∀ a b → neg (a + b) ≡ neg a + neg b
  neg-add zero    b       = sym (addInt-zero-l (neg b))
  neg-add (suc a) zero    = negsuc $≡ add-zero-r a ⟨≡⟩ʳ -NZ-spec 0 (suc a)
  neg-add (suc a) (suc b) = negsuc $≡ add-suc-r a b

  negate-diffNat : ∀ a b → negate (diffNat a b) ≡ diffNat b a
  negate-diffNat zero    zero    = refl
  negate-diffNat zero    (suc b) = refl
  negate-diffNat (suc a) zero    = refl
  negate-diffNat (suc a) (suc b) = negate-diffNat a b

negate-NZ : ∀ a b → negate (a -NZ b) ≡ b -NZ a
negate-NZ a b = negate $≡ -NZ-spec a b ⟨≡⟩ negate-diffNat a b ⟨≡⟩ʳ -NZ-spec b a

negate-addInt : (a b : Int) → negate (a + b) ≡ negate a + negate b
negate-addInt (pos a)       (pos b)       = neg-add a b
negate-addInt (pos zero)    (negsuc b)    = refl
negate-addInt (pos (suc a)) (negsuc b)    = negate-NZ (suc a) (suc b)
negate-addInt (negsuc a)    (pos zero)    = pos ∘ suc $≡ sym (add-zero-r a)
negate-addInt (negsuc a)    (pos (suc b)) = negate-NZ (suc b) (suc a)
negate-addInt (negsuc a)    (negsuc b)    = pos $≡ sym (add-suc-r (suc a) b)

negate-subInt : (a b : Int) → negate (a - b) ≡ b - a
negate-subInt a b = negate-addInt a (negate b) ⟨≡⟩
                    negate a +_ $≡ negate-idempotent b ⟨≡⟩
                    addInt-commute (negate a) b

--- Properties of subtraction ---

private
  diffNat-equal : ∀ a → diffNat a a ≡ 0
  diffNat-equal zero = refl
  diffNat-equal (suc a) = diffNat-equal a

subInt-equal : (a b : Int) → a ≡ b → a - b ≡ 0
subInt-equal (pos zero)    _ refl = refl
subInt-equal (pos (suc n)) _ refl = -NZ-spec (suc n) (suc n) ⟨≡⟩ diffNat-equal n
subInt-equal (negsuc n)    _ refl = -NZ-spec (suc n) (suc n) ⟨≡⟩ diffNat-equal n


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

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

open import Categories.Category.Core using (Category)

-- Since we add extra proofs in the definition of `Category` (i.e. `sym-assoc` and
-- `identity²`), we might still want to construct a `Category` in its originally
-- easier manner. Thus, this redundant definition is here to ease the construction.
record CategoryHelper (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  infix  4 _≈_ _⇒_
  infixr 9 _∘_

  field
    Obj : Set o
    _⇒_ : Rel Obj ℓ
    _≈_ : ∀ {A B} → Rel (A ⇒ B) e

    id  : ∀ {A} → (A ⇒ A)
    _∘_ : ∀ {A B C} → (B ⇒ C) → (A ⇒ B) → (A ⇒ C)

  field
    assoc     : ∀ {A B C D} {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D} → (h ∘ g) ∘ f ≈ h ∘ (g ∘ f)
    identityˡ : ∀ {A B} {f : A ⇒ B} → id ∘ f ≈ f
    identityʳ : ∀ {A B} {f : A ⇒ B} → f ∘ id ≈ f
    equiv     : ∀ {A B} → IsEquivalence (_≈_ {A} {B})
    ∘-resp-≈  : ∀ {A B C} {f h : B ⇒ C} {g i : A ⇒ B} → f ≈ h → g ≈ i → f ∘ g ≈ h ∘ i

categoryHelper : ∀ {o ℓ e} → CategoryHelper o ℓ e → Category o ℓ e
categoryHelper C = record
  { Obj       = Obj
  ; _⇒_       = _⇒_
  ; _≈_       = _≈_
  ; id        = id
  ; _∘_       = _∘_
  ; assoc     = assoc
  ; sym-assoc = sym assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identityˡ
  ; equiv     = equiv
  ; ∘-resp-≈  = ∘-resp-≈
  }
  where open CategoryHelper C
        module _ {A B} where
          open IsEquivalence (equiv {A} {B}) public


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Variables and contexts
--
-- This module defines the syntax of contexts and subcontexts,
-- together with variables and properties of these notions.
--
-- This module is parametric in the syntax of types, so it
-- can be reused for different calculi.
------------------------------------------------------------------------

module Base.Syntax.Context
    (Type : Set)
  where

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

-- Typing Contexts
-- ===============

import Data.List as List
open import Base.Data.ContextList public

Context : Set
Context = List.List Type

-- Variables
-- =========
--
-- Here it is clear that we are using de Bruijn indices,
-- encoded as natural numbers, more or less.
data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ σ τ} → (x : Var Γ τ) → Var (σ • Γ) τ

-- Weakening
-- =========
--
-- We define weakening based on subcontext relationship.

-- Subcontexts
-- -----------
--
-- Useful as a reified weakening operation,
-- and for making theorems strong enough to prove by induction.
--
-- The contents of this module are currently exported at the end
-- of this file.

-- This handling of contexts is recommended by [this
-- email](https://lists.chalmers.se/pipermail/agda/2011/003423.html) and
-- attributed to Conor McBride.
--
-- The associated thread discusses a few alternatives solutions, including one
-- where beta-reduction can handle associativity of ++.

module Subcontexts where
  infix 4 _≼_

  data _≼_ : (Γ₁ Γ₂ : Context) → Set where
    ∅ : ∅ ≼ ∅
    keep_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      τ • Γ₁ ≼ τ • Γ₂
    drop_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      Γ₁ ≼ τ • Γ₂

  -- Properties

  ∅≼Γ : ∀ {Γ} → ∅ ≼ Γ
  ∅≼Γ {∅} = ∅
  ∅≼Γ {τ • Γ} = drop τ • ∅≼Γ

  ≼-refl : Reflexive _≼_
  ≼-refl {∅} = ∅
  ≼-refl {τ • Γ} = keep τ • ≼-refl

  ≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
  ≼-reflexive refl = ≼-refl

  ≼-trans : Transitive _≼_
  ≼-trans ≼₁ ∅ = ≼₁
  ≼-trans (keep .τ • ≼₁) (keep τ • ≼₂) = keep τ • ≼-trans ≼₁ ≼₂
  ≼-trans (drop .τ • ≼₁) (keep τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂
  ≼-trans ≼₁ (drop τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂

  ≼-isPreorder : IsPreorder _≡_ _≼_
  ≼-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive = ≼-reflexive
    ; trans = ≼-trans
    }

  ≼-preorder : Preorder _ _ _
  ≼-preorder = record
    { Carrier = Context
    ; _≈_ = _≡_
    ; _∼_ = _≼_
    ; isPreorder = ≼-isPreorder
    }

  module ≼-Reasoning where
    open import Relation.Binary.PreorderReasoning ≼-preorder public
      renaming
        ( _≈⟨_⟩_ to _≡⟨_⟩_
        ; _∼⟨_⟩_ to _≼⟨_⟩_
        ; _≈⟨⟩_ to _≡⟨⟩_
        )

  -- Lift a variable to a super context

  weaken-var : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
  weaken-var (keep τ • ≼₁) this = this
  weaken-var (keep τ • ≼₁) (that x) = that (weaken-var ≼₁ x)
  weaken-var (drop τ • ≼₁) x = that (weaken-var ≼₁ x)

-- Currently, we export the subcontext relation.

open Subcontexts public


-- Andreas, 2015-06-24

open import Common.Equality
open import Common.Product

Sing : {A : Set} (a : A) → Set
Sing a = ∃ λ b → a ≡ b

works : {A : Set} (f : ∀{a : A} → Sing a) (a : A) → Sing a
works f a = let b , p = f {_} in b , p

test : {A : Set} (f : ∀{a : A} → Sing a) (a : A) → Sing a
test f a = let b , p = f in b , p

-- ERROR WAS:
-- Type mismatch
-- when checking that the pattern b , p has type
-- {a = a₁ : .A} → Sing a₁

-- should work now


{-# OPTIONS --without-K #-}
module Wow-It-is-FV where

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

levelEq : lzero ≡ lzero
levelEq = refl

levelEq′ : lsuc lzero ≡ lsuc lzero
levelEq′ = refl

trans : {l : Level} {Q : Set l} {a b c : Q}
      → a ≡ b → b ≡ c → a ≡ c
trans refl refl = refl

J : {A : Set} (P : (x y : A) → x ≡ y → Set)
  → ((x : A) → P x x refl)
  → (x y : A) (xy : x ≡ y) → P x y xy
J P p x .x refl = p x

cong : {A B : Set} (f : A → B)
     → {m n : A} → m ≡ n → f m ≡ f n
cong f refl = refl

sym : {A : Set} {m n : A} → m ≡ n → n ≡ m
sym refl = refl

theorem : suc zero + suc zero ≡ _
theorem = refl

theorem′ : 1 + 1 ≡ 2
theorem′ = refl

trivialEq : {a : _} {A : Set a} → A ≡ A
trivialEq = refl

trivialEq′ : ∀ {a} {A : Set a} → A ≡ A
trivialEq′ = refl

trivialEq′′ : ∀ a b → a + b ≡ a + b
trivialEq′′ a b = refl

trans′ : ∀ {a} {A : Set a} (a b c : A)
       → a ≡ b → b ≡ c → a ≡ c
trans′ a .a c refl bc = bc

data _<=_ : (a b : Nat) → Set where
  0ltn : ∀ {n}   → 0 <= n
  nltm : ∀ {n m} → n <= m → suc n <= suc m

7lt13 : 7 <= 13
7lt13 = nltm (nltm (nltm (nltm (nltm (nltm (nltm 0ltn))))))

abc : ∀ {a b c} → a <= b → b <= c → a <= c
abc 0ltn bc = 0ltn
abc (nltm ab) (nltm bc) = nltm (abc ab bc)

data ⊥ : Set where

ridiculous : ⊥ → ⊥
ridiculous a = a

ridiculous′ : 1 ≡ 0 → ⊥
ridiculous′ ()

⊥-elim : ∀ {a} {A : Set a} → ⊥ → A
⊥-elim ()

4lt3 : 4 <= 3 → ⊥
4lt3 (nltm (nltm (nltm ())))

infix 3 ¬_
¬_ : ∀ {a} → Set a → Set a
¬ P = P → ⊥

_!=_ : ∀ {a} {A : Set a} → A → A → Set a
x != y = ¬ x ≡ y

_≡⟨_⟩_ : ∀ {A : Set} (x : A) {y z : A} → x ≡ y → y ≡ z → x ≡ z
_ ≡⟨ refl ⟩ c = c

_QED : ∀ {A : Set} (x : A) → x ≡ x
_ QED = refl

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

lemma₁ : ∀ n m → suc (n + m) ≡ n + suc m
lemma₁ zero _ = refl
lemma₁ (suc n) m = cong suc (lemma₁ n m)

comm : ∀ n m → n + m ≡ m + n
comm zero n = sym (lemma₀ n)
comm (suc n) m = suc n + m
  ≡⟨ refl ⟩ suc (n + m)
  ≡⟨ cong suc (comm n m) ⟩ suc (m + n)
  ≡⟨ lemma₁ m n ⟩ m + suc n QED

infixr 2 _≡⟨_⟩_
infix 3 _QED


{-# OPTIONS --cubical --guardedness --postfix-projections #-}

module Data.Graph where

open import Prelude
open import Data.List
open import Data.Nat

-- record Thunk (A : Type a) : Type a where
--   coinductive
--   constructor ⟪_⟫
--   field force : A
-- open Thunk

-- infixr 5 _◃_
-- record Stream (A : Type a) : Type a where
--   constructor _◃_
--   coinductive
--   field
--     head : A
--     tail : (Stream A)

-- open Stream

Graph : Type a → Type a
Graph A = A → List A

Stream : Type a → Type a
Stream A = ℕ → A

pure : A → Stream A
pure x _ = x

smap : (A → B) → Stream A → Stream B
smap f xs n = f (xs n)

bfs : Graph A → A → Stream (List A)
bfs g r zero    = r ∷ []
bfs g r (suc n) = concatMap g (bfs g r n)

-- module _ {A : Type a} (g : Graph A) where
--   mutual
--     bfs-foldr : List A → Stream (List A) → Stream (List A)
--     bfs-foldr []       qs = qs
--     bfs-foldr (x ∷ xs) qs .head = x ∷ bfs-foldr xs qs .head
--     bfs-foldr (x ∷ xs) qs .tail .force = bfs-foldr (g x) (bfs-foldr xs qs .tail .force)

--     -- bfs-cons : A → Stream (List A) → Stream (List A)
--     -- bfs-cons x (q ◃ qs) = (x ∷ q) ◃ bfs-foldr (g x) qs

--   -- bfs : A → Stream (List A)
--   -- bfs r = bfs-cons r (pure [])


module Data.Finitude.Exponent where
open import Data.Finitude
open import Data.Fin as Fin using (Fin; toℕ)
open import Data.Nat
open import Data.Vec as Vec
open import Relation.Binary.PropositionalEquality as P
open import Data.Nat.DivMod
open import Relation.Nullary.Decidable
open import Function
open import Function.Equality as F using (_⟶_; _⟨$⟩_; _⇨_)
open import Function.Inverse as Inv using (module Inverse; Inverse)
open import Data.Product
open import Data.Sum
open import Data.Empty
open import Relation.Binary

exponent : ∀ {m} {n} → Finitude (P.setoid (Vec (Fin m) n)) (m ^ n)
exponent {m} {n} = record {
    to = P.→-to-⟶ to
  ; from = P.→-to-⟶ from
  ; inverse-of = record {
      left-inverse-of = from∘to
    ; right-inverse-of = to∘from {m}{n}
    }
  }
  where
    open import Data.Nat.Properties
    open import Data.Fin.Properties hiding (≤-refl; _≟_; <-cmp)
    open import Relation.Nullary.Negation
    shift : ∀ {m n} (i : Fin m)(j : Fin n) → toℕ j + (toℕ i) * n < m * n
    shift {m}{n} i j =
              begin suc (toℕ j) + toℕ i * n
                ≤⟨ +-mono-≤ (toℕ<n j) (≤-refl {(toℕ i) * n}) ⟩
                  n + toℕ i * n
                ≤⟨ *-mono-≤ (toℕ<n i) ≤-refl ⟩ m * n ∎
          where
            open ≤-Reasoning
    to : ∀ {m n} → Vec (Fin m) n → Fin (m ^ n)
    to [] = Fin.zero
    to {m}{n = suc n} (i ∷ is) = Fin.fromℕ≤ (shift i (to is))

    suci^j≢0  : ∀ i j → suc i ^ j ≢ 0
    suci^j≢0 i j eq with i^j≡0⇒i≡0 _ j eq
    ... | ()

    from : ∀ {m n} → Fin (m ^ n) → Vec (Fin m) n
    from {m} {zero} i = []
    from {zero} {suc n} ()
    from {suc m} {suc n} i with ((toℕ i) divMod (suc m ^ n))
      {≢0 = fromWitnessFalse (suci^j≢0 _ n)}
    from {suc m} {suc n} i | result quotient remainder property
      = Fin.fromℕ≤ q<sm  ∷ from remainder
      where
        q<sm : quotient < suc m
        q<sm = ≰⇒> (λ sm≤q → <⇒≱ (toℕ<n i)
                (begin (suc m) * (suc m ^ n)
                   ≤⟨ *-mono-≤ sm≤q ≤-refl ⟩ quotient * (suc m ^ n)
                   ≤⟨ +-mono-≤ (z≤n {toℕ remainder}) ≤-refl ⟩ toℕ remainder + quotient * (suc m ^ n)
                   ≡⟨ P.sym property ⟩ toℕ i ∎))
              where
                open ≤-Reasoning
    ≢→<⊎> : ∀ {m n} → m ≢ n → m < n ⊎ n < m
    ≢→<⊎> {m}{n} m≢n  with <-cmp m n
    ≢→<⊎> {m} {n} m≢n | tri<  m<n _ _ = inj₁ m<n
    ≢→<⊎> {m} {n} m≢n | tri≈ _ m≡n _ = ⊥-elim (m≢n m≡n)
    ≢→<⊎> {m} {n} m≢n | tri> _ _ n<m = inj₂ n<m

    chn : ∀ m → ∀ {k₀ k₁} {r₀ r₁ : Fin m} → toℕ r₀ + k₀ * m  ≡ toℕ r₁ + k₁ * m → k₀ ≡ k₁ × r₀ ≡ r₁
    chn zero {k₀} {k₁} {()} {r₁} _
    chn (suc m) {k₀} {k₁} {r₀} {r₁} eq = k₀≡k₁ , r₀≡r₁
      where
        open ≤-Reasoning
        contra : k₀ ≢ k₁ → ⊥
        contra k₀≢k₁ with ≢→<⊎> k₀≢k₁
        ... | inj₁ k₀<k₁ = <⇒≱  (toℕ<n r₀) (+-cancelʳ-≤ (suc m) (toℕ r₀)
                                 (begin suc m + k₀ * suc m
                                   ≡⟨ refl ⟩ suc k₀ * suc m
                                   ≤⟨ *-mono-≤ (m≤m+n (suc k₀) (k₁ ∸ suc k₀)) (≤-refl {suc m}) ⟩
                                          (suc k₀ + (k₁ ∸ suc k₀)) * suc m
                                   ≡⟨ P.cong₂ _*_ (m+n∸m≡n k₀<k₁) refl ⟩ k₁ * suc m
                                   ≤⟨ n≤m+n (toℕ r₁) (k₁ * suc m)  ⟩ toℕ r₁ + k₁ * suc m
                                   ≡⟨ P.sym eq ⟩ toℕ r₀ + k₀ * suc m ∎))
        ... | inj₂ k₁<k₀ = <⇒≱  (toℕ<n r₁) (+-cancelʳ-≤  (suc m) (toℕ r₁)
                  (begin suc k₁ * suc m
                         ≤⟨ *-mono-≤ (m≤m+n (suc k₁) (k₀ ∸ suc k₁)) (≤-refl {suc m}) ⟩
                         (suc k₁ + (k₀ ∸ suc k₁)) * suc m
                         ≡⟨ P.cong₂ _*_ (m+n∸m≡n k₁<k₀) refl ⟩ k₀ * suc m
                         ≤⟨ n≤m+n  (toℕ r₀) (k₀ * suc m) ⟩ toℕ r₀ + k₀ * suc m
                         ≡⟨ eq ⟩ toℕ r₁ + k₁ * suc m  ∎ ))
        k₀≡k₁ : k₀ ≡ k₁
        k₀≡k₁ = decidable-stable (k₀ ≟ k₁) contra

        r₀≡r₁ : r₀ ≡ r₁
        r₀≡r₁ = toℕ-injective (+-cancelʳ-≡ (toℕ r₀) (toℕ r₁)
          (P.subst (λ k → toℕ r₀ + k * (suc m)  ≡ toℕ r₁ + k₁ * (suc m)) k₀≡k₁ eq))

    from∘to : ∀ {m n}(is : Vec (Fin m) n) → from (to is) ≡ is
    from∘to {m} {.0} [] = P.refl
    from∘to {zero} {.(suc _)} (() ∷ is)
    from∘to {suc m} {suc n} (i ∷ is) with to (i ∷ is) | P.inspect to (i ∷ is)
    from∘to {suc m} {suc n} (i ∷ is) | j | Reveal_·_is_.[ eq ] with P.cong toℕ eq
    ... | eq2 rewrite toℕ-fromℕ≤ (shift i (to is)) with ((toℕ j) divMod (suc m ^ n))
      {≢0 = fromWitnessFalse (suci^j≢0 _ n)}
    ... | result quotient remainder property with chn (suc m ^ n) {toℕ i}{quotient}
          {to is}{remainder} (trans eq2 property)
    ... | k₀≡k₁ , r₀≡r₁ rewrite P.sym r₀≡r₁ | from∘to is =
        P.cong (_∷ is) (toℕ-injective (begin toℕ (Fin.fromℕ≤ _)
                                               ≡⟨ toℕ-fromℕ≤ _ ⟩ quotient
                                               ≡⟨ P.sym k₀≡k₁ ⟩ toℕ i ∎))
        where
          open ≡-Reasoning

    to∘from : ∀ {m n}(i : Fin (m ^ n)) → to (from{m}{n} i) ≡ i
    to∘from {m} {zero} Fin.zero = refl
    to∘from {m} {zero} (Fin.suc ())
    to∘from {zero} {suc n} ()
    to∘from {suc m} {suc n} i with ((toℕ i) divMod (suc m ^ n))
      {≢0 = fromWitnessFalse (suci^j≢0 _ n)}
    to∘from {suc m} {suc n} i | result quotient remainder property = goal
      where
        q<sm : quotient < suc m
        q<sm = ≰⇒> (λ sm≤q → <⇒≱ (toℕ<n i)
                (begin (suc m) * (suc m ^ n)
                   ≤⟨ *-mono-≤ sm≤q ≤-refl ⟩ quotient * (suc m ^ n)
                   ≤⟨ +-mono-≤ (z≤n {toℕ remainder}) ≤-refl ⟩ toℕ remainder + quotient * (suc m ^ n)
                   ≡⟨ P.sym property ⟩ toℕ i ∎))
              where
                open ≤-Reasoning

        goal : to (Fin.fromℕ≤ q<sm  ∷ from {suc m}{n} remainder) ≡ i
        goal = toℕ-injective
              (begin _ ≡⟨ toℕ-fromℕ≤ _ ⟩
                         toℕ (to (from {suc m} {n} remainder)) + toℕ (Fin.fromℕ≤ q<sm ) * (suc m ^ n)
                       ≡⟨ P.cong₂ (λ r k → toℕ r + k * (suc m ^ n))
                            (to∘from {suc m} {n} remainder) (toℕ-fromℕ≤ q<sm)
                          ⟩  toℕ remainder + quotient * (suc m ^ n)
                       ≡⟨ P.sym property ⟩ toℕ i ∎)
          where
            open ≡-Reasoning

⟶-finitude-toVec : ∀{m n a b p q}{A : Setoid a p}{B : Setoid b q} → Finitude A m → Finitude B n
             → A ⟶ B → Vec (Fin n) m
⟶-finitude-toVec finA finB f = Vec.tabulate
                                   (λ i → (Inverse.to finB  F.∘ f F.∘ Inverse.from finA) ⟨$⟩ i )

⟶-finitude-fromVec : ∀{m n a b p q}{A : Setoid a p}{B : Setoid b q} → Finitude A m → Finitude B n
             → Vec (Fin n) m → A ⟶ B
⟶-finitude-fromVec {A = SA}{B = SB} finA finB vec =
  record {   _⟨$⟩_ = f
          ;  cong  = f-cong   }
  where
    open module SA = Setoid SA renaming (Carrier to A) using ()
    open module SB = Setoid SB renaming (Carrier to B) using ()
    f : A → B
    f x = Inverse.from finB ⟨$⟩ Vec.lookup (Inverse.to finA ⟨$⟩ x) vec

    f-cong : ∀ {x y} → x SA.≈ y → f x SB.≈ f y
    f-cong {x}{y} x≈y = F.cong (Inverse.from finB)
                           (P.cong (flip Vec.lookup vec) (F.cong (Inverse.to finA) x≈y))

⟶-finitude↔Vec : ∀{m n a b p q}{A : Setoid a p}{B : Setoid b q} → Finitude A n → Finitude B m
                 → Inverse (A ⇨ B) (P.setoid (Vec (Fin m) n))
Inverse.to (⟶-finitude↔Vec {m} {n} {A = S₁} {S₂} finA finB) ._⟨$⟩_ = ⟶-finitude-toVec finA finB
Inverse.to (⟶-finitude↔Vec {m} {n} {A = S₁} {S₂} finA finB) .F.cong {f} {g} eq = tabulate-cong ( λ i →
  F.cong (Inverse.to finB) (eq ≈₁-refl) )
  where
    open import Data.Vec.Properties
    open Setoid S₁ renaming (isEquivalence to isEquivalence₁)
    open IsEquivalence isEquivalence₁ renaming (refl to ≈₁-refl)

Inverse.from (⟶-finitude↔Vec finA finB) = P.→-to-⟶ (⟶-finitude-fromVec finA finB)
Inv._InverseOf_.left-inverse-of (Inverse.inverse-of (⟶-finitude↔Vec {m = m}{n}{A = S₁} {S₂} finA finB)) f {x}{y} x≈y =
  begin ⟶-finitude-fromVec finA finB (⟶-finitude-toVec finA finB f) ⟨$⟩ x
         ≈⟨ F.cong (Inverse.from finB) lemma  ⟩ _
         ≈⟨ linv₂ _  ⟩ _
         ≈⟨ F.cong f (linv₁ x) ⟩ _
         ≈⟨ F.cong f x≈y ⟩ f ⟨$⟩ y ∎
  where
    open import Data.Vec.Properties
    open import Relation.Binary.Reasoning.Setoid (S₂)
    open Setoid S₁ renaming (isEquivalence to isEquivalence₁)
    open IsEquivalence isEquivalence₁ renaming (refl to ≈₁-refl; trans to ≈₁-trans)
    open Setoid S₂ renaming (isEquivalence to isEquivalence₂)
    open IsEquivalence isEquivalence₂ renaming (refl to ≈₂-refl; trans to ≈₂-trans)
    F = (Inverse.to finB  F.∘ f F.∘ Inverse.from finA) ⟨$⟩_
    lemma = lookup∘tabulate F (Inverse.to finA ⟨$⟩ x)
    linv₁ = finA .Inverse.inverse-of .Inv._InverseOf_.left-inverse-of
    linv₂ = finB .Inverse.inverse-of .Inv._InverseOf_.left-inverse-of
Inv._InverseOf_.right-inverse-of (Inverse.inverse-of (⟶-finitude↔Vec finA finB)) vec =
  begin _  ≡⟨ tabulate-cong lemma ⟩ _
           ≡⟨ tabulate∘lookup vec ⟩ vec ∎
  where
    open import Data.Vec.Properties
    open P.≡-Reasoning
    rinv₁ = finA .Inverse.inverse-of .Inv._InverseOf_.right-inverse-of
    rinv₂ = finB .Inverse.inverse-of .Inv._InverseOf_.right-inverse-of
    lemma : Inverse.to finB F.∘ (⟶-finitude-fromVec finA finB vec) F.∘ Inverse.from finA ⟨$⟩_ ≗ flip lookup vec
    lemma i = begin _ ≡⟨ rinv₂ _ ⟩ _
                      ≡⟨ P.cong (flip lookup vec) (rinv₁ i)  ⟩ lookup i vec ∎

⟶-finitude : ∀{m n a b p q}{A : Setoid a p}{B : Setoid b q} → Finitude A n → Finitude B m
                 → Finitude (A ⇨ B) (m ^ n)
⟶-finitude finA finB = exponent  Inv.∘ (⟶-finitude↔Vec finA finB)


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

open import HoTT
open import homotopy.HSpace

module homotopy.CircleHSpace where

S¹-hSpace : HSpaceStructure S¹
S¹-hSpace = hSpaceStructure base μ μ-e-l μ-e-r μ-coh where

  turn-around : (x : S¹) → x == x
  turn-around = S¹-elim loop (↓-idf=idf-in (∙=∙' loop loop))

  module Mu = S¹Rec (idf S¹) (λ= turn-around)

  μ : S¹ → S¹ → S¹
  μ = Mu.f

  μ-e-l : (x : S¹) → μ base x == x
  μ-e-l x = idp

  μ-e-r : (x : S¹) → μ x base == x
  μ-e-r = S¹-elim idp (↓-app=idf-in
    (idp ∙' loop                          =⟨ ∙'-unit-l loop ⟩
     loop                                 =⟨ idp ⟩
     turn-around base                     =⟨ ! (app=-β turn-around base) ⟩
     ap (λ z → z base) (λ= turn-around)   =⟨ ! (Mu.loop-β |in-ctx (ap (λ z → z base))) ⟩
     ap (λ z → z base) (ap μ loop)        =⟨ ! (ap-∘ (λ z → z base) μ loop) ⟩
     ap (λ z → μ z base) loop             =⟨ ! (∙-unit-r _) ⟩
     ap (λ z → μ z base) loop ∙ idp ∎))

  μ-coh = idp


module Normalize where

open import Data.List
open import Data.Product

open import PiLevel0

-- We are going to use all the coherence as follows; make the right
-- hand side canonical and rewrite the left hand side to the right
-- hand side. Brute force below cannot work!

-- Use the same structure as
-- https://agda.github.io/agda-stdlib/Algebra.Monoid-solver.html ??

{-# NO_TERMINATION_CHECK #-}
normalize : {t₁ t₂ : U} → (t₁ ⟷ t₂) → (t₁ ⟷ t₂)
normalize unite₊ = {!!}
normalize uniti₊ = {!!}
normalize swap₊ = {!!}
normalize assocl₊ = {!!}
normalize assocr₊ = {!!}
normalize unite⋆ = {!!}
normalize uniti⋆ = {!!}
normalize swap⋆ = {!!}
normalize assocl⋆ = {!!}
normalize assocr⋆ = {!!}
normalize absorbr = {!!}
normalize absorbl = {!!}
normalize factorzr = {!!}
normalize factorzl = {!!}
normalize dist = {!!}
normalize factor = {!!}
normalize id⟷ = {!!}
normalize (c ◎ id⟷) = normalize c
normalize (unite₊ ◎ c₁) = {!!}
normalize (uniti₊ ◎ c₁) = {!!}
normalize (swap₊ ◎ c₁) = {!!}
normalize (assocl₊ ◎ c₁) = {!!}
normalize (assocr₊ ◎ c₁) = {!!}
normalize (unite⋆ ◎ c₁) = {!!}
normalize (uniti⋆ ◎ c₁) = {!!}
normalize (swap⋆ ◎ c₁) = {!!}
normalize (assocl⋆ ◎ c₁) = {!!}
normalize (assocr⋆ ◎ c₁) = {!!}
normalize (absorbr ◎ c₁) = {!!}
normalize (absorbl ◎ c₁) = {!!}
normalize (factorzr ◎ c₁) = {!!}
normalize (factorzl ◎ c₁) = {!!}
normalize (dist ◎ c₁) = {!!}
normalize (factor ◎ c₁) = {!!}
normalize (id⟷ ◎ c₁) = normalize c₁
normalize ((c ◎ c₁) ◎ c₂) = normalize (c ◎ (c₁ ◎ c₂))
normalize ((c ⊕ c₁) ◎ c₂) = {!!}
normalize ((c ⊗ c₁) ◎ c₂) = {!!}
normalize (c ⊕ unite₊) = {!!}
normalize (c ⊕ uniti₊) = {!!}
normalize (c ⊕ swap₊) = {!!}
normalize (c ⊕ assocl₊) = {!!}
normalize (c ⊕ assocr₊) = {!!}
normalize (c ⊕ unite⋆) = {!!}
normalize (c ⊕ uniti⋆) = {!!}
normalize (c ⊕ swap⋆) = {!!}
normalize (c ⊕ assocl⋆) = {!!}
normalize (c ⊕ assocr⋆) = {!!}
normalize (c ⊕ absorbr) = {!!}
normalize (c ⊕ absorbl) = {!!}
normalize (c ⊕ factorzr) = {!!}
normalize (c ⊕ factorzl) = {!!}
normalize (c ⊕ dist) = {!!}
normalize (c ⊕ factor) = {!!}
normalize (c ⊕ id⟷) = {!!}
normalize (c ⊕ c₁ ◎ c₂) = {!!}
normalize (c ⊕ (c₁ ⊕ c₂)) = {!!}
normalize (c ⊕ (c₁ ⊗ c₂)) = {!!}
normalize (c ⊗ c₁) = {!!}


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

module Math.NumberTheory.Summation.Generic.Properties.Lemma where

-- agda-stdlib
open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Solver
open import Relation.Binary.PropositionalEquality
open import Function.Base

lemma₁ : ∀ m n → 2 + m + n ≡ suc m + suc n
lemma₁ = solve 2 (λ m n → con 2 :+ m :+ n := con 1 :+ m :+ (con 1 :+ n)) refl
  where open +-*-Solver


{-# OPTIONS --inversion-max-depth=10 #-}

open import Agda.Builtin.Nat

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

F : Nat → Set
F zero    = Nat
F (suc n) = Nat × F n

f : (n : Nat) → F n
f zero    = zero
f (suc n) = n , f n

mutual

  n : Nat
  n = _

  test : F n
  test = f (suc n)


module Prelude where

-- Booleans
data Bool : Set where
  tt : Bool
  ff : Bool

_||_ : Bool -> Bool -> Bool
tt || y = tt
ff || y = y

_&&_ : Bool -> Bool -> Bool
tt && y = y
ff && y = ff

if_then_else : {A : Set} -> Bool -> A -> A -> A
if tt then x else _ = x
if ff then _ else y = y

-- Eq "type class"
record Eq (A : Set) : Set where
  field
    _==_   : A -> A ->  Bool

open Eq {{...}} public

-- Function composition
_∘_ : ∀ {x y z : Set} -> (y -> z) -> (x -> y) -> (x -> z)
(f ∘ g) x = f (g x)

-- Product type
data _×_ (A B : Set) : Set where
    _,_ : A -> B -> A × B

uncurry : ∀ {x y z : Set} -> (x -> y -> z) -> (x × y) -> z
uncurry f (a , b) = f a b

-- Lists
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

infixr 20 _::_
infixr 15 _++_

[_] : ∀ {A} -> A -> List A
[ x ] = x :: []

_++_ : ∀ {A} -> List A -> List A -> List A
[] ++ l = l
(x :: xs) ++ l = x :: (xs ++ l)

foldr : ∀ {A B : Set} -> (A -> B -> B) -> B -> List A -> B
foldr f b [] = b
foldr f b (x :: xs) = f x (foldr f b xs)

map : ∀ {A B} -> (A -> B) -> List A -> List B
map f [] = []
map f (x :: xs) = f x :: map f xs

zip : ∀ {A B} -> List A -> List B -> List (A × B)
zip [] _                = []
zip _  []               = []
zip (x :: xs) (y :: ys) = (x , y) :: zip xs ys

-- Bottom type
-- data ⊥ : Set where

-- ¬ : Set -> Set
-- ¬ A = A -> ⊥

-- Decidable propositions and relations:
-- Rel : Set -> Set₁
-- Rel a = a -> a -> Set

-- data Dec (P : Set) : Set where
--   yes : (p : P) → Dec P
--   no : (¬p : ¬ P) → Dec P

-- Decidable : {a : Set} → Rel a → Set
-- Decidable _∼_ = forall x y → Dec (x ∼ y)

-- Natural numbers
data ℕ : Set where
  zero : ℕ
  suc  : ℕ -> ℕ


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

module CombiningProofs.Eta where

infix 7 _≡_
infix 5 ∃

postulate
  D   : Set
  ∃   : (A : D → Set) → Set
  _≡_ : D → D → Set

syntax ∃ (λ x → e) = ∃[ x ] e

postulate
  t₁ : ∀ d → ∃[ e ] d ≡ e
  t₂ : ∀ d → ∃ (_≡_ d)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Results concerning function extensionality for propositional equality
------------------------------------------------------------------------

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

module Axiom.Extensionality.Propositional where

open import Function
open import Level using (Level; _⊔_; suc; lift)
open import Relation.Binary.Core
open import Relation.Binary.PropositionalEquality.Core

------------------------------------------------------------------------
-- Function extensionality states that if two functions are
-- propositionally equal for every input, then the functions themselves
-- must be propositionally equal.

Extensionality : (a b : Level) → Set _
Extensionality a b =
  {A : Set a} {B : A → Set b} {f g : (x : A) → B x} →
  (∀ x → f x ≡ g x) → f ≡ g

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

-- If extensionality holds for a given universe level, then it also
-- holds for lower ones.

lower-extensionality : ∀ {a₁ b₁} a₂ b₂ →
                       Extensionality (a₁ ⊔ a₂) (b₁ ⊔ b₂) →
                       Extensionality a₁ b₁
lower-extensionality a₂ b₂ ext f≡g = cong (λ h → Level.lower ∘ h ∘ lift) $
    ext (cong (lift {ℓ = b₂}) ∘ f≡g ∘ Level.lower {ℓ = a₂})

-- Functional extensionality implies a form of extensionality for
-- Π-types.

∀-extensionality : ∀ {a b} → Extensionality a (suc b) →
                   {A : Set a} (B₁ B₂ : A → Set b) →
                   (∀ x → B₁ x ≡ B₂ x) →
                   (∀ x → B₁ x) ≡ (∀ x → B₂ x)
∀-extensionality ext B₁ B₂ B₁≡B₂ with ext B₁≡B₂
∀-extensionality ext B .B  B₁≡B₂ | refl = refl


open import SingleSorted.AlgebraicTheory
open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import SingleSorted.Substitution
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)

module SingleSorted.Group where

data GroupOp : Set where
  e : GroupOp
  inv : GroupOp
  mul : GroupOp

_ : Context
_ = ctx-empty

_ : Context
_ = ctx-concat ctx-slot ctx-empty

_ : var ctx-slot
_ = var-var

_ : var (ctx-concat ctx-slot ctx-slot)
_ = var-inl var-var

_ : var (ctx-concat ctx-slot ctx-slot)
_ = var-inr var-var

ctx-1 : Context
ctx-1 = ctx-slot

ctx-2 : Context
ctx-2 = ctx-concat ctx-1 ctx-1

ctx : ∀ (n : ℕ) → Context
ctx zero = ctx-empty
ctx (suc n) = ctx-concat (ctx n) ctx-slot

-- the signature of the theory of groups
-- has one constant, one unary operation, one binary operation
Σ : Signature
Σ = record { oper = GroupOp ; oper-arity = λ{ e → ctx-empty ; inv → ctx 1 ; mul → ctx 2} }

open Signature Σ

-- some example terms
_ : Term ctx-1
_ = tm-var var-var

_ : Term ctx-2
_ = tm-var (var-inr var-var)

_ : Term ctx-2
_ = tm-var (var-inr var-var)

-- helper functions for creating terms
e' : ∀ {Γ : Context} → Term Γ
e' {Γ} = tm-oper e λ()

-- inv' : ∀ {Γ : Context} → Term Γ → Term Γ
-- inv' x = tm-oper inv λ{ _ → x}

-- mul' : ∀ {Γ : Context} → Term Γ → Term Γ → Term Γ
-- mul' x y = tm-oper mul λ{ (var-inl _) → x ; (var-inr _) → y}

concat-empty : var (ctx-concat ctx-empty ctx-slot) → (var ctx-slot)
concat-empty (var-inr x) = x

x*y : Term ctx-2
x*y = tm-oper mul λ{ (var-inl x) → tm-var (var-inl (concat-empty x)) ; (var-inr y) → tm-var (var-inr y)}

-- concat-empty-idʳ : ctx-concat ctx-empty ctx-slot ≡ ctx-slot
-- concat-empty-idʳ = {!!}

singleton-context : (var ctx-slot) → var (ctx-concat ctx-empty ctx-slot)
singleton-context (var-var) = var-inr var-var

σ : ∀ {Γ : Context} {t : Term Γ} →  Γ ⇒s (ctx 1)
σ {Γ} {t} = λ{ (var-inr var-var) → t}

δ : ∀ {Γ : Context} {t : Term Γ} {s : Term Γ} →   Γ ⇒s (ctx 2)
δ {Γ} {t} {s} = λ{ (var-inl x) → t ; (var-inr y) → s}

_∗_ : ∀ {Γ} → Term Γ → Term Γ → Term Γ
t ∗ s =  tm-oper mul λ{ xs → δ {t = t} {s = s} xs}

_ⁱ : ∀ {Γ : Context} →  Term Γ → Term Γ
t ⁱ =  tm-oper inv λ{ x → σ {t = t} x}

-- _∗_ : ∀ {Γ} → Term Γ → Term Γ → Term Γ
-- t ∗ s =  tm-oper mul λ{ (var-inl x) → t ; (var-inr args) → s}

-- _ⁱ : ∀ {Γ : Context} →  Term Γ → Term Γ
-- t ⁱ =  tm-oper inv λ{ x → t }

infixl 5 _∗_
infix 6 _ⁱ

_ : Term (ctx 2)
_ = tm-var (var-inl (var-inr var-var)) ∗ tm-var (var-inr var-var)

_ : Term (ctx 1)
_ = e' ∗ a
  where
  a : Term (ctx 1)
  a = tm-var (var-inr var-var)

-- group equations
data GroupEq : Set where
  mul-assoc e-left e-right inv-left inv-right : GroupEq

mul-assoc-ax : Equation
e-left-ax : Equation
e-right-ax : Equation
inv-left-ax : Equation
inv-right-ax : Equation

mul-assoc-ax = record { eq-ctx = ctx 3
                      ; eq-lhs = x ∗ y ∗ z
                      ; eq-rhs = x ∗ (y ∗ z)
                      }
             where
             x : Term (ctx 3)
             y : Term (ctx 3)
             z : Term (ctx 3)
             x = tm-var (var-inl (var-inl (var-inr var-var)))
             y = tm-var (var-inl (var-inr var-var))
             z = tm-var (var-inr var-var)

e-left-ax = record { eq-ctx = ctx 1 ; eq-lhs = e' ∗ x ; eq-rhs = x }
  where
  x : Term (ctx 1)
  x = tm-var (var-inr var-var)

e-right-ax = record { eq-ctx = ctx 1 ; eq-lhs = x ∗ e' ; eq-rhs = x }
  where
  x : Term (ctx 1)
  x = tm-var (var-inr var-var)

inv-left-ax = record { eq-ctx = ctx 1 ; eq-lhs = x ⁱ ∗ x ; eq-rhs = e' }
  where
  x : Term (ctx 1)
  x = tm-var (var-inr var-var)

inv-right-ax = record { eq-ctx = ctx 1 ; eq-lhs = x ∗ x ⁱ ; eq-rhs = e' }
  where
  x : Term (ctx 1)
  x = tm-var (var-inr var-var)

𝒢 : Theory lzero Σ
𝒢 = record { ax = GroupEq
            ; ax-eq = λ{ mul-assoc → mul-assoc-ax
                       ; e-left → e-left-ax
                       ; e-right → e-right-ax
                       ; inv-left → inv-left-ax
                       ; inv-right → inv-right-ax
                       }
            }


module Syntax where

open import Data.List using (List; []; _∷_; _++_; lookup; length)
open import Data.Product using (Σ; Σ-syntax; proj₁; proj₂)
open import Data.Unit renaming (⊤ to top)
open import Data.Empty renaming (⊥ to bot)

open import Level using (suc; _⊔_)

module PType {ℓ} (Gr : Set ℓ) where
  infixr 10 _*_
  infixr 9 _=>_

  data Type : Set ℓ where
    ⌊_⌋ : Gr -> Type
    Unit : Type
    _*_ : Type -> Type -> Type
    _=>_ : Type -> Type -> Type

  record Sorting : Set ℓ where
    field
      dom : Type
      cod : Type

  Context : Set ℓ
  Context = List Type

record Signature ℓ₁ ℓ₂ : Set (suc (ℓ₁ ⊔ ℓ₂)) where
  field
    Gr : Set ℓ₁
    Func : Set ℓ₂

  open PType Gr public

  field
    sorting : Func -> Sorting

  dom : Func -> Type
  dom f = Sorting.dom (sorting f)

  cod : Func -> Type
  cod f = Sorting.cod (sorting f)

module Term {ℓ₁ ℓ₂} (Sg : Signature ℓ₁ ℓ₂) where
  open Signature Sg

  infix 3 _⊨_
  infix 8 _∙_

  infix 3 _⊢_
  infixl 4 _[_]

  data _⊨_ : Context -> Context -> Set (ℓ₁ ⊔ ℓ₂)
  data _⊢_ : Context -> Type -> Set (ℓ₁ ⊔ ℓ₂)

  data _⊨_ where
    id : forall {Γ} -> Γ ⊨ Γ  -- identity morphism
    _∙_ : forall {Γ Γ′ Γ′′} -> Γ′ ⊨ Γ′′ -> Γ ⊨ Γ′ -> Γ ⊨ Γ′′ -- composition of morphisms
    weaken : forall {Γ A} -> A ∷ Γ ⊨ Γ -- the first projection
    ext : forall {Γ Γ′ A} -> Γ ⊨ Γ′ -> Γ ⊢ A -> Γ ⊨ A ∷ Γ′ -- the unique morphism into the product
    ! : forall {Γ} -> Γ ⊨ [] -- the unique morphism into the terminal object

  data _⊢_ where
    func : forall {Γ} (f : Func) -> Γ ⊢ dom f -> Γ ⊢ cod f

    var : forall {Γ A} -> A ∷ Γ ⊢ A

    unit : forall {Γ} -> Γ ⊢ Unit

    pair : forall {Γ A B} -> Γ ⊢ A -> Γ ⊢ B -> Γ ⊢ A * B
    fst : forall {Γ A B} -> Γ ⊢ A * B -> Γ ⊢ A
    snd : forall {Γ A B} -> Γ ⊢ A * B -> Γ ⊢ B

    abs : forall {Γ A B} -> A ∷ Γ ⊢ B -> Γ ⊢ A => B
    app : forall {Γ A B} -> Γ ⊢ A => B -> Γ ⊢ A -> Γ ⊢ B

    _[_] : forall {Γ Γ′ A} -> Γ′ ⊢ A -> Γ ⊨ Γ′ -> Γ ⊢ A

  infix 10 _×id′

  _×id′ : forall {Γ Γ′} {A} -> Γ ⊨ Γ′ -> A ∷ Γ ⊨ A ∷ Γ′
  γ ×id′ = ext (γ ∙ weaken) var


------------------------------------------------------------------------
-- H-levels
------------------------------------------------------------------------

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

-- Partly based on Voevodsky's work on so-called univalent
-- foundations.

open import Equality

module H-level
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open Derived-definitions-and-properties eq
open import Logical-equivalence hiding (id; _∘_)
open import Nat eq
open import Prelude
open import Surjection eq hiding (id; _∘_)

private
  variable
    a ℓ : Level
    m n : ℕ
    A B : Type a

------------------------------------------------------------------------
-- H-levels

-- H-levels ("homotopy levels").

H-level : ℕ → Type ℓ → Type ℓ
H-level zero          A = Contractible A
H-level (suc zero)    A = Is-proposition A
H-level (suc (suc n)) A = {x y : A} → H-level (suc n) (x ≡ y)

private

  -- Note that H-level 2 is a synonym for Is-set.

  H-level-2≡Is-set : H-level 2 A ≡ Is-set A
  H-level-2≡Is-set = refl _

-- For-iterated-equality n P A means that P holds for (equalities
-- over)^n A.

For-iterated-equality : ℕ → (Type ℓ → Type ℓ) → (Type ℓ → Type ℓ)
For-iterated-equality zero    P A = P A
For-iterated-equality (suc n) P A =
  (x y : A) → For-iterated-equality n P (x ≡ y)

-- An alternative definition of h-levels.
--
-- In some cases this definition, with only two cases, is easier to
-- use. In other cases the definition above, which is less complicated
-- for positive h-levels, is easier to use.

H-level′ : ℕ → Type ℓ → Type ℓ
H-level′ = flip For-iterated-equality Contractible

-- Propositions are propositional types.

Proposition : (ℓ : Level) → Type (lsuc ℓ)
Proposition _ = ∃ Is-proposition

-- Types that are sets.

Set : (ℓ : Level) → Type (lsuc ℓ)
Set _ = ∃ Is-set

-- The underlying type.

⌞_⌟ : Set ℓ → Type ℓ
⌞ A ⌟ = proj₁ A

------------------------------------------------------------------------
-- General properties

-- H-level′ is upwards closed in its first argument.

mono₁′ : ∀ n → H-level′ n A → H-level′ (1 + n) A
mono₁′         (suc n) h x y = mono₁′ n (h x y)
mono₁′ {A = A} zero    h x y = trivial x y , irr
  where
  trivial : (x y : A) → x ≡ y
  trivial x y =
    x        ≡⟨ sym $ proj₂ h x ⟩
    proj₁ h  ≡⟨ proj₂ h y ⟩∎
    y        ∎

  irr : (x≡y : x ≡ y) → trivial x y ≡ x≡y
  irr = elim (λ {x y} x≡y → trivial x y ≡ x≡y)
             (λ x → trans-symˡ (proj₂ h x))

-- H-level and H-level′ are pointwise logically equivalent.

H-level⇔H-level′ : H-level n A ⇔ H-level′ n A
H-level⇔H-level′ = record { to = to _; from = from _ }
  where
  to : ∀ n → H-level n A → H-level′ n A
  to zero          h = h
  to (suc zero)    h = λ x → mono₁′ 0 (x , h x) x
  to (suc (suc n)) h = λ x y → to (suc n) h

  from : ∀ n → H-level′ n A → H-level n A
  from zero          h = h
  from (suc zero)    h x y = proj₁ (h x y)
  from (suc (suc n)) h {x = x} {y = y} = from (suc n) (h x y)

-- If A has h-level 1 + n, then the types of equality proofs between
-- elements of type A have h-level n.

+⇒≡ : {x y : A} → H-level (suc n) A → H-level n (x ≡ y)
+⇒≡ h = _⇔_.from H-level⇔H-level′ $ _⇔_.to H-level⇔H-level′ h _ _

-- H-level is upwards closed in its first argument.

mono₁ : ∀ n → H-level n A → H-level (1 + n) A
mono₁ n =
  _⇔_.from H-level⇔H-level′ ∘
  mono₁′ n ∘
  _⇔_.to H-level⇔H-level′

abstract

  mono : m ≤ n → H-level m A → H-level n A
  mono (≤-refl′ eq)     = subst (λ n → H-level n _) eq
  mono (≤-step′ m≤n eq) =
    subst (λ n → H-level n _) eq ∘
    mono₁ _ ∘
    mono m≤n

  -- If A has h-level n, then the types of equality proofs between
  -- elements of type A also have h-level n.

  ⇒≡ : {x y : A} → ∀ n → H-level n A → H-level n (x ≡ y)
  ⇒≡ _ = +⇒≡ ∘ mono₁ _

  -- If something is contractible given the assumption that it is
  -- inhabited, then it is propositional.

  [inhabited⇒contractible]⇒propositional :
    (A → Contractible A) → Is-proposition A
  [inhabited⇒contractible]⇒propositional h x = mono₁ 0 (h x) x

  -- If something has h-level (1 + n) given the assumption that it is
  -- inhabited, then it has h-level (1 + n).

  [inhabited⇒+]⇒+ : ∀ n → (A → H-level (1 + n) A) → H-level (1 + n) A
  [inhabited⇒+]⇒+ n h =
    _⇔_.from H-level⇔H-level′ λ x → _⇔_.to H-level⇔H-level′ (h x) x

  -- An alternative characterisation of sets and higher h-levels.
  --
  -- This is Theorem 7.2.7 from the HoTT book.

  2+⇔∀1+≡ :
    ∀ n → H-level (2 + n) A ⇔ ((x : A) → H-level (1 + n) (x ≡ x))
  2+⇔∀1+≡ n = record
    { to   = λ h _ → h
    ; from = λ h → [inhabited⇒+]⇒+ _
                     (elim (λ {x y} _ → H-level (1 + n) (x ≡ y)) h)
    }

-- If a propositional type is inhabited, then it is contractible.

propositional⇒inhabited⇒contractible :
  Is-proposition A → A → Contractible A
propositional⇒inhabited⇒contractible p x = (x , p x)

-- H-level′ n respects (split) surjections.

respects-surjection′ :
  A ↠ B → ∀ n → H-level′ n A → H-level′ n B
respects-surjection′ A↠B zero (x , irr) = (to x , irr′)
  where
  open _↠_ A↠B

  irr′ : ∀ y → to x ≡ y
  irr′ = λ y →
    to x         ≡⟨ cong to (irr (from y)) ⟩
    to (from y)  ≡⟨ right-inverse-of y ⟩∎
    y            ∎

respects-surjection′ A↠B (suc n) h = λ x y →
  respects-surjection′ (↠-≡ A↠B) n (h (from x) (from y))
  where open _↠_ A↠B

-- H-level n respects (split) surjections.

respects-surjection :
  A ↠ B → ∀ n → H-level n A → H-level n B
respects-surjection A↠B n =
  _⇔_.from H-level⇔H-level′ ∘
  respects-surjection′ A↠B n ∘
  _⇔_.to H-level⇔H-level′


{-

Definition of the torus as a HIT together with a proof that it is
equivalent to two circles

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Torus.Base where

open import Cubical.Core.Glue

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

open import Cubical.Data.Nat
open import Cubical.Data.Int
open import Cubical.Data.Prod hiding (_×_) renaming (_×Σ_ to _×_)

open import Cubical.HITs.S1

data Torus : Type₀ where
  point : Torus
  line1 : point ≡ point
  line2 : point ≡ point
  square : PathP (λ i → line1 i ≡ line1 i) line2 line2

t2c : Torus → S¹ × S¹
t2c point        = ( base , base )
t2c (line1 i)    = ( loop i , base )
t2c (line2 j)    = ( base , loop j )
t2c (square i j) = ( loop i , loop j )

c2t : S¹ × S¹ → Torus
c2t (base   , base)   = point
c2t (loop i , base)   = line1 i
c2t (base   , loop j) = line2 j
c2t (loop i , loop j) = square i j

c2t-t2c : ∀ (t : Torus) → c2t (t2c t) ≡ t
c2t-t2c point        = refl
c2t-t2c (line1 _)    = refl
c2t-t2c (line2 _)    = refl
c2t-t2c (square _ _) = refl

t2c-c2t : ∀ (p : S¹ × S¹) → t2c (c2t p) ≡ p
t2c-c2t (base   , base)   = refl
t2c-c2t (base   , loop _) = refl
t2c-c2t (loop _ , base)   = refl
t2c-c2t (loop _ , loop _) = refl

Torus≡S¹×S¹ : Torus ≡ S¹ × S¹
Torus≡S¹×S¹ = isoToPath (iso t2c c2t t2c-c2t c2t-t2c)

ΩTorus : Type₀
ΩTorus = point ≡ point

-- TODO: upstream
lemPathAnd : ∀ {ℓ} {A B : Type ℓ} (t u : A × B) →
  Path _ (t ≡ u) ((t .fst ≡ u .fst) × ((t .snd) ≡ (u .snd)))
lemPathAnd t u = isoToPath (iso (λ tu → (λ i → tu i .fst) , λ i → tu i .snd)
                                 (λ tu i → tu .fst i , tu .snd i)
                                 (λ y → refl)
                                 (λ x → refl))

funDep : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) (u0 : A) (u1 : B) →
  (Path A u0 (transport (λ i → p (~ i)) u1)) ≡ (Path B (transport p u0) u1)
funDep p u0 u1 i = Path (p i) (transp (λ j → p (i ∧ j)) (~ i) u0) (transp (λ j → p (i ∨ ~ j)) i u1)

-- Can this proof be simplified?
ΩTorus≡Int×Int : ΩTorus ≡ Int × Int
ΩTorus≡Int×Int =
  ΩTorus
    ≡⟨ (λ i → Path Torus point (transp (\ j → Torus≡S¹×S¹ (~ j ∧ i)) (~ i)
                                       (glue (λ { (i = i0) → point
                                                ; (i = i1) → (base , base) }) (base , base)))) ⟩
  Path Torus point (transp (\ i → Torus≡S¹×S¹ (~ i)) i0 (base , base))
    ≡⟨ funDep (λ i → Torus≡S¹×S¹ i) point (base , base) ⟩
  Path (S¹ × S¹) (transp (\ i → Torus≡S¹×S¹ i) i0 point) (base , base)
    ≡⟨ (λ i → Path _ (transp (λ j → Torus≡S¹×S¹ (j ∨ i))  i
                             (glue (λ { (i = i0) → point
                                      ; (i = i1) → (base , base) }) (base , base))) (base , base)) ⟩
  Path (S¹ × S¹) (base , base) (base , base)
    ≡⟨ lemPathAnd (base , base) (base , base) ⟩
  ΩS¹ × ΩS¹
    ≡⟨ (λ i → ΩS¹≡Int i × ΩS¹≡Int i) ⟩
  Int × Int ∎

-- Computing the winding numbers on the torus
windingTorus : ΩTorus → Int × Int
windingTorus l = ( winding (λ i → t2c (l i) .fst)
                 , winding (λ i → t2c (l i) .snd))

module _ where
 private
  test1 : windingTorus (line1 ∙ line2) ≡ (pos 1 , pos 1)
  test1 = refl

  test2 : windingTorus (line1 ∙ line2 ∙ sym line1 ∙ sym line1) ≡ (negsuc 0 , pos 1)
  test2 = refl


data Unit : Set where
  unit : Unit

P : Unit → Set
P unit = Unit

postulate
  Q : (u : Unit) → P u → Set

variable
  u : Unit
  p : P u

postulate
  q : P u → Q u p

q' : (u : Unit) (p : P u) → P u → Q u p
q' u p = q {u} {p}


{-# OPTIONS --type-in-type #-}

data ⊥ : Set where

℘ : ∀ {ℓ} → Set ℓ → Set _
℘ {ℓ} S = S → Set

U : Set
U = ∀ (X : Set) → (℘ (℘ X) → X) → ℘ (℘ X)

{- If using two impredicative universe layers instead of type-in-type:
U : Set₁
U = ∀ (X : Set₁) → (℘ (℘ X) → X) → ℘ (℘ X)
-}

τ : ℘ (℘ U) → U
τ t = λ X f p → t (λ x → p (f (x X f)))

σ : U → ℘ (℘ U)
σ s = s U τ

Δ : ℘ U
Δ y = (∀ p → σ y p → p (τ (σ y))) → ⊥

Ω : U
Ω = τ (λ p → (∀ x → σ x p → p x))

R : ∀ p → (∀ x → σ x p → p x) → p Ω
R _ 𝟙 = 𝟙 Ω (λ x → 𝟙 (τ (σ x)))

M : ∀ x → σ x Δ → Δ x
M _ 𝟚 𝟛 = 𝟛 Δ 𝟚 (λ p → 𝟛 (λ y → p (τ (σ y))))

L : (∀ p → (∀ x → σ x p → p x) → p Ω) → ⊥
L 𝟘 = 𝟘 Δ M (λ p → 𝟘 (λ y → p (τ (σ y))))

false : ⊥
false = L R


module Trans where

open import Prelude

Rel : Set -> Set1
Rel A = A -> A -> Set

data [_]* {A : Set}(R : Rel A)(x : A) : A -> Set where
  ref : [ R ]* x x
  _▹_ : {y z : A} -> R x y -> [ R ]* y z -> [ R ]* x z

infixr 40 _▹_ _▹◃_

length : {A : Set}{R : Rel A}{x y : A} -> [ R ]* x y -> Nat
length ref      = zero
length (x ▹ xs) = suc (length xs)

_=[_]=>_ : {A B : Set}(R : Rel A)(i : A -> B)(S : Rel B) -> Set
R =[ i ]=> S = forall {x y} -> R x y -> S (i x) (i y)

map : {A B : Set}{R : Rel A}{S : Rel B}(i : A -> B) ->
      (R =[ i ]=> S) ->
      {x y : A} -> [ R ]* x y -> [ S ]* (i x) (i y)
map i f ref      = ref
map i f (x ▹ xs) = f x ▹ map i f xs

lem-length-map :
      {A B : Set}{R : Rel A}{S : Rel B}(i : A -> B)
      (f : R =[ i ]=> S){x y : A}(xs : [ R ]* x y) ->
      length xs ≡ length (map {S = S} i f xs)
lem-length-map i f ref      = refl
lem-length-map i f (x ▹ xs) = cong suc (lem-length-map i f xs)

_▹◃_ : {A : Set}{R : Rel A}{x y z : A} ->
       [ R ]* x y -> [ R ]* y z -> [ R ]* x z
ref      ▹◃ ys = ys
(x ▹ xs) ▹◃ ys = x ▹ (xs ▹◃ ys)

lem-length▹◃ : {A : Set}{R : Rel A}{x y z : A}
               (r₁ : [ R ]* x y)(r₂ : [ R ]* y z) ->
               length r₁ + length r₂ ≡ length (r₁ ▹◃ r₂)
lem-length▹◃ ref      ys = refl
lem-length▹◃ (x ▹ xs) ys = cong suc (lem-length▹◃ xs ys)


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

module sets.int.utils where

open import sum
open import equality
open import function
open import sets.nat.core
open import sets.int.definition
open import hott.level

module _ {i}{X : Set i}(hX : h 2 X)
  (f : ℕ → ℕ → ℕ → ℕ → X)
  (u : ∀ n n' d m m' e → f n n' m m' ≡ f (d + n) (d + n') (e + m) (e + m')) where

  private
    g : ℕ → ℕ → ℤ → X
    g n n' = elim-ℤ hX (f n n' , u n n' 0)

    lem : (n n' d m m' : ℕ) → g n n' (m [-] m') ≡ g (d + n) (d + n') (m [-] m')
    lem n n' d m m' = u n n' d m m' 0

    v : (n n' d : ℕ) → g n n' ≡ g (d + n) (d + n')
    v n n' d = funext λ m → elim-prop-ℤ
      (λ m → hX (g n n' m) (g (d + n) (d + n') m))
      (lem n n' d) m

    hX' : h 2 (ℤ → X)
    hX' = Π-level λ _ → hX

  elim₂-ℤ : ℤ → ℤ → X
  elim₂-ℤ = elim-ℤ hX' (g , v)

elim₂-prop-ℤ : ∀ {i}{X : ℤ → ℤ → Set i} → (∀ n m → h 1 (X n m))
             → ((n n' m m' : ℕ) → X (n [-] n') (m [-] m'))
             → ∀ n m → X n m
elim₂-prop-ℤ {i}{X} hX f = elim-prop-ℤ hX' g
  where
    g : (n n' : ℕ) → ∀ m → X (n [-] n') m
    g n n' = elim-prop-ℤ (hX (n [-] n')) (f n n')

    hX' : ∀ n → h 1 (∀ m → X n m)
    hX' n = Π-level λ m → hX n m

elim₃-prop-ℤ : ∀ {i}{X : ℤ → ℤ → ℤ → Set i} → (∀ n m p → h 1 (X n m p))
             → ((n n' m m' p p' : ℕ) → X (n [-] n') (m [-] m') (p [-] p'))
             → ∀ n m p → X n m p
elim₃-prop-ℤ {i}{X} hX f = elim-prop-ℤ hX' g
  where
    g : (n n' : ℕ) → ∀ m p → X (n [-] n') m p
    g n n' = elim₂-prop-ℤ (hX (n [-] n')) (f n n')

    hX' : ∀ n → h 1 (∀ m p → X n m p)
    hX' n = Π-level λ m → Π-level λ p → hX n m p


------------------------------------------------------------------------
-- An ad-hoc but straightforward solution to the problem of showing
-- that elegant definitions of the Hamming numbers (see EWD 792) and
-- the Fibonacci sequence are productive
------------------------------------------------------------------------

module StreamProg where

open import Codata.Musical.Notation
open import Codata.Musical.Stream as S using (Stream; _∷_; _≈_)
open import Data.Nat
open import Relation.Binary
import Relation.Binary.PropositionalEquality as P

private
  module SS {A : Set} = Setoid (S.setoid A)

------------------------------------------------------------------------
-- Merging of streams

data Ord : Set where
  lt : Ord
  eq : Ord
  gt : Ord

merge : {A : Set} → (A → A → Ord) → Stream A → Stream A → Stream A
merge cmp (x ∷ xs) (y ∷ ys) with cmp x y
... | lt = x ∷ ♯ merge cmp (♭ xs)   (y ∷ ys)
... | eq = x ∷ ♯ merge cmp (♭ xs)   (♭ ys)
... | gt = y ∷ ♯ merge cmp (x ∷ xs) (♭ ys)

------------------------------------------------------------------------
-- Stream programs

infixr 5 _∷_

data StreamP (A : Set) : Set1 where
  _∷_     : (x : A) (xs : ∞ (StreamP A)) → StreamP A
  zipWith : ∀ {B C} (f : B → C → A)
            (xs : StreamP B) (ys : StreamP C) → StreamP A
  map     : ∀ {B} (f : B → A) (xs : StreamP B) → StreamP A
  mergeP  : (cmp : A → A → Ord)
            (xs : StreamP A) (ys : StreamP A) → StreamP A

data StreamW A : Set1 where
  _∷_ : (x : A) (xs : StreamP A) → StreamW A

zipWithW : {A B C : Set} →
           (A → B → C) → StreamW A → StreamW B → StreamW C
zipWithW f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys

mapW : {A B : Set} → (A → B) → StreamW A → StreamW B
mapW f (x ∷ xs) = f x ∷ map f xs

mergeW : {A : Set} →
         (A → A → Ord) → StreamW A → StreamW A → StreamW A
mergeW cmp (x ∷ xs) (y ∷ ys) with cmp x y
... | lt = x ∷ mergeP cmp xs (y ∷ ♯ ys)
... | eq = x ∷ mergeP cmp xs ys
... | gt = y ∷ mergeP cmp (x ∷ ♯ xs) ys

whnf : ∀ {A} → StreamP A → StreamW A
whnf (x ∷ xs)           = x ∷ ♭ xs
whnf (zipWith f xs ys)  = zipWithW f (whnf xs) (whnf ys)
whnf (map f xs)         = mapW f (whnf xs)
whnf (mergeP cmp xs ys) = mergeW cmp (whnf xs) (whnf ys)

mutual

  ⟦_⟧W : ∀ {A} → StreamW A → Stream A
  ⟦ x ∷ xs ⟧W = x ∷ ♯ ⟦ xs ⟧P

  ⟦_⟧P : ∀ {A} → StreamP A → Stream A
  ⟦ xs ⟧P = ⟦ whnf xs ⟧W

------------------------------------------------------------------------
-- Examples

fib : StreamP ℕ
fib = 0 ∷ ♯ zipWith _+_ fib (1 ∷ ♯ fib)

-- Alternative definition showing that definitions do not need to
-- start with a cons constructor.

fib′ : StreamP ℕ
fib′ = zipWith _+_ (0 ∷ ♯ fib′) (0 ∷ ♯ (1 ∷ ♯ fib′))

cmp : ℕ → ℕ → Ord
cmp m n = toOrd (compare m n)
  where
  toOrd : ∀ {m n} → Ordering m n → Ord
  toOrd (less _ _)    = lt
  toOrd (equal _)     = eq
  toOrd (greater _ _) = gt

hamming : StreamP ℕ
hamming = 1 ∷ ♯ mergeP cmp (map (_*_ 2) hamming) (map (_*_ 3) hamming)

------------------------------------------------------------------------
-- The definition of fib is correct

-- ⟦_⟧P is homomorphic with respect to zipWith/S.zipWith.

zipWith-hom : ∀ {A B C} (_∙_ : A → B → C) xs ys →
              ⟦ zipWith _∙_ xs ys ⟧P ≈ S.zipWith _∙_ ⟦ xs ⟧P ⟦ ys ⟧P
zipWith-hom _∙_ xs ys with whnf xs | whnf ys
zipWith-hom _∙_ xs ys | x ∷ xs′ | y ∷ ys′ =
  P.refl ∷ ♯ zipWith-hom _∙_ xs′ ys′

-- Unfortunately Agda's definitional equality for coinductive
-- constructors is currently a little strange, so the result type
-- cannot be written out completely here:

fib-correct′ :
  ⟦ fib ⟧P ≈ 0 ∷ ♯ S.zipWith _+_ ⟦ fib ⟧P (1 ∷ _ {- ♯ ⟦ fib ⟧P -})
fib-correct′ = P.refl ∷ ♯ zipWith-hom _+_ fib (1 ∷ ♯ fib)

-- Fortunately there is a workaround.

fib-correct : ⟦ fib ⟧P ≈ 0 ∷ ♯ S.zipWith _+_ ⟦ fib ⟧P (1 ∷ ♯ ⟦ fib ⟧P)
fib-correct =
  P.refl ∷ ♯ SS.trans (zipWith-hom _+_ fib (1 ∷ ♯ fib))
                      (S.zipWith-cong _+_ (SS.refl {x = 0 ∷ _})
                                          (P.refl ∷ ♯ SS.refl))

-- For a proof showing that the given equation for fib has a unique
-- solution, see MapIterate.

------------------------------------------------------------------------
-- The definition of hamming is correct

-- ⟦_⟧P is homomorphic with respect to map/S.map.

map-hom : ∀ {A B} (f : A → B) xs →
          ⟦ map f xs ⟧P ≈ S.map f ⟦ xs ⟧P
map-hom f xs with whnf xs
... | x ∷ xs′ = P.refl ∷ ♯ map-hom f xs′

-- ⟦_⟧P is homomorphic with respect to mergeP/merge.

merge-hom : ∀ {A} (cmp : A → A → Ord) xs ys →
            ⟦ mergeP cmp xs ys ⟧P ≈ merge cmp ⟦ xs ⟧P ⟦ ys ⟧P
merge-hom cmp xs ys with whnf xs | whnf ys
... | x ∷ xs′ | y ∷ ys′ with cmp x y
...   | lt = P.refl ∷ ♯ merge-hom cmp xs′ (y ∷ ♯ ys′)
...   | eq = P.refl ∷ ♯ merge-hom cmp xs′ ys′
...   | gt = P.refl ∷ ♯ merge-hom cmp (x ∷ ♯ xs′) ys′

-- merge is a congruence.

merge-cong : ∀ {A} (cmp : A → A → Ord) {xs xs′ ys ys′} →
             xs ≈ xs′ → ys ≈ ys′ →
             merge cmp xs ys ≈ merge cmp xs′ ys′
merge-cong cmp (_∷_ {x = x} P.refl xs≈)
               (_∷_ {x = y} P.refl ys≈) with cmp x y
... | lt = P.refl ∷ ♯ merge-cong cmp (♭ xs≈) (P.refl ∷ ys≈)
... | eq = P.refl ∷ ♯ merge-cong cmp (♭ xs≈) (♭ ys≈)
... | gt = P.refl ∷ ♯ merge-cong cmp (P.refl ∷ xs≈) (♭ ys≈)

-- hamming is correct.

hamming-correct : ⟦ hamming ⟧P ≈
                  1 ∷ ♯ merge cmp (S.map (_*_ 2) ⟦ hamming ⟧P)
                                  (S.map (_*_ 3) ⟦ hamming ⟧P)
hamming-correct =
  P.refl ∷ ♯ SS.trans (merge-hom cmp (map (_*_ 2) hamming)
                                     (map (_*_ 3) hamming))
                      (merge-cong cmp (map-hom (_*_ 2) hamming)
                                      (map-hom (_*_ 3) hamming))