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

module Universes where

open import Agda.Primitive public
 renaming (
            Level to Universe -- We speak of universes rather than of levels.
          ; lzero to 𝓤₀       -- Our first universe is called 𝓤₀
          ; lsuc to _⁺        -- The universe after 𝓤 is 𝓤 ⁺
          ; Setω to 𝓤ω        -- There is a universe 𝓤ω strictly above 𝓤₀, 𝓤₁, ⋯ , 𝓤ₙ, ⋯
          )
 using    (_⊔_)               -- Least upper bound of two universes, e.g. 𝓤₀ ⊔ 𝓤₁ is 𝓤₁

Type = λ ℓ → Set ℓ

_̇   : (𝓤 : Universe) → Type (𝓤 ⁺)

𝓤 ̇  = Type 𝓤

𝓤₁ = 𝓤₀ ⁺
𝓤₂ = 𝓤₁ ⁺
𝓤₃ = 𝓤₂ ⁺

_⁺⁺ : Universe → Universe
𝓤 ⁺⁺ = 𝓤 ⁺ ⁺

universe-of : {𝓤 : Universe} (X : 𝓤 ̇ ) → Universe
universe-of {𝓤} X = 𝓤

infix  1 _̇


------------------------------------------------------------------------
-- The Agda standard library
--
-- Signs
------------------------------------------------------------------------

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

module Data.Sign where

open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary using (yes; no)

-- Signs.

data Sign : Set where
  - : Sign
  + : Sign

-- Decidable equality.

infix 4 _≟_

_≟_ : Decidable {A = Sign} _≡_
- ≟ - = yes refl
- ≟ + = no λ()
+ ≟ - = no λ()
+ ≟ + = yes refl

-- The opposite sign.

opposite : Sign → Sign
opposite - = +
opposite + = -

-- "Multiplication".

infixl 7 _*_

_*_ : Sign → Sign → Sign
+ * s₂ = s₂
- * s₂ = opposite s₂


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

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

module Relation.Nullary.Negation where

open import Category.Monad
open import Data.Bool.Base using (Bool; false; true; if_then_else_)
open import Data.Empty
open import Data.Product as Prod
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂; [_,_])
open import Function
open import Level
open import Relation.Nullary
open import Relation.Unary

contradiction : ∀ {p w} {P : Set p} {Whatever : Set w} →
                P → ¬ P → Whatever
contradiction p ¬p = ⊥-elim (¬p p)

contraposition : ∀ {p q} {P : Set p} {Q : Set q} →
                 (P → Q) → ¬ Q → ¬ P
contraposition f ¬q p = contradiction (f p) ¬q

-- Note also the following use of flip:

private
  note : ∀ {p q} {P : Set p} {Q : Set q} →
         (P → ¬ Q) → Q → ¬ P
  note = flip

-- If we can decide P, then we can decide its negation.

¬? : ∀ {p} {P : Set p} → Dec P → Dec (¬ P)
¬? (yes p) = no (λ ¬p → ¬p p)
¬? (no ¬p) = yes ¬p

------------------------------------------------------------------------
-- Quantifier juggling

∃⟶¬∀¬ : ∀ {a p} {A : Set a} {P : A → Set p} →
        ∃ P → ¬ (∀ x → ¬ P x)
∃⟶¬∀¬ = flip uncurry

∀⟶¬∃¬ : ∀ {a p} {A : Set a} {P : A → Set p} →
        (∀ x → P x) → ¬ ∃ λ x → ¬ P x
∀⟶¬∃¬ ∀xPx (x , ¬Px) = ¬Px (∀xPx x)

¬∃⟶∀¬ : ∀ {a p} {A : Set a} {P : A → Set p} →
        ¬ ∃ (λ x → P x) → ∀ x → ¬ P x
¬∃⟶∀¬ = curry

∀¬⟶¬∃ : ∀ {a p} {A : Set a} {P : A → Set p} →
        (∀ x → ¬ P x) → ¬ ∃ (λ x → P x)
∀¬⟶¬∃ = uncurry

∃¬⟶¬∀ : ∀ {a p} {A : Set a} {P : A → Set p} →
        ∃ (λ x → ¬ P x) → ¬ (∀ x → P x)
∃¬⟶¬∀ = flip ∀⟶¬∃¬

------------------------------------------------------------------------
-- Double-negation

¬¬-map : ∀ {p q} {P : Set p} {Q : Set q} →
         (P → Q) → ¬ ¬ P → ¬ ¬ Q
¬¬-map f = contraposition (contraposition f)

-- Stability under double-negation.

Stable : ∀ {ℓ} → Set ℓ → Set ℓ
Stable P = ¬ ¬ P → P

-- Everything is stable in the double-negation monad.

stable : ∀ {p} {P : Set p} → ¬ ¬ Stable P
stable ¬[¬¬p→p] = ¬[¬¬p→p] (λ ¬¬p → ⊥-elim (¬¬p (¬[¬¬p→p] ∘ const)))

-- Negated predicates are stable.

negated-stable : ∀ {p} {P : Set p} → Stable (¬ P)
negated-stable ¬¬¬P P = ¬¬¬P (λ ¬P → ¬P P)

-- Decidable predicates are stable.

decidable-stable : ∀ {p} {P : Set p} → Dec P → Stable P
decidable-stable (yes p) ¬¬p = p
decidable-stable (no ¬p) ¬¬p = ⊥-elim (¬¬p ¬p)

¬-drop-Dec : ∀ {p} {P : Set p} → Dec (¬ ¬ P) → Dec (¬ P)
¬-drop-Dec (yes ¬¬p) = no ¬¬p
¬-drop-Dec (no ¬¬¬p) = yes (negated-stable ¬¬¬p)

-- Double-negation is a monad (if we assume that all elements of ¬ ¬ P
-- are equal).

¬¬-Monad : ∀ {p} → RawMonad (λ (P : Set p) → ¬ ¬ P)
¬¬-Monad = record
  { return = contradiction
  ; _>>=_  = λ x f → negated-stable (¬¬-map f x)
  }

¬¬-push : ∀ {p q} {P : Set p} {Q : P → Set q} →
          ¬ ¬ ((x : P) → Q x) → (x : P) → ¬ ¬ Q x
¬¬-push ¬¬P⟶Q P ¬Q = ¬¬P⟶Q (λ P⟶Q → ¬Q (P⟶Q P))

-- A double-negation-translated variant of excluded middle (or: every
-- nullary relation is decidable in the double-negation monad).

excluded-middle : ∀ {p} {P : Set p} → ¬ ¬ Dec P
excluded-middle ¬h = ¬h (no (λ p → ¬h (yes p)))

-- If Whatever is instantiated with ¬ ¬ something, then this function
-- is call with current continuation in the double-negation monad, or,
-- if you will, a double-negation translation of Peirce's law.
--
-- In order to prove ¬ ¬ P one can assume ¬ P and prove ⊥. However,
-- sometimes it is nice to avoid leaving the double-negation monad; in
-- that case this function can be used (with Whatever instantiated to
-- ⊥).

call/cc : ∀ {w p} {Whatever : Set w} {P : Set p} →
          ((P → Whatever) → ¬ ¬ P) → ¬ ¬ P
call/cc hyp ¬p = hyp (λ p → ⊥-elim (¬p p)) ¬p

-- The "independence of premise" rule, in the double-negation monad.
-- It is assumed that the index set (Q) is inhabited.

independence-of-premise
  : ∀ {p q r} {P : Set p} {Q : Set q} {R : Q → Set r} →
    Q → (P → Σ Q R) → ¬ ¬ (Σ[ x ∈ Q ] (P → R x))
independence-of-premise {P = P} q f = ¬¬-map helper excluded-middle
  where
  helper : Dec P → _
  helper (yes p) = Prod.map id const (f p)
  helper (no ¬p) = (q , ⊥-elim ∘′ ¬p)

-- The independence of premise rule for binary sums.

independence-of-premise-⊎
  : ∀ {p q r} {P : Set p} {Q : Set q} {R : Set r} →
    (P → Q ⊎ R) → ¬ ¬ ((P → Q) ⊎ (P → R))
independence-of-premise-⊎ {P = P} f = ¬¬-map helper excluded-middle
  where
  helper : Dec P → _
  helper (yes p) = Sum.map const const (f p)
  helper (no ¬p) = inj₁ (⊥-elim ∘′ ¬p)

private

  -- Note that independence-of-premise-⊎ is a consequence of
  -- independence-of-premise (for simplicity it is assumed that Q and
  -- R have the same type here):

  corollary : ∀ {p ℓ} {P : Set p} {Q R : Set ℓ} →
              (P → Q ⊎ R) → ¬ ¬ ((P → Q) ⊎ (P → R))
  corollary {P = P} {Q} {R} f =
    ¬¬-map helper (independence-of-premise
                     true ([ _,_ true , _,_ false ] ∘′ f))
    where
    helper : ∃ (λ b → P → if b then Q else R) → (P → Q) ⊎ (P → R)
    helper (true  , f) = inj₁ f
    helper (false , f) = inj₂ f

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

-- Version 1.0

Excluded-Middle : (ℓ : Level) → Set (suc ℓ)
Excluded-Middle p = {P : Set p} → Dec P
{-# WARNING_ON_USAGE Excluded-Middle
"Warning: Excluded-Middle was deprecated in v1.0.
Please use ExcludedMiddle from `Axiom.ExcludedMiddle` instead."
#-}

Double-Negation-Elimination : (ℓ : Level) → Set (suc ℓ)
Double-Negation-Elimination p = {P : Set p} → Stable P
{-# WARNING_ON_USAGE Double-Negation-Elimination
"Warning: Double-Negation-Elimination was deprecated in v1.0.
Please use DoubleNegationElimination from `Axiom.DoubleNegationElimination` instead."
#-}


open import Type

module Formalization.ClassicalPropositionalLogic.TruthTable {ℓₚ}{P : Type{ℓₚ}} where

import      Lvl
open import Data
open import Data.Boolean
open import Data.Boolean.Operators using () renaming (module Logic to Bool)
import      Data.Boolean.Proofs as Bool
open import Data.Boolean.Stmt
open import Data.Boolean.Stmt.Proofs
open import Data.Either as Either using (_‖_ ; Left ; Right)
open import Data.Tuple as Tuple using ()
open import Formalization.ClassicalPropositionalLogic.Syntax
open import Formalization.ClassicalPropositionalLogic.Semantics
open import Functional
import      Logic.Propositional as Logic
import      Logic.Propositional.Theorems as Logic
open import Logic
open import Relator.Equals.Proofs.Equiv
import      Sets.PredicateSet
open        Sets.PredicateSet.BoundedQuantifiers

private variable ℓ : Lvl.Level

-- `_⊧_`, but decidable.
eval : Model(P) → Formula(P) → Bool
eval env (• p)   = env(p)
eval env (⊤)     = 𝑇
eval env (⊥)     = 𝐹
eval env (¬ φ)   = Bool.¬(eval env (φ))
eval env (φ ∧ ψ) = eval env (φ) Bool.∧ eval env (ψ)
eval env (φ ∨ ψ) = eval env (φ) Bool.∨ eval env (ψ)
eval env (φ ⟶ ψ) = eval env (φ) Bool.⟶ eval env (ψ)
eval env (φ ⟷ ψ) = eval env (φ) Bool.⟷ eval env (ψ)

_⊢_ : Formulas(P){ℓ} → Formula(P) → Stmt
Γ ⊢ φ = ∀{𝔐} → (∀ₛ(Γ) (IsTrue ∘ eval 𝔐)) → IsTrue(eval 𝔐 φ)

private variable Γ Γ₁ Γ₂ : Formulas(P){ℓ}
private variable φ ψ : Formula(P)
private variable 𝔐 : Model(P)

models-to-eval : (𝔐 ⊧ φ) → IsTrue(eval 𝔐 φ)
eval-to-models : IsTrue(eval 𝔐 φ) → (𝔐 ⊧ φ)

eval-to-models {φ = • x}   p = p
eval-to-models {φ = ⊤}     p = <>
eval-to-models {φ = ⊥}     p = p
eval-to-models {φ = ¬ φ}   p = Logic.[↔]-to-[→] IsTrue.preserves-[!][¬] p ∘ models-to-eval {φ = φ}
eval-to-models {φ = φ ∧ ψ} p = Tuple.map (eval-to-models {φ = φ}) (eval-to-models {φ = ψ}) (Logic.[↔]-to-[→] IsTrue.preserves-[&&][∧] p)
eval-to-models {φ = φ ∨ ψ} p = Either.map (eval-to-models {φ = φ}) (eval-to-models {φ = ψ}) (Logic.[↔]-to-[→] IsTrue.preserves-[||][∨] p)
eval-to-models {φ = φ ⟶ ψ} p = Either.map (Logic.contrapositiveᵣ (models-to-eval {φ = φ}) ∘ Logic.[↔]-to-[→] IsTrue.preserves-[!][¬]) (eval-to-models {φ = ψ}) (Logic.[↔]-to-[→] IsTrue.preserves-[||][∨] ([≡]-substitutionᵣ Bool.[→?]-disjunctive-form {f = IsTrue} p))
eval-to-models {φ = φ ⟷ ψ} p = Either.map (Tuple.map (eval-to-models {φ = φ}) (eval-to-models {φ = ψ}) ∘ (Logic.[↔]-to-[→] IsTrue.preserves-[&&][∧])) (Tuple.map (Logic.contrapositiveᵣ (models-to-eval {φ = φ}) ∘ Logic.[↔]-to-[→] IsTrue.preserves-[!][¬]) (Logic.contrapositiveᵣ (models-to-eval {φ = ψ}) ∘ Logic.[↔]-to-[→] IsTrue.preserves-[!][¬]) ∘ Logic.[↔]-to-[→] IsTrue.preserves-[&&][∧]) (Logic.[↔]-to-[→] IsTrue.preserves-[||][∨] ([≡]-substitutionᵣ Bool.[==]-disjunctive-form {f = IsTrue} p))

models-to-eval {φ = • x}   p = p
models-to-eval {φ = ⊤}     p = <>
models-to-eval {φ = ⊥}     p = p
models-to-eval {φ = ¬ φ}   p = Logic.[↔]-to-[←] IsTrue.preserves-[!][¬] (p ∘ eval-to-models {φ = φ})
models-to-eval {φ = φ ∧ ψ} p = Logic.[↔]-to-[←] IsTrue.preserves-[&&][∧] (Tuple.map (models-to-eval {φ = φ}) (models-to-eval {φ = ψ}) p)
models-to-eval {φ = φ ∨ ψ} p = Logic.[↔]-to-[←] IsTrue.preserves-[||][∨] (Either.map (models-to-eval {φ = φ}) (models-to-eval {φ = ψ}) p)
models-to-eval {φ = φ ⟶ ψ} p = [≡]-substitutionₗ Bool.[→?]-disjunctive-form {f = IsTrue} (Logic.[↔]-to-[←] IsTrue.preserves-[||][∨] (Either.map (Logic.[↔]-to-[←] IsTrue.preserves-[!][¬] ∘ Logic.contrapositiveᵣ (eval-to-models {φ = φ})) (models-to-eval {φ = ψ}) p))
models-to-eval {φ = φ ⟷ ψ} p = [≡]-substitutionₗ Bool.[==]-disjunctive-form {f = IsTrue} (Logic.[↔]-to-[←] IsTrue.preserves-[||][∨] (Either.map (Logic.[↔]-to-[←] IsTrue.preserves-[&&][∧] ∘ Tuple.map (models-to-eval {φ = φ}) (models-to-eval {φ = ψ})) (Logic.[↔]-to-[←] IsTrue.preserves-[&&][∧] ∘ Tuple.map (Logic.[↔]-to-[←] IsTrue.preserves-[!][¬] ∘ Logic.contrapositiveᵣ (eval-to-models {φ = φ})) (Logic.[↔]-to-[←] IsTrue.preserves-[!][¬] ∘ Logic.contrapositiveᵣ (eval-to-models {φ = ψ}))) p))

completeness : (Γ ⊨ φ) → (Γ ⊢ φ)
completeness {φ = φ} Γφ {𝔐} a = models-to-eval {φ = φ} (Γφ (\{γ} → eval-to-models {φ = γ} ∘ a))

soundness : (Γ ⊢ φ) → (Γ ⊨ φ)
soundness {φ = φ} Γφ {𝔐} a = eval-to-models {φ = φ} (Γφ (\{γ} → models-to-eval {φ = γ} ∘ a))


{-# OPTIONS --without-K #-}
module PathStructure.Id.Tr {a b} {A : Set a} {B : Set b} where

open import Equivalence
open import PathOperations
open import Types

tr-split : {a a′ : A} {b b′ : B} (p : a ≡ a′) →
  tr (λ _ → B) p b ≡ b′ → b ≡ b′
tr-split {b = b} {b′ = b′} = J
  (λ _ _ p → tr (λ _ → B) p b ≡ b′ → b ≡ b′)
  (λ _ p → p) _ _

tr-merge : {a a′ : A} {b b′ : B} (p : a ≡ a′) →
  b ≡ b′ → tr (λ _ → B) p b ≡ b′
tr-merge {b = b} {b′ = b′} = J
  (λ _ _ p → b ≡ b′ → tr (λ _ → B) p b ≡ b′)
  (λ _ p → p) _ _

tr-eq : {a a′ : A} {b b′ : B} (p : a ≡ a′) →
  (tr (λ _ → B) p b ≡ b′) ≃ (b ≡ b′)
tr-eq p
  = tr-split p
  , (tr-merge p , λ q → J
      (λ _ _ p → tr-split p (tr-merge p q) ≡ q)
      (λ _ → refl) _ _ p)
  , (tr-merge p , λ q → J
      (λ _ _ p → (b b′ : B) (q : tr (λ _ → B) p b ≡ b′) →
        tr-merge p (tr-split p q) ≡ q)
      (λ _ _ _ _ → refl) _ _ p _ _ q)

-- In presence of univalence axiom, this statement
-- can also be proven from tr-eq.
tr-≡ : {a a′ : A} {b b′ : B} (p : a ≡ a′) →
  (tr (λ _ → B) p b ≡ b′) ≡ (b ≡ b′)
tr-≡ {b = b} {b′ = b′} = J
  (λ _ _ p → (tr (λ _ → B) p b ≡ b′) ≡ (b ≡ b′))
  (λ _ → refl) _ _


-- Minimal implicational logic, de Bruijn approach, final encoding

module Bf.ArrMp where

open import Lib using (List; _,_; LMem; lzero; lsuc)

-- Types

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

-- Context and truth judgement

Cx : Set
Cx = List Ty

isTrue : Ty -> Cx -> Set
isTrue a tc = LMem a tc

-- Terms

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

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

    v0 : forall {tc a} -> tr (tc , a) a
    v0 = var lzero

    v1 : forall {tc a b} -> tr (tc , a , b) a
    v1 = var (lsuc lzero)

    v2 : forall {tc a b c} -> tr (tc , a , b , c) a
    v2 = var (lsuc (lsuc lzero))
  open Tm {{...}} public

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

-- Example theorems

aI : forall {a} -> Thm (a => a)
aI =
  lam=> v0

aK : forall {a b} -> Thm (a => b => a)
aK =
  lam=>
    lam=> v1

aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c)
aS =
  lam=>
    lam=>
      lam=> v2 $ v0 $ (v1 $ v0)

tSKK : forall {a} -> Thm (a => a)
tSKK {a = a} =
  aS {b = a => a} $ aK $ aK


open import Level using (_⊔_; suc; Lift; lift)
open import Function using (_$_; _∘_; _⤖_)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Decidable using (False)
open import Relation.Binary using (Rel; Decidable; Setoid; DecSetoid; IsEquivalence; IsDecEquivalence)

open import Data.Empty using (⊥)
open import Data.Product using (∃-syntax; _,_)
open import Data.Sum using (_⊎_)

module AKS.Algebra.Structures {c ℓ} (C : Set c) (_≈_ : Rel C ℓ) where

open import Data.Unit using (⊤; tt)
open import Agda.Builtin.FromNat using (Number)
open import AKS.Nat using (ℕ; _<_; _≟_)
open import AKS.Fin using (Fin)

open import Algebra.Core using (Op₂; Op₁)
open import Algebra.Structures _≈_ using (IsCommutativeRing; IsAbelianGroup)

infix 4 _≉_
_≉_ : Rel C ℓ
x ≉ y = x ≈ y → ⊥

record IsNonZeroCommutativeRing (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C) : Set (c ⊔ ℓ) where
  field
    isCommutativeRing : IsCommutativeRing _+_ _*_ -_ 0# 1#
    0#≉1# : 0# ≉ 1#

  open IsCommutativeRing isCommutativeRing public
  open import Relation.Binary.Reasoning.Setoid setoid
  open import Algebra.Properties.Ring (record { isRing = isRing }) using (-‿distribˡ-*; -‿involutive)

  1#≉0# : 1# ≉ 0#
  1#≉0# = 0#≉1# ∘ sym

  0#≉-1# : 0# ≉ - 1#
  0#≉-1# 0#≈-1# = 0#≉1# $ begin
    0#              ≈⟨ sym (zeroʳ 0#) ⟩
    0# * 0#         ≈⟨ *-cong 0#≈-1# 0#≈-1# ⟩
    (- 1#) * (- 1#) ≈⟨ sym (-‿distribˡ-* 1# (- 1#)) ⟩
    - (1# * (- 1#)) ≈⟨ -‿cong (*-identityˡ (- 1#)) ⟩
    - (- 1#)        ≈⟨ -‿involutive 1# ⟩
    1#              ∎

  -1#≉0# : - 1# ≉ 0#
  -1#≉0# = 0#≉-1# ∘ sym

  C/0 : Set (c ⊔ ℓ)
  C/0 = ∃[ x ] (x ≉ 0#)

  1#-nonzero : C/0
  1#-nonzero = 1# , 1#≉0#

  -1#-nonzero : C/0
  -1#-nonzero = - 1# , -1#≉0#

  fromNat : ℕ → C
  fromNat ℕ.zero = 0#
  fromNat (ℕ.suc ℕ.zero) = 1#
  fromNat (ℕ.suc (ℕ.suc n)) = 1# + fromNat (ℕ.suc n)

  instance
    C-number : Number C
    C-number = record
      { Constraint = λ _ → Lift c ⊤
      ; fromNat = λ n → fromNat n
      }

record IsIntegralDomain (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C) : Set (c ⊔ ℓ) where
  field
    isNonZeroCommutativeRing : IsNonZeroCommutativeRing _+_ _*_ -_ 0# 1#
    *-cancelˡ : ∀ x {y z} → x ≉ 0# → (x * y) ≈ (x * z) → y ≈ z

  open IsNonZeroCommutativeRing isNonZeroCommutativeRing public
  open import Relation.Binary.Reasoning.Setoid setoid

  *-cancelʳ : ∀ x {y z} → x ≉ 0# → (y * x) ≈ (z * x) → y ≈ z
  *-cancelʳ x {y} {z} x≉0 y*x≈z*x = *-cancelˡ x x≉0 $ begin
    (x * y) ≈⟨ *-comm x y ⟩
    (y * x) ≈⟨ y*x≈z*x ⟩
    (z * x) ≈⟨ *-comm z x ⟩
    (x * z) ∎

  *≉0 : ∀ {c₁ c₂} → c₁ ≉ 0# → c₂ ≉ 0# → c₁ * c₂ ≉ 0#
  *≉0 {c₁} {c₂} c₁≉0 c₂≉0 c₁*c₂≈0 = c₂≉0 $ *-cancelˡ c₁ c₁≉0 $ begin
     (c₁ * c₂) ≈⟨ c₁*c₂≈0 ⟩
     (0#)      ≈⟨ sym (zeroʳ c₁) ⟩
     (c₁ * 0#) ∎

  infixl 7 _*-nonzero_
  _*-nonzero_ : C/0 → C/0 → C/0
  (c₁ , c₁≉0) *-nonzero (c₂ , c₂≉0) = c₁ * c₂ , *≉0 c₁≉0 c₂≉0

module Divisibility (_*_ : Op₂ C) where
  infix 4 _∣_
  record _∣_ (d : C) (a : C) : Set (c ⊔ ℓ) where
    constructor divides
    field
      quotient : C
      equality : a ≈ (quotient * d)

  infix 4 _∤_
  _∤_ : C → C → Set (c ⊔ ℓ)
  d ∤ a = ¬ (d ∣ a)

  record IsGCD (gcd : Op₂ C) : Set (c ⊔ ℓ) where
    field
      gcd[a,b]∣a : ∀ a b → gcd a b ∣ a
      gcd[a,b]∣b : ∀ a b → gcd a b ∣ b
      gcd-greatest : ∀ {c a b} → c ∣ a → c ∣ b → c ∣ gcd a b

record IsGCDDomain (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C) (gcd : Op₂ C) : Set (c ⊔ ℓ) where
  open Divisibility _*_ public
  field
    isIntegralDomain : IsIntegralDomain _+_ _*_ -_ 0# 1#
    gcd-isGCD : IsGCD gcd

  open IsIntegralDomain isIntegralDomain public

record IsUniqueFactorizationDomain (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C) (gcd : Op₂ C) : Set (c ⊔ ℓ) where
  field
    isGCDDomain : IsGCDDomain _+_ _*_ -_ 0# 1# gcd
    -- TODO define factorization

  open IsGCDDomain isGCDDomain public

module Modulus
  (0# : C) (∣_∣ : ∀ n {n≉0 : n ≉ 0#} → ℕ) (_mod_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C)
  where
  data Remainder (n : C) (m : C) {m≉0 : m ≉ 0#} : Set (c ⊔ ℓ) where
    0≈ : (r≈0 : (n mod m) {m≉0} ≈ 0#) → Remainder n m
    0≉ : (r≉0 : (n mod m) {m≉0} ≉ 0#) → ∣ n mod m ∣ {r≉0} < ∣ m ∣ {m≉0} → Remainder n m

module _
  (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C) (∣_∣ : ∀ n {n≉0 : n ≉ 0#} → ℕ)
  (_div_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C) (_mod_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C)
  (gcd : Op₂ C)
  where

  record IsEuclideanDomain : Set (c ⊔ ℓ) where
    open Modulus 0# ∣_∣ _mod_ public
    field
      isUniqueFactorizationDomain : IsUniqueFactorizationDomain _+_ _*_ -_ 0# 1# gcd
      division : ∀ n m {m≉0 : m ≉ 0#} → n ≈ ((m * (n div m) {m≉0}) + (n mod m) {m≉0})
      modulus : ∀ n m {m≉0 : m ≉ 0#} → Remainder n m {m≉0}
      div-cong : ∀ {x₁ x₂} {y₁ y₂} → x₁ ≈ x₂ → y₁ ≈ y₂ → ∀ {y₁≉0 y₂≉0} → (x₁ div y₁) {y₁≉0} ≈ (x₂ div y₂) {y₂≉0}
      mod-cong : ∀ {x₁ x₂} {y₁ y₂} → x₁ ≈ x₂ → y₁ ≈ y₂ → ∀ {y₁≉0 y₂≉0} → (x₁ mod y₁) {y₁≉0} ≈ (x₂ mod y₂) {y₂≉0}

    open IsUniqueFactorizationDomain isUniqueFactorizationDomain public

record IsField (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C) (_/_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C) (gcd : Op₂ C) : Set (c ⊔ ℓ) where
  field
    isEuclideanDomain : IsEuclideanDomain _+_ _*_ -_ 0# 1# (λ _ → 0) _/_ (λ _ _ → 0#) gcd

  open IsEuclideanDomain isEuclideanDomain public renaming (div-cong to /-cong)
  open import Relation.Binary.Reasoning.Setoid setoid

  m*[n/m]≈n : ∀ n m {m≉0 : m ≉ 0#} → (m * (n / m) {m≉0}) ≈ n
  m*[n/m]≈n n m {m≉0} = begin
    (m * (n / m) {m≉0}) ≈⟨ sym (+-identityʳ (m * (n / m) {m≉0})) ⟩
    ((m * (n / m) {m≉0}) + 0#) ≈⟨ sym (division n m) ⟩
    n ∎

  [n/m]*m≈n : ∀ n m {m≉0 : m ≉ 0#} → ((n / m) {m≉0} * m) ≈ n
  [n/m]*m≈n n m {m≉0} = begin
    ((n / m) * m) ≈⟨ *-comm (n / m) m ⟩
    (m * (n / m)) ≈⟨ m*[n/m]≈n n m ⟩
    n ∎

  /≉0 : ∀ {c₁ c₂} → c₁ ≉ 0# → (c₂≉0 : c₂ ≉ 0#) → (c₁ / c₂) {c₂≉0} ≉ 0#
  /≉0 {c₁} {c₂} c₁≉0 c₂≉0 c₁/c₂≈0 = 0#≉1# $ *-cancelˡ c₂ c₂≉0 $ begin
    c₂ * 0#                      ≈⟨ *-congˡ (sym (zeroˡ ((c₂ / c₁) {c₁≉0}))) ⟩
    c₂ * (0# * (c₂ / c₁))        ≈⟨ *-congˡ (*-congʳ (sym (c₁/c₂≈0))) ⟩
    c₂ * ((c₁ / c₂) * (c₂ / c₁)) ≈⟨ sym (*-assoc c₂  (c₁ / c₂) (c₂ / c₁)) ⟩
    (c₂ * (c₁ / c₂)) * (c₂ / c₁) ≈⟨ *-congʳ (m*[n/m]≈n c₁ c₂) ⟩
    c₁ * (c₂ / c₁)               ≈⟨ m*[n/m]≈n c₂ c₁ ⟩
    c₂                           ≈⟨ sym (*-identityʳ c₂) ⟩
    c₂ * 1#                      ∎

  infixl 7 _/-nonzero_
  _/-nonzero_ : C/0 → C/0 → C/0
  (c₁ , c₁≉0) /-nonzero (c₂ , c₂≉0) = (c₁ / c₂) {c₂≉0} , /≉0 c₁≉0 c₂≉0

  infix 8 _⁻¹
  _⁻¹ : ∀ x {x≉0 : x ≉ 0#} → C
  _⁻¹ x {x≉0} = (1# / x) {x≉0}

  ⁻¹-inverseʳ : ∀ x {x≉0 : x ≉ 0#} → (x * (x ⁻¹) {x≉0}) ≈ 1#
  ⁻¹-inverseʳ = m*[n/m]≈n 1#

  ⁻¹-inverseˡ : ∀ x {x≉0 : x ≉ 0#} → ((x ⁻¹) {x≉0} * x) ≈ 1#
  ⁻¹-inverseˡ = [n/m]*m≈n 1#

  x⁻¹≉0 : ∀ x {x≉0 : x ≉ 0#} → (x ⁻¹) {x≉0} ≉ 0#
  x⁻¹≉0 x {x≉0} = /≉0 1#≉0# x≉0
  -- 0#≉1# $ begin
  --   0# ≈⟨ sym (zeroʳ x) ⟩
  --   x * 0# ≈⟨ *-congˡ (sym x⁻¹≈0) ⟩
  --   x * (x ⁻¹) {x≉0} ≈⟨ ⁻¹-inverseʳ x ⟩
  --   1# ∎

  ⁻¹-cong : ∀ {x y} {x≉0 : x ≉ 0#} {y≉0 : y ≉ 0#} → x ≈ y → (x ⁻¹) {x≉0} ≈ (y ⁻¹) {y≉0}
  ⁻¹-cong {x} {y} {x≉0} {y≉0} x≈y = *-cancelˡ x x≉0 $ begin
    (x * (x ⁻¹)) ≈⟨ ⁻¹-inverseʳ x ⟩
    1#           ≈⟨ sym (⁻¹-inverseʳ y {y≉0}) ⟩
    (y * (y ⁻¹)) ≈⟨ *-congʳ (sym x≈y) ⟩
    (x * (y ⁻¹)) ∎

record IsDecField
  (_≈?_ : Decidable _≈_) (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C)
  (_/_  : ∀ (n m : C) {m≉0 : m ≉ 0#} → C) (gcd : Op₂ C) : Set (c ⊔ ℓ) where
  field
    isField : IsField _+_ _*_ -_ 0# 1# _/_ gcd

  open IsField isField public

  isDecEquivalence : IsDecEquivalence _≈_
  isDecEquivalence = record
    { isEquivalence = isEquivalence
    ; _≟_ = _≈?_
    }

record IsFiniteField
  (_≈?_ : Decidable _≈_) (_+_ _*_ : Op₂ C) (-_ : Op₁ C) (0# 1# : C)
  (_/_  : ∀ (n m : C) {m≉0 : m ≉ 0#} → C) (gcd : Op₂ C)
  (cardinality : ℕ) : Set (suc c ⊔ ℓ) where
  field
    isDecField : IsDecField _≈?_ _+_ _*_ -_ 0# 1# _/_ gcd
    C↦Fin[cardinality] : C ⤖ Fin cardinality

  open IsDecField isDecField public


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

open import lib.Basics
open import lib.types.Truncation
open import lib.types.TwoSemiCategory
open import lib.two-semi-categories.Functor
open import lib.two-semi-categories.FunctorInverse
open import lib.two-semi-categories.GroupToCategory

module lib.two-semi-categories.FundamentalCategory where

module _ {i} (A : Type i) where

  2-type-fundamental-cat : {{_ : has-level 2 A}} → TwoSemiCategory i i
  2-type-fundamental-cat =
    record
    { El = A
    ; Arr = _==_
    ; Arr-level = λ _ _ → ⟨⟩
    ; two-semi-cat-struct = record
      { comp = _∙_
      ; assoc = ∙-assoc
      ; pentagon-identity = ∙-assoc-pentagon
      }
    }

  =ₜ-fundamental-cat : TwoSemiCategory i i
  =ₜ-fundamental-cat =
    record
    { El = Trunc 2 A
    ; Arr = _=ₜ_
    ; Arr-level = =ₜ-level
    ; two-semi-cat-struct = record
      { comp = λ {ta} → _∙ₜ_ {ta = ta}
      ; assoc = λ {ta} → ∙ₜ-assoc {ta = ta}
      ; pentagon-identity = λ {ta} → ∙ₜ-assoc-pentagon {ta = ta}
      }
    }

module _ {i} (A : Type i) where

  2-type-to-=ₜ-fundamental-cat :
    TwoSemiFunctor (2-type-fundamental-cat (Trunc 2 A))
                   (=ₜ-fundamental-cat A)
  2-type-to-=ₜ-fundamental-cat =
    record
    { F₀ = idf (Trunc 2 A)
    ; F₁ = λ {ta} {tb} → –> (=ₜ-equiv ta tb)
    ; pres-comp = –>-=ₜ-equiv-pres-∙
      -- TODO: The following line takes a really long time to check.
      -- Can we optimize this somehow?
    ; pres-comp-coh = λ {ta} → –>-=ₜ-equiv-pres-∙-coh {ta = ta}
    }

  private
    module FunctorInv =
      FunctorInverse 2-type-to-=ₜ-fundamental-cat
                     (idf-is-equiv (Trunc 2 A))
                     (λ ta tb → snd (=ₜ-equiv ta tb))
    module InvFunctor = TwoSemiFunctor FunctorInv.functor

  =ₜ-to-2-type-fundamental-cat :
    TwoSemiFunctor (=ₜ-fundamental-cat A)
                   (2-type-fundamental-cat (Trunc 2 A))
  =ₜ-to-2-type-fundamental-cat =
    record
    { F₀ = idf (Trunc 2 A)
    ; F₁ = λ {ta} {tb} → <– (=ₜ-equiv ta tb)
    ; pres-comp = InvFunctor.pres-comp
    ; pres-comp-coh = InvFunctor.pres-comp-coh
    }

  module =ₜ-to-2-type-fundamental-cat = TwoSemiFunctor =ₜ-to-2-type-fundamental-cat

  =ₜ-to-2-type-fundamental-cat-pres-comp-β : {a b c : A}
    (p : a == b) (q : b == c)
    → =ₜ-to-2-type-fundamental-cat.pres-comp {x = [ a ]} {y = [ b ]} {z = [ c ]} [ p ]₁ [ q ]₁
      == ap-∙ [_] p q
  =ₜ-to-2-type-fundamental-cat-pres-comp-β {a} p@idp q@idp =
    =ₛ-out (FunctorInv.pres-comp-β {[ a ]} {[ a ]} {[ a ]} [ idp ]₁ [ idp ]₁)

module _ {i} (C : Type i) (c₀ : C) {{C-level : has-level 1 C}} where

  open import lib.groups.LoopSpace

  fundamental-group-to-fundamental-groupoid :
    TwoSemiFunctor (group-to-cat (Ω^S-group 0 ⊙[ C , c₀ ]))
                   (2-type-fundamental-cat C {{raise-level 1 C-level}})
  fundamental-group-to-fundamental-groupoid =
    record
    { F₀ = λ _ → c₀
    ; F₁ = λ p → p
    ; pres-comp = λ p q → idp
    ; pres-comp-coh =
        λ p q r → =ₛ-in $
          prop-path (has-level-apply (has-level-apply C-level _ _) _ _) _ _
    }


open import Data.Nat using (ℕ; zero; suc; _+_; _∸_; _≥_; _≤_; z≤n; s≤s)
open import Function.Equivalence using (_⇔_)
open import Relation.Binary.PropositionalEquality using (→-to-⟶)

postulate
  adjoint : ∀ {x y z} → x + y ≥ z ⇔ x ≥ z ∸ y
  unit : ∀ {x y} → x ≥ (x + y) ∸ y
  apply : ∀ {x y} → (x ∸ y) + y ≥ x


module Sets.ImageSet.Oper where

open import Data
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.Predicate
import      Lvl
open import Sets.ImageSet
open import Structure.Function
open import Structure.Setoid renaming (_≡_ to _≡ₛ_)
open import Type
open import Type.Dependent

private variable ℓ ℓₑ ℓᵢ ℓᵢ₁ ℓᵢ₂ ℓᵢ₃ ℓᵢₑ ℓ₁ ℓ₂ ℓ₃ : Lvl.Level
private variable T X Y Z : Type{ℓ}

module _ where
  open import Data.Boolean
  open import Data.Boolean.Stmt
  open import Data.Either as Either using (_‖_)
  open import Function.Domains

  ∅ : ImageSet{ℓᵢ}(T)
  ∅ = intro empty

  𝐔 : ImageSet{Lvl.of(T)}(T)
  𝐔 = intro id

  singleton : T → ImageSet{ℓᵢ}(T)
  singleton(x) = intro{Index = Unit} \{<> → x}

  pair : T → T → ImageSet{ℓᵢ}(T)
  pair x y = intro{Index = Lvl.Up(Bool)} \{(Lvl.up 𝐹) → x ; (Lvl.up 𝑇) → y}

  _∪_ : ImageSet{ℓᵢ₁}(T) → ImageSet{ℓᵢ₂}(T) → ImageSet{ℓᵢ₁ Lvl.⊔ ℓᵢ₂}(T)
  A ∪ B = intro{Index = Index(A) ‖ Index(B)} (Either.map1 (elem(A)) (elem(B)))

  ⋃ : ImageSet{ℓᵢ}(ImageSet{ℓᵢ}(T)) → ImageSet{ℓᵢ}(T)
  ⋃ A = intro{Index = Σ(Index(A)) (Index ∘ elem(A))} \{(intro ia i) → elem(elem(A)(ia))(i)}

  indexFilter : (A : ImageSet{ℓᵢ}(T)) → (Index(A) → Stmt{ℓ}) → ImageSet{ℓᵢ Lvl.⊔ ℓ}(T)
  indexFilter A P = intro {Index = Σ(Index(A)) P} (elem(A) ∘ Σ.left)

  filter : (T → Stmt{ℓ}) → ImageSet{ℓᵢ}(T) → ImageSet{ℓᵢ Lvl.⊔ ℓ}(T)
  filter P(A) = indexFilter A (P ∘ elem(A))

  indexFilterBool : (A : ImageSet{ℓᵢ}(T)) → (Index(A) → Bool) → ImageSet{ℓᵢ}(T)
  indexFilterBool A f = indexFilter A (IsTrue ∘ f)

  filterBool : (T → Bool) → ImageSet{ℓᵢ}(T) → ImageSet{ℓᵢ}(T)
  filterBool f(A) = indexFilterBool A (f ∘ elem(A))

  map : (X → Y) → (ImageSet{ℓᵢ}(X) → ImageSet{ℓᵢ}(Y))
  map f(A) = intro{Index = Index(A)} (f ∘ elem(A))

  unapply : (X → Y) → ⦃ _ : Equiv{ℓₑ}(Y)⦄ → (Y → ImageSet{Lvl.of(X) Lvl.⊔ ℓₑ}(X))
  unapply f(y) = intro{Index = ∃(x ↦ f(x) ≡ₛ y)} [∃]-witness

  -- unmap : (X → Y) → ⦃ _ : Equiv{ℓₑ}(Y)⦄ → (ImageSet{{!Lvl.of(T) Lvl.⊔ ℓₑ!}}(Y) → ImageSet{Lvl.of(T) Lvl.⊔ ℓₑ}(X))
  -- unmap f(B) = intro{Index = ∃(x ↦ f(x) ∈ B)} [∃]-witness

  ℘ : ImageSet{ℓᵢ}(T) → ImageSet{Lvl.𝐒(ℓᵢ)}(ImageSet{ℓᵢ}(T))
  ℘(A) = intro{Index = Index(A) → Stmt} (indexFilter A)

  _∩_ : ⦃ _ : Equiv{ℓᵢ}(T) ⦄ → ImageSet{ℓᵢ}(T) → ImageSet{ℓᵢ}(T) → ImageSet{ℓᵢ}(T)
  A ∩ B = indexFilter(A) (iA ↦ elem(A) iA ∈ B)

  ⋂ : ⦃ _ : Equiv{ℓᵢ}(T) ⦄ → ImageSet{Lvl.of(T)}(ImageSet{Lvl.of(T)}(T)) → ImageSet{ℓᵢ Lvl.⊔ Lvl.of(T)}(T)
  -- ⋂ As = intro{Index = Σ((iAs : Index(As)) → Index(elem(As) iAs)) (f ↦ (∀{iAs₁ iAs₂} → (elem(elem(As) iAs₁)(f iAs₁) ≡ₛ elem(elem(As) iAs₂)(f iAs₂))))} {!!} (TODO: I think this definition only works with excluded middle because one must determine if an A from AS is empty or not and if it is not, then one can apply its index to the function in the Σ)
  ⋂ As = indexFilter(⋃ As) (iUAs ↦ ∃{Obj = (iAs : Index(As)) → Index(elem(As) iAs)}(f ↦ ∀{iAs} → (elem(⋃ As) iUAs ≡ₛ elem(elem(As) iAs) (f iAs))))
  -- ⋂ As = indexFilter(⋃ As) (iUAs ↦ ∀{iAs} → (elem(⋃ As) iUAs ∈ elem(As) iAs))

  {-
module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  open import Data.Boolean
  open import Data.Either as Either using (_‖_)
  open import Data.Tuple as Tuple using (_⨯_ ; _,_)
  import      Structure.Container.SetLike as Sets
  open import Structure.Function.Domain
  open import Structure.Operator.Properties
  open import Structure.Relator
  open import Structure.Relator.Properties
  open import Syntax.Transitivity

  private variable A B C : ImageSet{ℓₑ}(T)
  private variable x y a b : T

  [∈]-of-elem : ∀{ia : Index(A)} → (elem(A)(ia) ∈ A)
  ∃.witness ([∈]-of-elem {ia = ia}) = ia
  ∃.proof    [∈]-of-elem = reflexivity(_≡ₛ_)

  instance
    ∅-membership : Sets.EmptySet(_∈_ {T = T}{ℓ})
    Sets.EmptySet.∅          ∅-membership = ∅
    Sets.EmptySet.membership ∅-membership ()

  instance
    𝐔-membership : Sets.UniversalSet(_∈_ {T = T})
    Sets.UniversalSet.𝐔          𝐔-membership = 𝐔
    Sets.UniversalSet.membership 𝐔-membership {x = x} = [∃]-intro x ⦃ reflexivity(_≡ₛ_) ⦄

  instance
    singleton-membership : Sets.SingletonSet(_∈_ {T = T}{ℓ})
    Sets.SingletonSet.singleton singleton-membership = singleton
    Sets.SingletonSet.membership singleton-membership = proof where
      proof : (x ∈ singleton{ℓᵢ = ℓᵢ}(a)) ↔ (x ≡ₛ a)
      Tuple.left  proof xin = [∃]-intro <> ⦃ xin ⦄
      Tuple.right proof ([∃]-intro i ⦃ eq ⦄ ) = eq

  instance
    pair-membership : Sets.PairSet(_∈_ {T = T}{ℓ})
    Sets.PairSet.pair pair-membership = pair
    Sets.PairSet.membership pair-membership = proof where
      proof : (x ∈ pair a b) ↔ (x ≡ₛ a)∨(x ≡ₛ b)
      Tuple.left  proof ([∨]-introₗ p) = [∃]-intro (Lvl.up 𝐹) ⦃ p ⦄
      Tuple.left  proof ([∨]-introᵣ p) = [∃]-intro (Lvl.up 𝑇) ⦃ p ⦄
      Tuple.right proof ([∃]-intro (Lvl.up 𝐹) ⦃ eq ⦄) = [∨]-introₗ eq
      Tuple.right proof ([∃]-intro (Lvl.up 𝑇) ⦃ eq ⦄) = [∨]-introᵣ eq

  instance
    [∪]-membership : Sets.UnionOperator(_∈_ {T = T})
    Sets.UnionOperator._∪_        [∪]-membership = _∪_
    Sets.UnionOperator.membership [∪]-membership = proof where
      proof : (x ∈ (A ∪ B)) ↔ (x ∈ A)∨(x ∈ B)
      Tuple.left  proof ([∨]-introₗ ([∃]-intro  ia)) = [∃]-intro (Either.Left  ia)
      Tuple.left  proof ([∨]-introᵣ ([∃]-intro  ib)) = [∃]-intro (Either.Right ib)
      Tuple.right proof ([∃]-intro  ([∨]-introₗ ia)) = [∨]-introₗ ([∃]-intro ia)
      Tuple.right proof ([∃]-intro  ([∨]-introᵣ ib)) = [∨]-introᵣ ([∃]-intro ib)

  instance
    [∩]-membership : Sets.IntersectionOperator(_∈_ {T = T})
    Sets.IntersectionOperator._∩_        [∩]-membership = _∩_
    Sets.IntersectionOperator.membership [∩]-membership = proof where
      proof : (x ∈ (A ∩ B)) ↔ (x ∈ A)∧(x ∈ B)
      _⨯_.left proof ([↔]-intro ([∃]-intro iA ⦃ pA ⦄) ([∃]-intro iB ⦃ pB ⦄)) = [∃]-intro (intro iA ([∃]-intro iB ⦃ symmetry(_≡ₛ_) pA 🝖 pB ⦄))
      _⨯_.right proof ([∃]-intro (intro iA ([∃]-intro iB ⦃ pAB ⦄)) ⦃ pxAB ⦄) = [∧]-intro ([∃]-intro iA) ([∃]-intro iB ⦃ pxAB 🝖 pAB ⦄)

  instance
    map-membership : Sets.MapFunction(_∈_ {T = T})(_∈_ {T = T})
    Sets.MapFunction.map        map-membership f = map f
    Sets.MapFunction.membership map-membership {f = f} ⦃ function ⦄ = proof where
      proof : (y ∈ map f(A)) ↔ ∃(x ↦ (x ∈ A) ∧ (f(x) ≡ₛ y))
      ∃.witness (Tuple.left  (proof)                         ([∃]-intro x ⦃ [∧]-intro xA fxy ⦄)) = [∃]-witness xA
      ∃.proof   (Tuple.left  (proof {y = y} {A = A}) ([∃]-intro x ⦃ [∧]-intro xA fxy ⦄)) =
        y                                🝖[ _≡ₛ_ ]-[ fxy ]-sym
        f(x)                             🝖[ _≡ₛ_ ]-[ congruence₁(f) ⦃ function ⦄ ([∃]-proof xA) ]
        f(elem(A) ([∃]-witness xA))      🝖[ _≡ₛ_ ]-[]
        elem (map f(A)) ([∃]-witness xA) 🝖[ _≡ₛ_ ]-end
      ∃.witness (Tuple.right (proof {A = A}) ([∃]-intro iA))       = elem(A) iA
      ∃.proof   (Tuple.right proof           ([∃]-intro iA ⦃ p ⦄)) = [∧]-intro ([∈]-of-elem {ia = iA}) (symmetry(_≡ₛ_) p)

  indexFilter-membership : ∀{P : Index(A) → Stmt{ℓ}} → (x ∈ indexFilter A P) ↔ ∃(i ↦ (x ≡ₛ elem(A) i) ∧ P(i))
  _⨯_.left indexFilter-membership ([∃]-intro iA ⦃ [∧]-intro xe p ⦄) = [∃]-intro (intro iA p) ⦃ xe ⦄
  _⨯_.right indexFilter-membership ([∃]-intro (intro iA p) ⦃ xe ⦄) = [∃]-intro iA ⦃ [∧]-intro xe p ⦄

  indexFilter-subset : ∀{P : Index(A) → Stmt{ℓₑ}} → (indexFilter{ℓₑ} A P ⊆ A)
  indexFilter-subset = [∃]-map-proof [∧]-elimₗ ∘ [↔]-to-[→] indexFilter-membership

  indexFilter-elem-membershipₗ : ∀{P : Index(A) → Stmt{ℓ}}{i : Index(A)} → (elem(A)(i) ∈ indexFilter A P) ← P(i)
  indexFilter-elem-membershipₗ {i = i} pi = [∃]-intro (intro i pi) ⦃ reflexivity _ ⦄

  indexFilter-elem-membershipᵣ : ⦃ _ : Equiv{ℓₑ}(Index(A)) ⦄ ⦃ _ : Injective(elem A) ⦄ → ∀{P : Index(A) → Stmt{ℓ}} ⦃ _ : UnaryRelator(P) ⦄{i : Index(A)} → (elem(A)(i) ∈ indexFilter A P) → P(i)
  indexFilter-elem-membershipᵣ {A = A}{P = P} {i = i} ([∃]-intro (intro iA PiA) ⦃ p ⦄) = substitute₁ₗ(P) (injective(elem A) p) PiA

  instance
    filter-membership : Sets.FilterFunction(_∈_ {T = T})
    Sets.FilterFunction.filter     filter-membership f       = filter{ℓ = ℓₑ} f
    Sets.FilterFunction.membership filter-membership {P = P} = proof where
      proof : (x ∈ filter P(A)) ↔ ((x ∈ A) ∧ P(x))
      Tuple.left proof ([∧]-intro ([∃]-intro i ⦃ p ⦄) pb) = [∃]-intro (intro i (substitute₁(P) p pb)) ⦃ p ⦄
      Tuple.left  (Tuple.right proof ([∃]-intro (intro iA PiA)))        = [∃]-intro iA
      Tuple.right (Tuple.right proof ([∃]-intro (intro iA PiA) ⦃ pp ⦄)) = substitute₁ₗ(P) pp PiA

  filter-subset : ∀{P : T → Stmt{ℓₑ}} → (filter P(A) ⊆ A)
  filter-subset ([∃]-intro (intro i p) ⦃ xf ⦄) = [∃]-intro i ⦃ xf ⦄

  instance
    postulate [∩]-commutativity : Commutativity(_∩_ {T = T})

  -- TODO: These should come from Structure.Container.SetLike, which in turn should come from Structure.Operator.Lattice, which in turn should come from Structure.Relator.Ordering.Lattice
  postulate [∩]-subset-of-right : (A ⊆ B) → (A ∩ B ≡ₛ B)
  postulate [∩]-subset-of-left : (B ⊆ A) → (A ∩ B ≡ₛ A)
  postulate [∩]-subsetₗ : (A ∩ B) ⊆ A
  [∩]-subsetᵣ : (A ∩ B) ⊆ B
  [∩]-subsetᵣ {A} {B} {x} xAB = indexFilter-subset ([↔]-to-[→] (commutativity(_∩_) ⦃ [∩]-commutativity ⦄ {A} {B} {x}) xAB)

  instance
    ℘-membership : Sets.PowerFunction(_∈_)(_∈_)
    Sets.PowerFunction.℘ ℘-membership = ℘
    Sets.PowerFunction.membership ℘-membership = [↔]-intro l r where
      l : (B ∈ ℘(A)) ← (B ⊆ A)
      ∃.witness (l {B} {A} BA) iA = elem(A) iA ∈ B
      _⨯_.left (∃.proof (l {B}{A} BA) {x}) a = apply a $
        A ∩ B 🝖[ _⊆_ ]-[ [∩]-subsetᵣ ]
        B     🝖[ _⊆_ ]-end
      _⨯_.right (∃.proof (l {B}{A} BA) {x}) b = apply b $
        B     🝖[ _⊆_ ]-[ BA ]
        A     🝖[ _⊆_ ]-[ sub₂(_≡_)(_⊇_) ([∩]-subset-of-left BA) ]
        A ∩ B 🝖[ _⊆_ ]-end

      r : (B ∈ ℘(A)) → (B ⊆ A)
      r ([∃]-intro _ ⦃ BA ⦄) xB with [↔]-to-[→] BA xB
      ... | [∃]-intro (intro iA _) ⦃ xe ⦄ = [∃]-intro iA ⦃ xe ⦄
-}


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

open import Cubical.Foundations.Everything
open import Cubical.Data.HomotopyGroup
open import Cubical.Data.Nat
open import Cubical.Data.Sigma
open import Cubical.HITs.Nullification
open import Cubical.HITs.Susp
open import Cubical.HITs.Truncation as Trunc
open import Cubical.Homotopy.Connected

module WedgeConnectivity {ℓ ℓ' ℓ''} (n m : ℕ)
  (A : Pointed ℓ) (connA : isConnected (suc n) (typ A))
  (B : Pointed ℓ') (connB : isConnected (suc m) (typ B))
  (P : typ A → typ B → TypeOfHLevel ℓ'' (n + m))
  (f : (a : typ A) → P a (pt B) .fst)
  (g : (b : typ B) → P (pt A) b .fst)
  (p : f (pt A) ≡ g (pt B))
  where

  private
    Q : typ A → TypeOfHLevel _ n
    Q a =
      ( (Σ[ k ∈ ((b : typ B) → P a b .fst) ] k (pt B) ≡ f a)
      , isOfHLevelRetract n
          (λ {(h , q) → h , funExt λ _ → q})
          (λ {(h , q) → h , funExt⁻ q _})
          (λ _ → refl)
          (isOfHLevelPrecomposeConnected n m (P a) (λ _ → pt B)
            (isConnectedPoint m connB (pt B)) (λ _ → f a))
      )

    main : isContr (fiber (λ s _ → s (pt A)) (λ _ → g , p ⁻¹))
    main =
      elim.isEquivPrecompose (λ _ → pt A) n Q
        (isConnectedPoint n connA (pt A))
        .equiv-proof (λ _ → g , p ⁻¹)

  extension : ∀ a b → P a b .fst
  extension a b = main .fst .fst a .fst b

  left : ∀ a → extension a (pt B) ≡ f a
  left a = main .fst .fst a .snd

  right : ∀ b → extension (pt A) b ≡ g b
  right = funExt⁻ (cong fst (funExt⁻ (main .fst .snd) _))

    -- TODO: left (pt A) ⁻¹ ∙ right (pt B) ≡ p


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

open import lib.Basics
open import lib.Relation
open import lib.NType2
open import lib.types.Pi

module lib.types.SetQuotient {i} {A : Type i} {j} where

postulate  -- HIT
  SetQuot : (R : Rel A j) → Type (lmax i j)

module _ {R : Rel A j} where

  postulate  -- HIT
    q[_] : (a : A) → SetQuot R
    quot-rel : {a₁ a₂ : A} → R a₁ a₂ → q[ a₁ ] == q[ a₂ ]
    SetQuot-level : is-set (SetQuot R)

  SetQuot-is-set = SetQuot-level

  module SetQuotElim {k} {P : SetQuot R → Type k}
    (p : (x : SetQuot R) → is-set (P x)) (q[_]* : (a : A) → P q[ a ])
    (rel* : ∀ {a₁ a₂} (r : R a₁ a₂) → q[ a₁ ]* == q[ a₂ ]* [ P ↓ quot-rel r ]) where

    postulate  -- HIT
      f : Π (SetQuot R) P
      q[_]-β : (a : A) → f q[ a ] ↦ q[ a ]*
    {-# REWRITE q[_]-β #-}

    postulate  -- HIT
      quot-rel-β : ∀ {a₁ a₂} (r : R a₁ a₂) → apd f (quot-rel r) == rel* r

  open SetQuotElim public using () renaming (f to SetQuot-elim)

  module SetQuotRec {k} {B : Type k} (p : is-set B)
    (q[_]* : A → B) (rel* : ∀ {a₁ a₂} (r : R a₁ a₂) → q[ a₁ ]* == q[ a₂ ]*) where

    private
      module M = SetQuotElim (λ x → p) q[_]* (λ {a₁ a₂} r → ↓-cst-in (rel* r))

    f : SetQuot R → B
    f = M.f

  open SetQuotRec public using () renaming (f to SetQuot-rec)

  -- If [R] is an equivalence relation, then [quot-rel] is an equivalence.

module _ {R : Rel A j}
  (R-is-prop : ∀ {a b} → is-prop (R a b))
  (R-is-refl : is-refl R) (R-is-sym : is-sym R)
  (R-is-trans : is-trans R) where

  private
    Q : Type (lmax i j)
    Q = SetQuot R

    R'-over-quot : Q → Q → hProp j
    R'-over-quot = SetQuot-rec (→-is-set $ hProp-is-set j)
      (λ a → SetQuot-rec (hProp-is-set j)
        (λ b → R a b , R-is-prop)
        (nType=-out ∘ lemma-a))
      (λ ra₁a₂ → λ= $ SetQuot-elim
        (λ _ → raise-level -1 $ hProp-is-set j _ _)
        (λ _ → nType=-out $ lemma-b ra₁a₂)
        (λ _ → prop-has-all-paths-↓ $ hProp-is-set j _ _))
      where
        abstract
          lemma-a : ∀ {a b₁ b₂} → R b₁ b₂ → R a b₁ == R a b₂
          lemma-a rb₁b₂ = ua $ equiv
            (λ rab₁ → R-is-trans rab₁ rb₁b₂)
            (λ rab₂ → R-is-trans rab₂ (R-is-sym rb₁b₂))
            (λ _ → prop-has-all-paths R-is-prop _ _)
            (λ _ → prop-has-all-paths R-is-prop _ _)

          lemma-b : ∀ {a₁ a₂ b} → R a₁ a₂ → R a₁ b == R a₂ b
          lemma-b ra₁a₂ = ua $ equiv
            (λ ra₁b → R-is-trans (R-is-sym ra₁a₂) ra₁b)
            (λ ra₂b → R-is-trans ra₁a₂ ra₂b)
            (λ _ → prop-has-all-paths R-is-prop _ _)
            (λ _ → prop-has-all-paths R-is-prop _ _)

    R-over-quot : Q → Q → Type j
    R-over-quot q₁ q₂ = fst (R'-over-quot q₁ q₂)

    abstract
      R-over-quot-is-prop : {q₁ q₂ : Q} → is-prop (R-over-quot q₁ q₂)
      R-over-quot-is-prop {q₁} {q₂} = snd (R'-over-quot q₁ q₂)

      R-over-quot-is-refl : (q : Q) → R-over-quot q q
      R-over-quot-is-refl = SetQuot-elim
        (λ q → raise-level -1 (R-over-quot-is-prop {q} {q}))
        (λ a → R-is-refl a)
        (λ _ → prop-has-all-paths-↓ R-is-prop)

      path-to-R-over-quot : {q₁ q₂ : Q} → q₁ == q₂ → R-over-quot q₁ q₂
      path-to-R-over-quot {q} idp = R-over-quot-is-refl q

  quot-rel-equiv : ∀ {a₁ a₂ : A} → R a₁ a₂ ≃ (q[ a₁ ] == q[ a₂ ])
  quot-rel-equiv {a₁} {a₂} = equiv
    quot-rel (path-to-R-over-quot {q[ a₁ ]} {q[ a₂ ]})
    (λ _ → prop-has-all-paths (SetQuot-is-set _ _) _ _)
    (λ _ → prop-has-all-paths R-is-prop _ _)


module Agda.Builtin.Int where

open import Agda.Builtin.Nat
open import Agda.Builtin.String

infix 8 pos  -- Standard library uses this as +_

data Int : Set where
  pos    : (n : Nat) → Int
  negsuc : (n : Nat) → Int

{-# BUILTIN INTEGER       Int    #-}
{-# BUILTIN INTEGERPOS    pos    #-}
{-# BUILTIN INTEGERNEGSUC negsuc #-}

primitive primShowInteger : Int → String


open import Agda.Builtin.Equality

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

postulate
  A : Set
  B : A → Set
  C : {x : A} → B x → Set
  f : ∀ {x : A} (y : B x) → C y
  g : (x : A) → B x

test : (f ∘ g) ≡ (f ∘ g)
test = {!!}

-- WAS: goal displayed as ((λ {x} -> f) ∘ g) ≡ ((λ {x} -> f) ∘ g)
-- WANT: no spurious hidden lambda i.e. (f ∘ g) ≡ (f ∘ g)


-- Jesper, 2015-12-18: the helper function shouldn't be accepted, since it
-- matches on a heterogeneous equality and the equation between the types
-- Box A and Box B cannot be solved without injective type constructors.

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

data C : Set → Set₁ where
  c₁ c₂ : (A : Set) → C (Box A)

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

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 Foundation.Primitive where

open import Agda.Primitive

infix -65536 ℞_
℞_ : ∀ ℓ → Set _
℞_ ℓ = Set ℓ

⟰ : Level → Level
⟰ = lsuc

infix -65536 ℞₁_
℞₁_ : ∀ ℓ → Set _
℞₁_ ℓ = ℞ ⟰ ℓ

𝟘 : Level
𝟘 = lzero

open import Agda.Primitive using (_⊔_) public


import      Lvl
open import Type

module Structure.Logic.Constructive.Predicate
  {ℓₗ}  {Formula : Type{ℓₗ}}
  {ℓₘₗ} (Proof : Formula → Type{ℓₘₗ})
  {ℓₚ}  {Predicate : Type{ℓₚ}}
  {ℓₒ}  {Domain : Type{ℓₒ}}
  (_$_ : Predicate → Domain → Formula)
  where

import      Logic.Predicate as Meta
import      Structure.Logic.Constructive.Propositional as Propositional
open import Type.Properties.Inhabited using (◊)

private variable P : Predicate
private variable X Y Q : Formula
private variable x y z : Domain

-- Rules of universal quantification (for all).
record Universal(∀ₗ : Predicate → Formula) : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    intro : (∀{x} → Proof(P $ x)) → Proof(∀ₗ P)
    elim  : Proof(∀ₗ P) → ∀{x} → Proof(P $ x)
∀ₗ = \ ⦃(Meta.[∃]-intro ▫) : Meta.∃(Universal)⦄ → ▫
module ∀ₗ {▫} ⦃ p ⦄ = Universal {▫} p

-- Rules of existential quantification (exists).
record Existential(∃ : Predicate → Formula) : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    intro : Proof(P $ x) → Proof(∃ P)
    elim  : (∀{x} → Proof(P $ x) → Proof(Q)) → (Proof(∃ P) → Proof(Q))
∃ = \ ⦃(Meta.[∃]-intro ▫) : Meta.∃(Existential)⦄ → ▫
module ∃ {▫} ⦃ p ⦄ = Existential {▫} p

record ExistentialWitness(∃ : Predicate → Formula) : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    witness : Proof(∃ P) → Domain
    proof   : (p : Proof(∃ P)) → Proof(P $ witness p)

NonEmptyDomain = ◊ Domain

record Equality(_≡_ : Domain → Domain → Formula) : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Domain)} where
  field
    reflexivity : Proof(x ≡ x)
    substitute  : (P : Domain → Formula) → Proof(x ≡ y) → (Proof(P(x)) → Proof(P(y)))

record Logic : Type{ℓₘₗ Lvl.⊔ Lvl.of(Formula) Lvl.⊔ Lvl.of(Domain) Lvl.⊔ Lvl.of(Predicate)} where
  field
    ⦃ propositional ⦄ : Propositional.Logic(Proof)
    ⦃ universal ⦄     : Meta.∃(Universal)
    ⦃ existential ⦄   : Meta.∃(Existential)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some algebraic structures defined over some other structure
------------------------------------------------------------------------

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

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

module Algebra.Module.Structures where

open import Algebra.Bundles
open import Algebra.Core
import Algebra.Definitions as Defs
open import Algebra.Module.Definitions
open import Algebra.Structures
open import Data.Product using (_,_; proj₁; proj₂)
open import Level using (Level; _⊔_)

private
  variable
    m ℓm r ℓr s ℓs : Level
    M : Set m

module _ (semiring : Semiring r ℓr) (≈ᴹ : Rel {m} M ℓm) (+ᴹ : Op₂ M) (0ᴹ : M)
  where

  open Semiring semiring renaming (Carrier to R)

  record IsPreleftSemimodule (*ₗ : Opₗ R M) : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    open LeftDefs R ≈ᴹ
    field
      *ₗ-cong : Congruent _≈_ *ₗ
      *ₗ-zeroˡ : LeftZero 0# 0ᴹ *ₗ
      *ₗ-distribʳ : *ₗ DistributesOverʳ _+_ ⟶ +ᴹ
      *ₗ-identityˡ : LeftIdentity 1# *ₗ
      *ₗ-assoc : Associative _*_ *ₗ
      *ₗ-zeroʳ : RightZero 0ᴹ *ₗ
      *ₗ-distribˡ : *ₗ DistributesOverˡ +ᴹ

  record IsLeftSemimodule (*ₗ : Opₗ R M) : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    open LeftDefs R ≈ᴹ
    field
      +ᴹ-isCommutativeMonoid : IsCommutativeMonoid ≈ᴹ +ᴹ 0ᴹ
      isPreleftSemimodule : IsPreleftSemimodule *ₗ

    open IsPreleftSemimodule isPreleftSemimodule public

    open IsCommutativeMonoid +ᴹ-isCommutativeMonoid public
      using () renaming
      ( assoc                to +ᴹ-assoc
      ; comm                 to +ᴹ-comm
      ; identity             to +ᴹ-identity
      ; identityʳ            to +ᴹ-identityʳ
      ; identityˡ            to +ᴹ-identityˡ
      ; isEquivalence        to ≈ᴹ-isEquivalence
      ; isMagma              to +ᴹ-isMagma
      ; isMonoid             to +ᴹ-isMonoid
      ; isPartialEquivalence to ≈ᴹ-isPartialEquivalence
      ; isSemigroup          to +ᴹ-isSemigroup
      ; refl                 to ≈ᴹ-refl
      ; reflexive            to ≈ᴹ-reflexive
      ; setoid               to ≈ᴹ-setoid
      ; sym                  to ≈ᴹ-sym
      ; trans                to ≈ᴹ-trans
      ; ∙-cong               to +ᴹ-cong
      ; ∙-congʳ              to +ᴹ-congʳ
      ; ∙-congˡ              to +ᴹ-congˡ
      )

    *ₗ-congˡ : LeftCongruent *ₗ
    *ₗ-congˡ mm = *ₗ-cong refl mm

    *ₗ-congʳ : RightCongruent _≈_ *ₗ
    *ₗ-congʳ xx = *ₗ-cong xx ≈ᴹ-refl

  record IsPrerightSemimodule (*ᵣ : Opᵣ R M) : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    open RightDefs R ≈ᴹ
    field
      *ᵣ-cong : Congruent _≈_ *ᵣ
      *ᵣ-zeroʳ : RightZero 0# 0ᴹ *ᵣ
      *ᵣ-distribˡ : *ᵣ DistributesOverˡ _+_ ⟶ +ᴹ
      *ᵣ-identityʳ : RightIdentity 1# *ᵣ
      *ᵣ-assoc : Associative _*_ *ᵣ
      *ᵣ-zeroˡ : LeftZero 0ᴹ *ᵣ
      *ᵣ-distribʳ : *ᵣ DistributesOverʳ +ᴹ

  record IsRightSemimodule (*ᵣ : Opᵣ R M) : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    open RightDefs R ≈ᴹ
    field
      +ᴹ-isCommutativeMonoid : IsCommutativeMonoid ≈ᴹ +ᴹ 0ᴹ
      isPrerightSemimodule : IsPrerightSemimodule *ᵣ

    open IsPrerightSemimodule isPrerightSemimodule public

    open IsCommutativeMonoid +ᴹ-isCommutativeMonoid public
      using () renaming
      ( assoc                to +ᴹ-assoc
      ; comm                 to +ᴹ-comm
      ; identity             to +ᴹ-identity
      ; identityʳ            to +ᴹ-identityʳ
      ; identityˡ            to +ᴹ-identityˡ
      ; isEquivalence        to ≈ᴹ-isEquivalence
      ; isMagma              to +ᴹ-isMagma
      ; isMonoid             to +ᴹ-isMonoid
      ; isPartialEquivalence to ≈ᴹ-isPartialEquivalence
      ; isSemigroup          to +ᴹ-isSemigroup
      ; refl                 to ≈ᴹ-refl
      ; reflexive            to ≈ᴹ-reflexive
      ; setoid               to ≈ᴹ-setoid
      ; sym                  to ≈ᴹ-sym
      ; trans                to ≈ᴹ-trans
      ; ∙-cong               to +ᴹ-cong
      ; ∙-congʳ              to +ᴹ-congʳ
      ; ∙-congˡ              to +ᴹ-congˡ
      )

    *ᵣ-congˡ : LeftCongruent _≈_ *ᵣ
    *ᵣ-congˡ xx = *ᵣ-cong ≈ᴹ-refl xx

    *ᵣ-congʳ : RightCongruent *ᵣ
    *ᵣ-congʳ mm = *ᵣ-cong mm refl

module _ (R-semiring : Semiring r ℓr) (S-semiring : Semiring s ℓs)
         (≈ᴹ : Rel {m} M ℓm) (+ᴹ : Op₂ M) (0ᴹ : M)
  where

  open Semiring R-semiring using () renaming (Carrier to R)
  open Semiring S-semiring using () renaming (Carrier to S)

  record IsBisemimodule (*ₗ : Opₗ R M) (*ᵣ : Opᵣ S M)
                        : Set (r ⊔ s ⊔ m ⊔ ℓr ⊔ ℓs ⊔ ℓm) where
    open BiDefs R S ≈ᴹ
    field
      +ᴹ-isCommutativeMonoid : IsCommutativeMonoid ≈ᴹ +ᴹ 0ᴹ
      isPreleftSemimodule : IsPreleftSemimodule R-semiring ≈ᴹ +ᴹ 0ᴹ *ₗ
      isPrerightSemimodule : IsPrerightSemimodule S-semiring ≈ᴹ +ᴹ 0ᴹ *ᵣ
      *ₗ-*ᵣ-assoc : Associative *ₗ *ᵣ

    isLeftSemimodule : IsLeftSemimodule R-semiring ≈ᴹ +ᴹ 0ᴹ *ₗ
    isLeftSemimodule = record
      { +ᴹ-isCommutativeMonoid = +ᴹ-isCommutativeMonoid
      ; isPreleftSemimodule = isPreleftSemimodule
      }

    isRightSemimodule : IsRightSemimodule S-semiring ≈ᴹ +ᴹ 0ᴹ *ᵣ
    isRightSemimodule = record
      { +ᴹ-isCommutativeMonoid = +ᴹ-isCommutativeMonoid
      ; isPrerightSemimodule = isPrerightSemimodule
      }

    open IsLeftSemimodule isLeftSemimodule public
      hiding (+ᴹ-isCommutativeMonoid; isPreleftSemimodule)
    open IsPrerightSemimodule isPrerightSemimodule public
    open IsRightSemimodule isRightSemimodule public
      using (*ᵣ-congˡ; *ᵣ-congʳ)

module _ (commutativeSemiring : CommutativeSemiring r ℓr)
         (≈ᴹ : Rel {m} M ℓm) (+ᴹ : Op₂ M) (0ᴹ : M)
  where

  open CommutativeSemiring commutativeSemiring renaming (Carrier to R)

  -- An R-semimodule is an R-R-bisemimodule where R is commutative.
  -- This means that *ₗ and *ᵣ coincide up to mathematical equality, though it
  -- may be that they do not coincide up to definitional equality.

  record IsSemimodule (*ₗ : Opₗ R M) (*ᵣ : Opᵣ R M)
                      : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    field
      isBisemimodule : IsBisemimodule semiring semiring ≈ᴹ +ᴹ 0ᴹ *ₗ *ᵣ

    open IsBisemimodule isBisemimodule public

module _ (ring : Ring r ℓr)
         (≈ᴹ : Rel {m} M ℓm) (+ᴹ : Op₂ M) (0ᴹ : M) (-ᴹ : Op₁ M)
  where

  open Ring ring renaming (Carrier to R)

  record IsLeftModule (*ₗ : Opₗ R M) : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    open Defs ≈ᴹ
    field
      isLeftSemimodule : IsLeftSemimodule semiring ≈ᴹ +ᴹ 0ᴹ *ₗ
      -ᴹ‿cong : Congruent₁ -ᴹ
      -ᴹ‿inverse : Inverse 0ᴹ -ᴹ +ᴹ

    open IsLeftSemimodule isLeftSemimodule public

    +ᴹ-isAbelianGroup : IsAbelianGroup ≈ᴹ +ᴹ 0ᴹ -ᴹ
    +ᴹ-isAbelianGroup = record
      { isGroup = record
        { isMonoid = +ᴹ-isMonoid
        ; inverse = -ᴹ‿inverse
        ; ⁻¹-cong = -ᴹ‿cong
        }
      ; comm = +ᴹ-comm
      }

    open IsAbelianGroup +ᴹ-isAbelianGroup public
      using () renaming
      ( isGroup    to +ᴹ-isGroup
      ; inverseˡ   to -ᴹ‿inverseˡ
      ; inverseʳ   to -ᴹ‿inverseʳ
      ; uniqueˡ-⁻¹ to uniqueˡ‿-ᴹ
      ; uniqueʳ-⁻¹ to uniqueʳ‿-ᴹ
      )

  record IsRightModule (*ᵣ : Opᵣ R M) : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    open Defs ≈ᴹ
    field
      isRightSemimodule : IsRightSemimodule semiring ≈ᴹ +ᴹ 0ᴹ *ᵣ
      -ᴹ‿cong : Congruent₁ -ᴹ
      -ᴹ‿inverse : Inverse 0ᴹ -ᴹ +ᴹ

    open IsRightSemimodule isRightSemimodule public

    +ᴹ-isAbelianGroup : IsAbelianGroup ≈ᴹ +ᴹ 0ᴹ -ᴹ
    +ᴹ-isAbelianGroup = record
      { isGroup = record
        { isMonoid = +ᴹ-isMonoid
        ; inverse = -ᴹ‿inverse
        ; ⁻¹-cong = -ᴹ‿cong
        }
      ; comm = +ᴹ-comm
      }

    open IsAbelianGroup +ᴹ-isAbelianGroup public
      using () renaming
      ( isGroup    to +ᴹ-isGroup
      ; inverseˡ   to -ᴹ‿inverseˡ
      ; inverseʳ   to -ᴹ‿inverseʳ
      ; uniqueˡ-⁻¹ to uniqueˡ‿-ᴹ
      ; uniqueʳ-⁻¹ to uniqueʳ‿-ᴹ
      )

module _ (R-ring : Ring r ℓr) (S-ring : Ring s ℓs)
         (≈ᴹ : Rel {m} M ℓm) (+ᴹ : Op₂ M) (0ᴹ : M) (-ᴹ : Op₁ M)
  where

  open Ring R-ring renaming (Carrier to R; semiring to R-semiring)
  open Ring S-ring renaming (Carrier to S; semiring to S-semiring)

  record IsBimodule (*ₗ : Opₗ R M) (*ᵣ : Opᵣ S M)
                    : Set (r ⊔ s ⊔ m ⊔ ℓr ⊔ ℓs ⊔ ℓm) where
    open Defs ≈ᴹ
    field
      isBisemimodule : IsBisemimodule R-semiring S-semiring ≈ᴹ +ᴹ 0ᴹ *ₗ *ᵣ
      -ᴹ‿cong : Congruent₁ -ᴹ
      -ᴹ‿inverse : Inverse 0ᴹ -ᴹ +ᴹ

    open IsBisemimodule isBisemimodule public

    isLeftModule : IsLeftModule R-ring ≈ᴹ +ᴹ 0ᴹ -ᴹ *ₗ
    isLeftModule = record
      { isLeftSemimodule = isLeftSemimodule
      ; -ᴹ‿cong = -ᴹ‿cong
      ; -ᴹ‿inverse = -ᴹ‿inverse
      }

    open IsLeftModule isLeftModule public
      using ( +ᴹ-isAbelianGroup; +ᴹ-isGroup; -ᴹ‿inverseˡ; -ᴹ‿inverseʳ
            ; uniqueˡ‿-ᴹ; uniqueʳ‿-ᴹ)

    isRightModule : IsRightModule S-ring ≈ᴹ +ᴹ 0ᴹ -ᴹ *ᵣ
    isRightModule = record
      { isRightSemimodule = isRightSemimodule
      ; -ᴹ‿cong = -ᴹ‿cong
      ; -ᴹ‿inverse = -ᴹ‿inverse
      }

module _ (commutativeRing : CommutativeRing r ℓr)
         (≈ᴹ : Rel {m} M ℓm) (+ᴹ : Op₂ M) (0ᴹ : M) (-ᴹ : Op₁ M)
  where

  open CommutativeRing commutativeRing renaming (Carrier to R)

  -- An R-module is an R-R-bimodule where R is commutative.
  -- This means that *ₗ and *ᵣ coincide up to mathematical equality, though it
  -- may be that they do not coincide up to definitional equality.

  record IsModule (*ₗ : Opₗ R M) (*ᵣ : Opᵣ R M) : Set (r ⊔ m ⊔ ℓr ⊔ ℓm) where
    field
      isBimodule : IsBimodule ring ring ≈ᴹ +ᴹ 0ᴹ -ᴹ *ₗ *ᵣ

    open IsBimodule isBimodule public

    isSemimodule : IsSemimodule commutativeSemiring ≈ᴹ +ᴹ 0ᴹ *ₗ *ᵣ
    isSemimodule = record { isBisemimodule = isBisemimodule }


open import GGT

-- Throughout the following assume A is a (right) Action
module GGT.Theory
  {a b ℓ₁ ℓ₂}
  (A : Action a b ℓ₁ ℓ₂)
  where

open import Level
open import Relation.Unary hiding (_\\_; _⇒_)
open import Relation.Binary
open import Algebra
open import Data.Product

open Action A renaming (setoid to Ω')
open import Relation.Binary.Reasoning.MultiSetoid
-- open import Relation.Binary.Reasoning.Setoid Ω' would be enough

open Group G renaming (setoid to S)
open import GGT.Group.Structures {a} {ℓ₂} {ℓ₁}
open import GGT.Group.Bundles {a} {ℓ₂} {ℓ₁}
open import Function.Bundles
open import Function.Base using (_on_)

orbitalEq : IsEquivalence _ω_
orbitalEq = record { refl =  r ;
                     sym  =  s ;
                     trans = t } where
  open Setoid Ω' renaming (sym to σ)
  r : Reflexive _ω_
  r {o} = ε , actId o

  s : Symmetric _ω_
  s {x} {y} ( g , x·g≡y ) = (g ⁻¹ , y·g⁻¹≡x) where
    y·g⁻¹≡x = σ x≡y·g⁻¹ where
      x≡y·g⁻¹ = begin⟨ Ω' ⟩
                  x              ≈˘⟨ actId x ⟩
                  x · ε          ≈˘⟨ G-ext (inverseʳ _) ⟩
                  x · (g ∙ g ⁻¹) ≈⟨ actAssoc _ _ _ ⟩
                  x · g · g ⁻¹   ≈⟨ ·-cong (g ⁻¹) x·g≡y ⟩
                  y · g ⁻¹ ∎
  t : Transitive _ω_
  t {x} {y} {z} ( g , x·g≡y ) ( h , y·h≡z ) = ( g ∙ h , x·gh≡z ) where
    x·gh≡z : _
    x·gh≡z = begin⟨ Ω' ⟩
              x · (g ∙ h) ≈⟨ actAssoc _ _ _ ⟩
              x · g · h ≈⟨ ·-cong _ x·g≡y ⟩
              y · h ≈⟨ y·h≡z ⟩
              z ∎

ω≤≋ : _≋_ ⇒ _ω_
ω≤≋ {o} {o'} o≋o' = (ε , oε≋o' ) where
  oε≋o' = begin⟨ Ω' ⟩
            o · ε ≈⟨ actId o ⟩
            o ≈⟨ o≋o' ⟩
            o' ∎

stabIsSubGroup : ∀ (o : Ω) → (stab o) ≤ G
stabIsSubGroup o = record { ε∈ = actId o ;
                            ∙-⁻¹-closed = itis ;
                            r = resp } where
  itis = λ {x} {y} px py → begin⟨ Ω' ⟩
                        (o · (x - y))  ≡⟨⟩
                        o · x ∙ (y ⁻¹) ≈⟨ actAssoc o x (y ⁻¹) ⟩
                        o · x · y ⁻¹ ≈⟨ ·-cong (y ⁻¹) px ⟩
                        o · y ⁻¹  ≈˘⟨ ·-cong (y ⁻¹) py ⟩
                        o · y · y ⁻¹ ≈˘⟨ actAssoc o y (y ⁻¹) ⟩
                        o · (y ∙ y ⁻¹) ≈⟨ G-ext (inverseʳ y) ⟩
                        o · ε ≈⟨ actId o ⟩
                        o ∎
  resp : ∀ {x y : Carrier} → x ≈ y → ((stab o) x) → ((stab o) y)
  resp {x} {y} x~y xfixeso = begin⟨ Ω' ⟩
                               o · y ≈˘⟨ G-ext x~y ⟩
                               o · x ≈⟨ xfixeso ⟩
                               o ∎

Stab : Ω → SubGroup G
Stab o = record { P = stab o;
                  isSubGroup = stabIsSubGroup o}

orbitalCorr : {o : Ω} → Bijection (Stab o \\ G) (Orbit o)
orbitalCorr {o} = record { f = f ;
                           cong = cc ;
                           bijective = inj ,′ surj } where
  open Setoid (Stab o \\ G) renaming (_≈_ to _≈₁_; Carrier to G')
  open Setoid (Orbit o)     renaming (_≈_ to _≈₂_)
  open Setoid S renaming (refl to r)

  f : G' → Σ Ω (o ·G)
  f x = (o · x , ( x , G-ext r))

  cc : f Preserves _≈₁_ ⟶ _≈₂_
  cc {g} {h} g≈₁h = begin⟨ Ω' ⟩  -- f h ≈₂ f g
                      o · g ≈˘⟨ actId (o · g) ⟩
                      o · g · ε ≈˘⟨ G-ext (inverseˡ h) ⟩
                      o · g · (h ⁻¹ ∙ h ) ≈˘⟨ actAssoc o g (h ⁻¹ ∙ h ) ⟩
                      o · (g  ∙ (h ⁻¹ ∙ h )) ≈˘⟨ G-ext (assoc _ _ _) ⟩
                      o · ((g  ∙ h ⁻¹) ∙ h ) ≈⟨ actAssoc _ _ h ⟩
                      o · (g  ∙ h ⁻¹) · h ≈⟨ ·-cong h g≈₁h ⟩
                      -- g≈₁h ⇒ P (g ∙ h ⁻¹) ⇒ (g ∙ h ⁻¹) ∈ Stab o
                      o · h ∎
  inj : _
  -- o · g = o · h ⇒ g ∙ h ⁻¹ ∈ Stab o
  inj {g} {h} fg≈₂fh = begin⟨ Ω' ⟩
                         o · g ∙ h ⁻¹ ≈⟨ actAssoc _ _ _ ⟩
                         o · g · h ⁻¹ ≈⟨ ·-cong _ fg≈₂fh ⟩
                         o · h · h ⁻¹ ≈˘⟨ actAssoc _ _ _ ⟩
                         o · (h ∙ h ⁻¹) ≈⟨ G-ext (inverseʳ h)⟩
                         o · ε ≈⟨ actId o ⟩
                         o ∎

  surj : _
  surj (_ , p) = p


import Algebra.FunctionProperties using (LeftZero; RightZero; _DistributesOverˡ_;_DistributesOverʳ_; Idempotent)
import Function using (_on_)
import Level
import Relation.Binary.EqReasoning as EqReasoning
import Relation.Binary.On using (isEquivalence)
import Algebra.Structures using (module IsCommutativeMonoid; IsCommutativeMonoid)
open import Relation.Binary    using (module IsEquivalence; IsEquivalence; _Preserves₂_⟶_⟶_ ; Setoid)
open import Data.Product renaming (_,_ to _,,_) -- just to avoid clash with other commas

open import Preliminaries using (Rel; UniqueSolution; LowerBound)

module SemiNearRingRecords where

record SemiNearRing : Set₁ where                  -- \structure{1}{|SemiNearRing|}
  field                                           -- \structure{1.1}{Carriers, operators}
     s : Set
     _≃s_  : s → s → Set
     zers  : s
     _+s_  : s → s → s
     _*s_  : s → s → s

  open Algebra.Structures                using (IsCommutativeMonoid)
  open Algebra.FunctionProperties _≃s_   using (LeftZero; RightZero)

  field                                           -- \structure{1.2}{Commutative monoid |(+,0)|}
    isCommMon : IsCommutativeMonoid _≃s_ _+s_ zers

    zeroˡ  : LeftZero   zers  _*s_   -- expands to |∀ x →  (zers *s x)  ≃s  zers|
    zeroʳ  : RightZero  zers  _*s_   -- expands to |∀ x →  (x *s zers)  ≃s  zers|
    _<*>_  : ∀ {x y u v} →  (x ≃s y)  →  (u ≃s v)  →  (x *s u   ≃s   y *s v)

  open Algebra.FunctionProperties _≃s_
    using (Idempotent; _DistributesOverˡ_; _DistributesOverʳ_)

  field                                           -- \structure{1.3}{Distributive, idempotent, \ldots}
     idem   : Idempotent _+s_

     distl  : _*s_ DistributesOverˡ _+s_
     distr  : _*s_ DistributesOverʳ _+s_
       -- expands to |∀ a b c →  (a +s b) *s c   ≃s   (a *s c) +s (b *s c)|

  infix  4 _≤s_
  _≤s_ : s -> s -> Set
  x ≤s y =  x +s y ≃s y

  infix 4 _≃s_; infixl 6 _+s_; infixl 7 _*s_

                                                  -- \structure{1.4}{Exporting commutative monoid operations}
  open Algebra.Structures.IsCommutativeMonoid isCommMon public
    hiding (refl)
    renaming
     (  isEquivalence  to isEquivs
     ;  assoc          to assocs
     ;  comm           to comms
     ;  ∙-cong         to _<+>_
     ;  identityˡ      to identityˡs
     )
  identityʳs = proj₂ identity

  sSetoid : Setoid Level.zero Level.zero          -- \structure{1.5}{Setoid, \ldots}
  sSetoid = record {  Carrier        = s;
                      _≈_            = _≃s_;
                      isEquivalence  = isEquivs }

  open IsEquivalence isEquivs public
    hiding   (reflexive) renaming (refl to refls ; sym to syms ; trans to transs)

  LowerBounds  = LowerBound  _≤s_                 -- \structure{1.6}{Lower bounds}

record SemiNearRing2 : Set₁ where                 -- \structure{2}{|SemiNearRing2|}
  field
    snr : SemiNearRing
  open SemiNearRing snr public   -- public = export the "local" names from |SemiNearRing|
  field                                           -- \structure{2.1}{Plus and times for |u|, \ldots}
     u : Set
     _+u_  : u → u → u
     _*u_  : u → u → u
     u2s   : u → s

  _≃u_ : u → u → Set
  _≃u_  = _≃s_ Function.on u2s

  _u*s_ : u → s → s
  _u*s_ u s =   u2s u  *s  s

  _s*u_ : s → u → s
  _s*u_ s u =   s  *s  u2s u

  infix   4  _≃u_;  infixl  6  _+u_;  infixl  7  _*u_ _u*s_ _s*u_

  uSetoid : Setoid Level.zero Level.zero
  uSetoid = record { isEquivalence = Relation.Binary.On.isEquivalence u2s isEquivs }

  _≤u_  : u → u → Set
  _≤u_  = _≤s_ Function.on u2s

  L : u → s → u → s → Set                         -- \structure{2.2}{Linear equation |L|}
  L a y b x =  y  +s  (a u*s x  +s  x s*u b) ≃s x

                                                  -- \structure{2.3}{Properties of |L|}
  UniqueL  = ∀ {a y b} → UniqueSolution _≃s_ (L a y b)
  CongL    = ∀ {a x b} -> ∀ {y y'} -> y ≃s y' -> L a y b x -> L a y' b x


------------------------------------------------------------------------------
-- Axiomatic PA propositional equality
------------------------------------------------------------------------------

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

module PA.Axiomatic.Mendelson.Relation.Binary.PropositionalEqualityI where

open import PA.Axiomatic.Mendelson.Base

------------------------------------------------------------------------------
-- Identity properties

≈-refl : ∀ {n} → n ≈ n
≈-refl {n} = S₁ (S₅ n) (S₅ n)

≈-sym : ∀ {m n} → m ≈ n → n ≈ m
≈-sym h = S₁ h ≈-refl

≈-trans : ∀ {m n o} → m ≈ n → n ≈ o → m ≈ o
≈-trans h = S₁ (≈-sym h)

------------------------------------------------------------------------------
-- Substitution

-- Using Mendelson's axioms we cannot prove

--    a ≈ b    A(x)
--  ----------------- substitution
--         A(x)

-- where A(x) is an arbitrary propositional function, We can prove
-- substitutivity of `_≈_` for the proper functional symbols of the
-- language (`succ`, `add` and `mult`). That is, we can prove (by
-- induction)

--   succCong    : ∀ {m n} → m ≈ n → succ m ≈ succ n
--   +-rightCong : ∀ {m n p} → n ≈ p → m + n ≈ m + p
--   +-leftCong  : ∀ {m n p} → m ≈ n → m + p ≈ n + p
--   *-rightCong : ∀ {m n p} → n ≈ p → m * n ≈ m * p
--   *-leftCong  : ∀ {m n p} → m ≈ n → m * p ≈ n * p

-- The proofs of the above properties are in the `PropertiesI` module.


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

-- nothing for the standard library needed directly!

open import FT
open import Equivalences
open import TypeEquivalences

-- We now have enough to map each Pi combinator to the corresponding type equivalence

path2equiv : {B₁ B₂ : FT} → (B₁ ⇛ B₂) → (⟦ B₁ ⟧ ≃ ⟦ B₂ ⟧)
path2equiv unite₊⇛  = unite₊equiv
path2equiv uniti₊⇛  = uniti₊equiv
path2equiv swap₊⇛   = swap₊equiv
path2equiv assocl₊⇛ = assocl₊equiv
path2equiv assocr₊⇛ = assocr₊equiv
path2equiv unite⋆⇛  = unite⋆equiv
path2equiv uniti⋆⇛  = uniti⋆equiv
path2equiv swap⋆⇛   = swap⋆equiv
path2equiv assocl⋆⇛ = assocl⋆equiv
path2equiv assocr⋆⇛ = assocr⋆equiv
path2equiv distz⇛   = distzequiv
path2equiv factorz⇛ = factorzequiv
path2equiv dist⇛    = distequiv
path2equiv factor⇛  = factorequiv
path2equiv id⇛      = idequiv
path2equiv (sym⇛ p) = sym≃ (path2equiv p)
path2equiv (p ◎ q)  = trans≃ (path2equiv p) (path2equiv q)
path2equiv (p ⊕ q)  = path⊎ (path2equiv p) (path2equiv q)
path2equiv (p ⊗ q)  = path× (path2equiv p) (path2equiv q)


------------------------------------------------------------------------
-- Bi-invertibility
------------------------------------------------------------------------

-- The development is based on the presentation of bi-invertibility
-- (for types and functions) and related things in the HoTT book.

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

open import Equality
open import Prelude hiding (id; _∘_)

-- The code is parametrised by something like a "raw" category.

module Bi-invertibility
  {e⁺}
  (eq : ∀ {a p} → Equality-with-J a p e⁺)
  {o h}
  (Obj : Type o)
  (Hom : Obj → Obj → Type h)
  (id : {A : Obj} → Hom A A)
  (_∘′_ : {A B C : Obj} → Hom B C → Hom A B → Hom A C)
  where

open Derived-definitions-and-properties eq
open import Equivalence eq as Eq using (_≃_; Is-equivalence)
open import Function-universe eq as F hiding (id; _∘_)
open import Logical-equivalence using (_⇔_)
open import H-level eq
open import H-level.Closure eq
open import Preimage eq
open import Surjection eq using (_↠_)

private
  variable
    A B : Obj
    f   : Hom A B

  infixr 9 _∘_

  _∘_ : {A B C : Obj} → Hom B C → Hom A B → Hom A C
  _∘_ = _∘′_

-- Has-left-inverse f means that f has a left inverse.

Has-left-inverse : Hom A B → Type h
Has-left-inverse f = ∃ λ f⁻¹ → f⁻¹ ∘ f ≡ id

-- Has-right-inverse f means that f has a right inverse.

Has-right-inverse : Hom A B → Type h
Has-right-inverse f = ∃ λ f⁻¹ → f ∘ f⁻¹ ≡ id

-- Is-bi-invertible f means that f has a left inverse and a (possibly
-- distinct) right inverse.

Is-bi-invertible : Hom A B → Type h
Is-bi-invertible f =
  Has-left-inverse f × Has-right-inverse f

-- Has-quasi-inverse f means that f has a left inverse that is also a
-- right inverse.

Has-quasi-inverse : Hom A B → Type h
Has-quasi-inverse f =
  ∃ λ f⁻¹ → f ∘ f⁻¹ ≡ id × f⁻¹ ∘ f ≡ id

-- Some notions of isomorphism or equivalence.

infix 4 _≊_ _≅_

_≊_ : Obj → Obj → Type h
A ≊ B = ∃ λ (f : Hom A B) → Is-bi-invertible f

_≅_ : Obj → Obj → Type h
A ≅ B = ∃ λ (f : Hom A B) → Has-quasi-inverse f

-- Morphisms with quasi-inverses are bi-invertible.

Has-quasi-inverse→Is-bi-invertible :
  (f : Hom A B) → Has-quasi-inverse f → Is-bi-invertible f
Has-quasi-inverse→Is-bi-invertible _ (f⁻¹ , f∘f⁻¹≡id , f⁻¹∘f≡id) =
    (f⁻¹ , f⁻¹∘f≡id)
  , (f⁻¹ , f∘f⁻¹≡id)

≅→≊ : A ≅ B → A ≊ B
≅→≊ = ∃-cong Has-quasi-inverse→Is-bi-invertible

-- The remaining code relies on some further assumptions, similar to
-- those of a precategory. However, note that Hom A B is not required
-- to be a set (some properties require Hom A A to be a set for some
-- A).

module More
  (left-identity  : {A B : Obj} (f : Hom A B) → id ∘ f ≡ f)
  (right-identity : {A B : Obj} (f : Hom A B) → f ∘ id ≡ f)
  (associativity  : {A B C D : Obj}
                    (f : Hom C D) (g : Hom B C) (h : Hom A B) →
                    f ∘ (g ∘ h) ≡ (f ∘ g) ∘ h)
  where

  -- Bi-invertible morphisms have quasi-inverses.

  Is-bi-invertible→Has-quasi-inverse :
    Is-bi-invertible f → Has-quasi-inverse f
  Is-bi-invertible→Has-quasi-inverse
    {f = f} ((f⁻¹₁ , f⁻¹₁∘f≡id) , (f⁻¹₂ , f∘f⁻¹₂≡id)) =
      (f⁻¹₁ ∘ f ∘ f⁻¹₂)
    , (f ∘ f⁻¹₁ ∘ f ∘ f⁻¹₂    ≡⟨ cong (f ∘_) $ associativity _ _ _ ⟩
       f ∘ (f⁻¹₁ ∘ f) ∘ f⁻¹₂  ≡⟨ cong (λ f′ → f ∘ f′ ∘ f⁻¹₂) f⁻¹₁∘f≡id ⟩
       f ∘ id ∘ f⁻¹₂          ≡⟨ cong (f ∘_) $ left-identity _ ⟩
       f ∘ f⁻¹₂               ≡⟨ f∘f⁻¹₂≡id ⟩∎
       id                     ∎)
    , ((f⁻¹₁ ∘ f ∘ f⁻¹₂) ∘ f  ≡⟨ cong (λ f′ → (f⁻¹₁ ∘ f′) ∘ f) f∘f⁻¹₂≡id ⟩
       (f⁻¹₁ ∘ id) ∘ f        ≡⟨ cong (_∘ f) $ right-identity _ ⟩
       f⁻¹₁ ∘ f               ≡⟨ f⁻¹₁∘f≡id ⟩∎
       id                     ∎)

  -- Has-left-inverse f is contractible if f has a quasi-inverse.

  Has-left-inverse-contractible :
    Has-quasi-inverse f → Contractible (Has-left-inverse f)
  Has-left-inverse-contractible
    {f = f} (f⁻¹ , f∘f⁻¹≡id , f⁻¹∘f≡id) =
    bijection⁻¹-contractible (record
      { surjection = record
        { logical-equivalence = record
          { to   = _∘ f
          ; from = _∘ f⁻¹
          }
        ; right-inverse-of = λ g →
            (g ∘ f⁻¹) ∘ f  ≡⟨ sym $ associativity _ _ _ ⟩
            g ∘ f⁻¹ ∘ f    ≡⟨ cong (g ∘_) f⁻¹∘f≡id ⟩
            g ∘ id         ≡⟨ right-identity _ ⟩∎
            g              ∎
        }
      ; left-inverse-of = λ g →
          (g ∘ f) ∘ f⁻¹  ≡⟨ sym $ associativity _ _ _ ⟩
          g ∘ f ∘ f⁻¹    ≡⟨ cong (g ∘_) f∘f⁻¹≡id ⟩
          g ∘ id         ≡⟨ right-identity _ ⟩∎
          g              ∎
      })
      id

  -- Has-right-inverse f is contractible if f has a quasi-inverse.

  Has-right-inverse-contractible :
    Has-quasi-inverse f → Contractible (Has-right-inverse f)
  Has-right-inverse-contractible
    {f = f} (f⁻¹ , f∘f⁻¹≡id , f⁻¹∘f≡id) =
    bijection⁻¹-contractible (record
      { surjection = record
        { logical-equivalence = record
          { to   = f ∘_
          ; from = f⁻¹ ∘_
          }
        ; right-inverse-of = λ g →
            f ∘ f⁻¹ ∘ g    ≡⟨ associativity _ _ _ ⟩
            (f ∘ f⁻¹) ∘ g  ≡⟨ cong (_∘ g) f∘f⁻¹≡id ⟩
            id ∘ g         ≡⟨ left-identity _ ⟩∎
            g              ∎
        }
      ; left-inverse-of = λ g →
          f⁻¹ ∘ f ∘ g    ≡⟨ associativity _ _ _ ⟩
          (f⁻¹ ∘ f) ∘ g  ≡⟨ cong (_∘ g) f⁻¹∘f≡id ⟩
          id ∘ g         ≡⟨ left-identity _ ⟩∎
          g              ∎
      })
      id

  -- Is-bi-invertible f is a proposition.

  Is-bi-invertible-propositional :
    (f : Hom A B) → Is-proposition (Is-bi-invertible f)
  Is-bi-invertible-propositional f =
    [inhabited⇒+]⇒+ 0 λ b →
      let q = Is-bi-invertible→Has-quasi-inverse b in
      mono₁ 0 $
      ×-closure 0
        (Has-left-inverse-contractible  q)
        (Has-right-inverse-contractible q)

  -- If Hom A A is a set, where A is the domain of f, then
  -- Has-quasi-inverse f is a proposition.

  Has-quasi-inverse-propositional-domain :
    {f : Hom A B} →
    Is-set (Hom A A) →
    Is-proposition (Has-quasi-inverse f)
  Has-quasi-inverse-propositional-domain {f = f} s =              $⟨ (λ inv → Σ-closure 1
                                                                                (mono₁ 0 $ Has-right-inverse-contractible inv)
                                                                                (λ _ → s)) ⟩
    (Has-quasi-inverse f →
     Is-proposition (∃ λ ((f⁻¹ , _) : Has-right-inverse f) →
                       f⁻¹ ∘ f ≡ id))                             ↝⟨ (∀-cong _ λ _ → H-level-cong _ 1 (inverse Σ-assoc)) ⟩

    (Has-quasi-inverse f → Is-proposition (Has-quasi-inverse f))  ↝⟨ [inhabited⇒+]⇒+ 0 ⟩□

    Is-proposition (Has-quasi-inverse f)                          □

  -- If Hom B B is a set, where B is the codomain of f, then
  -- Has-quasi-inverse f is a proposition.

  Has-quasi-inverse-propositional-codomain :
    {f : Hom A B} →
    Is-set (Hom B B) →
    Is-proposition (Has-quasi-inverse f)
  Has-quasi-inverse-propositional-codomain {f = f} s =            $⟨ (λ inv → Σ-closure 1
                                                                                (mono₁ 0 $ Has-left-inverse-contractible inv)
                                                                                (λ _ → s)) ⟩
    (Has-quasi-inverse f →
     Is-proposition (∃ λ ((f⁻¹ , _) : Has-left-inverse f) →
                       f ∘ f⁻¹ ≡ id))                             ↝⟨ (∀-cong _ λ _ → H-level-cong _ 1 lemma) ⟩

    (Has-quasi-inverse f → Is-proposition (Has-quasi-inverse f))  ↝⟨ [inhabited⇒+]⇒+ 0 ⟩□

    Is-proposition (Has-quasi-inverse f)                          □
    where
    lemma =
      (∃ λ ((f⁻¹ , _) : Has-left-inverse f) → f ∘ f⁻¹ ≡ id)      ↔⟨⟩
      (∃ λ ((f⁻¹ , _) : ∃ λ f⁻¹ → f⁻¹ ∘ f ≡ id) → f ∘ f⁻¹ ≡ id)  ↝⟨ inverse Σ-assoc ⟩
      (∃ λ f⁻¹ → f⁻¹ ∘ f ≡ id × f ∘ f⁻¹ ≡ id)                    ↝⟨ (∃-cong λ _ → ×-comm) ⟩
      (∃ λ f⁻¹ → f ∘ f⁻¹ ≡ id × f⁻¹ ∘ f ≡ id)                    ↔⟨⟩
      Has-quasi-inverse f                                        □

  -- There is a split surjection from Has-quasi-inverse f to
  -- Is-bi-invertible f.

  Has-quasi-inverse↠Is-bi-invertible :
    Has-quasi-inverse f ↠ Is-bi-invertible f
  Has-quasi-inverse↠Is-bi-invertible = record
    { logical-equivalence = record
      { to   = Has-quasi-inverse→Is-bi-invertible _
      ; from = Is-bi-invertible→Has-quasi-inverse
      }
    ; right-inverse-of = λ _ → Is-bi-invertible-propositional _ _ _
    }

  -- There is a split surjection from A ≅ B to A ≊ B.

  ≅↠≊ : (A ≅ B) ↠ (A ≊ B)
  ≅↠≊ = ∃-cong λ _ → Has-quasi-inverse↠Is-bi-invertible

  -- Is-bi-invertible and Has-quasi-inverse are equivalent for
  -- morphisms with domain A for which Hom A A is a set.

  Is-bi-invertible≃Has-quasi-inverse-domain :
    {f : Hom A B} →
    Is-set (Hom A A) →
    Is-bi-invertible f ≃ Has-quasi-inverse f
  Is-bi-invertible≃Has-quasi-inverse-domain s =
    inverse $ Eq.↔⇒≃ (record
      { surjection = Has-quasi-inverse↠Is-bi-invertible
      ; left-inverse-of = λ _ →
          Has-quasi-inverse-propositional-domain s _ _
      })

  -- Is-bi-invertible and Has-quasi-inverse are equivalent for
  -- morphisms with codomain B for which Hom B B is a set.

  Is-bi-invertible≃Has-quasi-inverse-codomain :
    {f : Hom A B} →
    Is-set (Hom B B) →
    Is-bi-invertible f ≃ Has-quasi-inverse f
  Is-bi-invertible≃Has-quasi-inverse-codomain s =
    inverse $ Eq.↔⇒≃ (record
      { surjection = Has-quasi-inverse↠Is-bi-invertible
      ; left-inverse-of = λ _ →
          Has-quasi-inverse-propositional-codomain s _ _
      })

  -- A ≊ B and A ≅ B are equivalent if Hom A A is a set.

  ≊≃≅-domain :
    Is-set (Hom A A) →
    (A ≊ B) ≃ (A ≅ B)
  ≊≃≅-domain s =
    ∃-cong λ _ → Is-bi-invertible≃Has-quasi-inverse-domain s

  -- A ≊ B and A ≅ B are equivalent if Hom B B is a set.

  ≊≃≅-codomain :
    Is-set (Hom B B) →
    (A ≊ B) ≃ (A ≅ B)
  ≊≃≅-codomain s =
    ∃-cong λ _ → Is-bi-invertible≃Has-quasi-inverse-codomain s

  -- An equality characterisation lemma for _≊_.

  equality-characterisation-≊ :
    (f g : A ≊ B) → (f ≡ g) ≃ (proj₁ f ≡ proj₁ g)
  equality-characterisation-≊ _ _ =
    Eq.↔⇒≃ $ inverse $ ignore-propositional-component $
      Is-bi-invertible-propositional _

  -- Two equality characterisation lemmas for _≅_.

  equality-characterisation-≅-domain :
    Is-set (Hom A A) →
    (f g : A ≅ B) → (f ≡ g) ≃ (proj₁ f ≡ proj₁ g)
  equality-characterisation-≅-domain s _ _ =
    Eq.↔⇒≃ $ inverse $ ignore-propositional-component $
      Has-quasi-inverse-propositional-domain s

  equality-characterisation-≅-codomain :
    Is-set (Hom B B) →
    (f g : A ≅ B) → (f ≡ g) ≃ (proj₁ f ≡ proj₁ g)
  equality-characterisation-≅-codomain s _ _ =
    Eq.↔⇒≃ $ inverse $ ignore-propositional-component $
      Has-quasi-inverse-propositional-codomain s

  -- If f : Hom A B has a quasi-inverse, then Has-quasi-inverse f is
  -- equivalent to id ≡ id, where id stands for either the identity at
  -- A or at B.

  Has-quasi-inverse≃id≡id-domain :
    {f : Hom A B} →
    Has-quasi-inverse f →
    Has-quasi-inverse f ≃ (id ≡ id {A = A})
  Has-quasi-inverse≃id≡id-domain {f = f} q-inv@(f⁻¹ , _ , f⁻¹∘f≡id) =
    Has-quasi-inverse f                                     ↔⟨ Σ-assoc ⟩
    (∃ λ ((f⁻¹ , _) : Has-right-inverse f) → f⁻¹ ∘ f ≡ id)  ↔⟨ drop-⊤-left-Σ (_⇔_.to contractible⇔↔⊤ $ Has-right-inverse-contractible q-inv) ⟩
    (f⁻¹ ∘ id) ∘ f ≡ id                                     ↝⟨ ≡⇒↝ _ $ cong (λ f′ → f′ ∘ _ ≡ _) $ right-identity _ ⟩
    f⁻¹ ∘ f ≡ id                                            ↝⟨ ≡⇒↝ _ $ cong (_≡ _) f⁻¹∘f≡id ⟩□
    id ≡ id                                                 □

  Has-quasi-inverse≃id≡id-codomain :
    {f : Hom A B} →
    Has-quasi-inverse f →
    Has-quasi-inverse f ≃ (id ≡ id {A = B})
  Has-quasi-inverse≃id≡id-codomain {f = f} q-inv@(f⁻¹ , f∘f⁻¹≡id , _) =
    Has-quasi-inverse f                                    ↔⟨ Σ-assoc F.∘ (∃-cong λ _ → ×-comm) ⟩
    (∃ λ ((f⁻¹ , _) : Has-left-inverse f) → f ∘ f⁻¹ ≡ id)  ↔⟨ drop-⊤-left-Σ (_⇔_.to contractible⇔↔⊤ $ Has-left-inverse-contractible q-inv) ⟩
    f ∘ id ∘ f⁻¹ ≡ id                                      ↝⟨ ≡⇒↝ _ $ cong (λ f′ → _ ∘ f′ ≡ _) $ left-identity _ ⟩
    f ∘ f⁻¹ ≡ id                                           ↝⟨ ≡⇒↝ _ $ cong (_≡ _) f∘f⁻¹≡id ⟩□
    id ≡ id                                                □

  ----------------------------------------------------------------------
  -- Univalence

  -- The relation _≅_ is reflexive.

  id-≅ : A ≅ A
  id-≅ = id , id , left-identity id , right-identity id

  -- Equal objects are related by _≅_.

  ≡→≅ : A ≡ B → A ≅ B
  ≡→≅ = elim (λ {A B} _ → A ≅ B) (λ _ → id-≅)

  -- A "computation" rule for ≡→≅.

  ≡→≅-refl : ≡→≅ (refl A) ≡ id-≅
  ≡→≅-refl = elim-refl _ _

  -- A notion of univalence, defined using _≅_.

  Univalence-≅ : Type (o ⊔ h)
  Univalence-≅ = {A B : Obj} → Is-equivalence (≡→≅ {A = A} {B = B})

  -- If equality is equivalent to _≅_, then univalence holds.

  ≡≃≅→Univalence-≅ :
    (∀ {A B} → (A ≡ B) ≃ (A ≅ B)) →
    Univalence-≅
  ≡≃≅→Univalence-≅ ≡≃≅ =
    Eq.≡≃→≡→→Is-equivalence (_ ≅_) ≡≃≅ ≡→≅

  -- The relation _≊_ is reflexive.

  id-≊ : A ≊ A
  id-≊ = id , (id , left-identity id) , (id , right-identity id)

  -- Equal objects are related by _≊_.

  ≡→≊ : A ≡ B → A ≊ B
  ≡→≊ = elim (λ {A B} _ → A ≊ B) (λ _ → id-≊)

  -- A "computation" rule for ≡→≊.

  ≡→≊-refl : ≡→≊ (refl A) ≡ id-≊
  ≡→≊-refl = elim-refl _ _

  -- A notion of univalence, defined using _≊_.

  Univalence-≊ : Type (o ⊔ h)
  Univalence-≊ = {A B : Obj} → Is-equivalence (≡→≊ {A = A} {B = B})

  -- If equality is equivalent to _≊_, then univalence holds.

  ≡≃≊→Univalence-≊ :
    (∀ {A B} → (A ≡ B) ≃ (A ≊ B)) →
    Univalence-≊
  ≡≃≊→Univalence-≊ ≡≃≊ =
    Eq.≡≃→≡→→Is-equivalence (_ ≊_) ≡≃≊ ≡→≊


module SafetyProof where

open import Algebra
import Algebra.Properties.CommutativeSemigroup as CommutativeSemigroupProperties
open import Data.List
open import Data.List.Relation.Unary.All using (All; []; _∷_)
open import Data.Fin.Patterns using (0F; 1F)
open import Data.Nat using (z≤n; s≤s)
open import Data.Integer using (+≤+; +<+; +_)
open import Data.Vec using (_∷_)
import Data.Vec.Functional as Vector
open import Data.Product using (_×_; _,_; uncurry)
open import Data.Sum
open import Level using (0ℓ)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)

open import Vehicle.Data.Tensor
open import AbstractRationals
import WindControllerSpec as Vehicle

open ≤-Reasoning

------------------------------------------------------------------------
-- Setup

toTensor : ℚ → ℚ → Tensor ℚ (2 ∷ [])
toTensor x y = Vector.fromList (x ∷ y ∷ [])

roadWidth : ℚ
roadWidth = + 3 / 1

maxWindShift : ℚ
maxWindShift = 1ℚ

maxSensorError : ℚ
maxSensorError = + 1 / 4

roadWidth≥0 : roadWidth ≥ 0ℚ
roadWidth≥0 = *≤* (+≤+ z≤n)

maxWindShift≥0 : maxWindShift ≥ 0ℚ
maxWindShift≥0 = *≤* (+≤+ z≤n)

maxSensorError≥0 : maxSensorError ≥ 0ℚ
maxSensorError≥0 = *≤* (+≤+ z≤n)

------------------------------------------------------------------------
-- Model data

record State : Set where
  constructor state
  field
    windSpeed : ℚ
    position  : ℚ
    velocity  : ℚ
    sensor    : ℚ

open State

record Observation : Set where
  constructor observe
  field
    windShift   : ℚ
    sensorError : ℚ

open Observation

------------------------------------------------------------------------
-- Model transitions

initialState : State
initialState = record
  { windSpeed = 0ℚ
  ; position  = 0ℚ
  ; velocity  = 0ℚ
  ; sensor    = 0ℚ
  }

controller : ℚ → ℚ → ℚ
controller x y = Vehicle.controller (toTensor x y)

nextState : Observation → State → State
nextState o s = record
  { windSpeed = newWindSpeed
  ; position  = newPosition
  ; velocity  = newVelocity
  ; sensor    = newSensor
  }
  where
  newWindSpeed = windSpeed s + windShift o
  newPosition  = position s + velocity s + newWindSpeed
  newSensor    = newPosition + sensorError o
  newVelocity  = velocity s + controller newSensor (sensor s)

finalState : List Observation → State
finalState xs = foldr nextState initialState xs

------------------------------------------------------------------------
-- Definition of correctness

nextPosition-windShift : State → ℚ
nextPosition-windShift s = position s + velocity s + windSpeed s

-- The vehicle is on the road if its position is less than the
-- width of the road.
OnRoad : State → Set
OnRoad s = ∣ position s ∣ ≤ roadWidth

-- The vehicle is in a "safe" state if it's more than the maxWindShift away
-- from the edge of the road.
SafeDistanceFromEdge : State → Set
SafeDistanceFromEdge s = ∣ nextPosition-windShift s ∣ < roadWidth - maxWindShift

-- The vehicle's previous sensor reading is accurate if it is no more than the
-- maximum error away from it's true location.
AccurateSensorReading : State → Set
AccurateSensorReading s = ∣ position s - sensor s ∣ ≤ maxSensorError

-- The vehicle's previous sensor reading was not off the road
SensorReadingNotOffRoad : State → Set
SensorReadingNotOffRoad s = ∣ sensor s ∣ ≤ roadWidth + maxSensorError

-- A state is safe if it both a safe distance from the edge and it's sensor
-- reading is accurate.
SafeState : State → Set
SafeState s = SafeDistanceFromEdge s
            × AccurateSensorReading s
            × SensorReadingNotOffRoad s

-- An observation is valid if the observed sensor error and the wind shift
-- are less than the expected maximum shifts.
ValidObservation : Observation → Set
ValidObservation o = ∣ sensorError o ∣ ≤ maxSensorError
                   × ∣ windShift   o ∣ ≤ maxWindShift

------------------------------------------------------------------------
-- Proof of correctness

-- Initial state is both a safe distance from the edge and on the road

initialState-onRoad : OnRoad initialState
initialState-onRoad = roadWidth≥0

initialState-safe : SafeState initialState
initialState-safe rewrite +-eq | *-eq | neg-eq =
  *<* (+<+ (s≤s z≤n)) ,
  *≤* (+≤+ z≤n) ,
  *≤* (+≤+ z≤n)

-- Transitions are well-behaved

controller-lem : ∀ x y →
                 ∣ x ∣ ≤ roadWidth + maxSensorError →
                 ∣ y ∣ ≤ roadWidth + maxSensorError →
                 ∣ controller x y + 2ℚ * x - y ∣ < roadWidth - maxWindShift - 3ℚ * maxSensorError
controller-lem x y ∣x∣≤rw+εₘₐₓ ∣y∣≤rw+εₘₐₓ rewrite +-eq | *-eq | neg-eq =
  uncurry -p<q<p⇒∣q∣<p (Vehicle.safe (toTensor x y) (λ
    { 0F → ∣p∣≤q⇒-q≤p≤q x ∣x∣≤rw+εₘₐₓ
    ; 1F → ∣p∣≤q⇒-q≤p≤q y ∣y∣≤rw+εₘₐₓ
    }))

valid⇒nextState-accurateSensor : ∀ o → ValidObservation o → ∀ s →
                                 AccurateSensorReading (nextState o s)
valid⇒nextState-accurateSensor o (ε≤εₘₐₓ , _) s = let s' = nextState o s in begin
  ∣ position s' - sensor s' ∣                     ≡⟨⟩
  ∣ position s' - (position s' + sensorError o) ∣ ≡⟨ cong ∣_∣ (p-[p+q]≡q (position s') (sensorError o)) ⟩
  ∣ sensorError o ∣                               ≤⟨ ε≤εₘₐₓ ⟩
  maxSensorError                                  ∎

valid+safe⇒nextState-onRoad : ∀ o → ValidObservation o →
                              ∀ s → SafeState s →
                              OnRoad (nextState o s)
valid+safe⇒nextState-onRoad o (_ , δw≤δwₘₐₓ) s (safeDist , _ , _) = begin
  ∣ position s + velocity s + (windSpeed s + windShift o) ∣ ≡˘⟨ cong ∣_∣ (+-assoc (position s + velocity s) (windSpeed s) (windShift o)) ⟩
  ∣ position s + velocity s + windSpeed s + windShift o   ∣ ≤⟨ ∣p+q∣≤∣p∣+∣q∣ _ (windShift o) ⟩
  ∣ nextPosition-windShift s ∣ + ∣ windShift o ∣            ≤⟨ +-mono-≤ (<⇒≤ safeDist) δw≤δwₘₐₓ ⟩
  roadWidth - maxWindShift + maxWindShift                   ≡⟨ p-q+q≡p roadWidth maxWindShift ⟩
  roadWidth                                                 ∎

valid+safe⇒nextState-sensorReadingNotOffRoad : ∀ s → SafeState s → ∀ o → ValidObservation o →
                                               SensorReadingNotOffRoad (nextState o s)
valid+safe⇒nextState-sensorReadingNotOffRoad s safe o valid@(ε≤εₘₐₓ , _) = begin
  ∣ position (nextState o s) + sensorError o ∣       ≤⟨ ∣p+q∣≤∣p∣+∣q∣ (position s + velocity s + (windSpeed s + windShift o)) (sensorError o) ⟩
  ∣ position (nextState o s) ∣ + ∣ sensorError o ∣   ≤⟨ +-mono-≤ (valid+safe⇒nextState-onRoad o valid s safe) ε≤εₘₐₓ ⟩
  roadWidth + maxSensorError                         ∎

valid+safe⇒nextState-safeDistanceFromEdge : ∀ o → ValidObservation o →
                                            ∀ s → SafeState s →
                                            SafeDistanceFromEdge (nextState o s)
valid+safe⇒nextState-safeDistanceFromEdge o valid@(ε-accurate , _) s safe@(safeDist , ε'-accurate , s-notOffRoad) = let
    s' = nextState o s
    y  = position  s; y' = position  s'
    v  = velocity  s; v' = velocity  s'
    w  = windSpeed s; w' = windSpeed s'
    p  = sensor    s; p' = sensor    s'
    ε  = y - p;       ε' = sensorError o
    dw = windShift   o
    dv = controller p' p
    ∣dv+2p'-p∣ = ∣ dv + 2ℚ * p' - p ∣
    s'-notOffRoad = valid+safe⇒nextState-sensorReadingNotOffRoad s safe o valid
  in begin-strict
  ∣ y' + v' + w' ∣                                                  ≡⟨ cong ∣_∣ (sym (p+q-q≡p (y' + v' + w') _)) ⟩
  ∣ y' + (v + dv) + w' + (y + ε' + ε' - p) - (y + ε' + ε' - p) ∣    ≡⟨ cong ∣_∣ (lem1 y' v dv w' y ε' p) ⟩
  ∣ dv + (y' + ε' + (y + v + w' + ε')) - p - (ε' + ε' + (y - p)) ∣  ≡⟨⟩
  ∣ dv + (p' + p') - p - (ε' + ε' + (y - p)) ∣                      ≡⟨ cong ∣_∣ (cong₂ (λ a b → dv + a - p - (b + (y - p))) (sym (2*p≡p+p p')) (sym (2*p≡p+p ε'))) ⟩
  ∣ dv + 2ℚ * p' - p - (2ℚ * ε' + (y - p)) ∣                        ≤⟨ ∣p-q∣≤∣p∣+∣q∣ (dv + 2ℚ * p' - p) (2ℚ * ε' + (y - p)) ⟩
  ∣ dv + 2ℚ * p' - p ∣ + ∣ 2ℚ * ε' + (y - p) ∣                      ≤⟨ +-monoʳ-≤ _ (∣p+q∣≤∣p∣+∣q∣ (2ℚ * ε') (y - p)) ⟩
  ∣ dv + 2ℚ * p' - p ∣ + (∣ 2ℚ * ε' ∣ + ∣ y - p ∣)                  ≡⟨ cong (λ v → ∣dv+2p'-p∣ + v) (cong (_+ _) (∣p*q∣≡∣p∣*∣q∣ 2ℚ ε')) ⟩
  ∣ dv + 2ℚ * p' - p ∣ + (2ℚ * ∣ ε' ∣ + ∣ ε ∣)                      ≤⟨ +-monoʳ-≤ _ (+-mono-≤ (*-monoʳ-≤ 2ℚ _ ε-accurate) ε'-accurate) ⟩
  ∣ dv + 2ℚ * p' - p ∣ + (2ℚ * maxSensorError + maxSensorError)     ≡⟨ cong (λ v → ∣dv+2p'-p∣ + v) (2p+p≡3p maxSensorError) ⟩
  ∣ dv + 2ℚ * p' - p ∣ + 3ℚ * maxSensorError                        <⟨ p<r-q⇒p+q<r _ _ _ (controller-lem p' p s'-notOffRoad s-notOffRoad) ⟩
  roadWidth - maxWindShift                                          ∎

safe⇒nextState-safe : ∀ s → SafeState s → ∀ o → ValidObservation o → SafeState (nextState o s)
safe⇒nextState-safe s safe o valid =
  valid+safe⇒nextState-safeDistanceFromEdge o valid s safe ,
  valid⇒nextState-accurateSensor o valid s ,
  valid+safe⇒nextState-sensorReadingNotOffRoad s safe o valid

finalState-safe : ∀ xs → All ValidObservation xs → SafeState (finalState xs)
finalState-safe []       []         = initialState-safe
finalState-safe (x ∷ xs) (px ∷ pxs) = safe⇒nextState-safe (finalState xs) (finalState-safe xs pxs) x px

finalState-onRoad : ∀ xs → All ValidObservation xs → OnRoad (finalState xs)
finalState-onRoad []       []         = initialState-onRoad
finalState-onRoad (x ∷ xs) (px ∷ pxs) = valid+safe⇒nextState-onRoad x px (finalState xs) (finalState-safe xs pxs)


open import Nat
open import Prelude
open import core
open import contexts

module typ-dec where
  lemma-arr-l : ∀{t1 t2 t4} → t1 ==> t2 == t1 ==> t4 → t2 == t4
  lemma-arr-l refl = refl

  lemma-arr-r : ∀{t1 t2 t3} → t1 ==> t2 == t3 ==> t2 → t1 == t3
  lemma-arr-r refl = refl

  lemma-arr-b : ∀{t1 t2 t3 t4} → t1 ==> t2 == t3 ==> t4 → t1 == t3
  lemma-arr-b refl = refl

  lemma-prod-l : ∀{t1 t2 t4} → t1 ⊗ t2 == t1 ⊗ t4 → t2 == t4
  lemma-prod-l refl = refl

  lemma-prod-r : ∀{t1 t2 t3} → t1 ⊗ t2 == t3 ⊗ t2 → t1 == t3
  lemma-prod-r refl = refl

  lemma-prod-b : ∀{t1 t2 t3 t4} → t1 ⊗ t2 == t3 ⊗ t4 → t1 == t3
  lemma-prod-b refl = refl

  -- types are decidable
  typ-dec : dec typ
  typ-dec b b = Inl refl
  typ-dec b ⦇·⦈ = Inr (λ ())
  typ-dec b (t2 ==> t3) = Inr (λ ())
  typ-dec ⦇·⦈ b = Inr (λ ())
  typ-dec ⦇·⦈ ⦇·⦈ = Inl refl
  typ-dec ⦇·⦈ (t2 ==> t3) = Inr (λ ())
  typ-dec (t1 ==> t2) b = Inr (λ ())
  typ-dec (t1 ==> t2) ⦇·⦈ = Inr (λ ())
  typ-dec (t1 ==> t2) (t3 ==> t4) with typ-dec t1 t3 | typ-dec t2 t4
  typ-dec (t1 ==> t2) (.t1 ==> .t2) | Inl refl | Inl refl = Inl refl
  typ-dec (t1 ==> t2) (.t1 ==> t4)  | Inl refl | Inr x₁   = Inr (λ x → x₁ (lemma-arr-l x))
  typ-dec (t1 ==> t2) (t3 ==> .t2)  | Inr x    | Inl refl = Inr (λ x₁ → x (lemma-arr-r x₁))
  typ-dec (t1 ==> t2) (t3 ==> t4)   | Inr x    | Inr x₁   = Inr (λ x₂ → x (lemma-arr-b x₂))
  typ-dec b (t2 ⊗ t3) = Inr (λ ())
  typ-dec ⦇·⦈ (t2 ⊗ t3) = Inr (λ ())
  typ-dec (t1 ==> t2) (t3 ⊗ t4) = Inr (λ ())
  typ-dec (t1 ⊗ t2) b = Inr (λ ())
  typ-dec (t1 ⊗ t2) ⦇·⦈ = Inr (λ ())
  typ-dec (t1 ⊗ t2) (t3 ==> t4) = Inr (λ ())
  typ-dec (t1 ⊗ t2) (t3 ⊗ t4) with typ-dec t1 t3 | typ-dec t2 t4
  typ-dec (t1 ⊗ t2) (.t1 ⊗ .t2) | Inl refl | Inl refl = Inl refl
  typ-dec (t1 ⊗ t2) (.t1 ⊗ t4)  | Inl refl | Inr x₁   = Inr (λ x → x₁ (lemma-prod-l x))
  typ-dec (t1 ⊗ t2) (t3 ⊗ .t2)  | Inr x    | Inl refl = Inr (λ x' → x (lemma-prod-r x'))
  typ-dec (t1 ⊗ t2) (t3 ⊗ t4)   | Inr x    | Inr x₁   = Inr (λ x' → x (lemma-prod-b x'))

  -- if an arrow is disequal, it disagrees in the first or second argument
  ne-factor : ∀{τ1 τ2 τ3 τ4} → (τ1 ==> τ2) ≠ (τ3 ==> τ4) → (τ1 ≠ τ3) + (τ2 ≠ τ4)
  ne-factor {τ1} {τ2} {τ3} {τ4} ne with typ-dec τ1 τ3 | typ-dec τ2 τ4
  ne-factor ne | Inl refl | Inl refl = Inl (λ x → ne refl)
  ne-factor ne | Inl x | Inr x₁ = Inr x₁
  ne-factor ne | Inr x | Inl x₁ = Inl x
  ne-factor ne | Inr x | Inr x₁ = Inl x


module Functor where

open import Category as Cat

record Functor (ℂ ⅅ : Cat) : Set1 where
  field
    F          : Cat.Obj ℂ -> Cat.Obj ⅅ
    map        : {A B : Cat.Obj ℂ} -> Cat._─→_ ℂ A B -> Cat._─→_ ⅅ (F A) (F B)
    mapEq      : {A B : Cat.Obj ℂ}{f g : Cat._─→_ ℂ A B} -> Category._==_ ℂ f g ->
                 Category._==_ ⅅ (map f) (map g)
    mapId      : {A : Cat.Obj ℂ} -> Category._==_ ⅅ (map (Cat.id ℂ {A})) (Cat.id ⅅ)
    mapCompose : {A B C : Cat.Obj ℂ}{f : Cat._─→_ ℂ B C}{g : Cat._─→_ ℂ A B} ->
                 Category._==_ ⅅ (map (Cat._∘_ ℂ f g)) (Cat._∘_ ⅅ (map f) (map g))