------------------------------------------------------------------------
-- The Agda standard library
--
-- Instantiates the natural coefficients ring solver, using coefficient
-- equality induced by ℕ.
--
-- This is sufficient for proving equalities that are independent of the
-- characteristic.  In particular, this is enough for equalities in rings of
-- characteristic 0.
------------------------------------------------------------------------

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

open import Algebra

module Algebra.Solver.Ring.NaturalCoefficients.Default
         {r₁ r₂} (R : CommutativeSemiring r₁ r₂) where

import Algebra.Operations.Semiring as SemiringOps
open import Data.Maybe.Base using (Maybe; map)
open import Data.Nat using (_≟_)
open import Relation.Binary.Consequences using (dec⟶weaklyDec)
import Relation.Binary.PropositionalEquality as P

open CommutativeSemiring R
open SemiringOps semiring

private
  dec : ∀ m n → Maybe (m × 1# ≈ n × 1#)
  dec m n = map (λ { P.refl → refl }) (dec⟶weaklyDec _≟_ m n)

open import Algebra.Solver.Ring.NaturalCoefficients R dec public


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

module lists where

import 17-number-theory
open 17-number-theory public

unit-list :
  {l1 : Level} {A : UU l1} → A → list A
unit-list a = cons a nil

{- First we introduce the functoriality of the list operation, because it will
   come in handy when we try to define and prove more advanced things. -}

functor-list :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) →
  list A → list B
functor-list f nil = nil
functor-list f (cons a x) = cons (f a) (functor-list f x)

identity-law-functor-list :
  {l1 : Level} {A : UU l1} →
  functor-list (id {A = A}) ~ id
identity-law-functor-list nil = refl
identity-law-functor-list (cons a x) =
  ap (cons a) (identity-law-functor-list x)

composition-law-functor-list :
  {l1 l2 l3 : Level} {A : UU l1} {B : UU l2} {C : UU l3} →
  (f : A → B) (g : B → C) →
  functor-list (g ∘ f) ~ (functor-list g ∘ functor-list f)
composition-law-functor-list f g nil = refl
composition-law-functor-list f g (cons a x) =
  ap (cons (g (f a))) (composition-law-functor-list f g x)

{- Concatenation of lists is an associative operation and nil is the unit for
   list concatenation. -}

assoc-concat-list :
  {l1 : Level} {A : UU l1} (x y z : list A) →
  Id (concat-list (concat-list x y) z) (concat-list x (concat-list y z))
assoc-concat-list nil y z = refl
assoc-concat-list (cons a x) y z = ap (cons a) (assoc-concat-list x y z)

left-unit-law-concat-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (concat-list nil x) x
left-unit-law-concat-list x = refl

right-unit-law-concat-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (concat-list x nil) x
right-unit-law-concat-list nil = refl
right-unit-law-concat-list (cons a x) =
  ap (cons a) (right-unit-law-concat-list x)

{- The length operation or course behaves well with respect to the other list
   operations. -}

length-nil :
  {l1 : Level} {A : UU l1} →
  Id (length-list {A = A} nil) zero-ℕ
length-nil = refl

length-concat-list :
  {l1 : Level} {A : UU l1} (x y : list A) →
  Id (length-list (concat-list x y)) (add-ℕ (length-list x) (length-list y))
length-concat-list nil y = inv (left-unit-law-add-ℕ (length-list y))
length-concat-list (cons a x) y =
  ( ap succ-ℕ (length-concat-list x y)) ∙
  ( inv (left-successor-law-add-ℕ (length-list x) (length-list y)))

{- We now prove the properties of flattening. -}

flatten-unit-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (flatten-list (unit-list x)) x
flatten-unit-list x = right-unit-law-concat-list x

length-flatten-list :
  {l1 : Level} {A : UU l1} (x : list (list A)) →
  Id ( length-list (flatten-list x))
     ( sum-list-ℕ (functor-list length-list x))
length-flatten-list nil = refl
length-flatten-list (cons a x) =
  ( length-concat-list a (flatten-list x)) ∙
  ( ap (add-ℕ (length-list a)) (length-flatten-list x))

flatten-concat-list :
  {l1 : Level} {A : UU l1} (x y : list (list A)) →
  Id ( flatten-list (concat-list x y))
     ( concat-list (flatten-list x) (flatten-list y))
flatten-concat-list nil y = refl
flatten-concat-list (cons a x) y =
  ( ap (concat-list a) (flatten-concat-list x y)) ∙
  ( inv (assoc-concat-list a (flatten-list x) (flatten-list y)))

flatten-flatten-list :
  {l1 : Level} {A : UU l1} (x : list (list (list A))) →
  Id ( flatten-list (flatten-list x))
     ( flatten-list (functor-list flatten-list x))
flatten-flatten-list nil = refl
flatten-flatten-list (cons a x) =
  ( flatten-concat-list a (flatten-list x)) ∙
  ( ap (concat-list (flatten-list a)) (flatten-flatten-list x))

{- Next, we prove the basic properties of list reversal. -}

reverse-unit-list :
  {l1 : Level} {A : UU l1} (a : A) →
  Id (reverse-list (unit-list a)) (unit-list a)
reverse-unit-list a = refl

length-reverse-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (length-list (reverse-list x)) (length-list x)
length-reverse-list nil = refl
length-reverse-list (cons a x) =
  ( length-concat-list (reverse-list x) (unit-list a)) ∙
  ( ap succ-ℕ (length-reverse-list x))

reverse-concat-list :
  {l1 : Level} {A : UU l1} (x y : list A) →
  Id ( reverse-list (concat-list x y))
     ( concat-list (reverse-list y) (reverse-list x))
reverse-concat-list nil y =
  inv (right-unit-law-concat-list (reverse-list y))
reverse-concat-list (cons a x) y =
  ( ap (λ t → concat-list t (unit-list a)) (reverse-concat-list x y)) ∙
  ( assoc-concat-list (reverse-list y) (reverse-list x) (unit-list a))

reverse-flatten-list :
  {l1 : Level} {A : UU l1} (x : list (list A)) →
  Id ( reverse-list (flatten-list x))
     ( flatten-list (reverse-list (functor-list reverse-list x)))
reverse-flatten-list nil = refl
reverse-flatten-list (cons a x) =
  ( reverse-concat-list a (flatten-list x)) ∙
  ( ( ap (λ t → concat-list t (reverse-list a)) (reverse-flatten-list x)) ∙
    ( ( ap
        ( concat-list
          ( flatten-list (reverse-list (functor-list reverse-list x))))
          ( inv (flatten-unit-list (reverse-list a)))) ∙
      ( inv
        ( flatten-concat-list
          ( reverse-list (functor-list reverse-list x))
          ( unit-list (reverse-list a))))))

reverse-reverse-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (reverse-list (reverse-list x)) x
reverse-reverse-list nil = refl
reverse-reverse-list (cons a x) =
  ( reverse-concat-list (reverse-list x) (unit-list a)) ∙
  ( ap (concat-list (unit-list a)) (reverse-reverse-list x))

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

{- Next we define the head and tail operations, and we define the operations
   of picking and removing the last element from a list. -}

head-list :
  {l1 : Level} {A : UU l1} → list A → list A
head-list nil = nil
head-list (cons a x) = unit-list a

tail-list :
  {l1 : Level} {A : UU l1} → list A → list A
tail-list nil = nil
tail-list (cons a x) = x

last-element-list :
  {l1 : Level} {A : UU l1} → list A → list A
last-element-list nil = nil
last-element-list (cons a nil) = unit-list a
last-element-list (cons a (cons b x)) = last-element-list (cons b x)

remove-last-element-list :
  {l1 : Level} {A : UU l1} → list A → list A
remove-last-element-list nil = nil
remove-last-element-list (cons a nil) = nil
remove-last-element-list (cons a (cons b x)) =
  cons a (remove-last-element-list (cons b x))

cons' :
  {l1 : Level} {A : UU l1} → list A → A → list A
cons' x a = concat-list x (unit-list a)

{- We prove the basic properties about heads and tails and their duals. -}

eta-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (concat-list (head-list x) (tail-list x)) x
eta-list nil = refl
eta-list (cons a x) = refl

eta-list' :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (concat-list (remove-last-element-list x) (last-element-list x)) x
eta-list' nil = refl
eta-list' (cons a nil) = refl
eta-list' (cons a (cons b x)) = ap (cons a) (eta-list' (cons b x))

last-element-cons' :
  {l1 : Level} {A : UU l1} (x : list A) (a : A) →
  Id (last-element-list (cons' x a)) (unit-list a)
last-element-cons' nil a = refl
last-element-cons' (cons b nil) a = refl
last-element-cons' (cons b (cons c x)) a =
  last-element-cons' (cons c x) a

head-concat-list :
  {l1 : Level} {A : UU l1} (x y : list A) →
  Id ( head-list (concat-list x y))
     ( head-list (concat-list (head-list x) (head-list y)))
head-concat-list nil nil = refl
head-concat-list nil (cons x y) = refl
head-concat-list (cons a x) y = refl

tail-concat-list :
  {l1 : Level} {A : UU l1} (x y : list A) →
  Id ( tail-list (concat-list x y))
     ( concat-list (tail-list x) (tail-list (concat-list (head-list x) y)))
tail-concat-list nil y = refl
tail-concat-list (cons a x) y = refl

last-element-concat-list :
  {l1 : Level} {A : UU l1} (x y : list A) →
  Id ( last-element-list (concat-list x y))
     ( last-element-list
       ( concat-list (last-element-list x) (last-element-list y)))
last-element-concat-list nil nil = refl
last-element-concat-list nil (cons b nil) = refl
last-element-concat-list nil (cons b (cons c y)) =
  last-element-concat-list nil (cons c y)
last-element-concat-list (cons a nil) nil = refl
last-element-concat-list (cons a nil) (cons b nil) = refl
last-element-concat-list (cons a nil) (cons b (cons c y)) =
  last-element-concat-list (cons a nil) (cons c y)
last-element-concat-list (cons a (cons b x)) y =
  last-element-concat-list (cons b x) y

remove-last-element-concat-list :
  {l1 : Level} {A : UU l1} (x y : list A) →
  Id ( remove-last-element-list (concat-list x y))
     ( concat-list
       ( remove-last-element-list (concat-list x (head-list y)))
       ( remove-last-element-list y))
remove-last-element-concat-list nil nil = refl
remove-last-element-concat-list nil (cons a nil) = refl
remove-last-element-concat-list nil (cons a (cons b y)) = refl
remove-last-element-concat-list (cons a nil) nil = refl
remove-last-element-concat-list (cons a nil) (cons b y) = refl
remove-last-element-concat-list (cons a (cons b x)) y =
  ap (cons a) (remove-last-element-concat-list (cons b x) y)

head-reverse-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (head-list (reverse-list x)) (last-element-list x)
head-reverse-list nil = refl
head-reverse-list (cons a nil) = refl
head-reverse-list (cons a (cons b x)) =
  ( ap head-list
    ( assoc-concat-list (reverse-list x) (unit-list b) (unit-list a))) ∙
  ( ( head-concat-list
      ( reverse-list x)
      ( concat-list (unit-list b) (unit-list a))) ∙
    ( ( inv (head-concat-list (reverse-list x) (unit-list b))) ∙
      ( head-reverse-list (cons b x))))

last-element-reverse-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (last-element-list (reverse-list x)) (head-list x)
last-element-reverse-list x =
  ( inv (head-reverse-list (reverse-list x))) ∙
  ( ap head-list (reverse-reverse-list x))

tail-concat-list' :
  {l1 : Level} {A : UU l1} (x y : list A) →
  Id ( tail-list (concat-list x y))
     ( concat-list
       ( tail-list x)
       ( tail-list (concat-list (last-element-list x) y)))
tail-concat-list' nil y = refl
tail-concat-list' (cons a nil) y = refl
tail-concat-list' (cons a (cons b x)) y =
  ap (cons b) (tail-concat-list' (cons b x) y)

tail-reverse-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (tail-list (reverse-list x)) (reverse-list (remove-last-element-list x))
tail-reverse-list nil = refl
tail-reverse-list (cons a nil) = refl
tail-reverse-list (cons a (cons b x)) =
  ( tail-concat-list' (reverse-list (cons b x)) (unit-list a)) ∙
  ( ( ap
      ( λ t → concat-list
        ( tail-list (reverse-list (cons b x)))
        ( tail-list (concat-list t (unit-list a))))
      ( last-element-cons' (reverse-list x) b)) ∙
    ( ap (λ t → concat-list t (unit-list a)) (tail-reverse-list (cons b x))))

remove-last-element-reverse-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  Id (remove-last-element-list (reverse-list x)) (reverse-list (tail-list x))
remove-last-element-reverse-list x =
  ( inv (reverse-reverse-list (remove-last-element-list (reverse-list x)))) ∙
  ( ( inv (ap reverse-list (tail-reverse-list (reverse-list x)))) ∙
    ( ap (reverse-list ∘ tail-list) (reverse-reverse-list x)))

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

map-algebra-list :
  {l1 : Level} (A : UU l1) →
  coprod unit (A × list A) → list A
map-algebra-list A (inl star) = nil
map-algebra-list A (inr (pair a x)) = cons a x

inv-map-algebra-list :
  {l1 : Level} (A : UU l1) →
  list A → coprod unit (A × list A)
inv-map-algebra-list A nil = inl star
inv-map-algebra-list A (cons a x) = inr (pair a x)

issec-inv-map-algebra-list :
  {l1 : Level} (A : UU l1) →
  (map-algebra-list A ∘ inv-map-algebra-list A) ~ id
issec-inv-map-algebra-list A nil = refl
issec-inv-map-algebra-list A (cons a x) = refl

isretr-inv-map-algebra-list :
  {l1 : Level} (A : UU l1) →
  (inv-map-algebra-list A ∘ map-algebra-list A) ~ id
isretr-inv-map-algebra-list A (inl star) = refl
isretr-inv-map-algebra-list A (inr (pair a x)) = refl

is-equiv-map-algebra-list :
  {l1 : Level} (A : UU l1) → is-equiv (map-algebra-list A)
is-equiv-map-algebra-list A =
  is-equiv-has-inverse
    ( inv-map-algebra-list A)
    ( issec-inv-map-algebra-list A)
    ( isretr-inv-map-algebra-list A)

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

Eq-list :
  {l1 : Level} {A : UU l1} →
  list A → list A → UU l1
Eq-list nil nil = raise _ unit
Eq-list nil (cons x y) = raise _ empty
Eq-list (cons a x) nil = raise _ empty
Eq-list (cons a x) (cons b y) = (Id a b) × (Eq-list x y)

data Eq-list' {l1 : Level} {A : UU l1} : list A → list A → UU l1 where
  refl-nil : Eq-list' nil nil
  eq-cons :
    (x y : list A) (a b : A) →
    Eq-list' x y → Id a b → Eq-list' (cons a x) (cons b y)

refl-Eq-list :
  {l1 : Level} {A : UU l1} (x : list A) → Eq-list x x
refl-Eq-list nil = map-raise star
refl-Eq-list (cons a x) = pair refl (refl-Eq-list x)

contraction-total-Eq-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  (y : Σ (list A) (Eq-list x)) →
  Id (pair x (refl-Eq-list x)) y
contraction-total-Eq-list nil (pair nil (map-raise star)) = refl
contraction-total-Eq-list nil (pair (cons b y) (map-raise ()))
contraction-total-Eq-list (cons a x) (pair nil (map-raise ()))
contraction-total-Eq-list (cons a x) (pair (cons .a y) (pair refl e)) =
  {!!}

is-contr-total-Eq-list :
  {l1 : Level} {A : UU l1} (x : list A) →
  is-contr (Σ (list A) (Eq-list x))
is-contr-total-Eq-list nil =
  pair
    ( pair nil (map-raise star))
    {!!}
is-contr-total-Eq-list (cons x x₁) = {!!}


open import Everything

module Test.Test7 where

  𝓅rop-id : ∀
    {𝔵} {𝔛 : Ø 𝔵}
    {𝔞} {𝔄 : 𝔛 → Ø 𝔞}
    {𝔟} {𝔅 : 𝔛 → Ø 𝔟}
    (let _∼_ = Arrow 𝔄 𝔅)
    {ℓ̇} {_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ̇}
    ⦃ _ : Transitivity.class _∼_ ⦄
    ⦃ _ : Reflexivity.class _∼_ ⦄
    ⦃ _ : Transleftidentity!.class _∼_ _∼̇_ ⦄
    ⦃ _ : ∀ {x y} → Symmetry.class (_∼̇_ {x} {y}) ⦄
    {m n}
    {ℓ} {f : m ∼ n} (P : ExtensionṖroperty ℓ (Arrow 𝔄 𝔅 m) _∼̇_) (let P₀ = π₀ (π₀ P))
    → P₀ f
    → P₀ (ε ∙ f)

  𝓅rop-id P Pf = hmap _ P Pf


-- The empty type; also used as absurd proposition (``Falsity'').

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

module Tools.Empty where

data ⊥ : Set where

-- Ex falsum quod libet.

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

⊥-elimω : ∀ {A : Agda.Primitive.Setω} → ⊥ → A
⊥-elimω ()


-- forcePi should be allowed to generate constraints

module Lambda where

data Bool : Set where
  true : Bool
  false : Bool

T : Bool -> Set
T true  = Bool -> Bool
T false = Bool

id : {x : Bool} -> T x -> T x
id y = y

f : Bool -> Bool
f = id (\x -> x)


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra.Instances.Unit where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Unit

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Instances.Unit
open import Cubical.Algebra.CommAlgebra

private
  variable
    ℓ ℓ' : Level

open CommAlgebraStr

module _ (R : CommRing ℓ) where

  UnitCommAlgebra : CommAlgebra R ℓ'
  UnitCommAlgebra = commAlgebraFromCommRing
      UnitCommRing
      (λ _ _ → tt*) (λ _ _ _ → refl) (λ _ _ _ → refl)
      (λ _ _ _ → refl) (λ _ → refl) (λ _ _ _ → refl)


module Squash where

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

data Wrap (A : Set) : Set where
  wrap : A -> Wrap A

data Squash (A : Set) : Set where
  squash : .A -> Squash A

postulate
  A : Set
  a1 a2 : A

irr : squash a1 == squash a2
irr = refl


module Properties.Product where

infixr 5 _×_ _,_

record Σ {A : Set} (B : A → Set) : Set where

  constructor _,_
  field fst : A
  field snd : B fst

open Σ public

_×_ : Set → Set → Set
A × B = Σ (λ (a : A) → B)


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

module FiniteTypeEquiv where
open import Level
open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)
open import Data.Product
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Function.Equality using (_∘_; _⟶_; _⟨$⟩_)
open ≡-Reasoning
open import Function renaming (_∘_ to _○_)
open import FinVec

------------------------------------------------------------------------------
-- Permutations

record CPerm {ℓ : Level} (values : ℕ) (size : ℕ) : Set ℓ where
  constructor cp
  field
    π  : FinVec values size
    πᵒ : FinVec size values
    αp : π ∘̂ πᵒ ≡ 1C
    βp : πᵒ ∘̂ π ≡ 1C

-- Permutations are compared by ≡

-- The setoid of permutations under ≡

SCPerm : ∀ {ℓ} → ℕ → ℕ → Setoid ℓ ℓ
SCPerm m n = setoid (CPerm m n)

------------------------------------------------------------------------------
-- Equivalences

_∼_ : ∀ {ℓ ℓ'} → {A : Set ℓ} {P : A → Set ℓ'} →
      (f g : (x : A) → P x) → Set (ℓ ⊔ ℓ')
_∼_ {ℓ} {ℓ'} {A} {P} f g = (x : A) → f x ≡ g x

record qinv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) :
  Set (ℓ ⊔ ℓ') where
  constructor mkqinv
  field
    g : B → A
    α : (f ○ g) ∼ id
    β : (g ○ f) ∼ id

_≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
A ≃ B = Σ (A → B) qinv

sym≃ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → (A ≃ B) → (B ≃ A)
sym≃ (A→B , equiv) = e.g , mkqinv A→B e.β e.α
  where module e = qinv equiv

-- Equivalences are compared by ≋ which reduces to extensional
-- equality of the underlying back and forth functions

_⋆_ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → (A ≃ B) → (x : A) → B
(f , _) ⋆ x = f x

record _≋_ {ℓ ℓ' : Level} {A : Set ℓ} {B : Set ℓ'} (eq₁ eq₂ : A ≃ B) :
  Set (ℓ ⊔ ℓ') where
  constructor eq
  field
    f≡ : ∀ x → eq₁ ⋆ x ≡ eq₂ ⋆ x
    g≡ : ∀ x → (sym≃ eq₁) ⋆ x ≡ (sym≃ eq₂) ⋆ x

id≋ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x : A ≃ B} → x ≋ x
id≋ = record { f≡ = λ x → refl ; g≡ = λ x → refl }

sym≋ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x y : A ≃ B} → x ≋ y → y ≋ x
sym≋ (eq f≡ g≡) = eq (λ a → sym (f≡ a)) (λ b → sym (g≡ b))

trans≋ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x y z : A ≃ B} → x ≋ y → y ≋ z → x ≋ z
trans≋ (eq f≡ g≡) (eq h≡ i≡) =
   eq (λ a → trans (f≡ a) (h≡ a)) (λ b → trans (g≡ b) (i≡ b))

-- The setoid of equivalences under ≋

_S≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Setoid (ℓ ⊔ ℓ') (ℓ ⊔ ℓ')
_S≃_ A B = record
 { Carrier = A ≃ B
 ; _≈_ = _≋_
 ; isEquivalence = record
   { refl = id≋
   ; sym = sym≋
   ; trans = trans≋
   }
 }

------------------------------------------------------------------------------
-- Univalence...

-- On one side we have permutations under ≡
-- On the other we have equivalences under ≋
--
-- The equivalence of these two sides uses a version of ≃ (called ≃S)
-- that relates setoids each with its own equivalence relation

infix 4 _≃S_

record _≃S_ {ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level} (A : Setoid ℓ₁ ℓ₂) (B : Setoid ℓ₃ ℓ₄) :
  Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where
  constructor equiv
  field
    f : A ⟶ B
    g : B ⟶ A
    α : ∀ {x y} → Setoid._≈_ B x y → Setoid._≈_ B ((f ∘ g) ⟨$⟩ x) y
    β : ∀ {x y} → Setoid._≈_ A x y → Setoid._≈_ A ((g ∘ f) ⟨$⟩ x) y

univalence : {m n : ℕ} →
  _≃S_ {zero} {zero} {zero} {zero} (SCPerm m n) (Fin m S≃ Fin n)
univalence {m} {n} = equiv {!!} {!!} {!!} {!!}

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


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

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

module Data.Product.N-ary.Properties where

open import Data.Nat.Base hiding (_^_)
open import Data.Product
open import Data.Product.N-ary
open import Data.Vec using (Vec; _∷_)
open import Function.Inverse using (_↔_; inverse)
open import Relation.Binary.PropositionalEquality as P
open ≡-Reasoning

------------------------------------------------------------------------
-- Basic proofs

module _ {a} {A : Set a} where

  cons-head-tail-identity : ∀ n (as : A ^ suc n) → cons n (head n as) (tail n as) ≡ as
  cons-head-tail-identity 0       as = P.refl
  cons-head-tail-identity (suc n) as = P.refl

  head-cons-identity : ∀ n a (as : A ^ n) → head n (cons n a as) ≡ a
  head-cons-identity 0       a as = P.refl
  head-cons-identity (suc n) a as = P.refl

  tail-cons-identity : ∀ n a (as : A ^ n) → tail n (cons n a as) ≡ as
  tail-cons-identity 0       a as = P.refl
  tail-cons-identity (suc n) a as = P.refl

  append-cons-commute : ∀ m n a (xs : A ^ m) ys →
    append (suc m) n (cons m a xs) ys ≡ cons (m + n) a (append m n xs ys)
  append-cons-commute 0       n a xs ys = P.refl
  append-cons-commute (suc m) n a xs ys = P.refl

  append-splitAt-identity : ∀ m n (as : A ^ (m + n)) → uncurry (append m n) (splitAt m n as) ≡ as
  append-splitAt-identity 0       n as = P.refl
  append-splitAt-identity (suc m) n as = begin
    let x         = head (m + n) as in
    let (xs , ys) = splitAt m n (tail (m + n) as) in
    append (suc m) n (cons m (head (m + n) as) xs) ys
      ≡⟨ append-cons-commute m n x xs ys ⟩
    cons (m + n) x (append m n xs ys)
      ≡⟨ P.cong (cons (m + n) x) (append-splitAt-identity m n (tail (m + n) as)) ⟩
    cons (m + n) x (tail (m + n) as)
      ≡⟨ cons-head-tail-identity (m + n) as ⟩
    as
      ∎

------------------------------------------------------------------------
-- Conversion to and from Vec

module _ {a} {A : Set a} where

  toVec : ∀ n → A ^ n → Vec A n
  toVec 0       _  = Vec.[]
  toVec (suc n) xs = head n xs Vec.∷ toVec n (tail n xs)

  fromVec : ∀ {n} → Vec A n → A ^ n
  fromVec         Vec.[]       = []
  fromVec {suc n} (x Vec.∷ xs) = cons n x (fromVec xs)

  fromVec∘toVec : ∀ n (xs : A ^ n) → fromVec (toVec n xs) ≡ xs
  fromVec∘toVec 0       _  = P.refl
  fromVec∘toVec (suc n) xs = begin
    cons n (head n xs) (fromVec (toVec n (tail n xs)))
      ≡⟨ P.cong (cons n (head n xs)) (fromVec∘toVec n (tail n xs)) ⟩
    cons n (head n xs) (tail n xs)
      ≡⟨ cons-head-tail-identity n xs ⟩
    xs ∎

  toVec∘fromVec : ∀ {n} (xs : Vec A n) → toVec n (fromVec xs) ≡ xs
  toVec∘fromVec         Vec.[]       = P.refl
  toVec∘fromVec {suc n} (x Vec.∷ xs) = begin
    head n (cons n x (fromVec xs)) Vec.∷ toVec n (tail n (cons n x (fromVec xs)))
      ≡⟨ P.cong₂ (λ x xs → x Vec.∷ toVec n xs) hd-prf tl-prf ⟩
    x Vec.∷ toVec n (fromVec xs)
      ≡⟨ P.cong (x Vec.∷_) (toVec∘fromVec xs) ⟩
    x Vec.∷ xs
      ∎ where

      hd-prf = head-cons-identity n x (fromVec xs)
      tl-prf = tail-cons-identity n x (fromVec xs)

  ↔Vec : ∀ n → A ^ n ↔ Vec A n
  ↔Vec n = inverse (toVec n) fromVec (fromVec∘toVec n) toVec∘fromVec


module MLib.Fin.Parts.Simple where

open import MLib.Prelude
open import MLib.Fin.Parts.Core
open import MLib.Fin.Parts
open import MLib.Fin.Parts.Nat
import MLib.Fin.Parts.Nat.Simple as PNS

open Nat using (_*_; _+_; _<_)
open Fin using (toℕ; fromℕ≤)
open Table

open PNS using (sum-replicate-*; repl)

asParts : ∀ {a b} → Fin (a * b) ↔ (Fin a × Fin b)
asParts {a} {b} = ≡.subst (λ n → Fin n ↔ (Fin a × Fin b)) (sum-replicate-* a b) (Parts.asParts (constParts a b))

fromParts : ∀ {a b} → Fin a × Fin b → Fin (a * b)
fromParts = Inverse.from asParts ⟨$⟩_

toParts : ∀ {a b} → Fin (a * b) → Fin a × Fin b
toParts = Inverse.to asParts ⟨$⟩_

fromParts³′ : ∀ {a b c} → Fin a × Fin b × Fin c → Fin (a * (b * c))
fromParts³′ {a} {b} {c} (i , j , k) = fromParts (i , fromParts (j , k))

fromParts³ : ∀ {a b c} → Fin a × Fin b × Fin c → Fin (a * b * c)
fromParts³ {a} {b} {c} (i , j , k) = fromParts (fromParts (i , j) , k)

private
  fromParts′ : ∀ {a b} → Fin a × Fin b → Fin (sum (repl a b))
  fromParts′ {a} {b} = Parts.fromParts (constParts a b)

  toParts′ : ∀ {a b} → Fin (sum (repl a b)) → Fin a × Fin b
  toParts′ {a} {b} = Parts.toParts (constParts a b)

  asParts-prop : ∀ {a b} → asParts {a} {b} ≅ Parts.asParts (constParts a b)
  asParts-prop {a} {b} = ≅.≡-subst-removable _ _ _

  abstract
    fromParts′-prop : ∀ {a b} (ij : Fin a × Fin b) → toℕ (fromParts ij) ≡ toℕ (fromParts′ ij)
    fromParts′-prop {a} {b} ij =
      ≅.≅-to-≡ (≅.icong (λ n → Fin n ↔ (Fin a × Fin b))
                         (≡.sym (sum-replicate-* a b))
                         (λ {n} (ap : Fin n ↔ (Fin a × Fin b)) → toℕ (Inverse.from ap ⟨$⟩ ij))
                         asParts-prop)

    toParts′-prop : ∀ {a b} {x : Fin (a * b)} {x′ : Fin (sum (repl a b))} → x ≅ x′ → Σ.map toℕ toℕ (toParts {a} x) ≡ Σ.map toℕ toℕ (toParts′ {a} x′)
    toParts′-prop {a} {b} {x} {x′} x≅x′ =
      ≅.≅-to-≡ (≅.icong₂
        (λ n → Fin n ↔ (Fin a × Fin b))
        (≡.sym (sum-replicate-* a b))
        (λ {n} (ap : Fin n ↔ (Fin a × Fin b)) x → Σ.map toℕ toℕ (Inverse.to ap ⟨$⟩ x))
        asParts-prop
        x≅x′)

    fromParts³′-prop : ∀ {a b c} (i : Fin a) (j : Fin b) (k : Fin c) → toℕ (fromParts³′ (i , j , k)) ≡ PNS.fromParts³′ a b c (toℕ i , toℕ j , toℕ k)
    fromParts³′-prop {a} {b} {c} i j k =
      begin
        toℕ (fromParts (i , fromParts (j , k)))                                                 ≡⟨ fromParts′-prop (i , _) ⟩
        toℕ (fromParts′ (i , fromParts (j , k)))                                                ≡⟨ Parts.fromParts-fromPartsℕ (constParts a (b * c)) i _ ⟩
        Partsℕ.fromParts (constParts a (b * c)) (toℕ i , toℕ (fromParts (j , k)))           ≡⟨ ≡.cong₂ (λ x y → Partsℕ.fromParts (constParts a x) (toℕ i , y))
                                                                                (≡.sym (sum-replicate-* b c))
                                                                                (fromParts′-prop (j , k)) ⟩
        Partsℕ.fromParts (constParts a (sum (repl b c))) (toℕ i , toℕ (fromParts′ (j , k)))  ≡⟨ ≡.sym (Parts.fromParts-fromPartsℕ (constParts a _) i _) ⟩
        toℕ (Parts.fromParts (constParts a (sum (repl b c))) (i , fromParts′ (j , k)))        ≡⟨ Parts.fromParts-fromPartsℕ (constParts a (sum (repl b c))) i _ ⟩
        PNS.fromParts a (sum (repl b c)) (toℕ i , toℕ (fromParts′ (j , k)))                  ≡⟨ ≡.cong₂ (λ x y → PNS.fromParts a x (toℕ i , y))
                                                                                (sum-replicate-* b c)
                                                                                (Parts.fromParts-fromPartsℕ (constParts b c) j k) ⟩
        PNS.fromParts a (b * c) (toℕ i , PNS.fromParts b c (toℕ j , toℕ k))               ∎
      where
      open ≡.Reasoning

    fromParts³-prop : ∀ {a b c} (i : Fin a) (j : Fin b) (k : Fin c) → toℕ (fromParts³ (i , j , k)) ≡ PNS.fromParts³ a b c (toℕ i , toℕ j , toℕ k)
    fromParts³-prop {a} {b} {c} i j k =
      begin
        toℕ (fromParts (fromParts (i , j) , k))                                                  ≡⟨ fromParts′-prop (fromParts (i , j) , k) ⟩
        toℕ (fromParts′ (fromParts (i , j) , k))                                                 ≡⟨ Parts.fromParts-fromPartsℕ (constParts (a * b) c) (fromParts (i , j)) k ⟩
        Partsℕ.fromParts (constParts (a * b) c) (toℕ (fromParts (i , j)) , toℕ k)            ≡⟨ ≡.cong₂ (λ x y → Partsℕ.fromParts (constParts x c) (y , toℕ k))
                                                                                (≡.sym (sum-replicate-* a b))
                                                                                (fromParts′-prop (i , j)) ⟩
        Partsℕ.fromParts (constParts (sum (repl a b)) c) (toℕ (fromParts′ (i , j)) , toℕ k)   ≡⟨ ≡.sym (Parts.fromParts-fromPartsℕ (constParts _ c) (fromParts′ (i , j)) k) ⟩
        toℕ (fromParts′ (fromParts′ (i , j) , k))                                                 ≡⟨ Parts.fromParts-fromPartsℕ (constParts _ c) (fromParts′ (i , j)) k ⟩
        PNS.fromParts (sum (repl a b)) c (toℕ (fromParts′ (i , j)) , toℕ k)                   ≡⟨ ≡.cong₂ (λ x y → PNS.fromParts x c (y , toℕ k))
                                                                                (sum-replicate-* a b)
                                                                                (Parts.fromParts-fromPartsℕ (constParts a b) i j) ⟩
        PNS.fromParts (a * b) c (PNS.fromParts a b (toℕ i , toℕ j) , toℕ k)                ∎
      where open ≡.Reasoning

abstract
  fromParts-assoc : ∀ {a b c} (ijk : Fin a × Fin b × Fin c) → fromParts³ ijk ≅ fromParts³′ ijk
  fromParts-assoc {a} {b} {c} (i , j , k) =
    Fin.toℕ-injective′ (begin
      toℕ (fromParts³ (i , j , k))                       ≡⟨ fromParts³-prop i j k ⟩
      PNS.fromParts³ a b c (toℕ i , toℕ j , toℕ k)   ≡⟨ ≡.sym (PNS.fromParts-assoc _ _ _ (Fin.bounded i) (Fin.bounded j) (Fin.bounded k)) ⟩
      PNS.fromParts³′ a b c (toℕ i , toℕ j , toℕ k)  ≡⟨ ≡.sym (fromParts³′-prop i j k) ⟩
      toℕ (fromParts³′ (i , j , k))                      ∎)
    (Nat.*-assoc a _ _)
    where open ≡.Reasoning

module _ (a b c : ℕ) where

  toParts³ : Fin (a * b * c) → Fin a × Fin b × Fin c
  toParts³ x =
    let ij , k = toParts x
        i , j = toParts ij
    in i , j , k

  toParts³′ : Fin (a * (b * c)) → Fin a × Fin b × Fin c
  toParts³′ i =
    let i₁ , i₂₃ = toParts i
        i₂ , i₃ = toParts i₂₃
    in i₁ , i₂ , i₃

  abstract
    fromParts³-toParts³ : ∀ i → fromParts³ (toParts³ i) ≡ i
    fromParts³-toParts³ x =
      let i , j , k = toParts³ x
          open ≡.Reasoning
      in begin
        fromParts³ (toParts³ x)          ≡⟨⟩
        fromParts (fromParts (i , j) , k)  ≡⟨ ≡.cong (fromParts ∘ (_, k)) (asParts {a} {b} .Inverse.left-inverse-of (toParts x .proj₁)) ⟩
        fromParts {a * b} (toParts x)    ≡⟨ asParts {a * b} .Inverse.left-inverse-of x ⟩
        x                                  ∎

    toParts³′-fromParts³′ : ∀ ijk → toParts³′ (fromParts³′ ijk) ≡ ijk
    toParts³′-fromParts³′ (i , j , k) =
      let i′ , j′ , k′ = toParts³′ (fromParts³′ (i , j , k))
          p , q = Σ.≡⇒≡×≡ (asParts .Inverse.right-inverse-of (i , fromParts (j , k)))
          q′ = ≡.trans (≡.cong toParts q) (asParts .Inverse.right-inverse-of (j , k))

      in Σ.≡×≡⇒≡ (p , q′)

    toParts-assoc : {i : Fin (a * b * c)} {i′ : Fin (a * (b * c))} → i ≅ i′ → toParts³ i ≡ toParts³′ i′
    toParts-assoc {i} {i′} eq =
      begin
        toParts³ i                              ≡⟨ ≡.sym (toParts³′-fromParts³′ _) ⟩
        toParts³′ (fromParts³′ (toParts³ i))  ≡⟨ ≡.cong toParts³′ lem ⟩
        toParts³′ i′                            ∎
      where
      lem : fromParts³′ (toParts³ i) ≡ i′
      lem = ≅.≅-to-≡ (
        let open ≅.Reasoning
        in begin
          fromParts³′ (toParts³ i)   ≅⟨ ≅.sym (fromParts-assoc (toParts³ i)) ⟩
          fromParts³ (toParts³ i)    ≡⟨ fromParts³-toParts³ i ⟩
          i                            ≅⟨ eq ⟩
          i′                           ∎)

      open ≡.Reasoning

    toParts³-fromParts³ : ∀ ijk → toParts³ (fromParts³ ijk) ≡ ijk
    toParts³-fromParts³ ijk =
      begin
        toParts³  (fromParts³ ijk)    ≡⟨ toParts-assoc (fromParts-assoc ijk) ⟩
        toParts³′ (fromParts³′ ijk)   ≡⟨ toParts³′-fromParts³′ ijk ⟩
        ijk                             ∎
      where open ≡.Reasoning

    fromParts³′-toParts³′ : ∀ k → fromParts³′ (toParts³′ k) ≡ k
    fromParts³′-toParts³′ k =
      let k′ = ≡.subst Fin (≡.sym (Nat.*-assoc a b c)) k
          k′≅k = ≅.≡-subst-removable Fin _ k
      in ≅.≅-to-≡ (begin
        fromParts³′ (toParts³′ k )   ≡⟨ ≡.cong fromParts³′ (≡.sym (toParts-assoc k′≅k)) ⟩
        fromParts³′ (toParts³  k′)   ≅⟨ ≅.sym (fromParts-assoc (toParts³ k′)) ⟩
        fromParts³  (toParts³  k′)   ≡⟨ fromParts³-toParts³ k′ ⟩
        k′                             ≅⟨ k′≅k ⟩
        k                              ∎)
      where open ≅.Reasoning

  asParts³ : Fin (a * b * c) ↔ (Fin a × Fin b × Fin c)
  asParts³ = record
    { to = ≡.→-to-⟶ toParts³
    ; from = ≡.→-to-⟶ fromParts³
    ; inverse-of = record
      { left-inverse-of = fromParts³-toParts³
      ; right-inverse-of = toParts³-fromParts³
      }
    }

  asParts³′ : Fin (a * (b * c)) ↔ (Fin a × Fin b × Fin c)
  asParts³′ = record
    { to = ≡.→-to-⟶ toParts³′
    ; from = ≡.→-to-⟶ fromParts³′
    ; inverse-of = record
      { left-inverse-of = fromParts³′-toParts³′
      ; right-inverse-of = toParts³′-fromParts³′
      }
    }

abstract
  toParts-1ˡ : ∀ {b} (x : Fin (1 * b)) (x′ : Fin b) → x ≅ x′ → toParts {1} x ≡ (zero , x′)
  toParts-1ˡ {b} x x′ x≅x′ =
    let i  , j = toParts {1} x
        i′ , j′ = toParts′ {1} x
        i′′ , j′′ = Partsℕ.toParts (constParts 1 b) (toℕ x)
        i≅i′ , j≅j′ = Σ.≡⇒≡×≡ (toParts′-prop {1} {x = x} {x′ = x} ≅.refl)

        i′≅i′′ , j′≅j′′ = Σ.≡⇒≡×≡ (Parts.toParts-toPartsℕ (constParts 1 b) x)
        p , q = Σ.≡⇒≡×≡ (PNS.toParts-1ˡ {b} _ (Nat.≤-trans (Fin.bounded x) (Nat.≤-reflexive (Nat.*-identityˡ _))))
        open ≡.Reasoning
    in Σ.≡×≡⇒≡
      ( Fin.toℕ-injective (begin
          toℕ i  ≡⟨ i≅i′ ⟩
          toℕ i′ ≡⟨ i′≅i′′ ⟩
          i′′    ≡⟨ p ⟩
          0      ∎)
      , Fin.toℕ-injective (begin
          toℕ j    ≡⟨ j≅j′ ⟩
          toℕ j′   ≡⟨ j′≅j′′ ⟩
          j′′      ≡⟨ q ⟩
          toℕ x    ≡⟨ ≅.≅-to-≡ (≅.icong Fin (Nat.*-identityˡ _) toℕ x≅x′) ⟩
          toℕ x′   ∎)
      )

  toParts-1ʳ : ∀ {a} (x : Fin (a * 1)) (x′ : Fin a) → x ≅ x′ → toParts x ≡ (x′ , zero)
  toParts-1ʳ {a} x x′ x≅x′ =
    let x′′ : Fin (sum (repl a 1))
        x′′ = ≡.subst Fin (≡.sym (sum-replicate-* a 1)) x

        x≅x′′ = ≅.sym (≅.≡-subst-removable Fin (≡.sym (sum-replicate-* a 1)) x)
        x′′≅x′ = ≅.trans (≅.sym x≅x′′) x≅x′
        sra≡a = ≡.trans (sum-replicate-* a 1) (Nat.*-identityʳ a)

        i , j = toParts x
        i′ , j′ = toParts′ {a} {1} x′′
        i′′ , j′′ = Partsℕ.toParts (constParts a 1) (toℕ x′′)

        i≅i′ , j≅j′ = Σ.≡⇒≡×≡ (toParts′-prop {a} {x = x} {x′ = x′′} x≅x′′)
        i′≅i′′ , j′≅j′′ = Σ.≡⇒≡×≡ (Parts.toParts-toPartsℕ (constParts a 1) x′′)

        p , q = Σ.≡⇒≡×≡ (PNS.toParts-1ʳ {a} (toℕ x′′) (Nat.≤-trans (Nat.≤-reflexive (≅.≅-to-≡ (≅.icong Fin sra≡a (suc ∘ toℕ) x′′≅x′))) (Fin.bounded x′)))

        open ≡.Reasoning
    in Σ.≡×≡⇒≡
      ( Fin.toℕ-injective (begin
          toℕ i    ≡⟨ i≅i′ ⟩
          toℕ i′   ≡⟨ i′≅i′′ ⟩
          i′′      ≡⟨ p ⟩
          toℕ x′′  ≡⟨ ≅.≅-to-≡ (≅.icong Fin sra≡a toℕ x′′≅x′) ⟩
          toℕ x′   ∎)
      , Fin.toℕ-injective (begin
          toℕ j  ≡⟨ j≅j′ ⟩
          toℕ j′ ≡⟨ j′≅j′′ ⟩
          j′′     ≡⟨ q ⟩
          0      ∎)
      )


------------------------------------------------------------------------
-- The Agda standard library
--
-- An example of how Algebra.IdempotentCommutativeMonoidSolver can be
-- used
------------------------------------------------------------------------

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

module Algebra.Solver.IdempotentCommutativeMonoid.Example where

open import Relation.Binary.PropositionalEquality using (_≡_)

open import Data.Bool.Base using (_∨_)
open import Data.Bool.Properties using (∨-idempotentCommutativeMonoid)

open import Data.Fin using (zero; suc)
open import Data.Vec using ([]; _∷_)

open import Algebra.Solver.IdempotentCommutativeMonoid
  ∨-idempotentCommutativeMonoid

test : ∀ x y z → (x ∨ y) ∨ (x ∨ z) ≡ (z ∨ y) ∨ x
test a b c = let _∨_ = _⊕_ in
  prove 3 ((x ∨ y) ∨ (x ∨ z)) ((z ∨ y) ∨ x) (a ∷ b ∷ c ∷ [])
  where
  x = var zero
  y = var (suc zero)
  z = var (suc (suc zero))


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

open import Categories.Category
open import Categories.Category.Complete.Finitely

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

open import Level using (Level)
open import Data.Nat using (ℕ)
open import Data.Product using (Σ; _,_; proj₁; ∃₂) renaming (_×_ to _&_)
open import Data.Fin
open import Data.Fin.Properties
open import Data.Sum using (inj₁; inj₂)
open import Data.List hiding ([_])
open import Data.List.Relation.Unary.Any as Any using (here; there)
open import Data.List.Relation.Unary.Any.Properties
open import Data.List.Relation.Unary.Unique.Propositional
open import Data.List.Membership.Propositional
open import Relation.Binary.PropositionalEquality as ≡ using (refl; _≡_; cong)
open import Function renaming (_∘_ to _∙_)

import Data.List.Relation.Unary.Unique.Propositional.Properties as Uₚ
import Data.List.Membership.Propositional.Properties as ∈ₚ
import Data.List.Membership.Setoid.Properties as S∈ₚ

open import Categories.Category
open import Categories.Category.Cartesian.Properties C
open import Categories.Category.Finite.Fin
open import Categories.Diagram.Equalizer C
open import Categories.Morphism.Reasoning C
open import Categories.Functor

import Categories.Category.Construction.Cones as Co
import Categories.Diagram.Limit as Lim

open FinitelyComplete finite

module GeneralProperties where

  module _ {a} {A : Set a} where

    concatMap-∈ : ∀ {b} {B : Set b} (f : A → List B) {l : List A} →
                  ∀ {x y} → x ∈ l → y ∈ f x → y ∈ concatMap f l
    concatMap-∈ f (here refl) y∈fx     = ++⁺ˡ y∈fx
    concatMap-∈ f (there {z} x∈l) y∈fx = ++⁺ʳ (f z) (concatMap-∈ f x∈l y∈fx)

  module _ {a} {A : Set a} where

    concatMap²-∈ : ∀ {m n} {ms : List (Fin m)} {ns : List (Fin n)}
                     (f : Fin m → Fin n → List A) →
                     ∀ {x y k} → x ∈ ms → y ∈ ns → k ∈ f x y →
                       k ∈ concatMap (λ z → concatMap (λ w → f z w) ns) ms
    concatMap²-∈ {m} {n} {ms} {ns} f {x} {y} {k} x∈ms y∈ns k∈fxy = concatMap-∈ _ x∈ms k∈ns
      where k∈ns : k ∈ concatMap (λ w → f x w) ns
            k∈ns  = concatMap-∈ _ y∈ns k∈fxy

    module _ {b} {B : Set b} where

      concatMap²-map-∈ : ∀ {m n} {ms : List (Fin m)} {ns : List (Fin n)}
                           (f : Fin m → Fin n → List A) →
                           (g : A → B) →
                           ∀ {x y k} → x ∈ ms → y ∈ ns → k ∈ f x y →
                             g k ∈ map g (concatMap (λ z → concatMap (λ w → f z w) ns) ms)
      concatMap²-map-∈ f g x∈ms y∈ns k∈fxy = map⁺ (Any.map (cong g) (concatMap²-∈ f x∈ms y∈ns k∈fxy))

open GeneralProperties
open Prods cartesian

-- construct a finite limit from cartesian products and equalizer
--
-- c.f. Awodey 5.21
module _ (shape : FinCatShape) (F : Functor (FinCategory shape) C) where
  private
    module C = Category C
    open C
    open HomReasoning
    S = FinCategory shape
    open Co F
    open Lim F
    open FinCatShape shape using (size; ∣_⇒_∣; objects; morphisms; wrap-arr; Obj-UIP)
    module S = Category S
    module F = Functor F

    obj∈-irr : ∀ {x} → (p q : x ∈ objects) → p ≡ q
    obj∈-irr = S∈ₚ.unique⇒irrelevant (≡.setoid _) Obj-UIP (Uₚ.allFin⁺ size)

    prods-gen : List (Fin size) → Obj
    prods-gen ns = prod (map F.₀ ns)

    prods : Obj
    prods = prods-gen objects

    cods : List Obj
    cods = map (λ n → F.₀ (Arrow.cod n)) morphisms

    arrs : Obj
    arrs = prod cods

    ∈-objects : ∀ n → n ∈ objects
    ∈-objects n = ∈ₚ.∈-allFin n

    Fn∈obj : ∀ n → F.₀ n ∈ map F.₀ objects
    Fn∈obj n = ∈ₚ.∈-map⁺ F.₀ (∈-objects n)

    π : ∀ n → prods ⇒ F.₀ n
    π n = π[ Fn∈obj n ]

    ϕ⇒ : ∀ (a : Arrow size ∣_⇒_∣) → prods ⇒ F.F₀ (Arrow.cod a)
    ϕ⇒ a = π (Arrow.cod a)

    ϕπ : prods ⇒ cods *
    ϕπ = build-mors _ ϕ⇒ morphisms

    ϕ : prods ⇒ arrs
    ϕ = ⟨ ϕπ ⟩*

    ψ⇒ : ∀ a → prods ⇒ F.F₀ (Arrow.cod a)
    ψ⇒ a = F.₁ (Arrow.arr a) ∘ π (Arrow.dom a)

    ψπ : prods ⇒ cods *
    ψπ = build-mors _ ψ⇒ morphisms

    ψ : prods ⇒ arrs
    ψ = ⟨ ψπ ⟩*

    ∈-morphisms : ∀ {d c} (f : Fin ∣ d ⇒ c ∣) → record { arr = f } ∈ morphisms
    ∈-morphisms {d} {c} f = concatMap²-∈ (λ _ _ → tabulate wrap-arr) (∈-objects d) (∈-objects c) (∈ₚ.∈-tabulate⁺ f)

    Fc∈cods : ∀ {d c} (f : Fin ∣ d ⇒ c ∣) → F.₀ c ∈ cods
    Fc∈cods f = ∈ₚ.∈-map⁺ (λ a → F.₀ (Arrow.cod a)) (∈-morphisms f)

    π′ : ∀ {d c} (f : Fin ∣ d ⇒ c ∣) → arrs ⇒ F.₀ c
    π′ f = π[ Fc∈cods f ]

    ψπ-proj : ∀ {d c} (f : Fin ∣ d ⇒ c ∣) →
                F.₁ f ∘ π d ≈ π[ Fc∈cods f ] ∘ ψ
    ψπ-proj f = build-proj (λ a → F.₀ (Arrow.cod a))
                           (λ a → F.₁ (Arrow.arr a) ∘ π (Arrow.dom a))
                           (∈-morphisms f)

    ϕπ-proj : ∀ {d c} (f : Fin ∣ d ⇒ c ∣) →
                π c ≈ π[ Fc∈cods f ] ∘ ϕ
    ϕπ-proj f = build-proj (λ a → F.₀ (Arrow.cod a))
                           (λ a → π (Arrow.cod a))
                           (∈-morphisms f)

    e⇒prods : Equalizer ψ ϕ
    e⇒prods = equalizer ψ ϕ

    module e⇒prods = Equalizer e⇒prods

    open e⇒prods

    ⊤cone : Cone
    ⊤cone = record
      { N    = obj
      ; apex = record
        { ψ       = λ n → π n ∘ arr
        ; commute = λ {m n} f → begin
          F.₁ f ∘ π m ∘ arr ≈⟨ pullˡ (ψπ-proj f) ⟩
          (π′ f ∘ ψ) ∘ arr  ≈⟨ pullʳ equality ⟩
          π′ f ∘ ϕ ∘ arr    ≈˘⟨ pushˡ (ϕπ-proj f) ⟩
          π n ∘ arr         ∎
        }
      }

    module _ {K : Cone} where
      private
        module K = Cone K

      N⇒* : K.N ⇒ map F.₀ objects *
      N⇒* = build-mors F.₀ K.ψ objects

      Kmor : K.N ⇒ prods
      Kmor = ⟨ N⇒* ⟩*

      ψ∘Kmor≈ϕ∘Kmor : ∀ a → ψ⇒ a ∘ Kmor ≈ ϕ⇒ a ∘ Kmor
      ψ∘Kmor≈ϕ∘Kmor a = begin
        ψ⇒ a ∘ Kmor                           ≈˘⟨ pushʳ (build-proj F.₀ K.ψ (∈-objects (Arrow.dom a))) ⟩
        F.₁ (Arrow.arr a) ∘ K.ψ (Arrow.dom a) ≈⟨ K.commute (Arrow.arr a) ⟩
        K.ψ (Arrow.cod a)                     ≈⟨ build-proj F.₀ K.ψ (∈-objects (Arrow.cod a)) ⟩
        ϕ⇒ a ∘ Kmor                           ∎

      equalize-eq : ψ ∘ Kmor ≈ ϕ ∘ Kmor
      equalize-eq = begin
        ψ ∘ Kmor                                        ≈⟨ build-⟨⟩*∘ _ ψ⇒ Kmor morphisms ⟩
        ⟨ build-mors _ (λ a → ψ⇒ a ∘ Kmor) morphisms ⟩* ≈⟨ build-uniqueness* _ ψ∘Kmor≈ϕ∘Kmor morphisms ⟩
        ⟨ build-mors _ (λ a → ϕ⇒ a ∘ Kmor) morphisms ⟩* ≈˘⟨ build-⟨⟩*∘ _ ϕ⇒ Kmor morphisms ⟩
        ϕ ∘ Kmor ∎

      !cone : Cone⇒ K ⊤cone
      !cone = record
        { arr     = equalize equalize-eq
        ; commute = commute _
        }
        where commute : ∀ n → (π n ∘ arr) ∘ equalize equalize-eq ≈ K.ψ n
              commute n = begin
                (π n ∘ arr) ∘ equalize equalize-eq ≈˘⟨ pushʳ universal ⟩
                π n ∘ Kmor                         ≈˘⟨ build-proj _ K.ψ (∈-objects n) ⟩
                K.ψ n                              ∎

    module _ {K : Cone} (f : Cones [ K , ⊤cone ]) where
      private
        module K = Cone K
        module f = Cone⇒ f

      !cone-unique : Cones [ !cone ≈ f ]
      !cone-unique = begin
        equalize equalize-eq ≈˘⟨ e⇒prods.unique eq ⟩
        f.arr                ∎
        where eq″ : ∀ y → π y ∘ arr ∘ f.arr ≈ π y ∘ Kmor {K}
              eq″ y = begin
                π y ∘ arr ∘ f.arr   ≈⟨ sym-assoc ⟩
                (π y ∘ arr) ∘ f.arr ≈⟨ f.commute ⟩
                K.ψ y               ≈⟨ build-proj _ K.ψ (∈-objects y) ⟩
                π y ∘ Kmor {K}      ∎

              eq′ : ∀ {y : Fin size} (y∈ys : y ∈ objects) →
                    π[ ∈ₚ.∈-map⁺ F.₀ y∈ys ] ∘ arr ∘ f.arr ≈ π[ ∈ₚ.∈-map⁺ F.₀ y∈ys ] ∘ Kmor {K}
              eq′ {y} y∈ys with obj∈-irr y∈ys (∈-objects y)
              ... | refl = eq″ y

              eq : Kmor {K} ≈ arr ∘ f.arr
              eq = sym (uniqueness*′ F.₀ {K.N} {objects} eq′)

  finiteLimit : Limit
  finiteLimit = record
    { terminal = record
      { ⊤        = ⊤cone
      ; !        = !cone
      ; !-unique = !cone-unique
      }
    }


-- Andreas, 2016-10-09, re issue #2223

module Issue2223.Setoids where

open import Common.Level

record Setoid c ℓ : Set (lsuc (c ⊔ ℓ)) where
  infix 4 _≈_
  field
    Carrier       : Set c
    _≈_           : (x y : Carrier) → Set ℓ

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


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

module SpacesFirstAttempt where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base -- Rel
open import Data.Nat.Base using (ℕ) renaming (_≤_ to _≤ₙ_)

record PoorField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    Carrier : Type ℓ
    -- comm ring
    0f   : Carrier
    1f   : Carrier
    _+_  : Carrier → Carrier → Carrier
    _·_  : Carrier → Carrier → Carrier
    -_   : Carrier → Carrier
    -- lattice
    _<_  : Rel Carrier Carrier ℓ' -- stronger than _#_ and _≤_
    min  : Carrier → Carrier → Carrier
    max  : Carrier → Carrier → Carrier
    -- other
    _#_  : Rel Carrier Carrier ℓ'
    _≤_  : Rel Carrier Carrier ℓ'
    ∣_∣ᶠ' : Carrier → Σ[ x ∈ Carrier ] 0f ≤ x -- absolute value
    _⁻¹ᶠ : (x : Carrier) → {{x # 0f}} → Carrier
    conj : Carrier → Carrier -- complex conjugation (only for ℂ; this is the identity function on ℝ)
    -- sqrt -- need that on ℝ₀⁺ to define a norm from an inner product

  ∣_∣ᶠ : Carrier → Carrier -- NOTE: well, this should be "into" ℝ₀⁺
  ∣ x ∣ᶠ = fst (∣ x ∣ᶠ')

  _-_ : Carrier → Carrier → Carrier
  x - y = x + (- y)

  infix  9 _⁻¹ᶠ
  infix  8 -_
  infixl 7 _·_
  infixl 6 _+_
  infixl 6 _-_
  infixl 4 _#_
  infixl 4 _<_
  infixl 4 _≤_

-- different "variants" of reals
--   this might be a "basis" for an instance-based, typeclass-like coercion "mechanism" between different "numbers"
--
-- NOTE: the intuition with "variants" might align with "subset" where different properties are available
--       from a "subset" in this manner, we want that it is "easy" to
--       - make use of properties from the "full" set
--         - this might be realized with an abuse of Agda's record-update syntax
--         - the "core" of such a mechanism is to have a proper naming-scheme (because record-update basically just matches names)
--       - "spontaneously enrich" some current context with a subset proof
--         and then make use of the subset lemmas on elements of the "whole" set

{- IDEA: for the organization of these definitions

we might have some "ur"-reals
  these are "the" "numbers"
or even better: just "ur-numbers" to support functions from 𝕂 into ℝ₀⁺
being part of some concrete number type is attached via a hidden instance-proof property
  this should be similar to a typeclass mechanism in Coq or Isabelle/HOL
  TODO: maybe, when re-reading their papers, it becomes apparent that this is how it's done in Hölzl 2013 and the Coq-Port of their work
    because I remember them writing something like "this work makes heavy use of typeclasses"
so we explicitly quantify over "numbers" and implicitly quantify over "properties"
the available properties must have the same name in each different number type
  that way we can make use of Agda's record update syntax
  (well, there can be exceptions since it is possible to rename stuff on the fly, but it'd be more convenient if the names already match)
we might decide NOT (!) to overload operations such as _<_ and similar
  because having both overloaded - operations and numbers - is likely to generate resolving issues
AND we must be very aware when a type depends on a hidden argument
  because in that case, we need to add an explicit coercion to our result
  so we just accept that "inconvenience" and embrace a style where these "important" arguments/instances are treated differently
    especially they should not be used anonymously
    and this might also embrace an anonymous-module style to create a scope that is shared by both: the declaration and the definition of something
      This might look ugly at first but that's okay if it works out

-}

record IsℝField (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF

record Isℝ₀⁺Field (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF
  field
    isℝField : IsℝField PF
    isNonnegative : ∀ x → 0f ≤ x
  open IsℝField isℝField public

record Isℝ⁺Field (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF
  field
    isℝField : IsℝField PF
    -- NOTE: 0f is not an element of ℝ⁺, so we do not have a neutral element for addition
    --       so the following holds in a different way
    -- isPositive : ∀ x → 0f < x
  open IsℝField isℝField public

record Is𝕂Field (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF

record ℝField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    isℝField : IsℝField poorField
  open PoorField poorField public
  open IsℝField isℝField public

record ℝ₀⁺Field : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    isℝ₀⁺Field : Isℝ₀⁺Field poorField
  open PoorField poorField public
  open Isℝ₀⁺Field isℝ₀⁺Field public

record ℝ⁺Field : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    isℝ⁺Field : Isℝ⁺Field poorField
  open PoorField poorField public
  open Isℝ⁺Field isℝ⁺Field public

record 𝕂Field : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    is𝕂Field : Is𝕂Field poorField
  open PoorField poorField public
  open Is𝕂Field is𝕂Field public

postulate
  ℝℓ ℝℓ' : Level
  ℝF    : ℝField   {ℝℓ} {ℝℓ'} -- reals
  ℝ⁺F   : ℝ⁺Field  {ℝℓ} {ℝℓ'} -- positive reals without 0
  ℝ₀⁺F  : ℝ₀⁺Field {ℝℓ} {ℝℓ'} -- positive reals with 0
  -- we also often use ℂ in the application
  -- we might often use ℝ in places where ℚ would suffice
  -- we use 𝕂 for "ℝ or ℂ"
  -- and we use ℕ, Fin k, ℤ of course
  -- then, there is (exterior) algebra

-- NOTE: one could bring different "variants" of the reals into scope like so
--       but we are likely to omit populating the scope with overlapping reals as much as possible

open ℝField ℝF using () renaming
  ( Carrier to ℝ
  )

open ℝ₀⁺Field ℝ₀⁺F using () renaming
  ( Carrier to ℝ₀⁺
  ; 0f to 0f₀⁺
  )

open ℝ⁺Field ℝ⁺F using () renaming
  ( Carrier to ℝ⁺
  )

---------- application -------------

{-
-- ∅ : ⊥ →

-- topology on a set X
record IsTopology
  (X : Type ℓ)
  (isOpen : X → Type ℓ')
  (_∪_ : X → X → X)
  (_∩_ : X → X → X)
  : Type _ where
  field

record TopologicalSpace : Type _ where
-}

record IsMetric {ℓ} {X : Type ℓ} (d : X → X → ℝ₀⁺) : Type (ℓ-max ℓ (ℓ-max ℝℓ ℝℓ')) where
  open ℝ₀⁺Field ℝ₀⁺F
  field
    -- identity of indiscernibles
    isPositiveOnNonzero      : ∀ x y → 0f ≡ d x y → x ≡ y
    isPositiveOnNonzero-back : ∀ x y → x ≡ y → 0f ≡ d x y
    isSym                    : ∀ x y → d x y ≡ d y x
    -- subadditivity / triangle inequality
    isTriangleIneq           : ∀ x y z → d x y ≤ d x z + d z y

record MetricSpace : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max ℝℓ' ℝℓ)) where
  field
    Carrier  : Type ℓ
    d        : Carrier → Carrier → ℝ₀⁺
    isMetric : IsMetric d
  open IsMetric isMetric public

𝕂ℓ  = ℝℓ
𝕂ℓ' = ℝℓ'

module _ (𝕂F : 𝕂Field {𝕂ℓ} {𝕂ℓ'}) where
  open 𝕂Field 𝕂F renaming (Carrier to 𝕂; 0f to 0ₛ; _+_ to _+ₛ_)
  postulate
    ∣_∣ᵣ : 𝕂 → ℝ₀⁺
  record IsVectorAddition {X : Type ℓ} (0v : X) (_+_ : X → X → X) (-_ : X → X) : Type (ℓ-max ℓ (ℓ-max 𝕂ℓ 𝕂ℓ')) where
    field
      isCommutative : ∀ x y → x + y ≡ y + x
      isAssociative : ∀ x y z → (x + y) + z ≡ x + (y + z)
      rid           : ∀ x → x + 0v ≡ x
      rid-back      : ∀ x y → x + y ≡ x → y ≡ 0v
      invr          : ∀ x → x + (- x) ≡ 0v

  record IsScalarMultiplication {X : Type ℓ} (0v : X) (_+_ : X → X → X) (-_ : X → X) (_·ₛ_ : 𝕂 → X → X) : Type (ℓ-max ℓ (ℓ-max 𝕂ℓ 𝕂ℓ')) where
    field
      ·ₛ-dist-+ : ∀ α x y → α ·ₛ (x + y) ≡ (α ·ₛ x) + (α ·ₛ y)
      0-left-nullifies : ∀ x → 0ₛ ·ₛ x ≡ 0v
      +ₛ-dist-· : ∀ α β x → (α +ₛ β) ·ₛ x ≡ (α ·ₛ x) + (β ·ₛ x)

  record VectorSpace : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max 𝕂ℓ 𝕂ℓ')) where
    field
      Carrier : Type ℓ
      0v      : Carrier
      _+_     : Carrier → Carrier → Carrier
      -_      : Carrier → Carrier
      _·ₛ_    : 𝕂 → Carrier → Carrier
      isVectorAddition : IsVectorAddition 0v _+_ (-_)
      isScalarMultiplication : IsScalarMultiplication 0v _+_ -_ _·ₛ_

    open IsVectorAddition isVectorAddition public
    open IsScalarMultiplication isScalarMultiplication public

  module _ (VS : VectorSpace {ℓ}) where
    open VectorSpace VS using (_+_; _·ₛ_) renaming (Carrier to V; 0v to 0ᵥ)
    open ℝ₀⁺Field ℝ₀⁺F using () renaming (0f to 0ᵣ; _≤_ to _≤ᵣ_; _+_ to _+ᵣ_; _·_ to _·ᵣ_)
    record IsNorm (‖_‖ᵥ : V → ℝ₀⁺) : Type (ℓ-max ℓ (ℓ-max 𝕂ℓ 𝕂ℓ')) where
      field
        idToIndisc      : ∀ x → ‖ x ‖ᵥ ≡ 0ᵣ → x ≡ 0ᵥ
        idToIndisc-back : ∀ x → x ≡ 0ᵥ → ‖ x ‖ᵥ ≡ 0ᵣ
        triangleIneq    : ∀ x y → ‖ x + y ‖ᵥ ≤ᵣ ‖ x ‖ᵥ +ᵣ ‖ y ‖ᵥ
        absLinear       : ∀ α x → ‖ α ·ₛ x ‖ᵥ ≡ ∣ α ∣ᵣ ·ᵣ ‖ x ‖ᵥ

  record NormedVectorSpace : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max 𝕂ℓ 𝕂ℓ')) where
    field
      VS : VectorSpace {ℓ}
    open VectorSpace VS public
    field
      ‖_‖ᵥ : Carrier → ℝ₀⁺
      isNorm : IsNorm VS ‖_‖ᵥ
    open IsNorm isNorm public

-- cauchy w.r.t. a distance function
-- NOTE: Booij defines cauchy w.r.t. the rationals ℚ

IsCauchy : {X : Type ℓ} (d : X → X → ℝ₀⁺) → IsMetric d → (x : ℕ → X) → Type (ℓ-max ℝℓ ℝℓ')
IsCauchy d isMetric x =
  let open ℝ₀⁺Field ℝ₀⁺F using () renaming (0f to 0ᵣ; _<_ to _<ᵣ_; _≤_ to _≤ᵣ_; _+_ to _+ᵣ_; _·_ to _·ᵣ_)
  in ∀(ε : ℝ₀⁺) → 0ᵣ <ᵣ ε → Σ[ I ∈ ℕ ] ∀ m n → I ≤ₙ m → I ≤ₙ n → d (x m) (x n) <ᵣ ε

-- limit w.r.t. a metric
IsLimit : {X : Type ℓ} {d : X → X → ℝ₀⁺} → (isMetric : IsMetric d) → (x : ℕ → X) → X → Type (ℓ-max ℝℓ ℝℓ')
IsLimit {d = d} isMetric x a =
  let open ℝ₀⁺Field ℝ₀⁺F using () renaming (0f to 0ᵣ; _<_ to _<ᵣ_; _≤_ to _≤ᵣ_; _+_ to _+ᵣ_; _·_ to _·ᵣ_)
  in ∀(ε : ℝ₀⁺) → 0ᵣ <ᵣ ε → Σ[ I ∈ ℕ ] ∀ m → I ≤ₙ m → d (x m) a <ᵣ ε

IsCauchyConvergent : {X : Type ℓ} (d : X → X → ℝ₀⁺) → (isMetric : IsMetric d) → (x : ℕ → X) → IsCauchy d isMetric x → Type (ℓ-max ℓ (ℓ-max ℝℓ ℝℓ'))
IsCauchyConvergent {X = X} d isMetric x isCauchy = Σ[ a ∈ X ] IsLimit isMetric x a

record CompleteMetricSpace : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max ℝℓ' ℝℓ)) where
  field
    MS : MetricSpace {ℓ}

  open MetricSpace MS public

  field
    isCauchyComplete : ∀ x → (isCauchy : IsCauchy d isMetric x) → Σ[ a ∈ Carrier ] IsLimit isMetric x a

module Lemma-1 (𝕂F : 𝕂Field {𝕂ℓ} {𝕂ℓ'}) (NVS : NormedVectorSpace 𝕂F {ℓ}) where
  open NormedVectorSpace NVS renaming (Carrier to V)
  open ℝ₀⁺Field ℝ₀⁺F using () renaming (_≤_ to _≤ᵣ_; _+_ to _+ᵣ_)

  d : V → V → ℝ₀⁺
  d x y = ‖ x + (- y) ‖ᵥ

  lemma-1 : IsMetric d
  lemma-1 = record
    { isPositiveOnNonzero      = {!!}
    ; isPositiveOnNonzero-back = {!!}
    ; isSym                    = {! λ x y → ?!}
    ; isTriangleIneq           = {!!}
    }

  IsNormMetric : (V → V → ℝ₀⁺) → Type (ℓ-max ℓ ℝℓ)
  IsNormMetric d' = ∀ x y → d' x y ≡ d x y

module _ (𝕂F : 𝕂Field {𝕂ℓ} {𝕂ℓ'}) where
  record CompleteNormedVectorSpace : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max 𝕂ℓ' 𝕂ℓ)) where
    field
      NVS : NormedVectorSpace 𝕂F {ℓ}

    open NormedVectorSpace NVS public

    d : Carrier → Carrier → ℝ₀⁺
    d x y = ‖ x + (- y) ‖ᵥ

    isMetric : IsMetric d
    isMetric = Lemma-1.lemma-1 𝕂F NVS

    field
      isCauchyComplete : ∀ x → (isCauchy : IsCauchy d isMetric x) → Σ[ a ∈ Carrier ] IsLimit isMetric x a

  BanachSpace = CompleteNormedVectorSpace

module _ (𝕂F : 𝕂Field {𝕂ℓ} {𝕂ℓ'}) (VS : VectorSpace 𝕂F {ℓ}) where
  open 𝕂Field 𝕂F using (conj) renaming (Carrier to 𝕂; _·_ to _·ₖ_; _+_ to _+ₖ_)
  open VectorSpace VS renaming (Carrier to V)

  record IsInnerProduct (‹_,_›ᵥ : V → V → 𝕂) : Type (ℓ-max ℓ (ℓ-max 𝕂ℓ' 𝕂ℓ)) where
    field
      -- pos-definite : ∀ x → x ≠ 0v → ‹ x , x › ∈ ℝ⁺ -- TODO
      conj-sym  : ∀ x y → ‹ x , y ›ᵥ ≡ conj (‹ y , x ›ᵥ)
      lin₁      : ∀ α x y → ‹ α ·ₛ x , y ›ᵥ ≡ α ·ₖ ‹ x , y ›ᵥ
      +distrib₁ : ∀ x y z → ‹ x + y , z ›ᵥ ≡ ‹ x , z ›ᵥ +ₖ ‹ y , z ›ᵥ

  -- If the positive-definite condition is replaced by merely requiring that ⟨ x , x ⟩ ≥ 0 for all x,
  --   then one obtains the definition of positive semi-definite Hermitian form.

module _ (𝕂F : 𝕂Field {𝕂ℓ} {𝕂ℓ'}) where
  open 𝕂Field 𝕂F using (conj) renaming (Carrier to 𝕂; _·_ to _·ₖ_; _+_ to _+ₖ_)

  record InnerProductSpace : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max 𝕂ℓ' 𝕂ℓ)) where
    field
      VS : VectorSpace 𝕂F {ℓ}
    open VectorSpace VS public
    field
      ‹_,_›ᵥ : Carrier → Carrier → 𝕂
      isInnerProduct : IsInnerProduct 𝕂F VS ‹_,_›ᵥ
    open IsInnerProduct isInnerProduct public

    -- ‖_‖ᵥ : Carrier →  ℝ₀⁺
    -- ‖ x ‖ᵥ = sqrt (‹ x , x ›ᵥ)

    -- isNorm : IsNorm VS ‖_‖ᵥ
    -- isNorm = ?

    -- d : Carrier → Carrier → ℝ₀⁺
    -- d x y = ‖ x + (- y) ‖ᵥ

    -- isMetric : IsMetric d
    -- isMetric = Lemma-1.lemma-1 𝕂F NVS

  -- NOTE: there are a lot of properties for InnerProductSpaces: https://en.wikipedia.org/wiki/Inner_product_space#Norm

  record HilbertSpace : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max 𝕂ℓ' 𝕂ℓ)) where
    field
      VS : VectorSpace 𝕂F {ℓ}
    open VectorSpace VS public

    field
      ‹_,_›ᵥ : Carrier → Carrier → 𝕂
      isInnerProduct : IsInnerProduct 𝕂F VS ‹_,_›ᵥ
    open IsInnerProduct isInnerProduct public

    -- ‖_‖ᵥ : Carrier →  ℝ₀⁺
    -- ‖ x ‖ᵥ = sqrt (‹ x , x ›ᵥ)

    -- isNorm : IsNorm VS ‖_‖ᵥ
    -- isNorm = ?

    -- d : Carrier → Carrier → ℝ₀⁺
    -- d x y = ‖ x + (- y) ‖ᵥ

    -- isMetric : IsMetric d
    -- isMetric = Lemma-1.lemma-1 𝕂F NVS

    -- field
    --   isCauchyComplete : ∀ x → (isCauchy : IsCauchy d isMetric x) → Σ[ a ∈ Carrier ] IsLimit isMetric x a

-- NOTE:
--   we observe that stronger structure "replaces" weaker structure in the sequence
--     InnerProductSpace < NormedVectorSpace < MetricSpace
--   when we add Cauchy completeness, we get
--     HilbertSpace < BanachSpace < CompleteMetricSpace

-- next up: EuclideanSpace ?
--   see "Hölzl, Immler, Huffman 2013 - Type Classes and Filters for Mathematical Analysis in Isabelle/HOL"
--   here, they start with topological spaces, where we start with the real numbers

-- what about subspaces? How to formulate these?

{-

observed issues
- subspaces
- inclusions/coercions between different variants of "numbers"
- conj
- sqrt
- topological spaces (do we need them after all?)
  - can we follow "Hölzl 2013" ?
- size issues:
  the "amount" of ℓs is "high" and we are not ℓ-suc-ing to 𝕂ℓ and 𝕂ℓ'
  but we are ℓ-suc-ing to ℓ in the definition of PoorField
  so PoorField cannot be in ℓ-zero
- is IsCauchy defined for ε ∈ ℚ or for ε ∈ ℝ ?

in `Cubical.Data.Fin.Base` is written

  Finite types.

  Currently it is most convenient to define these as a subtype of the
  natural numbers, because indexed inductive definitions don't behave
  well with cubical Agda. This definition also has some more general
  attractive properties, of course, such as easy conversion back to ℕ.

and then they state

  Fin : ℕ → Type₀
  Fin n = Σ[ k ∈ ℕ ] k < n

so Σ[ x ∈ 𝕏 ] (P x) kind of falls under what is called a "subtype"

next-up
- infimum and supremum on posets (and sub-posets / sub-lattices ?)
  - we do only really need these on ℝ
  - these do not necessarily exist in the subspace that we regard
- morphisms on these spaces
- (potentially) unbounded linear operators
- algebraic and continuous dual spaces
- Formulation of Riesz representation Theorem on Hilbert spaces

-}


-- Reported by nils.anders.danielsson, Feb 17, 2015

-- See also  Issue 292 ,  Issue 1406 , and Issue 1427.

-- The code below is accepted by Agda 2.4.2.2, but not by the current
-- maintenance or master branches.

data Box (A : Set) : Set where
  [_] : A → Box A

data _≡_ (A : Set) : Set → Set₁ where
  refl : A ≡ A

data _≅_ {A : Set₁} (x : A) : {B : Set₁} → B → Set₂ where
  refl : x ≅ x

-- C could be a typed DSEL.

data C : Set → Set₁ where
  c₁ c₂ : (A : Set) → C (Box A)
-- If A is considered forced, the code no longer type-checks.

-- D could be some kind of semantics for C.

data D : {A : Set} → C A → Set₂ where
  d₁ : (A : Set) → D (c₁ A)
  d₂ : (A : Set) → D (c₂ A)

module Doesn't-work where

  -- Let's try to write an eliminator for the part of the semantics
  -- that concerns c₁ programs. The basic approach doesn't work:

  D-elim-c₁ : (P : {A : Set} → D (c₁ A) → Set₂) →
              ((A : Set) → P (d₁ A)) →
              {A : Set} (x : D (c₁ A)) → P x
  D-elim-c₁ P p (d₁ A) = p A

  -- The following trick also fails (but for some reason the absurd
  -- case is accepted):

  -- Jesper 2015-12-18 update: this is no longer accepted by the new unifier.
  --D-elim-c₁-helper :
  --  (P : {A B : Set} {c : C A} →
  --       D c → A ≡ Box B → c ≅ c₁ B → Set₂) →
  --  ((A : Set) → P (d₁ A) refl refl) →
  --  {A B : Set} {c : C A}
  --  (x : D c) (eq₂ : c ≅ c₁ B) (eq₁ : A ≡ Box B) → P x eq₁ eq₂
  --D-elim-c₁-helper P p (d₂ A) ()   _
  --D-elim-c₁-helper P p (d₁ A) refl refl = p A

module Works where

  -- I can define the eliminators by first defining and proving no
  -- confusion (following McBride, Goguen and McKinna). However, this
  -- requires a fair amount of work, and easy dependent pattern
  -- matching is arguably one of the defining features of Agda.
  --
  -- A quote from "A Few Constructions on Constructors": "The Epigram
  -- language and system [25, 23] takes these constructions for
  -- granted. We see no reason why the users of other systems should
  -- work harder than we do."

  data ⊥ : Set₁ where

  No-confusion : ∀ {A B} → C A → C B → Set₁
  No-confusion (c₁ A) (c₁ B) = A ≡ B
  No-confusion (c₂ A) (c₂ B) = A ≡ B
  No-confusion _      _      = ⊥

  no-confusion :
    ∀ {A B} (x : C A) (y : C B) → A ≡ B → x ≅ y → No-confusion x y
  no-confusion (c₁ A) .(c₁ A) refl refl = refl
  no-confusion (c₂ A) .(c₂ A) refl refl = refl

  D-elim-c₁-helper :
    (P : {A B : Set} {c : C A} →
         D c → A ≡ Box B → c ≅ c₁ B → Set₂) →
    ((A : Set) → P (d₁ A) refl refl) →
    {A B : Set} {c : C A}
    (x : D c) (eq₂ : c ≅ c₁ B) (eq₁ : A ≡ Box B) → P x eq₁ eq₂
  D-elim-c₁-helper P p (d₁ A) eq₂  eq₁  with no-confusion _ _ eq₁ eq₂
  D-elim-c₁-helper P p (d₁ B) refl refl | refl = p B
  D-elim-c₁-helper P p (d₂ A) eq₂  eq₁  with no-confusion _ _ eq₁ eq₂
  D-elim-c₁-helper P p (d₂ A) eq₂  eq₁  | ()

  cast : {A B : Set} {x : C A} {y : C B} →
         A ≡ B → x ≅ y → D x → D y
  cast refl refl x = x

  D-elim-c₁ :
    (P : {A : Set} → D (c₁ A) → Set₂) →
    ((A : Set) → P (d₁ A)) →
    {A : Set} (x : D (c₁ A)) → P x
  D-elim-c₁ P p x =
    D-elim-c₁-helper (λ x eq₁ eq₂ → P (cast eq₁ eq₂ x)) p x refl refl

-- should type-check


{-# OPTIONS --universe-polymorphism #-}
module Support.FinSet where

open import Support
open import Support.Nat

unbound : ∀ {n} (m : Fin n) → ℕ
unbound zero = zero
unbound {suc n} (suc y) = suc (unbound {n} y)

.Fin-is-bounded : ∀ (n : ℕ) (m : Fin n) → (unbound m < n)
Fin-is-bounded .(suc n) (zero {n}) = Z<Sn
Fin-is-bounded .(suc n) (suc {n} y) = raise< (Fin-is-bounded n y)

enlarge : ∀ {a} (b : Fin (suc a)) (c : Fin (unbound b)) → Fin a
enlarge {zero} zero ()
enlarge {zero} (suc ()) c
enlarge {suc a′} zero ()
enlarge {suc a′} (suc b′) zero = zero
enlarge {suc a′} (suc b′) (suc c′) = suc (enlarge b′ c′)

widen-by : ∀ {a} {b} (a≤b : a < suc b) (c : Fin a) → Fin b
widen-by Z<Sn ()
widen-by (raise< Z<Sn) zero = zero
widen-by (raise< (raise< n<m)) zero = zero
widen-by (raise< Z<Sn) (suc ())
widen-by (raise< (raise< n<m)) (suc y') = suc (widen-by (raise< n<m) y')

widen-+ : (b : ℕ) → ∀ {a} (c : Fin a) → Fin (a + b)
widen-+ b zero = zero
widen-+ b (suc y) = suc (widen-+ b y)

shift : (a : ℕ) → ∀ {b} (c : Fin b) → Fin (a + b)
shift zero c = c
shift (suc y) c = suc (shift y c)

_bounded-by_ : (m : ℕ) → ∀ {n} (m<n : m < n) → Fin n
.0 bounded-by Z<Sn = zero
.(suc n) bounded-by (raise< {n} n<m) = suc (n bounded-by n<m)

unbound-unbounds-bounded-by : ∀ (m n : ℕ) (m<n : m < n) → unbound (m bounded-by m<n) ≣ m
unbound-unbounds-bounded-by .0 .(suc n) (Z<Sn {n}) = ≣-refl
unbound-unbounds-bounded-by .(suc n) .(suc m) (raise< {n} {m} n<m) = ≣-cong suc (unbound-unbounds-bounded-by n m n<m)

_lessen_ : (n : ℕ) → (m : Fin (suc n)) → ℕ
n lessen zero = n
.0 lessen suc {zero} ()
.(suc y) lessen suc {suc y} y' = y lessen y'

lessen-is-subtraction₁ : ∀ (n : ℕ) (m : Fin (suc n)) → (unbound m + (n lessen m)) ≣ n
lessen-is-subtraction₁ n zero = ≣-refl
lessen-is-subtraction₁ .0 (suc {zero} ())
lessen-is-subtraction₁ .(suc y) (suc {suc y} y') = ≣-cong suc (lessen-is-subtraction₁ y y')

lessen-is-subtraction₂ : ∀ (n m : ℕ) → ((n + m) lessen (n bounded-by (+-is-nondecreasingʳ n m)) ≣ m)
lessen-is-subtraction₂ zero m = ≣-refl
lessen-is-subtraction₂ (suc y) m = lessen-is-subtraction₂ y m

_split_ : ∀ {n} (k : Fin n) (m : Fin (suc n)) → Either (Fin (unbound m)) (Fin (n lessen m))
k split zero = inr k
zero split suc y = inl zero
suc y split suc y' = left suc (y split y')

_chops_ : (n : ℕ) → ∀ {m} (k : Fin (n + m)) → Either (Fin n) (Fin m)
0 chops k = inr k
suc n chops zero = inl zero
suc n chops suc k = left suc (n chops k)

rejoin-chops : (n m : ℕ) (k : Fin (n + m)) → either₀ (widen-+ m) (shift n) (n chops k) ≣ k
rejoin-chops zero _ _ = ≣-refl
rejoin-chops (suc _) _ zero = ≣-refl
rejoin-chops (suc n') m (suc k') with n' chops k' | rejoin-chops n' m k'
rejoin-chops (suc _) _ (suc ._) | inl _ | ≣-refl = ≣-refl
rejoin-chops (suc _) _ (suc ._) | inr _ | ≣-refl = ≣-refl

chop-widen-+ : (n m : ℕ) (k : Fin n) → n chops widen-+ m k ≣ inl k
chop-widen-+ zero _ ()
chop-widen-+ (suc n') _ zero = ≣-refl
chop-widen-+ (suc n') m (suc k') with n' chops widen-+ m k' | chop-widen-+ n' m k'
chop-widen-+ (suc n') m (suc ._) | inl k' | ≣-refl = ≣-refl
chop-widen-+ (suc n') m (suc _) | inr _ | ()

chop-shift : (n m : ℕ) (k : Fin m) → n chops shift n k ≣ inr k
chop-shift zero m k = ≣-refl
chop-shift (suc n') m k = ≣-cong (left suc) (chop-shift n' m k)

_cat₀_ : ∀ {ℓ} {n m} {A : Set ℓ} (f : Fin n → A) (g : Fin m → A) → Fin (n + m) → A
_cat₀_ {n = n} {m} f g i = either₀ f g (n chops i)

∙-dist-cat₀ : ∀ {ℓ ℓ′} {n m} {A : Set ℓ} {A′ : Set ℓ′} (f : Fin n → A) (g : Fin m → A) (h : A → A′) {i : Fin (n + m)} → (h ∙ (f cat₀ g)) i ≣ ((h ∙ f) cat₀ (h ∙ g)) i
∙-dist-cat₀ {n = n} {A′ = A′} f g h {i} = answer
  where
  open ≣-reasoning A′
  split-i = n chops i
  answer = begin
      ((h ∙ (f cat₀ g)) i)
    ≈⟨ ≣-refl ⟩
      (h ((f cat₀ g) i))
    ≈⟨ ≣-cong h ≣-refl ⟩
      h (either₀ f g split-i)
    ≈⟨ ≣-refl ⟩
      (h ∙ either₀ f g) split-i
    ≈⟨ ∙-dist-either₀ f g h {split-i} ⟩
      either₀ (h ∙ f) (h ∙ g) split-i
    ≈⟨ ≣-refl ⟩
      ((h ∙ f) cat₀ (h ∙ g)) i
    ∎

_cat_ : ∀ {ℓ} {n m} {A : Fin n → Set ℓ} {B : Fin m → Set ℓ} (f : (i : Fin n) → A i) (g : (j : Fin m) → B j) → (k : Fin (n + m)) → (A cat₀ B) k
_cat_ {n = n} f g i = either f g (n chops i)

_cat′_ : ∀ {ℓ} {n m} {A : Fin (n + m) → Set ℓ} (f : (i : Fin n) → A (widen-+ m i)) (g : (j : Fin m) → A (shift n j)) → (k : Fin (n + m)) → A k
_cat′_ {n = n} {m = m} {A = T} f g k = ≣-subst T (rejoin-chops n m k) (either′ {A = T ∙ either₀ (widen-+ m) (shift n)} f g (n chops k))

_✂_ : ∀ {n} (m : Fin (suc n)) {ℓ} {A : Set ℓ} (f : Fin n → A) → (Fin (unbound m) → A) × (Fin (n lessen m) → A)
_✂_ {n = n} m f = f ∙ enlarge m , f ∙ (≣-subst Fin (lessen-is-subtraction₁ n m) ∙ shift (unbound m))

_✂₀′_ : (m : ℕ) → ∀ {ℓ} {A : Set ℓ} {n} (f : Fin (m + n) → A) → (Fin m → A) × (Fin n → A)
_✂₀′_ m {n = n} f = f ∙ widen-+ n , f ∙ shift m

_✂′_ : (m : ℕ) → ∀ {ℓ} {n} {A : Fin (m + n) → Set ℓ} (f : (k : Fin (m + n)) → A k) → uncurry₀ _×_ (⟨ (λ Aˡ → (i : Fin m) → Aˡ i) , (λ Aʳ → (j : Fin n) → Aʳ j) ⟩ (m ✂₀′ A))
_✂′_ m {n = n} f = f ∙ widen-+ n , f ∙ shift m


------------------------------------------------------------------------
-- The Agda standard library
--
-- Non-empty AVL trees, where equality for keys is propositional equality
------------------------------------------------------------------------

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

open import Relation.Binary using (Rel; IsStrictTotalOrder; StrictTotalOrder)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst)

module Data.AVL.NonEmpty.Propositional
  {k r} {Key : Set k} {_<_ : Rel Key r}
  (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_) where

open import Level

private strictTotalOrder = record { isStrictTotalOrder = isStrictTotalOrder}
open import Data.AVL.Value (StrictTotalOrder.Eq.setoid strictTotalOrder)
import Data.AVL.NonEmpty strictTotalOrder as AVL⁺

Tree⁺ : ∀ {v} (V : Key → Set v) → Set (k ⊔ v ⊔ r)
Tree⁺ V = AVL⁺.Tree⁺ λ where
  .Value.family          → V
  .Value.respects refl t → t

open AVL⁺ hiding (Tree⁺) public


{-# OPTIONS --safe #-}

module Cubical.Algebra.CommAlgebra.Instances.FreeCommAlgebra where
{-
  The free commutative algebra over a commutative ring,
  or in other words the ring of polynomials with coefficients in a given ring.
  Note that this is a constructive definition, which entails that polynomials
  cannot be represented by lists of coefficients, where the last one is non-zero.
  For rings with decidable equality, that is still possible.

  I learned about this (and other) definition(s) from David Jaz Myers.
  You can watch him talk about these things here:
  https://www.youtube.com/watch?v=VNp-f_9MnVk

  This file contains
  * the definition of the free commutative algebra on a type I over a commutative ring R as a HIT
    (let us call that R[I])
  * a prove that the construction is an commutative R-algebra
  * definitions of the induced maps appearing in the universal property of R[I],
    that is:  * for any map I → A, where A is a commutative R-algebra,
                the induced algebra homomorphism R[I] → A
                ('inducedHom')
              * for any hom R[I] → A, the 'restricttion to variables' I → A
                ('evaluateAt')
  * a proof that the two constructions are inverse to each other
    ('homRetrievable' and 'mapRetrievable')
  * a proof, that the corresponding pointwise equivalence of functors is natural
    ('naturalR', 'naturalL')
-}
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Function hiding (const)

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring        using ()
open import Cubical.Algebra.CommAlgebra
open import Cubical.Algebra.Algebra
open import Cubical.HITs.SetTruncation

private
  variable
    ℓ ℓ' ℓ'' : Level

module Construction (R : CommRing ℓ) where
  open CommRingStr (snd R) using (1r; 0r) renaming (_+_ to _+r_; _·_ to _·r_)

  data R[_] (I : Type ℓ') : Type (ℓ-max ℓ ℓ') where
    var : I → R[ I ]
    const : ⟨ R ⟩ → R[ I ]
    _+_ : R[ I ] → R[ I ] → R[ I ]
    -_ : R[ I ] → R[ I ]
    _·_ : R[ I ] → R[ I ] → R[ I ]            -- \cdot

    +-assoc : (x y z : R[ I ]) → x + (y + z) ≡ (x + y) + z
    +-rid : (x : R[ I ]) → x + (const 0r) ≡ x
    +-rinv : (x : R[ I ]) → x + (- x) ≡ (const 0r)
    +-comm : (x y : R[ I ]) → x + y ≡ y + x

    ·-assoc : (x y z : R[ I ]) → x · (y · z) ≡ (x · y) · z
    ·-lid : (x : R[ I ]) → (const 1r) · x ≡ x
    ·-comm : (x y : R[ I ]) → x · y ≡ y · x

    ldist : (x y z : R[ I ]) → (x + y) · z ≡ (x · z) + (y · z)

    +HomConst : (s t : ⟨ R ⟩) → const (s +r t) ≡ const s + const t
    ·HomConst : (s t : ⟨ R ⟩) → const (s ·r t) ≡ (const s) · (const t)

    0-trunc : (x y : R[ I ]) (p q : x ≡ y) → p ≡ q

  _⋆_ : {I : Type ℓ'} → ⟨ R ⟩ → R[ I ] → R[ I ]
  r ⋆ x = const r · x

  ⋆-assoc : {I : Type ℓ'} → (s t : ⟨ R ⟩) (x : R[ I ]) → (s ·r t) ⋆ x ≡ s ⋆ (t ⋆ x)
  ⋆-assoc s t x = const (s ·r t) · x       ≡⟨ cong (λ u → u · x) (·HomConst _ _) ⟩
                  (const s · const t) · x  ≡⟨ sym (·-assoc _ _ _) ⟩
                  const s · (const t · x)  ≡⟨ refl ⟩
                  s ⋆ (t ⋆ x) ∎

  ⋆-ldist-+ : {I : Type ℓ'} → (s t : ⟨ R ⟩) (x : R[ I ]) → (s +r t) ⋆ x ≡ (s ⋆ x) + (t ⋆ x)
  ⋆-ldist-+ s t x = (s +r t) ⋆ x             ≡⟨ cong (λ u → u · x) (+HomConst _ _) ⟩
                    (const s + const t) · x  ≡⟨ ldist _ _ _ ⟩
                    (s ⋆ x) + (t ⋆ x) ∎

  ⋆-rdist-+ : {I : Type ℓ'} → (s : ⟨ R ⟩) (x y : R[ I ]) → s ⋆ (x + y) ≡ (s ⋆ x) + (s ⋆ y)
  ⋆-rdist-+ s x y = const s · (x + y)             ≡⟨ ·-comm _ _ ⟩
                    (x + y) · const s             ≡⟨ ldist _ _ _ ⟩
                    (x · const s) + (y · const s) ≡⟨ cong (λ u → u + (y · const s)) (·-comm _ _) ⟩
                    (s ⋆ x) + (y · const s)       ≡⟨ cong (λ u → (s ⋆ x) + u) (·-comm _ _)  ⟩
                    (s ⋆ x) + (s ⋆ y) ∎

  ⋆-assoc-· : {I : Type ℓ'} → (s : ⟨ R ⟩) (x y : R[ I ]) → (s ⋆ x) · y ≡ s ⋆ (x · y)
  ⋆-assoc-· s x y = (s ⋆ x) · y ≡⟨ sym (·-assoc _ _ _) ⟩
                    s ⋆ (x · y) ∎

  0a : {I : Type ℓ'} → R[ I ]
  0a = (const 0r)

  1a : {I : Type ℓ'} → R[ I ]
  1a = (const 1r)

  isCommAlgebra : {I : Type ℓ'} → IsCommAlgebra R {A = R[ I ]} 0a 1a _+_ _·_ -_ _⋆_
  isCommAlgebra = makeIsCommAlgebra 0-trunc
                                    +-assoc +-rid +-rinv +-comm
                                    ·-assoc ·-lid ldist ·-comm
                                    ⋆-assoc ⋆-ldist-+ ⋆-rdist-+ ·-lid ⋆-assoc-·

_[_] : (R : CommRing ℓ) (I : Type ℓ') → CommAlgebra R (ℓ-max ℓ ℓ')
(R [ I ]) = R[ I ] , commalgebrastr 0a 1a _+_ _·_ -_ _⋆_ isCommAlgebra
  where
  open Construction R

module Theory {R : CommRing ℓ} {I : Type ℓ'} where
  open CommRingStr (snd R)
         using (0r; 1r)
         renaming (_·_ to _·r_; _+_ to _+r_; ·Comm to ·r-comm; ·Rid to ·r-rid)

  module _ (A : CommAlgebra R ℓ'') (φ : I → ⟨ A ⟩) where
    open CommAlgebraStr (A .snd)
    open AlgebraTheory (CommRing→Ring R) (CommAlgebra→Algebra A)
    open Construction using (var; const) renaming (_+_ to _+c_; -_ to -c_; _·_ to _·c_)

    imageOf0Works : 0r ⋆ 1a ≡ 0a
    imageOf0Works = 0-actsNullifying 1a

    imageOf1Works : 1r ⋆ 1a ≡ 1a
    imageOf1Works = ⋆-lid 1a

    inducedMap : ⟨ R [ I ] ⟩ → ⟨ A ⟩
    inducedMap (var x) = φ x
    inducedMap (const r) = r ⋆ 1a
    inducedMap (P +c Q) = (inducedMap P) + (inducedMap Q)
    inducedMap (-c P) = - inducedMap P
    inducedMap (Construction.+-assoc P Q S i) = +-assoc (inducedMap P) (inducedMap Q) (inducedMap S) i
    inducedMap (Construction.+-rid P i) =
      let
        eq : (inducedMap P) + (inducedMap (const 0r)) ≡ (inducedMap P)
        eq = (inducedMap P) + (inducedMap (const 0r)) ≡⟨ refl ⟩
             (inducedMap P) + (0r ⋆ 1a)               ≡⟨ cong
                                                         (λ u → (inducedMap P) + u)
                                                         (imageOf0Works) ⟩
             (inducedMap P) + 0a                      ≡⟨ +-rid _ ⟩
             (inducedMap P) ∎
      in eq i
    inducedMap (Construction.+-rinv P i) =
      let eq : (inducedMap P - inducedMap P) ≡ (inducedMap (const 0r))
          eq = (inducedMap P - inducedMap P) ≡⟨ +-rinv _ ⟩
               0a                            ≡⟨ sym imageOf0Works ⟩
               (inducedMap (const 0r))∎
      in eq i
    inducedMap (Construction.+-comm P Q i) = +-comm (inducedMap P) (inducedMap Q) i
    inducedMap (P ·c Q) = inducedMap P · inducedMap Q
    inducedMap (Construction.·-assoc P Q S i) = ·Assoc (inducedMap P) (inducedMap Q) (inducedMap S) i
    inducedMap (Construction.·-lid P i) =
      let eq = inducedMap (const 1r) · inducedMap P ≡⟨ cong (λ u → u · inducedMap P) imageOf1Works ⟩
               1a · inducedMap P                    ≡⟨ ·Lid (inducedMap P) ⟩
               inducedMap P ∎
      in eq i
    inducedMap (Construction.·-comm P Q i) = ·-comm (inducedMap P) (inducedMap Q) i
    inducedMap (Construction.ldist P Q S i) = ·Ldist+ (inducedMap P) (inducedMap Q) (inducedMap S) i
    inducedMap (Construction.+HomConst s t i) = ⋆-ldist s t 1a i
    inducedMap (Construction.·HomConst s t i) =
      let eq = (s ·r t) ⋆ 1a       ≡⟨ cong (λ u → u ⋆ 1a) (·r-comm _ _) ⟩
               (t ·r s) ⋆ 1a       ≡⟨ ⋆-assoc t s 1a ⟩
               t ⋆ (s ⋆ 1a)        ≡⟨ cong (λ u → t ⋆ u) (sym (·Rid _)) ⟩
               t ⋆ ((s ⋆ 1a) · 1a) ≡⟨ ⋆-rassoc t (s ⋆ 1a) 1a ⟩
               (s ⋆ 1a) · (t ⋆ 1a) ∎
      in eq i
    inducedMap (Construction.0-trunc P Q p q i j) =
      isSetAlgebra (CommAlgebra→Algebra A) (inducedMap P) (inducedMap Q) (cong _ p) (cong _ q) i j

    module _ where
      open IsAlgebraHom

      inducedHom : AlgebraHom (CommAlgebra→Algebra (R [ I ])) (CommAlgebra→Algebra A)
      inducedHom .fst = inducedMap
      inducedHom .snd .pres0 = 0-actsNullifying _
      inducedHom .snd .pres1 = imageOf1Works
      inducedHom .snd .pres+ x y = refl
      inducedHom .snd .pres· x y = refl
      inducedHom .snd .pres- x = refl
      inducedHom .snd .pres⋆ r x =
        (r ⋆ 1a) · inducedMap x ≡⟨ ⋆-lassoc r 1a (inducedMap x) ⟩
        r ⋆ (1a · inducedMap x) ≡⟨ cong (λ u → r ⋆ u) (·Lid (inducedMap x)) ⟩
        r ⋆ inducedMap x ∎

  module _ (A : CommAlgebra R ℓ'') where
    open CommAlgebraStr (A .snd)
    open AlgebraTheory (CommRing→Ring R) (CommAlgebra→Algebra A)
    open Construction using (var; const) renaming (_+_ to _+c_; -_ to -c_; _·_ to _·c_)

    Hom = AlgebraHom (CommAlgebra→Algebra (R [ I ])) (CommAlgebra→Algebra A)
    open IsAlgebraHom

    evaluateAt : Hom → I → ⟨ A ⟩
    evaluateAt φ x = φ .fst (var x)

    mapRetrievable : ∀ (φ : I → ⟨ A ⟩)
                     → evaluateAt (inducedHom A φ) ≡ φ
    mapRetrievable φ = refl

    proveEq : ∀ {X : Type ℓ''} (isSetX : isSet X) (f g : ⟨ R [ I ] ⟩ → X)
              → (var-eq : (x : I) → f (var x) ≡ g (var x))
              → (const-eq : (r : ⟨ R ⟩) → f (const r) ≡ g (const r))
              → (+-eq : (x y : ⟨ R [ I ] ⟩) → (eq-x : f x ≡ g x) → (eq-y : f y ≡ g y)
                        → f (x +c y) ≡ g (x +c y))
              → (·-eq : (x y : ⟨ R [ I ] ⟩) → (eq-x : f x ≡ g x) → (eq-y : f y ≡ g y)
                        → f (x ·c y) ≡ g (x ·c y))
              → (-eq : (x : ⟨ R [ I ] ⟩) → (eq-x : f x ≡ g x)
                        → f (-c x) ≡ g (-c x))
              → f ≡ g
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (var x) = var-eq x i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (const x) = const-eq x i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (x +c y) =
      +-eq x y
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i y)
           i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (-c x) =
      -eq x ((λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)) i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (x ·c y) =
      ·-eq x y
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i y)
           i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-assoc x y z j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c (y +c z)) ≡ g (x +c (y +c z))
        a₀₋ = +-eq _ _ (rec x) (+-eq _ _ (rec y) (rec z))
        a₁₋ : f ((x +c y) +c z) ≡ g ((x +c y) +c z)
        a₁₋ = +-eq _ _ (+-eq _ _ (rec x) (rec y)) (rec z)
        a₋₀ : f (x +c (y +c z)) ≡ f ((x +c y) +c z)
        a₋₀ = cong f (Construction.+-assoc x y z)
        a₋₁ : g (x +c (y +c z)) ≡ g ((x +c y) +c z)
        a₋₁ = cong g (Construction.+-assoc x y z)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-rid x j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c (const 0r)) ≡ g (x +c (const 0r))
        a₀₋ = +-eq _ _ (rec x) (const-eq 0r)
        a₁₋ : f x ≡ g x
        a₁₋ = rec x
        a₋₀ : f (x +c (const 0r)) ≡ f x
        a₋₀ = cong f (Construction.+-rid x)
        a₋₁ : g (x +c (const 0r)) ≡ g x
        a₋₁ = cong g (Construction.+-rid x)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-rinv x j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c (-c x)) ≡ g (x +c (-c x))
        a₀₋ = +-eq x (-c x) (rec x) (-eq x (rec x))
        a₁₋ : f (const 0r) ≡ g (const 0r)
        a₁₋ = const-eq 0r
        a₋₀ : f (x +c (-c x)) ≡ f (const 0r)
        a₋₀ = cong f (Construction.+-rinv x)
        a₋₁ : g (x +c (-c x)) ≡ g (const 0r)
        a₋₁ = cong g (Construction.+-rinv x)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-comm x y j) =
      let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c y) ≡ g (x +c y)
        a₀₋ = +-eq x y (rec x) (rec y)
        a₁₋ : f (y +c x) ≡ g (y +c x)
        a₁₋ = +-eq y x (rec y) (rec x)
        a₋₀ : f (x +c y) ≡ f (y +c x)
        a₋₀ = cong f (Construction.+-comm x y)
        a₋₁ : g (x +c y) ≡ g (y +c x)
        a₋₁ = cong g (Construction.+-comm x y)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·-assoc x y z j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x ·c (y ·c z)) ≡ g (x ·c (y ·c z))
        a₀₋ = ·-eq _ _ (rec x) (·-eq _ _ (rec y) (rec z))
        a₁₋ : f ((x ·c y) ·c z) ≡ g ((x ·c y) ·c z)
        a₁₋ = ·-eq _ _ (·-eq _ _ (rec x) (rec y)) (rec z)
        a₋₀ : f (x ·c (y ·c z)) ≡ f ((x ·c y) ·c z)
        a₋₀ = cong f (Construction.·-assoc x y z)
        a₋₁ : g (x ·c (y ·c z)) ≡ g ((x ·c y) ·c z)
        a₋₁ = cong g (Construction.·-assoc x y z)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·-lid x j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f ((const 1r) ·c x) ≡ g ((const 1r) ·c x)
        a₀₋ = ·-eq _ _ (const-eq 1r) (rec x)
        a₁₋ : f x ≡ g x
        a₁₋ = rec x
        a₋₀ : f ((const 1r) ·c x) ≡ f x
        a₋₀ = cong f (Construction.·-lid x)
        a₋₁ : g ((const 1r) ·c x) ≡ g x
        a₋₁ = cong g (Construction.·-lid x)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·-comm x y j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x ·c y) ≡ g (x ·c y)
        a₀₋ = ·-eq _ _ (rec x) (rec y)
        a₁₋ : f (y ·c x) ≡ g (y ·c x)
        a₁₋ = ·-eq _ _ (rec y) (rec x)
        a₋₀ : f (x ·c y) ≡ f (y ·c x)
        a₋₀ = cong f (Construction.·-comm x y)
        a₋₁ : g (x ·c y) ≡ g (y ·c x)
        a₋₁ = cong g (Construction.·-comm x y)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.ldist x y z j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f ((x +c y) ·c z) ≡ g ((x +c y) ·c z)
        a₀₋ = ·-eq (x +c y) z
           (+-eq _ _ (rec x) (rec y))
           (rec z)
        a₁₋ : f ((x ·c z) +c (y ·c z)) ≡ g ((x ·c z) +c (y ·c z))
        a₁₋ = +-eq _ _ (·-eq _ _ (rec x) (rec z)) (·-eq _ _ (rec y) (rec z))
        a₋₀ : f ((x +c y) ·c z) ≡ f ((x ·c z) +c (y ·c z))
        a₋₀ = cong f (Construction.ldist x y z)
        a₋₁ : g ((x +c y) ·c z) ≡ g ((x ·c z) +c (y ·c z))
        a₋₁ = cong g (Construction.ldist x y z)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+HomConst s t j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (const (s +r t)) ≡ g (const (s +r t))
        a₀₋ = const-eq (s +r t)
        a₁₋ : f (const s +c const t) ≡ g (const s +c const t)
        a₁₋ = +-eq _ _ (const-eq s) (const-eq t)
        a₋₀ : f (const (s +r t)) ≡ f (const s +c const t)
        a₋₀ = cong f (Construction.+HomConst s t)
        a₋₁ : g (const (s +r t)) ≡ g (const s +c const t)
        a₋₁ = cong g (Construction.+HomConst s t)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·HomConst s t j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (const (s ·r t)) ≡ g (const (s ·r t))
        a₀₋ = const-eq (s ·r t)
        a₁₋ : f (const s ·c const t) ≡ g (const s ·c const t)
        a₁₋ = ·-eq _ _ (const-eq s) (const-eq t)
        a₋₀ : f (const (s ·r t)) ≡ f (const s ·c const t)
        a₋₀ = cong f (Construction.·HomConst s t)
        a₋₁ : g (const (s ·r t)) ≡ g (const s ·c const t)
        a₋₁ = cong g (Construction.·HomConst s t)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.0-trunc x y p q j k) =
      let
        P : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        P x i = proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x
        Q : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        Q x i = proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x
      in isOfHLevel→isOfHLevelDep 2
           (λ z → isProp→isSet (isSetX (f z) (g z))) _ _
           (cong P p)
           (cong Q q)
           (Construction.0-trunc x y p q) j k i

    homRetrievable : ∀ (f : Hom)
                     → inducedMap A (evaluateAt f) ≡ fst f
    homRetrievable f =
       proveEq
        (isSetAlgebra (CommAlgebra→Algebra A))
        (inducedMap A (evaluateAt f))
        (λ x → f $a x)
        (λ x → refl)
        (λ r → r ⋆ 1a                     ≡⟨ cong (λ u → r ⋆ u) (sym f.pres1) ⟩
               r ⋆ (f $a (const 1r))      ≡⟨ sym (f.pres⋆ r _) ⟩
               f $a (const r ·c const 1r) ≡⟨ cong (λ u → f $a u) (sym (Construction.·HomConst r 1r)) ⟩
               f $a (const (r ·r 1r))     ≡⟨ cong (λ u → f $a (const u)) (·r-rid r) ⟩
               f $a (const r) ∎)

        (λ x y eq-x eq-y →
              ι (x +c y)            ≡⟨ refl ⟩
              (ι x + ι y)           ≡⟨ cong (λ u → u + ι y) eq-x ⟩
              ((f $a x) + ι y)      ≡⟨
                                     cong (λ u → (f $a x) + u) eq-y ⟩
              ((f $a x) + (f $a y)) ≡⟨ sym (f.pres+ _ _) ⟩ (f $a (x +c y)) ∎)

        (λ x y eq-x eq-y →
           ι (x ·c y)          ≡⟨ refl ⟩
           ι x     · ι y       ≡⟨ cong (λ u → u · ι y) eq-x ⟩
           (f $a x) · (ι y)    ≡⟨ cong (λ u → (f $a x) · u) eq-y ⟩
           (f $a x) · (f $a y) ≡⟨ sym (f.pres· _ _) ⟩
           f $a (x ·c y) ∎)
       (λ x eq-x →
           ι (-c x)    ≡⟨ refl ⟩
           - ι x       ≡⟨ cong (λ u → - u) eq-x ⟩
           - (f $a x)  ≡⟨ sym (f.pres- x) ⟩
           f $a (-c x) ∎)
      where
      ι = inducedMap A (evaluateAt f)
      module f = IsAlgebraHom (f .snd)

evaluateAt : {R : CommRing ℓ} {I : Type ℓ'} (A : CommAlgebra R ℓ'')
             (f : AlgebraHom (CommAlgebra→Algebra (R [ I ])) (CommAlgebra→Algebra A))
             → (I → ⟨ A ⟩)
evaluateAt A f x = f $a (Construction.var x)

inducedHom : {R : CommRing ℓ} {I : Type ℓ'} (A : CommAlgebra R ℓ'')
             (φ : I → ⟨ A ⟩)
             → AlgebraHom (CommAlgebra→Algebra (R [ I ])) (CommAlgebra→Algebra A)
inducedHom A φ = Theory.inducedHom A φ

module _ {R : CommRing ℓ} {A B : CommAlgebra R ℓ''} where
  A′ = CommAlgebra→Algebra A
  B′ = CommAlgebra→Algebra B
  R′ = (CommRing→Ring R)
  ν : AlgebraHom A′ B′ → (⟨ A ⟩ → ⟨ B ⟩)
  ν φ = φ .fst

  {-
    Hom(R[I],A) → (I → A)
         ↓          ↓
    Hom(R[I],B) → (I → B)
  -}
  naturalR : {I : Type ℓ'} (ψ : AlgebraHom A′ B′)
             (f : AlgebraHom (CommAlgebra→Algebra (R [ I ])) A′)
             → (ν ψ) ∘ evaluateAt A f ≡ evaluateAt B (ψ ∘a f)
  naturalR ψ f = refl

  {-
    Hom(R[I],A) → (I → A)
         ↓          ↓
    Hom(R[J],A) → (J → A)
  -}
  naturalL : {I J : Type ℓ'} (φ : J → I)
             (f : AlgebraHom (CommAlgebra→Algebra (R [ I ])) A′)
             → (evaluateAt A f) ∘ φ
               ≡ evaluateAt A (f ∘a (inducedHom (R [ I ]) (λ x → Construction.var (φ x))))
  naturalL φ f = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties of reflexive closures
------------------------------------------------------------------------

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

module Relation.Binary.Construct.Closure.Reflexive.Properties where

open import Data.Product as Prod
open import Data.Sum.Base as Sum
open import Function.Equivalence using (_⇔_; equivalence)
open import Function using (id)
open import Level
open import Relation.Binary
open import Relation.Binary.Construct.Closure.Reflexive
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; refl)
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Nullary.Sum using (_⊎-dec_)
open import Relation.Unary using (Pred)

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

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

module _ {P : Rel A p} {Q : Rel B q} where

  =[]⇒ : ∀ {f : A → B} → P =[ f ]⇒ Q → Refl P =[ f ]⇒ Refl Q
  =[]⇒ x [ x∼y ] = [ x x∼y ]
  =[]⇒ x refl    = refl

module _ {_~_ : Rel A ℓ} where

  sym : Symmetric _~_ → Symmetric (Refl _~_)
  sym ~-sym [ x∼y ] = [ ~-sym x∼y ]
  sym ~-sym refl    = refl

  trans : Transitive _~_ → Transitive (Refl _~_)
  trans ~-trans [ x∼y ] [ x∼y₁ ] = [ ~-trans x∼y x∼y₁ ]
  trans ~-trans [ x∼y ] refl     = [ x∼y ]
  trans ~-trans refl    [ x∼y ]  = [ x∼y ]
  trans ~-trans refl    refl     = refl

  antisym : ∀ {ℓ'} (_≈_ : Rel A ℓ') → Reflexive _≈_ →
            Asymmetric _~_ → Antisymmetric _≈_ (Refl _~_)
  antisym _≈_ ref asym [ x∼y ] [ y∼x ] = contradiction x∼y (asym y∼x)
  antisym _≈_ ref asym [ x∼y ] refl    = ref
  antisym _≈_ ref asym refl    _       = ref

  total : Trichotomous _≡_ _~_ → Total (Refl _~_)
  total compare x y with compare x y
  ... | tri< a _    _ = inj₁ [ a ]
  ... | tri≈ _ refl _ = inj₁ refl
  ... | tri> _ _    c = inj₂ [ c ]

  fromSum : ∀ {a b} → a ≡ b ⊎ a ~ b → Refl _~_ a b
  fromSum (inj₁ refl) = refl
  fromSum (inj₂ y) = [ y ]

  toSum : ∀ {a b} → Refl _~_ a b → a ≡ b ⊎ a ~ b
  toSum [ x∼y ] = inj₂ x∼y
  toSum refl = inj₁ refl

  ⊎⇔Refl : ∀ {a b} → (a ≡ b ⊎ a ~ b) ⇔ Refl _~_ a b
  ⊎⇔Refl = equivalence fromSum toSum

  dec : Decidable {A = A} _≡_ → Decidable _~_ → Decidable (Refl _~_)
  dec ≡-dec ~-dec a b = Dec.map ⊎⇔Refl (≡-dec a b ⊎-dec ~-dec a b)

  decidable : Trichotomous _≡_ _~_ → Decidable (Refl _~_)
  decidable ~-tri a b with ~-tri a b
  ... | tri< a~b  _  _ = yes [ a~b ]
  ... | tri≈ _  refl _ = yes refl
  ... | tri> ¬a ¬b   _ = no λ { refl → ¬b refl ; [ p ] → ¬a p }

  respˡ : ∀ {P : REL A B p} → P Respectsˡ _~_ → P Respectsˡ (Refl _~_)
  respˡ p-respˡ-~ [ x∼y ] = p-respˡ-~ x∼y
  respˡ _         refl    = id

  respʳ : ∀ {P : REL B A p} → P Respectsʳ _~_ → P Respectsʳ (Refl _~_)
  respʳ = respˡ

module _ {_~_ : Rel A ℓ} {P : Pred A p} where

  resp : P Respects _~_ → P Respects (Refl _~_)
  resp p-resp-~ [ x∼y ] = p-resp-~ x∼y
  resp _        refl    = id

module _ {_~_ : Rel A ℓ} {P : Rel A p} where

  resp₂ : P Respects₂ _~_ → P Respects₂ (Refl _~_)
  resp₂ = Prod.map respˡ respʳ

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

module _ {_~_ : Rel A ℓ} where

  isPreorder : Transitive _~_ → IsPreorder _≡_ (Refl _~_)
  isPreorder ~-trans = record
    { isEquivalence = PropEq.isEquivalence
    ; reflexive     = λ { refl → refl }
    ; trans         = trans ~-trans
    }

  isPartialOrder : IsStrictPartialOrder _≡_ _~_ → IsPartialOrder _≡_ (Refl _~_)
  isPartialOrder O = record
    { isPreorder = isPreorder O.trans
    ; antisym    = antisym _≡_ refl O.asym
    } where module O = IsStrictPartialOrder O

  isDecPartialOrder : IsDecStrictPartialOrder _≡_ _~_ → IsDecPartialOrder _≡_ (Refl _~_)
  isDecPartialOrder O = record
    { isPartialOrder = isPartialOrder O.isStrictPartialOrder
    ; _≟_            = O._≟_
    ; _≤?_           = dec O._≟_ O._<?_
    } where module O = IsDecStrictPartialOrder O

  isTotalOrder : IsStrictTotalOrder _≡_ _~_ → IsTotalOrder _≡_ (Refl _~_)
  isTotalOrder O = record
    { isPartialOrder = isPartialOrder isStrictPartialOrder
    ; total          = total compare
    } where open IsStrictTotalOrder O

  isDecTotalOrder : IsStrictTotalOrder _≡_ _~_ → IsDecTotalOrder _≡_ (Refl _~_)
  isDecTotalOrder O = record
    { isTotalOrder = isTotalOrder O
    ; _≟_          = _≟_
    ; _≤?_         = dec _≟_ _<?_
    } where open IsStrictTotalOrder O


------------------------------------------------------------------------
-- Many properties which hold for _∼_ also hold for flip₁ _∼_
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.Flip where

open import Data.Function
open import Data.Product

implies : ∀ {A} (≈ ∼ : Rel A) → ≈ ⇒ ∼ → flip₁ ≈ ⇒ flip₁ ∼
implies _ _ impl = impl

reflexive : ∀ {A} (∼ : Rel A) → Reflexive ∼ → Reflexive (flip₁ ∼)
reflexive _ refl = refl

irreflexive : ∀ {A} (≈ ∼ : Rel A) →
              Irreflexive ≈ ∼ → Irreflexive (flip₁ ≈) (flip₁ ∼)
irreflexive _ _ irrefl = irrefl

symmetric : ∀ {A} (∼ : Rel A) → Symmetric ∼ → Symmetric (flip₁ ∼)
symmetric _ sym = sym

transitive : ∀ {A} (∼ : Rel A) → Transitive ∼ → Transitive (flip₁ ∼)
transitive _ trans = flip trans

antisymmetric : ∀ {A} (≈ ≤ : Rel A) →
                Antisymmetric ≈ ≤ → Antisymmetric (flip₁ ≈) (flip₁ ≤)
antisymmetric _ _ antisym = antisym

asymmetric : ∀ {A} (< : Rel A) → Asymmetric < → Asymmetric (flip₁ <)
asymmetric _ asym = asym

respects : ∀ {A} (∼ : Rel A) P →
           Symmetric ∼ → P Respects ∼ → P Respects flip₁ ∼
respects _ _ sym resp ∼ = resp (sym ∼)

respects₂ : ∀ {A} (∼₁ ∼₂ : Rel A) →
            Symmetric ∼₂ → ∼₁ Respects₂ ∼₂ → flip₁ ∼₁ Respects₂ flip₁ ∼₂
respects₂ _ _ sym (resp₁ , resp₂) =
  ((λ {_} {_} {_} ∼ → resp₂ (sym ∼)) , λ {_} {_} {_} ∼ → resp₁ (sym ∼))

decidable : ∀ {A} (∼ : Rel A) → Decidable ∼ → Decidable (flip₁ ∼)
decidable _ dec x y = dec y x

total : ∀ {A} (∼ : Rel A) → Total ∼ → Total (flip₁ ∼)
total _ tot x y = tot y x

trichotomous : ∀ {A} (≈ < : Rel A) →
               Trichotomous ≈ < → Trichotomous (flip₁ ≈) (flip₁ <)
trichotomous _ _ compare x y = compare y x

isEquivalence : ∀ {A} {≈ : Rel A} →
                IsEquivalence ≈ → IsEquivalence (flip₁ ≈)
isEquivalence {≈ = ≈} eq = record
  { refl  = reflexive  ≈ Eq.refl
  ; sym   = symmetric  ≈ Eq.sym
  ; trans = transitive ≈ Eq.trans
  }
  where module Eq = IsEquivalence eq

setoid : Setoid → Setoid
setoid S = record
  { _≈_           = flip₁ S._≈_
  ; isEquivalence = isEquivalence S.isEquivalence
  } where module S = Setoid S

isPreorder : ∀ {A} {≈ ∼ : Rel A} →
             IsPreorder ≈ ∼ → IsPreorder (flip₁ ≈) (flip₁ ∼)
isPreorder {≈ = ≈} {∼} pre = record
  { isEquivalence = isEquivalence Pre.isEquivalence
  ; reflexive     = implies ≈ ∼ Pre.reflexive
  ; trans         = transitive ∼ Pre.trans
  ; ∼-resp-≈      = respects₂ ∼ ≈ Pre.Eq.sym Pre.∼-resp-≈
  }
  where module Pre = IsPreorder pre

preorder : Preorder → Preorder
preorder P = record
  { _∼_        = flip₁ P._∼_
  ; _≈_        = flip₁ P._≈_
  ; isPreorder = isPreorder P.isPreorder
  } where module P = Preorder P

isDecEquivalence : ∀ {A} {≈ : Rel A} →
                   IsDecEquivalence ≈ → IsDecEquivalence (flip₁ ≈)
isDecEquivalence {≈ = ≈} dec = record
  { isEquivalence = isEquivalence Dec.isEquivalence
  ; _≟_           = decidable ≈ Dec._≟_
  }
  where module Dec = IsDecEquivalence dec

decSetoid : DecSetoid → DecSetoid
decSetoid S = record
  { _≈_              = flip₁ S._≈_
  ; isDecEquivalence = isDecEquivalence S.isDecEquivalence
  } where module S = DecSetoid S

isPartialOrder : ∀ {A} {≈ ≤ : Rel A} →
                 IsPartialOrder ≈ ≤ →
                 IsPartialOrder (flip₁ ≈) (flip₁ ≤)
isPartialOrder {≈ = ≈} {≤} po = record
  { isPreorder = isPreorder Po.isPreorder
  ; antisym    = antisymmetric ≈ ≤ Po.antisym
  }
  where module Po = IsPartialOrder po

poset : Poset → Poset
poset O = record
  { _≈_            = flip₁ O._≈_
  ; _≤_            = flip₁ O._≤_
  ; isPartialOrder = isPartialOrder O.isPartialOrder
  } where module O = Poset O

isStrictPartialOrder : ∀ {A} {≈ < : Rel A} →
                       IsStrictPartialOrder ≈ < →
                       IsStrictPartialOrder (flip₁ ≈) (flip₁ <)
isStrictPartialOrder {≈ = ≈} {<} spo = record
  { isEquivalence = isEquivalence Spo.isEquivalence
  ; irrefl        = irreflexive ≈ < Spo.irrefl
  ; trans         = transitive < Spo.trans
  ; <-resp-≈      = respects₂ < ≈ Spo.Eq.sym Spo.<-resp-≈
  }
  where module Spo = IsStrictPartialOrder spo

strictPartialOrder : StrictPartialOrder → StrictPartialOrder
strictPartialOrder O = record
  { _≈_                  = flip₁ O._≈_
  ; _<_                  = flip₁ O._<_
  ; isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder
  } where module O = StrictPartialOrder O

isTotalOrder : ∀ {A} {≈ ≤ : Rel A} →
               IsTotalOrder ≈ ≤ →
               IsTotalOrder (flip₁ ≈) (flip₁ ≤)
isTotalOrder {≈ = ≈} {≤} to = record
  { isPartialOrder = isPartialOrder To.isPartialOrder
  ; total          = total ≤ To.total
  }
  where module To = IsTotalOrder to

totalOrder : TotalOrder → TotalOrder
totalOrder O = record
  { _≈_          = flip₁ O._≈_
  ; _≤_          = flip₁ O._≤_
  ; isTotalOrder = isTotalOrder O.isTotalOrder
  } where module O = TotalOrder O

isDecTotalOrder : ∀ {A} {≈ ≤ : Rel A} →
                  IsDecTotalOrder ≈ ≤ →
                  IsDecTotalOrder (flip₁ ≈) (flip₁ ≤)
isDecTotalOrder {≈ = ≈} {≤} dec = record
  { isTotalOrder = isTotalOrder Dec.isTotalOrder
  ; _≟_          = decidable ≈ Dec._≟_
  ; _≤?_         = decidable ≤ Dec._≤?_
  }
  where module Dec = IsDecTotalOrder dec

decTotalOrder : DecTotalOrder → DecTotalOrder
decTotalOrder O = record
  { _≈_             = flip₁ O._≈_
  ; _≤_             = flip₁ O._≤_
  ; isDecTotalOrder = isDecTotalOrder O.isDecTotalOrder
  } where module O = DecTotalOrder O

isStrictTotalOrder : ∀ {A} {≈ < : Rel A} →
                     IsStrictTotalOrder ≈ < →
                       IsStrictTotalOrder (flip₁ ≈) (flip₁ <)
isStrictTotalOrder {≈ = ≈} {<} sto = record
  { isEquivalence = isEquivalence Sto.isEquivalence
  ; trans         = transitive < Sto.trans
  ; compare       = trichotomous ≈ < Sto.compare
  ; <-resp-≈      = respects₂ < ≈ Sto.Eq.sym Sto.<-resp-≈
  }
  where module Sto = IsStrictTotalOrder sto

strictTotalOrder : StrictTotalOrder → StrictTotalOrder
strictTotalOrder O = record
  { _≈_                = flip₁ O._≈_
  ; _<_                = flip₁ O._<_
  ; isStrictTotalOrder = isStrictTotalOrder O.isStrictTotalOrder
  } where module O = StrictTotalOrder O