module Data.Boolean.Proofs where

import      Lvl
open import Data
open import Data.Boolean
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Logic using (_⊼_ ; _⊽_ ; _⊕_)
open        Data.Boolean.Operators.Programming
open import Data.Either as Either using (_‖_ ; Left ; Right)
open import Functional
open import Logic.IntroInstances
open import Logic.Propositional as Logic using (_∨_ ; _∧_ ; ¬_ ; _↔_ ; [⊤]-intro ; [↔]-intro ; [⊥]-elim ; [↔]-to-[←] ; [↔]-to-[→])
open import Logic.Predicate
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Operator.Monoid
import      Structure.Operator.Names as Names
open import Structure.Operator.Properties
open import Type

private variable ℓ : Lvl.Level
private variable T : Type{ℓ}
private variable P : Bool → Type{ℓ}
private variable a b c t f : Bool
private variable x y : Bool
private variable pt pf : ∀{b} → P(b)

---------------------------------------------
-- Eliminator

module _ {pt pf : T} where
  elim-nested : (elim pt pf (elim t f b) ≡ elim{T = const T} (elim pt pf t) (elim pt pf f) b)
  elim-nested{t = t}{f = f}{b = b} = elim{T = b ↦ (elim pt pf (elim t f b) ≡ elim(elim pt pf t) (elim pt pf f) b)} [≡]-intro [≡]-intro b

module _ {x : T} where
  elim-redundant : (elim{T = const T} x x b ≡ x)
  elim-redundant{b = b} = elim{T = b ↦ elim x x b ≡ x} [≡]-intro [≡]-intro b

elim-inverse : (elim 𝑇 𝐹 b ≡ b)
elim-inverse{b = b} = elim{T = b ↦ elim 𝑇 𝐹 b ≡ b} [≡]-intro [≡]-intro b

elim-anti-inverse : (elim 𝐹 𝑇 b ≡ ! b)
elim-anti-inverse {𝑇} = [≡]-intro
elim-anti-inverse {𝐹} = [≡]-intro

---------------------------------------------
-- Negation

[!]-no-fixpoints : ∀{b} → (! b ≢ b)
[!]-no-fixpoints {𝑇} ()
[!]-no-fixpoints {𝐹} ()

[!!]-elim : ∀{a} → (!(! a) ≡ a)
[!!]-elim {𝑇} = [≡]-intro
[!!]-elim {𝐹} = [≡]-intro
{-# REWRITE [!!]-elim #-}

---------------------------------------------
-- Idempotence

[&&]-idempotence-raw : ∀{a} → (a && a ≡ a)
[&&]-idempotence-raw {𝑇} = [≡]-intro
[&&]-idempotence-raw {𝐹} = [≡]-intro
{-# REWRITE [&&]-idempotence-raw #-}
instance
  [&&]-idempotence : Idempotence(_&&_)
  Idempotence.proof([&&]-idempotence) = [&&]-idempotence-raw

[||]-idempotence-raw : ∀{a} → (a || a ≡ a)
[||]-idempotence-raw {𝑇} = [≡]-intro
[||]-idempotence-raw {𝐹} = [≡]-intro
{-# REWRITE [||]-idempotence-raw #-}
instance
  [||]-idempotence : Idempotence(_||_)
  Idempotence.proof([||]-idempotence) = [||]-idempotence-raw
---------------------------------------------
-- Left anti-identities

[==]-anti-identityₗ : ∀{a} → (𝐹 == a ≡ ! a)
[==]-anti-identityₗ {𝑇} = [≡]-intro
[==]-anti-identityₗ {𝐹} = [≡]-intro
{-# REWRITE [==]-anti-identityₗ #-}

[!=]-anti-identityₗ : ∀{a} → (𝑇 != a ≡ ! a)
[!=]-anti-identityₗ {𝑇} = [≡]-intro
[!=]-anti-identityₗ {𝐹} = [≡]-intro
{-# REWRITE [!=]-anti-identityₗ #-}

---------------------------------------------
-- Right anti-identities

[==]-anti-identityᵣ : ∀{a} → (a == 𝐹 ≡ ! a)
[==]-anti-identityᵣ {𝑇} = [≡]-intro
[==]-anti-identityᵣ {𝐹} = [≡]-intro
{-# REWRITE [==]-anti-identityᵣ #-}

[!=]-anti-identityᵣ : ∀{a} → (a != 𝑇 ≡ ! a)
[!=]-anti-identityᵣ {𝑇} = [≡]-intro
[!=]-anti-identityᵣ {𝐹} = [≡]-intro
{-# REWRITE [!=]-anti-identityᵣ #-}

---------------------------------------------
-- Left identities

[||]-identityₗ-raw : ∀{a} → (𝐹 || a ≡ a)
[||]-identityₗ-raw {𝑇} = [≡]-intro
[||]-identityₗ-raw {𝐹} = [≡]-intro
{-# REWRITE [||]-identityₗ-raw #-}
instance
  [||]-identityₗ : Identityₗ(_||_)(𝐹)
  Identityₗ.proof([||]-identityₗ) = [||]-identityₗ-raw

[&&]-identityₗ-raw : ∀{a} → (𝑇 && a ≡ a)
[&&]-identityₗ-raw {𝑇} = [≡]-intro
[&&]-identityₗ-raw {𝐹} = [≡]-intro
{-# REWRITE [&&]-identityₗ-raw #-}
instance
  [&&]-identityₗ : Identityₗ(_&&_)(𝑇)
  Identityₗ.proof([&&]-identityₗ) = [&&]-identityₗ-raw

[==]-identityₗ-raw : ∀{a} → (𝑇 == a ≡ a)
[==]-identityₗ-raw {𝑇} = [≡]-intro
[==]-identityₗ-raw {𝐹} = [≡]-intro
{-# REWRITE [==]-identityₗ-raw #-}
instance
  [==]-identityₗ : Identityₗ(_==_)(𝑇)
  Identityₗ.proof([==]-identityₗ) = [==]-identityₗ-raw

[!=]-identityₗ-raw : ∀{a} → (𝐹 != a ≡ a)
[!=]-identityₗ-raw {𝑇} = [≡]-intro
[!=]-identityₗ-raw {𝐹} = [≡]-intro
{-# REWRITE [!=]-identityₗ-raw #-}
instance
  [!=]-identityₗ : Identityₗ(_!=_)(𝐹)
  Identityₗ.proof([!=]-identityₗ) = [!=]-identityₗ-raw

---------------------------------------------
-- Left absorbers

[||]-absorberₗ-raw : ∀{a} → (𝑇 || a ≡ 𝑇)
[||]-absorberₗ-raw {𝑇} = [≡]-intro
[||]-absorberₗ-raw {𝐹} = [≡]-intro
{-# REWRITE [||]-absorberₗ-raw #-}
instance
  [||]-absorberₗ : Absorberₗ(_||_)(𝑇)
  Absorberₗ.proof([||]-absorberₗ) {a} = [||]-absorberₗ-raw {a}

[&&]-absorberₗ-raw : ∀{a} → (𝐹 && a ≡ 𝐹)
[&&]-absorberₗ-raw {𝑇} = [≡]-intro
[&&]-absorberₗ-raw {𝐹} = [≡]-intro
{-# REWRITE [&&]-absorberₗ-raw #-}
instance
  [&&]-absorberₗ : Absorberₗ(_&&_)(𝐹)
  Absorberₗ.proof([&&]-absorberₗ) {a} = [&&]-absorberₗ-raw {a}

---------------------------------------------
-- Right identities

[||]-identityᵣ-raw : ∀{a} → (a || 𝐹 ≡ a)
[||]-identityᵣ-raw {𝑇} = [≡]-intro
[||]-identityᵣ-raw {𝐹} = [≡]-intro
{-# REWRITE [||]-identityᵣ-raw #-}
instance
  [||]-identityᵣ : Identityᵣ(_||_)(𝐹)
  Identityᵣ.proof([||]-identityᵣ) = [||]-identityᵣ-raw

[&&]-identityᵣ-raw : ∀{a} → (a && 𝑇 ≡ a)
[&&]-identityᵣ-raw {𝑇} = [≡]-intro
[&&]-identityᵣ-raw {𝐹} = [≡]-intro
{-# REWRITE [&&]-identityᵣ-raw #-}
instance
  [&&]-identityᵣ : Identityᵣ(_&&_)(𝑇)
  Identityᵣ.proof([&&]-identityᵣ) = [&&]-identityᵣ-raw

[==]-identityᵣ-raw : ∀{a} → (a == 𝑇 ≡ a)
[==]-identityᵣ-raw {𝑇} = [≡]-intro
[==]-identityᵣ-raw {𝐹} = [≡]-intro
{-# REWRITE [==]-identityᵣ-raw #-}
instance
  [==]-identityᵣ : Identityᵣ(_==_)(𝑇)
  Identityᵣ.proof([==]-identityᵣ) = [==]-identityᵣ-raw

[!=]-identityᵣ-raw : ∀{a} → (a != 𝐹 ≡ a)
[!=]-identityᵣ-raw {𝑇} = [≡]-intro
[!=]-identityᵣ-raw {𝐹} = [≡]-intro
{-# REWRITE [!=]-identityᵣ-raw #-}
instance
  [!=]-identityᵣ : Identityᵣ(_!=_)(𝐹)
  Identityᵣ.proof([!=]-identityᵣ) = [!=]-identityᵣ-raw

---------------------------------------------
-- Identities

instance
  [||]-identity : Identity(_||_)(𝐹)
  [||]-identity = record{}

instance
  [&&]-identity : Identity(_&&_)(𝑇)
  [&&]-identity = record{}

instance
  [==]-identity : Identity(_==_)(𝑇)
  [==]-identity = record{}

instance
  [!=]-identity : Identity(_!=_)(𝐹)
  [!=]-identity = record{}

---------------------------------------------
-- Right absorbers

[||]-absorberᵣ-raw : ∀{a} → (a || 𝑇 ≡ 𝑇)
[||]-absorberᵣ-raw {𝑇} = [≡]-intro
[||]-absorberᵣ-raw {𝐹} = [≡]-intro
{-# REWRITE [||]-absorberᵣ-raw #-}
instance
  [||]-absorberᵣ : Absorberᵣ(_||_)(𝑇)
  Absorberᵣ.proof([||]-absorberᵣ) {a} = [||]-absorberᵣ-raw {a}

[&&]-absorberᵣ-raw : ∀{a} → (a && 𝐹 ≡ 𝐹)
[&&]-absorberᵣ-raw {𝑇} = [≡]-intro
[&&]-absorberᵣ-raw {𝐹} = [≡]-intro
{-# REWRITE [&&]-absorberᵣ-raw #-}
instance
  [&&]-absorberᵣ : Absorberᵣ(_&&_)(𝐹)
  Absorberᵣ.proof([&&]-absorberᵣ) {a} = [&&]-absorberᵣ-raw {a}

---------------------------------------------
-- Associativity

instance
  [||]-associativity : Associativity(_||_)
  Associativity.proof([||]-associativity) = proof where
    proof : Names.Associativity(_||_)
    proof {𝑇}{𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝑇}{𝐹} = [≡]-intro
    proof {𝑇}{𝐹}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇}{𝑇} = [≡]-intro
    proof {𝐹}{𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹}{𝐹} = [≡]-intro

instance
  [&&]-associativity : Associativity(_&&_)
  Associativity.proof([&&]-associativity) = proof where
    proof : Names.Associativity(_&&_)
    proof {𝑇}{𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝑇}{𝐹} = [≡]-intro
    proof {𝑇}{𝐹}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇}{𝑇} = [≡]-intro
    proof {𝐹}{𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹}{𝐹} = [≡]-intro

instance
  [==]-associativity : Associativity(_==_)
  Associativity.proof([==]-associativity) = proof where
    proof : Names.Associativity(_==_)
    proof {𝑇}{𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝑇}{𝐹} = [≡]-intro
    proof {𝑇}{𝐹}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇}{𝑇} = [≡]-intro
    proof {𝐹}{𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹}{𝐹} = [≡]-intro

instance
  [!=]-associativity : Associativity(_!=_)
  Associativity.proof([!=]-associativity) = proof where
    proof : Names.Associativity(_!=_)
    proof {𝑇}{𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝑇}{𝐹} = [≡]-intro
    proof {𝑇}{𝐹}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇}{𝑇} = [≡]-intro
    proof {𝐹}{𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹}{𝐹} = [≡]-intro

---------------------------------------------
-- Other

[⊼]-pseudo-associativity : (!(a ⊼ b) ⊼ c ≡ a ⊼ !(b ⊼ c))
[⊼]-pseudo-associativity {𝑇} {𝑇} {𝑇} = [≡]-intro
[⊼]-pseudo-associativity {𝑇} {𝑇} {𝐹} = [≡]-intro
[⊼]-pseudo-associativity {𝑇} {𝐹} {𝑇} = [≡]-intro
[⊼]-pseudo-associativity {𝑇} {𝐹} {𝐹} = [≡]-intro
[⊼]-pseudo-associativity {𝐹} {𝑇} {𝑇} = [≡]-intro
[⊼]-pseudo-associativity {𝐹} {𝑇} {𝐹} = [≡]-intro
[⊼]-pseudo-associativity {𝐹} {𝐹} {𝑇} = [≡]-intro
[⊼]-pseudo-associativity {𝐹} {𝐹} {𝐹} = [≡]-intro

[⊼]-to-conjunction : (!(a ⊼ b) ≡ a && b)
[⊼]-to-conjunction {𝑇} {𝑇} = [≡]-intro
[⊼]-to-conjunction {𝑇} {𝐹} = [≡]-intro
[⊼]-to-conjunction {𝐹} {𝑇} = [≡]-intro
[⊼]-to-conjunction {𝐹} {𝐹} = [≡]-intro

[⊼]-to-negation : (b ⊼ b ≡ ! b)
[⊼]-to-negation {𝑇} = [≡]-intro
[⊼]-to-negation {𝐹} = [≡]-intro

[⊼]-pseudo-absorptionₗ : (a ⊼ (a ⊼ b) ≡ a ⊼ (! b))
[⊼]-pseudo-absorptionₗ {𝑇} {𝑇} = [≡]-intro
[⊼]-pseudo-absorptionₗ {𝑇} {𝐹} = [≡]-intro
[⊼]-pseudo-absorptionₗ {𝐹} {𝑇} = [≡]-intro
[⊼]-pseudo-absorptionₗ {𝐹} {𝐹} = [≡]-intro

[⊼]-pseudo-absorptionᵣ : ((a ⊼ b) ⊼ b ≡ (! a) ⊼ b)
[⊼]-pseudo-absorptionᵣ {𝑇} {𝑇} = [≡]-intro
[⊼]-pseudo-absorptionᵣ {𝑇} {𝐹} = [≡]-intro
[⊼]-pseudo-absorptionᵣ {𝐹} {𝑇} = [≡]-intro
[⊼]-pseudo-absorptionᵣ {𝐹} {𝐹} = [≡]-intro

[⊼]-pseudo-pseudo-absorptionₗ : (((! a) ⊼ b) ⊼ (a ⊼ b) ≡ b)
[⊼]-pseudo-pseudo-absorptionₗ {𝑇} {𝑇} = [≡]-intro
[⊼]-pseudo-pseudo-absorptionₗ {𝑇} {𝐹} = [≡]-intro
[⊼]-pseudo-pseudo-absorptionₗ {𝐹} {𝑇} = [≡]-intro
[⊼]-pseudo-pseudo-absorptionₗ {𝐹} {𝐹} = [≡]-intro

[⊼]-pseudo-pseudo-absorptionᵣ : ((a ⊼ (! b)) ⊼ (a ⊼ b) ≡ a)
[⊼]-pseudo-pseudo-absorptionᵣ {𝑇} {𝑇} = [≡]-intro
[⊼]-pseudo-pseudo-absorptionᵣ {𝑇} {𝐹} = [≡]-intro
[⊼]-pseudo-pseudo-absorptionᵣ {𝐹} {𝑇} = [≡]-intro
[⊼]-pseudo-pseudo-absorptionᵣ {𝐹} {𝐹} = [≡]-intro

[⊽]-pseudo-associativity : (!(a ⊽ b) ⊽ c ≡ a ⊽ !(b ⊽ c))
[⊽]-pseudo-associativity {𝑇} {𝑇} {𝑇} = [≡]-intro
[⊽]-pseudo-associativity {𝑇} {𝑇} {𝐹} = [≡]-intro
[⊽]-pseudo-associativity {𝑇} {𝐹} {𝑇} = [≡]-intro
[⊽]-pseudo-associativity {𝑇} {𝐹} {𝐹} = [≡]-intro
[⊽]-pseudo-associativity {𝐹} {𝑇} {𝑇} = [≡]-intro
[⊽]-pseudo-associativity {𝐹} {𝑇} {𝐹} = [≡]-intro
[⊽]-pseudo-associativity {𝐹} {𝐹} {𝑇} = [≡]-intro
[⊽]-pseudo-associativity {𝐹} {𝐹} {𝐹} = [≡]-intro

[⊽]-to-disjunction : (!(a ⊽ b) ≡ a || b)
[⊽]-to-disjunction {𝑇} {𝑇} = [≡]-intro
[⊽]-to-disjunction {𝑇} {𝐹} = [≡]-intro
[⊽]-to-disjunction {𝐹} {𝑇} = [≡]-intro
[⊽]-to-disjunction {𝐹} {𝐹} = [≡]-intro

[⊽]-to-negation : (b ⊽ b ≡ ! b)
[⊽]-to-negation {𝑇} = [≡]-intro
[⊽]-to-negation {𝐹} = [≡]-intro

[⊽]-pseudo-absorptionₗ : (a ⊽ (a ⊽ b) ≡ a ⊽ (! b))
[⊽]-pseudo-absorptionₗ {𝑇} {𝑇} = [≡]-intro
[⊽]-pseudo-absorptionₗ {𝑇} {𝐹} = [≡]-intro
[⊽]-pseudo-absorptionₗ {𝐹} {𝑇} = [≡]-intro
[⊽]-pseudo-absorptionₗ {𝐹} {𝐹} = [≡]-intro

[⊽]-pseudo-absorptionᵣ : ((a ⊽ b) ⊽ b ≡ (! a) ⊽ b)
[⊽]-pseudo-absorptionᵣ {𝑇} {𝑇} = [≡]-intro
[⊽]-pseudo-absorptionᵣ {𝑇} {𝐹} = [≡]-intro
[⊽]-pseudo-absorptionᵣ {𝐹} {𝑇} = [≡]-intro
[⊽]-pseudo-absorptionᵣ {𝐹} {𝐹} = [≡]-intro

[⊽]-pseudo-pseudo-absorptionₗ : (((! a) ⊽ b) ⊽ (a ⊽ b) ≡ b)
[⊽]-pseudo-pseudo-absorptionₗ {𝑇} {𝑇} = [≡]-intro
[⊽]-pseudo-pseudo-absorptionₗ {𝑇} {𝐹} = [≡]-intro
[⊽]-pseudo-pseudo-absorptionₗ {𝐹} {𝑇} = [≡]-intro
[⊽]-pseudo-pseudo-absorptionₗ {𝐹} {𝐹} = [≡]-intro

[⊽]-pseudo-pseudo-absorptionᵣ : ((a ⊽ (! b)) ⊽ (a ⊽ b) ≡ a)
[⊽]-pseudo-pseudo-absorptionᵣ {𝑇} {𝑇} = [≡]-intro
[⊽]-pseudo-pseudo-absorptionᵣ {𝑇} {𝐹} = [≡]-intro
[⊽]-pseudo-pseudo-absorptionᵣ {𝐹} {𝑇} = [≡]-intro
[⊽]-pseudo-pseudo-absorptionᵣ {𝐹} {𝐹} = [≡]-intro

---------------------------------------------
-- Commutativity

instance
  [||]-commutativity : Commutativity(_||_)
  Commutativity.proof([||]-commutativity) = proof where
    proof : Names.Commutativity(_||_)
    proof {𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹} = [≡]-intro

instance
  [&&]-commutativity : Commutativity(_&&_)
  Commutativity.proof([&&]-commutativity) = proof where
    proof : Names.Commutativity(_&&_)
    proof {𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹} = [≡]-intro

instance
  [==]-commutativity : Commutativity(_==_)
  Commutativity.proof([==]-commutativity) = proof where
    proof : Names.Commutativity(_==_)
    proof {𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹} = [≡]-intro

instance
  [!=]-commutativity : Commutativity(_!=_)
  Commutativity.proof([!=]-commutativity) = proof where
    proof : Names.Commutativity(_!=_)
    proof {𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹} = [≡]-intro

instance
  [⊼]-commutativity : Commutativity(_⊼_)
  Commutativity.proof([⊼]-commutativity) = proof where
    proof : Names.Commutativity(_⊼_)
    proof {𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹} = [≡]-intro

instance
  [⊽]-commutativity : Commutativity(_⊽_)
  Commutativity.proof([⊽]-commutativity) = proof where
    proof : Names.Commutativity(_⊽_)
    proof {𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹} = [≡]-intro

instance
  [⊕]-commutativity : Commutativity(_⊕_)
  Commutativity.proof([⊕]-commutativity) = proof where
    proof : Names.Commutativity(_⊕_)
    proof {𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹} = [≡]-intro

instance
  [&&][||]-distributivityₗ : Distributivityₗ(_&&_)(_||_)
  Distributivityₗ.proof([&&][||]-distributivityₗ) = proof where
    proof : Names.Distributivityₗ(_&&_)(_||_)
    proof {𝑇}{𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝑇}{𝐹} = [≡]-intro
    proof {𝑇}{𝐹}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇}{𝑇} = [≡]-intro
    proof {𝐹}{𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹}{𝐹} = [≡]-intro

instance
  [||][&&]-distributivityₗ : Distributivityₗ(_||_)(_&&_)
  Distributivityₗ.proof([||][&&]-distributivityₗ) = proof where
    proof : Names.Distributivityₗ(_||_)(_&&_)
    proof {𝑇}{𝑇}{𝑇} = [≡]-intro
    proof {𝑇}{𝑇}{𝐹} = [≡]-intro
    proof {𝑇}{𝐹}{𝑇} = [≡]-intro
    proof {𝑇}{𝐹}{𝐹} = [≡]-intro
    proof {𝐹}{𝑇}{𝑇} = [≡]-intro
    proof {𝐹}{𝑇}{𝐹} = [≡]-intro
    proof {𝐹}{𝐹}{𝑇} = [≡]-intro
    proof {𝐹}{𝐹}{𝐹} = [≡]-intro

instance
  [||]-oppositeFunctionₗ : ComplementFunctionₗ(_||_)(!)
  ComplementFunctionₗ.proof([||]-oppositeFunctionₗ) = proof where
    proof : Names.InverseFunctionₗ(_||_)(𝑇)(!)
    proof {𝑇} = [≡]-intro
    proof {𝐹} = [≡]-intro

instance
  [||]-oppositeFunctionᵣ : ComplementFunctionᵣ(_||_)(!)
  ComplementFunctionᵣ.proof([||]-oppositeFunctionᵣ) = proof where
    proof : Names.InverseFunctionᵣ(_||_)(𝑇)(!)
    proof {𝑇} = [≡]-intro
    proof {𝐹} = [≡]-intro

instance
  [&&]-oppositeFunctionₗ : ComplementFunctionₗ(_&&_)(!)
  ComplementFunctionₗ.proof([&&]-oppositeFunctionₗ) = proof where
    proof : Names.InverseFunctionₗ(_&&_)(𝐹)(!)
    proof {𝑇} = [≡]-intro
    proof {𝐹} = [≡]-intro

instance
  [&&]-oppositeFunctionᵣ : ComplementFunctionᵣ(_&&_)(!)
  ComplementFunctionᵣ.proof([&&]-oppositeFunctionᵣ) = proof where
    proof : Names.InverseFunctionᵣ(_&&_)(𝐹)(!)
    proof {𝑇} = [≡]-intro
    proof {𝐹} = [≡]-intro

---------------------------------------------
-- Algebraic structures

instance
  [&&]-monoid : Monoid(_&&_)
  [&&]-monoid = record{}

instance
  [||]-monoid : Monoid(_||_)
  [||]-monoid = record{}

instance
  [==]-monoid : Monoid(_==_)
  [==]-monoid = record{}

instance
  [!=]-monoid : Monoid(_!=_)
  [!=]-monoid = record{}

-- TODO: Set algebra

---------------------------------------------
-- Inverting

inverted-[==][!=] : ∀{a b} → (!(a == b) ≡ (a != b))
inverted-[==][!=] {𝑇}{𝑇} = [≡]-intro
inverted-[==][!=] {𝑇}{𝐹} = [≡]-intro
inverted-[==][!=] {𝐹}{𝑇} = [≡]-intro
inverted-[==][!=] {𝐹}{𝐹} = [≡]-intro

inverted-[!=][==] : ∀{a b} → (!(a != b) ≡ (a == b))
inverted-[!=][==] {𝑇}{𝑇} = [≡]-intro
inverted-[!=][==] {𝑇}{𝐹} = [≡]-intro
inverted-[!=][==] {𝐹}{𝑇} = [≡]-intro
inverted-[!=][==] {𝐹}{𝐹} = [≡]-intro

---------------------------------------------
-- Rules of classical logic

-- A boolean operation is either true or false
bivalence : ∀{a} → ((a ≡ 𝑇) ∨ (a ≡ 𝐹))
bivalence {𝑇} = Logic.[∨]-introₗ [≡]-intro
bivalence {𝐹} = Logic.[∨]-introᵣ [≡]-intro

-- A boolean operation is not both true and false at the same time
disjointness : ∀{a} → ¬((a ≡ 𝑇) ∧ (a ≡ 𝐹))
disjointness {𝑇} (Logic.[∧]-intro [≡]-intro ())
disjointness {𝐹} (Logic.[∧]-intro () [≡]-intro)

[→?]-disjunctive-form : ∀{a b} → ((a →? b) ≡ ((! a) || b))
[→?]-disjunctive-form {𝑇} {𝑇} = [≡]-intro
[→?]-disjunctive-form {𝑇} {𝐹} = [≡]-intro
[→?]-disjunctive-form {𝐹} {𝑇} = [≡]-intro
[→?]-disjunctive-form {𝐹} {𝐹} = [≡]-intro

[==]-disjunctive-form : ∀{a b} → ((a == b) ≡ ((a && b) || ((! a) && (! b))))
[==]-disjunctive-form {𝑇} {𝑇} = [≡]-intro
[==]-disjunctive-form {𝑇} {𝐹} = [≡]-intro
[==]-disjunctive-form {𝐹} {𝑇} = [≡]-intro
[==]-disjunctive-form {𝐹} {𝐹} = [≡]-intro

module 𝑇 where
  [∧]-intro : ∀{a b} → (a ≡ 𝑇) → (b ≡ 𝑇) → ((a && b) ≡ 𝑇)
  [∧]-intro [≡]-intro [≡]-intro = [≡]-intro

  [∨]-introₗ : ∀{a b} → (a ≡ 𝑇) → ((a || b) ≡ 𝑇)
  [∨]-introₗ {_}{𝑇} [≡]-intro = [≡]-intro
  [∨]-introₗ {_}{𝐹} [≡]-intro = [≡]-intro

  [∨]-introᵣ : ∀{a b} → (b ≡ 𝑇) → ((a || b) ≡ 𝑇)
  [∨]-introᵣ {𝑇}{_} [≡]-intro = [≡]-intro
  [∨]-introᵣ {𝐹}{_} [≡]-intro = [≡]-intro

  [∧]-elimₗ : ∀{a b} → ((a && b) ≡ 𝑇) → (a ≡ 𝑇)
  [∧]-elimₗ {𝑇}{𝑇} [≡]-intro = [≡]-intro
  [∧]-elimₗ {𝑇}{𝐹} ()
  [∧]-elimₗ {𝐹}{𝑇} ()
  [∧]-elimₗ {𝐹}{𝐹} ()

  [∧]-elimᵣ : ∀{a b} → ((a && b) ≡ 𝑇) → (b ≡ 𝑇)
  [∧]-elimᵣ {𝑇}{𝑇} [≡]-intro = [≡]-intro
  [∧]-elimᵣ {𝑇}{𝐹} ()
  [∧]-elimᵣ {𝐹}{𝑇} ()
  [∧]-elimᵣ {𝐹}{𝐹} ()

  [∨]-elim : ∀{a b}{ℓ₂}{φ : Type{ℓ₂}} → ((a ≡ 𝑇) → φ) → ((b ≡ 𝑇) → φ) → ((a || b) ≡ 𝑇) → φ
  [∨]-elim {𝑇}{𝑇}{_} f _ [≡]-intro = f [≡]-intro
  [∨]-elim {𝑇}{𝐹}{_} f _ [≡]-intro = f [≡]-intro
  [∨]-elim {𝐹}{𝑇}{_} _ f [≡]-intro = f [≡]-intro
  [∨]-elim {𝐹}{𝐹}{_} _ f ()

  [¬]-intro : ∀{a} → (a ≡ 𝐹) → (! a ≡ 𝑇)
  [¬]-intro [≡]-intro = [≡]-intro

  [¬]-elim : ∀{a} → (! a ≡ 𝑇) → (a ≡ 𝐹)
  [¬]-elim {𝑇} ()
  [¬]-elim {𝐹} [≡]-intro = [≡]-intro

  [¬¬]-elim : ∀{a} → (!(! a) ≡ 𝑇) → (a ≡ 𝑇)
  [¬¬]-elim {𝑇} [≡]-intro = [≡]-intro
  [¬¬]-elim {𝐹} ()

  preserves-[&&][∧] : ∀{a b} → ((a && b) ≡ 𝑇) ↔ (a ≡ 𝑇)∧(b ≡ 𝑇)
  preserves-[&&][∧] = [↔]-intro
    (\{(Logic.[∧]-intro l r) → [∧]-intro l r})
    (proof ↦ Logic.[∧]-intro ([∧]-elimₗ proof) ([∧]-elimᵣ proof))

  preserves-[||][∨] : ∀{a b} → ((a || b) ≡ 𝑇) ↔ (a ≡ 𝑇)∨(b ≡ 𝑇)
  preserves-[||][∨] = [↔]-intro
    (Logic.[∨]-elim [∨]-introₗ [∨]-introᵣ)
    ([∨]-elim Logic.[∨]-introₗ Logic.[∨]-introᵣ)

  preserves-[!][¬] : ∀{a} → (! a ≡ 𝑇) ↔ ¬(a ≡ 𝑇)
  preserves-[!][¬] {a} = [↔]-intro (l{a}) (r{a}) where
    l : ∀{a} → (! a ≡ 𝑇) ← ¬(a ≡ 𝑇)
    l {𝐹} _ = [≡]-intro
    l {𝑇} f = [⊥]-elim (f [≡]-intro)

    r : ∀{a} → (! a ≡ 𝑇) → ¬(a ≡ 𝑇)
    r {𝑇} () _
    r {𝐹} _ ()

  [≡]-transfer : ∀{a b} → ((a == b) ≡ 𝑇) ↔ (a ≡ b)
  [≡]-transfer {𝑇}{𝑇} = [↔]-intro (_ ↦ [≡]-intro) (_ ↦ [≡]-intro)
  [≡]-transfer {𝐹}{𝑇} = [↔]-intro (\()) (\())
  [≡]-transfer {𝑇}{𝐹} = [↔]-intro (\()) (\())
  [≡]-transfer {𝐹}{𝐹} = [↔]-intro (_ ↦ [≡]-intro) (_ ↦ [≡]-intro)

  [≢]-transfer : ∀{a b} → ((a != b) ≡ 𝑇) ↔ (a ≢ b)
  [≢]-transfer {𝑇}{𝑇} = [↔]-intro (ab ↦ [⊥]-elim(ab [≡]-intro)) (\())
  [≢]-transfer {𝐹}{𝑇} = [↔]-intro (_ ↦ [≡]-intro) (_ ↦ \())
  [≢]-transfer {𝑇}{𝐹} = [↔]-intro (_ ↦ [≡]-intro) (_ ↦ \())
  [≢]-transfer {𝐹}{𝐹} = [↔]-intro (ab ↦ [⊥]-elim(ab [≡]-intro)) (\())

module 𝐹 where
  [∧]-introₗ : ∀{a b} → (a ≡ 𝐹) → ((a && b) ≡ 𝐹)
  [∧]-introₗ {_}{𝑇} [≡]-intro = [≡]-intro
  [∧]-introₗ {_}{𝐹} [≡]-intro = [≡]-intro

  [∧]-introᵣ : ∀{a b} → (b ≡ 𝐹) → ((a && b) ≡ 𝐹)
  [∧]-introᵣ {𝑇}{_} [≡]-intro = [≡]-intro
  [∧]-introᵣ {𝐹}{_} [≡]-intro = [≡]-intro

  [∨]-intro : ∀{a b} → (a ≡ 𝐹) → (b ≡ 𝐹) → ((a || b) ≡ 𝐹)
  [∨]-intro [≡]-intro [≡]-intro = [≡]-intro

  [¬]-intro : ∀{a} → (! a ≡ 𝑇) → (a ≡ 𝐹)
  [¬]-intro = 𝑇.[¬]-elim

  [¬]-elim : ∀{a} → (a ≡ 𝐹) → (! a ≡ 𝑇)
  [¬]-elim = 𝑇.[¬]-intro

[≢][𝑇]-is-[𝐹] : ∀{a} → (a ≢ 𝑇) ↔ (a ≡ 𝐹)
[≢][𝑇]-is-[𝐹] {a} = [↔]-intro (l{a}) (r{a}) where
  r : ∀{a} → (a ≢ 𝑇) → (a ≡ 𝐹)
  r {𝑇} (a≢𝑇) = [⊥]-elim ((a≢𝑇) ([≡]-intro))
  r {𝐹} (a≢𝑇) = [≡]-intro

  l : ∀{a} → (a ≢ 𝑇) ← (a ≡ 𝐹)
  l {𝑇} ()
  l {𝐹} (a≡𝐹) ()

[≢][𝐹]-is-[𝑇] : ∀{a} → (a ≢ 𝐹) ↔ (a ≡ 𝑇)
[≢][𝐹]-is-[𝑇] {a} = [↔]-intro (l{a}) (r{a}) where
  r : ∀{a} → (a ≢ 𝐹) → (a ≡ 𝑇)
  r {𝑇} (a≢𝐹) = [≡]-intro
  r {𝐹} (a≢𝐹) = [⊥]-elim ((a≢𝐹) ([≡]-intro))

  l : ∀{a} → (a ≢ 𝐹) ← (a ≡ 𝑇)
  l {𝑇} (a≡𝑇) ()
  l {𝐹} ()

---------------------------------------------
-- If-statements

module _ {ℓ₁ ℓ₂} {T : Type{ℓ₁}} {x y : T} {P : T → Type{ℓ₂}} where
  if-intro : ∀{B} → ((B ≡ 𝑇) → P(x)) → ((B ≡ 𝐹) → P(y)) → P(if B then x else y)
  if-intro {𝑇} px py = px [≡]-intro
  if-intro {𝐹} px py = py [≡]-intro

module _ {ℓ₁ ℓ₂ ℓ₃} {T : Type{ℓ₁}} {x y : T} {P : T → Type{ℓ₂}} {Q : Bool → Type{ℓ₃}} where
  if-elim : ∀{B} → P(if B then x else y) → (P(x) → Q(𝑇)) → (P(y) → Q(𝐹)) → Q(B)
  if-elim{𝑇} p pxq pyq = pxq p
  if-elim{𝐹} p pxq pyq = pyq p

module _ {ℓ₁ ℓ₂ ℓ₃} {T : Type{ℓ₁}} {x y : T} {P : T → Type{ℓ₂}} {Q : Type{ℓ₃}} where
  if-bool-elim : ∀{B} → P(if B then x else y) → (P(x) → (B ≡ 𝑇) → Q) → (P(y) → (B ≡ 𝐹) → Q) → Q
  if-bool-elim{𝑇} p pxq pyq = pxq p [≡]-intro
  if-bool-elim{𝐹} p pxq pyq = pyq p [≡]-intro

module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {T : Type{ℓ₁}} {P : T → Type{ℓ₂}} {X : Type{ℓ₃}} {Y : Type{ℓ₄}} (nxy : X → Y → Logic.⊥) where
  either-bool-left : (xy : (X ∨ Y)) → (X ↔ (Either.isRight(xy) ≡ 𝐹))
  either-bool-left xy with bivalence{Either.isRight(xy)}
  either-bool-left (Left  x) | Right f = [↔]-intro (const x) (const f)
  either-bool-left (Right y) | Left  t = [↔]-intro (\()) (x ↦ empty(nxy x y))

  either-bool-right : (xy : (X ∨ Y)) → (Y ↔ (Either.isRight(xy) ≡ 𝑇))
  either-bool-right xy with bivalence{Either.isRight(xy)}
  either-bool-right (Left  x) | Right f = [↔]-intro (\()) (y ↦ empty(nxy x y))
  either-bool-right (Right y) | Left  t = [↔]-intro (const y) (const t)

module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {T : Type{ℓ₁}} {P : T → Type{ℓ₂}} {X : Type{ℓ₃}} {Y : Type{ℓ₄}} where
  either-bool-leftₗ : (xy : (X ∨ Y)) → (X ← (Either.isRight(xy) ≡ 𝐹))
  either-bool-leftₗ xy with bivalence{Either.isRight(xy)}
  either-bool-leftₗ (Left  x) | Right f = const x
  either-bool-leftₗ (Right y) | Left  t = \()

  either-bool-rightₗ : (xy : (X ∨ Y)) → (Y ← (Either.isRight(xy) ≡ 𝑇))
  either-bool-rightₗ xy with bivalence{Either.isRight(xy)}
  either-bool-rightₗ (Left  x) | Right f = \()
  either-bool-rightₗ (Right y) | Left  t = const y

  if-not-either-bool-intro : ∀{x y : T} → (X → P(x)) → (Y → P(y)) → (xy : (X ∨ Y)) → P(if not(Either.isRight(xy)) then x else y)
  if-not-either-bool-intro {x}{y} xp yp xy = if-intro {x = x}{y = y} (xp ∘ either-bool-leftₗ xy ∘ 𝑇.[¬]-elim) (yp ∘ either-bool-rightₗ xy ∘ 𝑇.[¬¬]-elim ∘ 𝐹.[¬]-elim)

module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {T : Type{ℓ₁}} {P : T → Type{ℓ₂}} {X : Type{ℓ₃}} {Y : Type{ℓ₄}} where
  if-either-bool-intro : ∀{x y : T} → (X → P(x)) → (Y → P(y)) → (xy : (X ∨ Y)) → P(if Either.isRight(xy) then y else x)
  if-either-bool-intro {x}{y} xp yp xy = if-intro {x = y}{y = x} (yp ∘ either-bool-rightₗ {P = P} xy) (xp ∘ either-bool-leftₗ {P = P} xy)

---------------------------------------------
-- The predicate of if-statements

module _ {ℓ} {T : Type{ℓ}} {x y : T} where
  if-and : ∀{B₁ B₂} → (if (B₁ && B₂) then x else y ≡ if B₁ then (if B₂ then x else y) else y)
  if-and {𝐹}{𝐹} = [≡]-intro
  if-and {𝐹}{𝑇} = [≡]-intro
  if-and {𝑇}{𝐹} = [≡]-intro
  if-and {𝑇}{𝑇} = [≡]-intro

  if-or : ∀{B₁ B₂} → (if (B₁ || B₂) then x else y ≡ if B₁ then x else if B₂ then x else y)
  if-or {𝐹}{𝐹} = [≡]-intro
  if-or {𝐹}{𝑇} = [≡]-intro
  if-or {𝑇}{𝐹} = [≡]-intro
  if-or {𝑇}{𝑇} = [≡]-intro

  if-not : ∀{B} → (if (! B) then x else y ≡ if B then y else x)
  if-not {𝐹} = [≡]-intro
  if-not {𝑇} = [≡]-intro

---------------------------------------------
-- The results of if-statements

module _ {ℓ} {T : Type{ℓ}} {x : T} {B} where
  if-then-redundant : (if B then x else x ≡ x)
  if-then-redundant = elim-redundant{b = B}

module _ {ℓ} {T : Type{ℓ}} {B} where
  if-then-bool-inverse : (if B then 𝑇 else 𝐹 ≡ B)
  if-then-bool-inverse = elim-inverse{b = B}

  if-then-bool-anti-inverse : (if B then 𝐹 else 𝑇 ≡ ! B)
  if-then-bool-anti-inverse = elim-anti-inverse{b = B}


------------------------------------------------------------------------------
-- The unary numbers are LTC-PCF total natural numbers
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.UnaryNumbers.Totality where

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Type
open import LTC-PCF.Data.Nat.UnaryNumbers

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

0-N : N [0]
0-N = nzero

1-N : N [1]
1-N = nsucc 0-N

2-N : N [2]
2-N = nsucc 1-N


open import Type

module Structure.Operator.SetAlgebra {ℓ} (S : Type{ℓ}) where

import      Lvl
open import Functional
open import Logic
open import Logic.Propositional
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Operator.Properties
open import Structure.Operator.Proofs
open import Structure.Relator.Properties
open import Syntax.Transitivity

record Fundamentals : Stmt{ℓ} where
  infixl 1001 _∩_
  infixl 1000 _∪_

  field
    _∪_ : S → S → S -- Union
    _∩_ : S → S → S -- Intersection
    ∅   : S         -- Empty set
    𝐔   : S         -- Universal set

  field -- TODO: This is two commutative monoids with distributivity over each other
    ⦃ [∪]-commutativity ⦄ : Commutativity(_∪_)
    ⦃ [∩]-commutativity ⦄ : Commutativity(_∩_)

    ⦃ [∪]-associativity ⦄ : Associativity(_∪_)
    ⦃ [∩]-associativity ⦄ : Associativity(_∩_)

    ⦃ [∪][∩]-distributivityₗ ⦄ : Distributivityₗ(_∪_)(_∩_)
    ⦃ [∩][∪]-distributivityₗ ⦄ : Distributivityₗ(_∩_)(_∪_)

    ⦃ [∪]-identityₗ ⦄ : Identityₗ(_∪_)(∅)
    ⦃ [∩]-identityₗ ⦄ : Identityₗ(_∩_)(𝐔)

  instance
    [∪][∩]-distributivityᵣ : Distributivityᵣ(_∪_)(_∩_)
    [∪][∩]-distributivityᵣ = [↔]-to-[→] OneTypeTwoOp.distributivity-equivalence-by-commutativity [∪][∩]-distributivityₗ

  instance
    [∩][∪]-distributivityᵣ : Distributivityᵣ(_∩_)(_∪_)
    [∩][∪]-distributivityᵣ = [↔]-to-[→] OneTypeTwoOp.distributivity-equivalence-by-commutativity [∩][∪]-distributivityₗ

  instance
    [∪]-identityᵣ : Identityᵣ(_∪_)(∅)
    [∪]-identityᵣ = [↔]-to-[→] One.identity-equivalence-by-commutativity [∪]-identityₗ

  instance
    [∩]-identityᵣ : Identityᵣ(_∩_)(𝐔)
    [∩]-identityᵣ = [↔]-to-[→] One.identity-equivalence-by-commutativity [∩]-identityₗ

record Complement : Stmt{ℓ} where
  infixl 1002 ∁_
  infixl 1000 _∖_

  field
    ∁_   : S → S -- Complement

  field
    ⦃ fundamentals ⦄ : Fundamentals
  open Fundamentals(fundamentals)

  field -- TODO: Not really inverses. These are using the absorbers
    [∪]-inverseᵣ : ∀{s : S} → (s ∪ ∁(s) ≡ 𝐔)
    [∩]-inverseᵣ : ∀{s : S} → (s ∩ ∁(s) ≡ ∅)

  _∖_ : S → S → S -- Difference
  _∖_ (s₁)(s₂) = s₁ ∩ ∁(s₂)

  [∪]-inverseₗ : ∀{s : S} → (∁(s) ∪ s ≡ 𝐔)
  [∪]-inverseₗ = transitivity(_≡_) (commutativity(_∪_)) [∪]-inverseᵣ

  [∩]-inverseₗ : ∀{s : S} → (∁(s) ∩ s ≡ ∅)
  [∩]-inverseₗ = transitivity(_≡_) (commutativity(_∩_)) [∩]-inverseᵣ

  [∁]-of-[∅] : (∁(∅) ≡ 𝐔)
  [∁]-of-[∅] =
    symmetry(_≡_) (identityₗ(_∪_)(∅))
    🝖 ([∪]-inverseᵣ)

  [∁]-of-[𝐔] : (∁(𝐔) ≡ ∅)
  [∁]-of-[𝐔] =
    symmetry(_≡_) (identityₗ(_∩_)(𝐔))
    🝖 ([∩]-inverseᵣ)

  [∪]-idempotence : ∀{s : S} → (s ∪ s) ≡ s
  [∪]-idempotence{s} =
    ([≡]-intro)
    🝖 (symmetry(_≡_) (identityᵣ(_∩_)(𝐔)))
    🝖 ([≡]-with(expr ↦ ((s ∪ s) ∩ expr)) (symmetry(_≡_) [∪]-inverseᵣ))
    🝖 (symmetry(_≡_) (distributivityₗ(_∪_)(_∩_)))
    🝖 ([≡]-with(expr ↦ (s ∪ expr)) [∩]-inverseᵣ)
    🝖 ((identityᵣ(_∪_)(∅)))

  [∩]-idempotence : ∀{s : S} → (s ∩ s) ≡ s
  [∩]-idempotence{s} =
    ([≡]-intro)
    🝖 (symmetry(_≡_) (identityᵣ(_∪_)(∅)))
    🝖 ([≡]-with(expr ↦ ((s ∩ s) ∪ expr)) (symmetry(_≡_) [∩]-inverseᵣ))
    🝖 (symmetry(_≡_) (distributivityₗ(_∩_)(_∪_)))
    🝖 ([≡]-with(expr ↦ (s ∩ expr)) [∪]-inverseᵣ)
    🝖 ((identityᵣ(_∩_)(𝐔)))

  [∪]-absorber : ∀{s : S} → (s ∪ 𝐔) ≡ 𝐔
  [∪]-absorber{s} =
    ([≡]-with(expr ↦ s ∪ expr) (symmetry(_≡_) [∪]-inverseᵣ))
    🝖 (symmetry(_≡_) (associativity(_∪_)))
    🝖 ([≡]-with(expr ↦ expr ∪ ∁(s)) [∪]-idempotence)
    🝖 ([∪]-inverseᵣ)
    -- s∪𝐔 = s∪(s ∪ ∁(s)) = (s∪s) ∪ ∁(s) = s ∪ ∁(s) = 𝐔

  [∩]-absorber : ∀{s : S} → (s ∩ ∅) ≡ ∅
  [∩]-absorber{s} =
    ([≡]-with(expr ↦ s ∩ expr) (symmetry(_≡_) [∩]-inverseᵣ))
    🝖 (symmetry(_≡_) (associativity(_∩_)))
    🝖 ([≡]-with(expr ↦ expr ∩ ∁(s)) [∩]-idempotence)
    🝖 ([∩]-inverseᵣ)
    -- s∩∅ = s∩(s ∩ ∁(s)) = (s∩s) ∩ ∁(s) = s ∩ ∁(s) = ∅

  -- postulate [∪]-absorptionₗ : ∀{s₁ s₂ : S} → (s₁ ∪ (s₁ ∩ s₂)) ≡ s₁
    -- s₁∪(s₁∩s₂)
    -- = (s₁∪s₁)∩(s₁∪s₂)
    -- = s₁∩(s₁∪s₂)
    -- = (s₁∩s₁) ∪ (s₁∩s₂)
    -- = s₁ ∪ (s₁∩s₂)
    -- = ?
  -- postulate [∩]-absorptionₗ : ∀{s₁ s₂ : S} → (s₁ ∩ (s₁ ∪ s₂)) ≡ s₁

  -- ∁(s₁) ∪ ∁(s₁ ∪ s₂) = ∁(s₁)
  -- ∁(s₁) ∩ ∁(s₁ ∪ s₂) = ∁(s₁ ∪ s₂)
  -- ∁(s₁) ∪ ∁(s₁ ∩ s₂) = ∁(s₁ ∩ s₂)
  -- ∁(s₁) ∩ ∁(s₁ ∩ s₂) = ∁(s₁)

--    postulate a : ∀{a} → a

  -- postulate [∁]-of-[∪] : ∀{s₁ s₂ : S} → ∁(s₁ ∪ s₂) ≡ ∁(s₁) ∩ ∁(s₂)
  -- [∁]-of-[∪] =
    -- ((∁(s₁) ∩ ∁(s₂)) ∪ (s₁ ∪ s₂)) = 𝐔 ?

    -- (s₁ ∪ s₂) ∪ ∁(s₁ ∪ s₂) = 𝐔
    -- ∁(s₂) ∩ ((s₁ ∪ s₂) ∪ ∁(s₁ ∪ s₂)) = ∁(s₁) ∩ 𝐔
    -- (∁(s₂) ∩ (s₁ ∪ s₂)) ∪ (∁(s₁) ∩ ∁(s₁ ∪ s₂)) = ∁(s₂) ∩ 𝐔
    -- (∁(s₂) ∩ (s₁ ∪ s₂)) ∪ (∁(s₁) ∩ ∁(s₁ ∪ s₂)) = ∁(s₂) ∩ 𝐔
    -- (∁(s₂) ∩ (s₁ ∪ s₂)) ∪ (∁(s₁) ∩ ∁(s₁ ∪ s₂)) = ∁(s₂)
    -- ∁(s₂) = (∁(s₂) ∩ (s₁ ∪ s₂)) ∪ (∁(s₁) ∩ ∁(s₁ ∪ s₂))
    -- ∁(s₂) = ((∁(s₂) ∩ s₁) ∪ (∁(s₂) ∩ s₂)) ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₂) = ((∁(s₂) ∩ s₁) ∪ ∅) ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₂) = (∁(s₂) ∩ s₁) ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₁) ∩ ∁(s₂) = ∁(s₁) ∩ ((∁(s₂) ∩ s₁) ∪ ∁(s₁ ∪ s₂))
    -- ∁(s₁) ∩ ∁(s₂) = (∁(s₁) ∩ (∁(s₂) ∩ s₁)) ∪ (∁(s₁) ∩ ∁(s₁ ∪ s₂))
    -- ∁(s₁) ∩ ∁(s₂) = (∁(s₁) ∩ (∁(s₂) ∩ s₁)) ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₁) ∩ ∁(s₂) = (∁(s₁) ∩ (s₁ ∩ ∁(s₂))) ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₁) ∩ ∁(s₂) = ((∁(s₁) ∩ s₁) ∩ ∁(s₂)) ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₁) ∩ ∁(s₂) = (∅ ∩ ∁(s₂)) ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₁) ∩ ∁(s₂) = ∅ ∪ ∁(s₁ ∪ s₂)
    -- ∁(s₁) ∩ ∁(s₂) = ∁(s₁ ∪ s₂)

    -- postulate proof1 : ∀{a b c d} → (a ∩ b) ∩ (c ∪ d) ≡ (a ∩ (b ∩ d)) ∪ (b ∩ (a ∩ c))
      -- (a ∩ b) ∩ (c ∪ d)
      -- = ((a ∩ b) ∩ c) ∪ ((a ∩ b) ∩ d)
      -- = ((b ∩ a) ∩ c) ∪ ((a ∩ b) ∩ d)
      -- = (b ∩ (a ∩ c)) ∪ ((a ∩ b) ∩ d)
      -- = (b ∩ (a ∩ c)) ∪ (a ∩ (b ∩ d))
      -- = (a ∩ (b ∩ d)) ∪ (b ∩ (a ∩ c))

    -- postulate proof2 : ∀{a b} → (a ∩ b) ∩ (∁(a) ∪ ∁(b)) ≡ ∅
      -- (a ∩ b) ∩ (∁(a) ∪ ∁(b))
      -- = (a ∩ (b ∩ ∁(b))) ∪ (b ∩ (a ∩ ∁(a)))
      -- = (a ∩ ∅) ∪ (b ∩ (a ∩ ∁(a)))
      -- = ∅ ∪ (b ∩ (a ∩ ∁(a)))
      -- = b ∩ (a ∩ ∁(a))
      -- = b ∩ ∅
      -- = ∅

    -- ∁(s₁ ∪ s₂) ∪ (s₁ ∪ s₂) = 𝐔
    -- (∁(s₁ ∪ s₂) ∪ (s₁ ∪ s₂)) ∩ (∁(a) ∪ ∁(b)) = 𝐔 ∩ (∁(a) ∪ ∁(b))
    -- (∁(s₁ ∪ s₂) ∪ (s₁ ∪ s₂)) ∩ (∁(a) ∪ ∁(b)) = ∁(a) ∪ ∁(b)
    -- ∁(a) ∪ ∁(b) = (∁(s₁ ∪ s₂) ∪ (s₁ ∪ s₂)) ∩ (∁(a) ∪ ∁(b))
    -- ∁(a) ∪ ∁(b) = (∁(s₁ ∪ s₂) ∩ (∁(a) ∪ ∁(b))) ∪ ((s₁ ∪ s₂) ∩ (∁(a) ∪ ∁(b)))
    -- ∁(a) ∪ ∁(b) = (∁(s₁ ∪ s₂) ∩ (∁(a) ∪ ∁(b))) ∪ ∅
    -- ∁(a) ∪ ∁(b) = ∁(s₁ ∪ s₂) ∩ (∁(a) ∪ ∁(b))

  postulate [∁]-of-[∩] : ∀{s₁ s₂ : S} → ∁(s₁ ∩ s₂) ≡ ∁(s₁) ∪ ∁(s₂)

  [∁∁]-elim : ∀{s : S} → ∁(∁(s)) ≡ s
  [∁∁]-elim {s} = transitivity(_≡_) proof2 (symmetry(_≡_) proof1) where
    proof1 : s ≡ s ∪ ∁(∁(s))
    proof1 =
      [∩]-inverseᵣ {∁(s)}
      ⩺ [≡]-with(s ∪_)
      ⩺ (eq ↦ transitivity(_≡_) eq ((identityᵣ(_∪_)(∅)) {s}))
      ⩺ symmetry(_≡_)
      ⩺ (eq ↦ transitivity(_≡_) eq ((distributivityₗ(_∪_)(_∩_))))
      ⩺ (eq ↦ transitivity(_≡_) eq ([≡]-with(_∩ (s ∪ ∁(∁(s)))) ([∪]-inverseᵣ)))
      ⩺ (eq ↦ transitivity(_≡_) eq (identityₗ(_∩_)(𝐔)))
      -- ∁(s) ∩ ∁(∁(s)) ≡ ∅
      -- s ∪ (∁(s) ∩ ∁(∁(s))) ≡ s ∪ ∅
      -- s ∪ (∁(s) ∩ ∁(∁(s))) ≡ s
      -- s ≡ s ∪ (∁(s) ∩ ∁(∁(s)))
      -- s ≡ (s ∪ ∁(s)) ∩ (s ∪ ∁(∁(s)))
      -- s ≡ 𝐔 ∩ (s ∪ ∁(∁(s)))
      -- s ≡ s ∪ ∁(∁(s))

    proof2 : ∁(∁(s)) ≡ s ∪ ∁(∁(s))
    proof2 =
      [∩]-inverseᵣ {s}
      ⩺ [≡]-with(_∪ ∁(∁(s)))
      ⩺ (eq ↦ transitivity(_≡_) eq (identityₗ(_∪_)(∅)))
      ⩺ symmetry(_≡_)
      ⩺ (eq ↦ transitivity(_≡_) eq ((distributivityᵣ(_∪_)(_∩_))))
      ⩺ (eq ↦ transitivity(_≡_) eq ([≡]-with((s ∪ ∁(∁(s))) ∩_) ([∪]-inverseᵣ)))
      ⩺ (eq ↦ transitivity(_≡_) eq ((identityᵣ(_∩_)(𝐔))))
      -- (s ∩ ∁(s)) ∪ ∁(∁(s)) ≡ ∅ ∪ ∁(∁(s))
      -- (s ∩ ∁(s)) ∪ ∁(∁(s)) ≡ ∁(∁(s))
      -- ∁(∁(s)) ≡ (s ∩ ∁(s)) ∪ ∁(∁(s))
      -- ∁(∁(s)) ≡ (s ∪ ∁(∁(s))) ∩ (∁(s) ∪ ∁(∁(s)))
      -- ∁(∁(s)) ≡ (s ∪ ∁(∁(s))) ∩ 𝐔
      -- ∁(∁(s)) ≡ s ∪ ∁(∁(s))

  postulate [∁]-uniqueness : ∀{s₁ s₂ : S} → (s₁ ∪ s₂ ≡ 𝐔) → (s₁ ∩ s₂ ≡ ∅) → (s₁ ≡ ∁(s₂))

  postulate [∁]-of-[∖] : ∀{s₁ s₂ : S} → ∁(s₁ ∖ s₂) ≡ ∁(s₁) ∪ s₂
  postulate [∖]-of-[∁] : ∀{s₁ s₂ : S} → ∁(s₁) ∖ ∁(s₂) ≡ s₂ ∖ s₁

  postulate [∖]-of-[∪]ᵣ : ∀{s₁ s₂ s₃ : S} → (s₁ ∖ (s₂ ∪ s₃)) ≡ (s₁ ∖ s₂)∩(s₁ ∖ s₃)
  postulate [∖]-of-[∩]ᵣ : ∀{s₁ s₂ s₃ : S} → (s₁ ∖ (s₂ ∩ s₃)) ≡ (s₁ ∖ s₂)∪(s₁ ∖ s₃)

  postulate [∖]-of-[∖]ᵣ : ∀{s₁ s₂ s₃ : S} → (s₁ ∖ (s₂ ∖ s₃)) ≡ (s₁ ∩ s₃)∪(s₁ ∖ s₂)
  postulate [∩]-from-[∖] : ∀{s₁ s₂ : S} → (s₁ ∖ (s₁ ∖ s₂)) ≡ (s₁ ∩ s₂) -- TODO: from [∖]-of-[∖]ᵣ

  postulate [∖]-self : ∀{s : S} → s ∖ s ≡ ∅
  postulate [∖]-of-[∅]ₗ : ∀{s : S} → ∅ ∖ s ≡ ∅
  postulate [∖]-of-[∅]ᵣ : ∀{s : S} → s ∖ ∅ ≡ s
  postulate [∖]-of-[𝐔]ₗ : ∀{s : S} → 𝐔 ∖ s ≡ ∁(s)
  postulate [∖]-of-[𝐔]ᵣ : ∀{s : S} → s ∖ 𝐔 ≡ ∅

record Subset : Type{Lvl.𝐒(ℓ)} where
  field
    _⊆_ : S → S → Stmt{ℓ} -- Subset
    ⦃ fundamentals ⦄ : Fundamentals
  open Fundamentals(fundamentals)

  field
    ⦃ [⊆]-antisymmetry ⦄ : Antisymmetry(_⊆_)(_≡_)
    ⦃ [⊆]-transitivity ⦄ : Transitivity(_⊆_)
    ⦃ [⊆]-reflexivity  ⦄ : Reflexivity(_⊆_)

    [≡]-to-[⊆] : ∀{a b} → (a ≡ b) → (a ⊆ b)

    [⊆]ₗ-of-[∪] : ∀{a b c} → (a ⊆ c) → (b ⊆ c) → ((a ∪ b) ⊆ c)
    [⊆]ᵣ-of-[∪]ₗ : ∀{a b} → (a ⊆ (a ∪ b))

    [⊆]ₗ-of-[∩]ₗ : ∀{a b} → ((a ∩ b) ⊆ a)
    [⊆]ᵣ-of-[∩] : ∀{a b c} → (c ⊆ a) → (c ⊆ b) → (c ⊆ (a ∩ b))

  [⊆]ᵣ-of-[∪]ᵣ : ∀{a b} → (b ⊆ (a ∪ b))
  [⊆]ᵣ-of-[∪]ᵣ {a}{b} =
    [⊆]ᵣ-of-[∪]ₗ {b}{a}
    🝖 [≡]-to-[⊆] (commutativity(_∪_))

  [⊆]ₗ-of-[∩]ᵣ : ∀{a b} → ((a ∩ b) ⊆ b)
  [⊆]ₗ-of-[∩]ᵣ {a}{b} =
    [≡]-to-[⊆] (commutativity(_∩_))
    🝖 [⊆]ₗ-of-[∩]ₗ {b}{a}

  [⊆]-min : ∀{s} → (∅ ⊆ s)
  [⊆]-min {s} =
    [⊆]ᵣ-of-[∪]ₗ {∅}{s}
    🝖 [≡]-to-[⊆] (identityₗ(_∪_)(∅))

  [⊆]-max : ∀{s} → (s ⊆ 𝐔)
  [⊆]-max {s} =
    [≡]-to-[⊆] (symmetry(_≡_) (identityₗ(_∩_)(𝐔)))
    🝖 [⊆]ₗ-of-[∩]ₗ {𝐔}{s}

  [⊆][∩]-equiv : ∀{a b} → (a ⊆ b) ↔ (a ∩ b ≡ a)
  [⊆][∩]-equiv {a}{b} = [↔]-intro l r where
    l : (a ⊆ b) ← (a ∩ b ≡ a)
    l aba =
      [≡]-to-[⊆] (symmetry(_≡_) aba)
      🝖 [⊆]ₗ-of-[∩]ᵣ

    r : (a ⊆ b) → (a ∩ b ≡ a)
    r ab =
      (antisymmetry(_⊆_)(_≡_)
        ([⊆]ₗ-of-[∩]ₗ)
        ([⊆]ᵣ-of-[∩] {a}{b}{a} (reflexivity(_⊆_)) ab)
      )
{-
  [⊆][∪]-equiv : ∀{a b} → (a ⊆ b) ↔ (a ∪ b ≡ b)
  [⊆][∪]-equiv {a}{b} = [↔]-intro l r where
    l : (a ⊆ b) ← (a ∪ b ≡ b)
    l aba =
      [≡]-to-[⊆] (symmetry(_≡_) aba)
      🝖 [⊆]ᵣ-of-[∪]ᵣ

    r : (a ⊆ b) → (a ∪ b ≡ b)
    r ab =
      (antisymmetry
        ([⊆]ᵣ-of-[∪]ᵣ)
        ([⊆]ₗ-of-[∪] {a}{b}{a} reflexivity ab)
      )
-}
  -- [⊆][∖]-equiv : (a ⊆ b) ↔ (a ∖ b ≡ ∅)

  -- [⊆][∁]-equiv : (a ⊆ b) ↔ (∁(b) ⊆ ∁(a))

  -- [∩][∪]-sub : (a ∩ b) ⊆ (a ∪ b)


{-# OPTIONS --universe-polymorphism #-}

module NiceGoals where

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

postulate
  Level : Set
  zero : Level
  suc  : (i : Level) → Level
  _⊔_ : Level → Level → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}
{-# BUILTIN LEVELMAX _⊔_ #-}

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

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

module M (rm : RawMonoid zero zero) where

  open RawMonoid rm

  thm : ∀ x → x ∙ ε ≈ x
  thm = {!!}

  -- agda2-goal-and-context:

  -- rm : RawMonoid zero zero
  -- ------------------------
  -- Goal: (x : RawMonoid.Carrier rm) →
  --       RawMonoid._≈_ rm (RawMonoid._∙_ rm x (RawMonoid.ε rm)) x

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

record RawMonoid′ : Set₁ where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set
    _≈_     : Carrier → Carrier → Set
    _∙_     : Carrier → Carrier → Carrier
    ε       : Carrier

module M′ (rm : RawMonoid′) where

  open RawMonoid′ rm

  thm′ : ∀ x → x ∙ ε ≈ x
  thm′ = {!!}

  -- agda2-goal-and-context:

  -- rm : RawMonoid′
  -- ---------------
  -- Goal: (x : Carrier) → x ∙ ε ≈ x

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

-- UP isn't relevant.

record RawMonoid″ (Carrier : Set) : Set₁ where
  infixl 7 _∙_
  infix  4 _≈_
  field
    _≈_     : Carrier → Carrier → Set
    _∙_     : Carrier → Carrier → Carrier
    ε       : Carrier

data Bool : Set where
  true false : Bool

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

module M″ (rm : RawMonoid″ (List Bool)) where

  open RawMonoid″ rm

  thm″ : ∀ x → x ∙ ε ≈ x
  thm″ = {!!}

  -- agda2-goal-and-context:

  -- rm : RawMonoid″ (List Bool)
  -- ---------------------------
  -- Goal: (x : List Bool) →
  --       RawMonoid″._≈_ rm (RawMonoid″._∙_ rm x (RawMonoid″.ε rm)) x

module M₁ (Z : Set₁) where

  postulate
    P : Set
    Q : Set → Set

module M₂ (X Y : Set) where

  module M₁′ = M₁ Set
  open M₁′

  p : P
  p = {!!}

  q : Q X
  q = {!!}

postulate X : Set

pp : M₂.M₁′.P X X
pp = {!!}


-- TODO: Generalize and move to Structure.Categorical.Proofs
module Structure.Category.Proofs where

import      Lvl
open import Data
open import Data.Tuple as Tuple using (_,_)
open import Functional using (const ; swap ; _$_)
open import Lang.Instance
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Category
open import Structure.Categorical.Names
open import Structure.Categorical.Properties
import      Structure.Operator.Properties as Properties
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Function
open import Syntax.Transitivity
open import Type

module _
  {ℓₒ ℓₘ ℓₑ : Lvl.Level}
  {Obj : Type{ℓₒ}}
  {Morphism : Obj → Obj → Type{ℓₘ}}
  ⦃ morphism-equiv : ∀{x y} → Equiv{ℓₑ}(Morphism x y) ⦄
  (cat : Category(Morphism))
  where

  open Category(cat)
  open Category.ArrowNotation(cat)
  open Morphism.OperModule(\{x} → _∘_ {x})
  open Morphism.IdModule(\{x} → _∘_ {x})(id)
  private open module [≡]-Equivalence {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equiv{x}{y} ⦄) using ()

  private variable x y z : Obj
  private variable f g h i : x ⟶ y

  associate4-123-321 : (((f ∘ g) ∘ h) ∘ i ≡ f ∘ (g ∘ (h ∘ i)))
  associate4-123-321 = Morphism.associativity(_∘_) 🝖 Morphism.associativity(_∘_)

  associate4-123-213 : (((f ∘ g) ∘ h) ∘ i ≡ (f ∘ (g ∘ h)) ∘ i)
  associate4-123-213 = congruence₂ₗ(_∘_)(_) (Morphism.associativity(_∘_))

  associate4-321-231 : (f ∘ (g ∘ (h ∘ i)) ≡ f ∘ ((g ∘ h) ∘ i))
  associate4-321-231 = congruence₂ᵣ(_∘_)(_) (symmetry(_≡_) (Morphism.associativity(_∘_)))

  associate4-213-121 : ((f ∘ (g ∘ h)) ∘ i ≡ (f ∘ g) ∘ (h ∘ i))
  associate4-213-121 = symmetry(_≡_) (congruence₂ₗ(_∘_)(_) (Morphism.associativity(_∘_))) 🝖 Morphism.associativity(_∘_)

  associate4-231-213 : f ∘ ((g ∘ h) ∘ i) ≡ (f ∘ (g ∘ h)) ∘ i
  associate4-231-213 = symmetry(_≡_) (Morphism.associativity(_∘_))

  associate4-231-123 : f ∘ ((g ∘ h) ∘ i) ≡ ((f ∘ g) ∘ h) ∘ i
  associate4-231-123 = associate4-231-213 🝖 symmetry(_≡_) associate4-123-213

  associate4-231-121 : (f ∘ ((g ∘ h) ∘ i) ≡ (f ∘ g) ∘ (h ∘ i))
  associate4-231-121 = congruence₂ᵣ(_∘_)(_) (Morphism.associativity(_∘_)) 🝖 symmetry(_≡_) (Morphism.associativity(_∘_))

  id-automorphism : Automorphism(id{x})
  ∃.witness id-automorphism = id
  ∃.proof   id-automorphism = intro(Morphism.identityₗ(_∘_)(id)) , intro(Morphism.identityᵣ(_∘_)(id))

  inverse-isomorphism : (f : x ⟶ y) → ⦃ _ : Isomorphism(f) ⦄ → Isomorphism(inv f)
  ∃.witness (inverse-isomorphism f) = f
  ∃.proof   (inverse-isomorphism f) = intro (inverseᵣ(f)(inv f)) , intro (inverseₗ(f)(inv f)) where
    open Isomorphism(f)

  module _ ⦃ op : ∀{x y z} → BinaryOperator(_∘_ {x}{y}{z}) ⦄ where
    op-closed-under-isomorphism : ∀{A B C : Obj} → (f : B ⟶ C) → (g : A ⟶ B) → ⦃ _ : Isomorphism(f) ⦄ → ⦃ _ : Isomorphism(g) ⦄ → Isomorphism(f ∘ g)
    ∃.witness (op-closed-under-isomorphism f g) = inv g ∘ inv f
    Tuple.left (∃.proof (op-closed-under-isomorphism f g)) = intro $
      (inv g ∘ inv f) ∘ (f ∘ g) 🝖-[ associate4-213-121 ]-sym
      (inv g ∘ (inv f ∘ f)) ∘ g 🝖-[ congruence₂ₗ(_∘_) ⦃ op ⦄ (g) (congruence₂ᵣ(_∘_) ⦃ op ⦄ (inv g) (Morphism.inverseₗ(_∘_)(id) (f)(inv f))) ]
      (inv g ∘ id) ∘ g          🝖-[ congruence₂ₗ(_∘_) ⦃ op ⦄ (g) (Morphism.identityᵣ(_∘_)(id)) ]
      inv g ∘ g                 🝖-[ Morphism.inverseₗ(_∘_)(id) (g)(inv g) ]
      id                        🝖-end
      where
        open Isomorphism(f)
        open Isomorphism(g)
    Tuple.right (∃.proof (op-closed-under-isomorphism f g)) = intro $
      (f ∘ g) ∘ (inv g ∘ inv f) 🝖-[ associate4-213-121 ]-sym
      (f ∘ (g ∘ inv g)) ∘ inv f 🝖-[ congruence₂ₗ(_∘_) ⦃ op ⦄ (_) (congruence₂ᵣ(_∘_) ⦃ op ⦄ (_) (Morphism.inverseᵣ(_∘_)(id) (_)(_))) ]
      (f ∘ id) ∘ inv f          🝖-[ congruence₂ₗ(_∘_) ⦃ op ⦄ (_) (Morphism.identityᵣ(_∘_)(id)) ]
      f ∘ inv f                 🝖-[ Morphism.inverseᵣ(_∘_)(id) (_)(_) ]
      id                        🝖-end
      where
        open Isomorphism(f)
        open Isomorphism(g)

  instance
    Isomorphic-reflexivity : Reflexivity(Isomorphic)
    ∃.witness (Reflexivity.proof Isomorphic-reflexivity) = id
    ∃.proof   (Reflexivity.proof Isomorphic-reflexivity) = id-automorphism

  instance
    Isomorphic-symmetry : Symmetry(Isomorphic)
    ∃.witness (Symmetry.proof Isomorphic-symmetry iso-xy) = inv(∃.witness iso-xy)
    ∃.proof   (Symmetry.proof Isomorphic-symmetry iso-xy) = inverse-isomorphism(∃.witness iso-xy)

  module _ ⦃ op : ∀{x y z} → BinaryOperator(_∘_ {x}{y}{z}) ⦄ where
    instance
      Isomorphic-transitivity : Transitivity(Isomorphic)
      ∃.witness (Transitivity.proof Isomorphic-transitivity ([∃]-intro xy) ([∃]-intro yz)) = yz ∘ xy
      ∃.proof   (Transitivity.proof Isomorphic-transitivity ([∃]-intro xy) ([∃]-intro yz)) = op-closed-under-isomorphism ⦃ op ⦄ yz xy

    instance
      Isomorphic-equivalence : Equivalence(Isomorphic)
      Isomorphic-equivalence = record{}


{-# OPTIONS --safe #-}
module Cubical.Algebra.Lattice where

open import Cubical.Algebra.Lattice.Base public
open import Cubical.Algebra.Lattice.Properties public


------------------------------------------------------------------------------
-- We could not define the FOTC colists using the Agda machinery for
-- co-inductive types.
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Colist.TypeSL where

open import Codata.Musical.Notation

open import FOTC.Base
open import FOTC.Base.List

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

data Colist : D → Set where
  nilCL  : Colist []
  consCL : ∀ x xs → ∞ (Colist xs) → Colist (x ∷ xs)

-- Example (finite colist).
l₁ : Colist (zero ∷ true ∷ [])
l₁ = consCL zero (true ∷ []) (♯ (consCL true [] (♯ nilCL)))

-- Example (infinite colist).
-- zerosCL : Colist {!!}
-- zerosCL = consCL zero {!!} (♯ zerosCL)


module Direction where

open import Relation.Binary.PropositionalEquality hiding (Extensionality)

----------------------------------------------------------------------
-- direction

data Dir : Set where
  SND RCV : Dir

variable
  d d₁ d₂ d₃ : Dir

-- dual
dual-dir : Dir → Dir
dual-dir SND = RCV
dual-dir RCV = SND

dual-dir-inv : (d : Dir) → dual-dir (dual-dir d) ≡ d
dual-dir-inv SND = refl
dual-dir-inv RCV = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Sums of nullary relations
------------------------------------------------------------------------

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

module Relation.Nullary.Sum where

open import Data.Sum
open import Data.Empty
open import Level
open import Relation.Nullary

-- Some properties which are preserved by _⊎_.

infixr 1 _¬-⊎_ _⊎-dec_

_¬-⊎_ : ∀ {p q} {P : Set p} {Q : Set q} →
        ¬ P → ¬ Q → ¬ (P ⊎ Q)
(¬p ¬-⊎ ¬q) (inj₁ p) = ¬p p
(¬p ¬-⊎ ¬q) (inj₂ q) = ¬q q

_⊎-dec_ : ∀ {p q} {P : Set p} {Q : Set q} →
          Dec P → Dec Q → Dec (P ⊎ Q)
yes p ⊎-dec _     = yes (inj₁ p)
_     ⊎-dec yes q = yes (inj₂ q)
no ¬p ⊎-dec no ¬q = no helper
  where
  helper : _ ⊎ _ → ⊥
  helper (inj₁ p) = ¬p p
  helper (inj₂ q) = ¬q q


{-# OPTIONS --universe-polymorphism #-}
-- {-# OPTIONS --verbose tc.records.ifs:15 #-}
-- {-# OPTIONS --verbose tc.constr.findInScope:15 #-}
-- {-# OPTIONS --verbose tc.term.args.ifs:15 #-}
-- {-# OPTIONS --verbose cta.record.ifs:15 #-}
-- {-# OPTIONS --verbose tc.section.apply:25 #-}
-- {-# OPTIONS --verbose tc.mod.apply:100 #-}
-- {-# OPTIONS --verbose scope.rec:15 #-}
-- {-# OPTIONS --verbose tc.rec.def:15 #-}

module 07-subclasses where

open import Data.Bool hiding (_≟_)
open import Data.Nat hiding (_<_)
open import Relation.Nullary.Decidable
open import Function using (_$_; id)

record Eq (A : Set) : Set where
  field eq : A → A → Bool

primEqBool : Bool → Bool → Bool
primEqBool true = id
primEqBool false = not

eqBool : Eq Bool
eqBool = record { eq = primEqBool }

primEqNat : ℕ → ℕ → Bool
primEqNat a b = ⌊ a ≟ b ⌋

primLtNat : ℕ → ℕ → Bool
primLtNat 0 _ = true
primLtNat (suc a) (suc b) = primLtNat a b
primLtNat _ _ = false

neq : {t : Set} → {{eqT : Eq t}} → t → t → Bool
neq a b = not $ eq a b
  where open Eq {{...}}

record Ord₁ (A : Set) : Set where
  field _<_ : A → A → Bool
        eqA : Eq A

ord₁Nat : Ord₁ ℕ
ord₁Nat = record { _<_ = primLtNat; eqA = eqNat }
  where eqNat : Eq ℕ
        eqNat = record { eq = primEqNat }

record Ord₂ {A : Set} (eqA : Eq A) : Set where
  field _<_ : A → A → Bool

ord₂Nat : Ord₂ (record { eq = primEqNat })
ord₂Nat = record { _<_ = primLtNat }

record Ord₃ (A : Set) : Set where
  field _<_ : A → A → Bool
        eqA : Eq A
  open Eq eqA public

ord₃Nat : Ord₃ ℕ
ord₃Nat = record { _<_ = primLtNat; eqA = eqNat }
  where eqNat : Eq ℕ
        eqNat = record { eq = primEqNat }

record Ord₄ {A : Set} (eqA : Eq A) : Set where
  field _<_ : A → A → Bool
  open Eq eqA public

ord₄Nat : Ord₄ (record { eq = primEqNat })
ord₄Nat = record { _<_ = primLtNat }

module test₁ where
  open Ord₁ {{...}}
  open Eq {{...}}

  eqNat = eqA

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq true false
  test₄ : {A : Set} → {{ ordA : Ord₁ A }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b
    where eqA' = eqA

module test₂ where
  open Ord₂ {{...}}
  open Eq {{...}}

  eqNat : Eq ℕ
  eqNat = record { eq = primEqNat }

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq true false
  test₄ : {A : Set} → {eqA : Eq A} → {{ ordA : Ord₂ eqA }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b

module test₃ where
  open Ord₃ {{...}}
  open Eq {{...}} renaming (eq to eq')

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq' true false
  test₄ : {A : Set} → {{ ordA : Ord₃ A }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b

module test₄ where
  open Ord₄ {{...}}
  open Eq {{...}} renaming (eq to eq')

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq' true false
  test₄ : {A : Set} → {eqA : Eq A} → {{ ordA : Ord₄ eqA }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b

module test₄′ where
  open Ord₄ {{...}} hiding (eq)
  open Eq {{...}}

  eqNat : Eq ℕ
  eqNat = record { eq = primEqNat }

  test₁ = 5 < 3
  test₂ = eq 5 3
  test₃ = eq true false
  test₄ : {A : Set} → {eqA : Eq A} → {{ ordA : Ord₄ eqA }} → A → A → Bool
  test₄ a b = a < b ∨ eq a b


{-# OPTIONS --without-K  #-}
module algebra.semigroup.morphism where

open import level
open import algebra.semigroup.core
open import equality.core
open import hott.level

module _ {i}{j}
         {X : Set i}⦃ sX : IsSemigroup X ⦄
         {Y : Set j}⦃ sY : IsSemigroup Y ⦄ where
  open IsSemigroup ⦃ ... ⦄

  IsSemigroupMorphism : (X → Y) → Set (i ⊔ j)
  IsSemigroupMorphism f = (x₁ x₂ : X) → f (x₁ * x₂) ≡ f x₁ * f x₂

  is-semigroup-morphism-level : (f : X → Y) → h 1 (IsSemigroupMorphism f)
  is-semigroup-morphism-level f = Π-level λ x₁ → Π-level λ x₂ → is-set _ _


{-

This file contains a diagonalization procedure simpler than Smith normalization.
For any matrix M, it provides two invertible matrices P, Q, one diagonal matrix D and an equality M = P·D·Q.
The only difference from Smith is, the numbers in D are allowed to be arbitrary, instead of being consecutively divisible.
But it is enough to establish important properties of finitely presented abelian groups.
Also, it can be computed much more efficiently (than Smith, only).

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.IntegerMatrix.Diagonalization where

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

open import Cubical.Data.Nat
  hiding   (_·_)
  renaming (_+_ to _+ℕ_ ; +-assoc to +Assocℕ)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Nat.Divisibility
  using    (m∣n→m≤n)
  renaming (∣-trans to ∣ℕ-trans ; ∣-refl to ∣-reflℕ)
open import Cubical.Data.Int
  hiding   (_+_ ; _·_ ; _-_ ; -_ ; addEq)
open import Cubical.Data.Int.Divisibility
open import Cubical.Data.FinData

open import Cubical.Data.Empty as Empty
open import Cubical.Data.Unit  as Unit
open import Cubical.Data.Sum
open import Cubical.Data.Sigma
open import Cubical.Data.List

open import Cubical.Algebra.Matrix
open import Cubical.Algebra.Matrix.CommRingCoefficient
open import Cubical.Algebra.Matrix.Elementaries
open import Cubical.Algebra.IntegerMatrix.Base
open import Cubical.Algebra.IntegerMatrix.Elementaries

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Instances.Int
  renaming (ℤ to ℤRing)

open import Cubical.Relation.Nullary
open import Cubical.Induction.WellFounded

private
  variable
    m n k : ℕ

open CommRingStr      (ℤRing .snd)

open Coefficient ℤRing
open Sim

open ElemTransformation ℤRing
open ElemTransformationℤ
open SwapPivot
open RowsImproved
open ColsImproved

-- Sequence of non-zero integers

isNonZero : List ℤ → Type
isNonZero [] = Unit
isNonZero (x ∷ xs) = (¬ x ≡ 0) × isNonZero xs

isPropIsNonZero : (xs : List ℤ) → isProp (isNonZero xs)
isPropIsNonZero [] = isPropUnit
isPropIsNonZero (x ∷ xs) = isProp× (isPropΠ (λ _ → isProp⊥)) (isPropIsNonZero xs)

NonZeroList : Type
NonZeroList = Σ[ xs ∈ List ℤ ] isNonZero xs

cons : (n : ℤ)(xs : NonZeroList) → ¬ n ≡ 0 → NonZeroList
cons n (xs , _) _ .fst = n ∷ xs
cons n ([] , _) p .snd = p , tt
cons n (x ∷ xs , q) p .snd = p , q

-- Smith normal matrix

_+length_ : NonZeroList → ℕ → ℕ
xs +length n = length (xs .fst) +ℕ n

diagMat : (xs : List ℤ)(m n : ℕ) → Mat (length xs +ℕ m) (length xs +ℕ n)
diagMat [] _ _ = 𝟘
diagMat (x ∷ xs) _ _ = x ⊕ diagMat xs _ _

diagMat⊕ :
    (a : ℤ)(xs : NonZeroList){m n : ℕ}
  → (p : ¬ a ≡ 0)
  → a ⊕ diagMat (xs .fst) m n ≡ diagMat (cons a xs p .fst) m n
diagMat⊕ _ _ _ = refl

-- Diagonal matrix with non-zero diagonal elements
-- Notice that we allow non-square matrices.

record isDiagonal (M : Mat m n) : Type where
  field
    divs : NonZeroList
    rowNull : ℕ
    colNull : ℕ

    rowEq : divs +length rowNull ≡ m
    colEq : divs +length colNull ≡ n
    matEq : PathP (λ t → Mat (rowEq t) (colEq t)) (diagMat (divs .fst) rowNull colNull) M

open isDiagonal

row col : {M : Mat m n} → isDiagonal M → ℕ
row isNorm = isNorm .divs +length isNorm .rowNull
col isNorm = isNorm .divs +length isNorm .colNull

isDiagonal𝟘 : isDiagonal (𝟘 {m = m} {n = n})
isDiagonal𝟘 .divs = [] , tt
isDiagonal𝟘 {m = m} .rowNull = m
isDiagonal𝟘 {n = n} .colNull = n
isDiagonal𝟘 .rowEq = refl
isDiagonal𝟘 .colEq = refl
isDiagonal𝟘 .matEq = refl

isDiagonalEmpty : (M : Mat 0 n) → isDiagonal M
isDiagonalEmpty _ .divs = [] , tt
isDiagonalEmpty _ .rowNull = 0
isDiagonalEmpty {n = n} _ .colNull = n
isDiagonalEmpty _ .rowEq = refl
isDiagonalEmpty _ .colEq = refl
isDiagonalEmpty _ .matEq = isContr→isProp isContrEmpty _ _

isDiagonalEmptyᵗ : (M : Mat m 0) → isDiagonal M
isDiagonalEmptyᵗ _ .divs = [] , tt
isDiagonalEmptyᵗ {m = m} _ .rowNull = m
isDiagonalEmptyᵗ _ .colNull = 0
isDiagonalEmptyᵗ _ .rowEq = refl
isDiagonalEmptyᵗ _ .colEq = refl
isDiagonalEmptyᵗ _ .matEq = isContr→isProp isContrEmptyᵗ _ _

-- Induction step towards diagonalization

data DivStatus (a : ℤ)(M : Mat (suc m) (suc n)) : Type where
  badCol  : (i : Fin m)(p : ¬ a ∣ M (suc i) zero) → DivStatus a M
  badRow  : (j : Fin n)(p : ¬ a ∣ M zero (suc j)) → DivStatus a M
  allDone : ((i : Fin m) → a ∣ M (suc i) zero)
          → ((j : Fin n) → a ∣ M zero (suc j)) → DivStatus a M

divStatus : (a : ℤ)(M : Mat (suc m) (suc n)) → DivStatus a M
divStatus a M =
  let  col? = ∀Dec (λ i → a ∣ M (suc i) zero) (λ _ → dec∣ _ _)
       row? = ∀Dec (λ j → a ∣ M zero (suc j)) (λ _ → dec∣ _ _) in
  case col?
  return (λ _ → DivStatus a M) of λ
  { (inr p) → badCol (p .fst) (p .snd)
  ; (inl p) →
      case row?
      return (λ _ → DivStatus a M) of λ
      { (inr q) → badRow (q .fst) (q .snd)
      ; (inl q) → allDone p q }}

record DiagStep (M : Mat (suc m) (suc n)) : Type where
  field
    sim : Sim M

    firstColClean : (i : Fin m) → sim .result (suc i) zero ≡ 0
    firstRowClean : (j : Fin n) → sim .result zero (suc j) ≡ 0

    nonZero : ¬ sim .result zero zero ≡ 0

open DiagStep

simDiagStep : {M : Mat (suc m) (suc n)}(sim : Sim M) → DiagStep (sim .result) → DiagStep M
simDiagStep simM diag .sim = compSim simM (diag .sim)
simDiagStep _    diag .firstColClean = diag .firstColClean
simDiagStep _    diag .firstRowClean = diag .firstRowClean
simDiagStep _    diag .nonZero = diag .nonZero

private
  diagStep-helper :
      (M : Mat (suc m) (suc n))
    → (p : ¬ M zero zero ≡ 0)(h : Norm (M zero zero))
    → (div? : DivStatus (M zero zero) M)
    → DiagStep M
  diagStep-helper M p (acc ind) (badCol i q) =
    let improved = improveRows M p
        normIneq =
          ind _ (stDivIneq p q (improved .div zero) (improved .div (suc i)))
    in  simDiagStep (improved .sim)
                    (diagStep-helper _ (improved .nonZero) normIneq (divStatus _ _))
  diagStep-helper M p (acc ind) (badRow j q) =
    let improved = improveCols M p
        normIneq =
          ind _ (stDivIneq p q (improved .div zero) (improved .div (suc j)))
    in  simDiagStep (improved .sim)
                    (diagStep-helper _ (improved .nonZero) normIneq (divStatus _ _))
  diagStep-helper M p (acc ind) (allDone div₁ div₂) =
    let improveColM = improveCols M p
        invCol = bézoutRows-inv _ p div₂
        divCol = (λ i → transport (λ t → invCol t zero ∣ invCol t (suc i)) (div₁ i))
        improveRowM = improveRows (improveColM .sim .result) (improveColM .nonZero)
        invCol = bézoutRows-inv _ (improveColM .nonZero) divCol
    in  record
        { sim = compSim (improveColM .sim) (improveRowM .sim)
        ; firstColClean = improveRowM .vanish
        ; firstRowClean = (λ j → (λ t → invCol (~ t) (suc j)) ∙ improveColM .vanish j)
        ; nonZero = improveRowM .nonZero }

  diagStep-getStart : (M : Mat (suc m) (suc n)) → NonZeroOrNot M → DiagStep M ⊎ (M ≡ 𝟘)
  diagStep-getStart _ (allZero p) = inr p
  diagStep-getStart M (hereIs i j p) =
    let swapM = swapPivot i j M
        swapNonZero = (λ r → p (swapM .swapEq ∙ r))
        diagM = diagStep-helper _ swapNonZero (<-wellfounded _) (divStatus _ _)
    in  inl (simDiagStep (swapM .sim) diagM)

diagStep : (M : Mat (suc m) (suc n)) → DiagStep M ⊎ (M ≡ 𝟘)
diagStep _ = diagStep-getStart _ (findNonZero _)

-- The diagonalization

record Diag (M : Mat m n) : Type where
  field
    sim : Sim M
    isdiag : isDiagonal (sim .result)

open Diag

simDiag : {M : Mat m n}(sim : Sim M) → Diag (sim .result) → Diag M
simDiag simM diag .sim = compSim simM (diag .sim)
simDiag _ diag .isdiag = diag .isdiag

diag𝟘 : Diag (𝟘 {m = m} {n = n})
diag𝟘 .sim    = idSim _
diag𝟘 .isdiag = isDiagonal𝟘

diagEmpty : (M : Mat 0 n) → Diag M
diagEmpty _ .sim    = idSim _
diagEmpty M .isdiag = isDiagonalEmpty M

diagEmptyᵗ : (M : Mat m 0) → Diag M
diagEmptyᵗ _ .sim    = idSim _
diagEmptyᵗ M .isdiag = isDiagonalEmptyᵗ M

decompDiagStep :
    (M : Mat (suc m) (suc n))(step : DiagStep M)
  → step .sim .result ≡ step .sim .result zero zero ⊕ sucMat (step .sim .result)
decompDiagStep M step t zero zero = step .sim .result zero zero
decompDiagStep M step t zero (suc j) = step .firstRowClean j t
decompDiagStep M step t (suc i) zero = step .firstColClean i t
decompDiagStep M step t (suc i) (suc j) = step .sim .result (suc i) (suc j)

consIsDiagonal :
    (a : ℤ)(M : Mat m n)
  → (p : ¬ a ≡ 0)
  → isDiagonal M → isDiagonal (a ⊕ M)
consIsDiagonal a _ p diag .divs = cons a (diag .divs) p
consIsDiagonal _ _ _ diag .rowNull = diag .rowNull
consIsDiagonal _ _ _ diag .colNull = diag .colNull
consIsDiagonal _ _ _ diag .rowEq = (λ t → suc (diag .rowEq t))
consIsDiagonal _ _ _ diag .colEq = (λ t → suc (diag .colEq t))
consIsDiagonal a _ _ diag .matEq = (λ t → a ⊕ diag .matEq t)

diagReduction :
    (a : ℤ)(M : Mat m n)
  → (p : ¬ a ≡ 0)
  → Diag M → Diag (a ⊕ M)
diagReduction a _ _ diag .sim = ⊕Sim a (diag .sim)
diagReduction a _ p diag .isdiag = consIsDiagonal a _ p (diag .isdiag)

-- The Existence of Diagonalization

diagonalize : (M : Mat m n) → Diag M
diagonalize {m = 0} = diagEmpty
diagonalize {m = suc m} {n = 0} = diagEmptyᵗ
diagonalize {m = suc m} {n = suc n} M = helper (diagStep _)
  where
  helper : DiagStep M ⊎ (M ≡ 𝟘) → Diag M
  helper (inr p) = subst Diag (sym p) diag𝟘
  helper (inl stepM) =
    let sucM = sucMat (stepM .sim .result)
        diagM = diagReduction _ _ (stepM .nonZero) (diagonalize sucM)
    in  simDiag (compSim (stepM .sim) (≡Sim (decompDiagStep _ stepM))) diagM


{-# OPTIONS --without-K #-}
module function.extensionality.core where

open import level using (lsuc; _⊔_)
open import equality.core

Extensionality : ∀ i j → Set (lsuc (i ⊔ j))
Extensionality i j = {X : Set i}{Y : Set j}
                   → {f g : X → Y}
                   → ((x : X) → f x ≡ g x)
                   → f ≡ g

Extensionality' : ∀ i j → Set (lsuc (i ⊔ j))
Extensionality' i j = {X : Set i}{Y : X → Set j}
                    → {f g : (x : X) → Y x}
                    → ((x : X) → f x ≡ g x)
                    → f ≡ g

StrongExt : ∀ i j → Set (lsuc (i ⊔ j))
StrongExt i j = {X : Set i}{Y : X → Set j}
              → {f g : (x : X) → Y x}
              → (∀ x → f x ≡ g x) ≡ (f ≡ g)

funext-inv : ∀ {i j}{X : Set i}{Y : X → Set j}
        → {f g : (x : X) → Y x}
        → f ≡ g
        → (x : X) → f x ≡ g x
funext-inv refl x = refl


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

open import Cubical.Core.Everything
open import Cubical.Foundations.Logic
open import Cubical.Foundations.Everything

private
  variable
    A : Type₀

infixr 20 _∷_
infix 30 _∈_

data LFSet (A : Type₀) : Type₀ where
  []    : LFSet A
  _∷_   : (x : A) → (xs : LFSet A) → LFSet A
  dup   : ∀ x xs   → x ∷ x ∷ xs ≡ x ∷ xs
  comm  : ∀ x y xs → x ∷ y ∷ xs ≡ y ∷ x ∷ xs
  trunc : isSet (LFSet A)

-- Membership.
--
-- Doing some proofs with equational reasoning adds an extra "_∙ refl"
-- at the end.
-- We might want to avoid it, or come up with a more clever equational reasoning.
_∈_ : A → LFSet A → hProp _
z ∈ []                  = ⊥
z ∈ (y ∷ xs)            = (z ≡ₚ y) ⊔ (z ∈ xs)
z ∈ dup x xs i          = proof i
  where
    -- proof : z ∈ (x ∷ x ∷ xs) ≡ z ∈ (x ∷ xs)
    proof = z ≡ₚ x  ⊔ (z ≡ₚ x ⊔ z ∈ xs) ≡⟨ ⊔-assoc (z ≡ₚ x) (z ≡ₚ x) (z ∈ xs) ⟩
            (z ≡ₚ x ⊔ z ≡ₚ x) ⊔ z ∈ xs  ≡⟨ cong (_⊔ (z ∈ xs)) (⊔-idem (z ≡ₚ x)) ⟩
            z ≡ₚ x            ⊔ z ∈ xs  ∎
z ∈ comm x y xs i       = proof i
  where
    -- proof : z ∈ (x ∷ y ∷ xs) ≡ z ∈ (y ∷ x ∷ xs)
    proof = z ≡ₚ x  ⊔ (z ≡ₚ y ⊔ z ∈ xs) ≡⟨ ⊔-assoc (z ≡ₚ x) (z ≡ₚ y) (z ∈ xs) ⟩
            (z ≡ₚ x ⊔ z ≡ₚ y) ⊔ z ∈ xs  ≡⟨ cong (_⊔ (z ∈ xs)) (⊔-comm (z ≡ₚ x) (z ≡ₚ y)) ⟩
            (z ≡ₚ y ⊔ z ≡ₚ x) ⊔ z ∈ xs  ≡⟨ sym (⊔-assoc (z ≡ₚ y) (z ≡ₚ x) (z ∈ xs)) ⟩
            z ≡ₚ y  ⊔ (z ≡ₚ x ⊔ z ∈ xs) ∎

x ∈ trunc xs ys p q i j = isSetHProp (x ∈ xs) (x ∈ ys) (cong (x ∈_) p) (cong (x ∈_) q) i j

module LFSetElim {ℓ}
  (B : LFSet A → Type ℓ)
  ([]* : B [])
  (_∷*_ : (x : A) {xs : LFSet A} → B xs → B (x ∷ xs))
  (comm* : (x y : A) {xs : LFSet A} (b : B xs)
    → PathP (λ i → B (comm x y xs i)) (x ∷* (y ∷* b)) (y ∷* (x ∷* b)))
  (dup* : (x : A) {xs : LFSet A} (b : B xs)
    → PathP (λ i → B (dup x xs i)) (x ∷* (x ∷* b)) (x ∷* b))
  (trunc* : (xs : LFSet A) → isSet (B xs)) where

  f : ∀ x → B x
  f [] = []*
  f (x ∷ xs) = x ∷* f xs
  f (dup x xs i) = dup* x (f xs) i
  f (comm x y xs i) = comm* x y (f xs) i
  f (trunc x y p q i j) =
    isOfHLevel→isOfHLevelDep 2 trunc*
      (f x) (f y)
      (λ i → f (p i)) (λ i → f (q i))
      (trunc x y p q) i j

module LFSetRec {ℓ} {B : Type ℓ}
  ([]* : B)
  (_∷*_ : (x : A) → B → B)
  (comm* : (x y : A) (xs : B) → (x ∷* (y ∷* xs)) ≡ (y ∷* (x ∷* xs)))
  (dup* : (x : A) (b : B) → (x ∷* (x ∷* b)) ≡ (x ∷* b))
  (trunc* : isSet B) where

  f : LFSet A → B
  f = LFSetElim.f _
    []* (λ x xs → x ∷* xs)
    (λ x y b → comm* x y b) (λ x b → dup* x b)
    λ _ → trunc*

module LFPropElim {ℓ}
  (B : LFSet A → Type ℓ)
  ([]* : B []) (_∷*_ : (x : A) {xs : LFSet A} → B xs → B (x ∷ xs))
  (trunc* : (xs : LFSet A) → isProp (B xs)) where

  f : ∀ x → B x
  f = LFSetElim.f _
    []* _∷*_
    (λ _ _ _ → isOfHLevel→isOfHLevelDep 1 trunc* _ _ _)
    (λ _ _ → isOfHLevel→isOfHLevelDep 1 trunc* _ _ _)
    λ xs → isProp→isSet (trunc* xs)


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

open import lib.Base

module lib.Relation {i} where

Rel : ∀ (A : Type i) j → Type (lmax i (lsucc j))
Rel A j = A → A → Type j

module _ {A : Type i} {j} (rel : Rel A j) where

  Decidable : Type (lmax i j)
  Decidable = ∀ a₁ a₂ → Dec (rel a₁ a₂)

  is-refl : Type (lmax i j)
  is-refl = ∀ a → rel a a

  is-sym : Type (lmax i j)
  is-sym = ∀ {a b} → rel a b → rel b a

  is-trans : Type (lmax i j)
  is-trans = ∀ {a b c} → rel a b → rel b c → rel a c

  -- as equivalence relation
  -- is-equational : Type (lmax i j)


module Type.Category.IntensionalFunctionsCategory{ℓ} where

open import Data
open import Functional
open import Logic.Propositional
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Category
open import Structure.Categorical.Properties
open import Structure.Operator
open import Type
open import Type.Properties.Singleton

-- The type category is a category containing all types of a single universe level in the language.
-- The objects are all sets/types.
-- The morphisms are all functions where the domain/codomain-pair are from these objects.
typeIntensionalFnCategory : Category{Obj = Type{ℓ}}(_→ᶠ_)
Category._∘_            typeIntensionalFnCategory = _∘_
Category.id             typeIntensionalFnCategory = id
BinaryOperator.congruence (Category.binaryOperator typeIntensionalFnCategory) [≡]-intro [≡]-intro = [≡]-intro
Category.associativity  typeIntensionalFnCategory = Morphism.intro [≡]-intro
Category.identity       typeIntensionalFnCategory = [∧]-intro (Morphism.intro [≡]-intro) (Morphism.intro [≡]-intro)

typeIntensionalFnCategoryObject : CategoryObject
typeIntensionalFnCategoryObject = intro typeIntensionalFnCategory

Unit-terminalObject : Object.Terminal{Obj = Type{ℓ}}(_→ᶠ_) (Unit)
IsUnit.unit       Unit-terminalObject = const <>
IsUnit.uniqueness Unit-terminalObject = [≡]-intro


{-# OPTIONS --safe #-}
module Cubical.Categories.Presheaf.Base where

open import Cubical.Foundations.Prelude

open import Cubical.Categories.Category
open import Cubical.Categories.Instances.Sets
open import Cubical.Categories.Instances.Functors

PreShv : ∀ {ℓ ℓ'} → Category ℓ ℓ' → (ℓS : Level)
       → Category (ℓ-max (ℓ-max ℓ ℓ') (ℓ-suc ℓS))
                  (ℓ-max (ℓ-max ℓ ℓ') ℓS)
PreShv C ℓS = FUNCTOR (C ^op) (SET ℓS)


open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    num   : htyp
    ⦇-⦈   : htyp
    _==>_ : htyp → htyp → htyp
    _⊕_   : htyp → htyp → htyp
    _⊠_   : htyp → htyp → htyp

  -- type constructors bind very tightly
  infixr 25  _==>_
  infixr 25 _⊕_
  infixr 25 _⊠_

  -- external expressions
  data hexp : Set where
    N        : Nat → hexp
    _·+_     : hexp → hexp → hexp
    _·:_     : hexp → htyp → hexp
    X        : Nat → hexp
    ·λ       : Nat → hexp → hexp
    ·λ_·[_]_ : Nat → htyp → hexp → hexp
    _∘_      : hexp → hexp → hexp
    inl      : hexp → hexp
    inr      : hexp → hexp
    case     : hexp → Nat → hexp → Nat → hexp → hexp
    ⟨_,_⟩    : hexp → hexp → hexp
    fst      : hexp → hexp
    snd      : hexp → hexp
    ⦇-⦈[_]   : Nat → hexp
    ⦇⌜_⌟⦈[_] : hexp → Nat → hexp

  -- the type of type contexts, i.e. Γs in the judgements below
  tctx : Set
  tctx = htyp ctx

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇-⦈
    TCHole2 : {τ : htyp} → ⦇-⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
              τ1 ~ τ1' →
              τ2 ~ τ2' →
              τ1 ==> τ2 ~ τ1' ==> τ2'
    TCSum   : {τ1 τ2 τ1' τ2' : htyp} →
              τ1 ~ τ1' →
              τ2 ~ τ2' →
              τ1 ⊕ τ2 ~ τ1' ⊕ τ2'
    TCProd  : {τ1 τ2 τ1' τ2' : htyp} →
              τ1 ~ τ1' →
              τ2 ~ τ2' →
              τ1 ⊠ τ2 ~ τ1' ⊠ τ2'

  -- type inconsistency
  _~̸_ : htyp → htyp → Set
  t1 ~̸ t2 = (t1 ~ t2) → ⊥

  -- matching for arrows
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇-⦈ ▸arr ⦇-⦈ ==> ⦇-⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- matching for sums
  data _▸sum_ : htyp → htyp → Set where
    MSHole : ⦇-⦈ ▸sum ⦇-⦈ ⊕ ⦇-⦈
    MSSum  : {τ1 τ2 : htyp} → τ1 ⊕ τ2 ▸sum τ1 ⊕ τ2

  -- matching for sums
  data _▸prod_ : htyp → htyp → Set where
    MPHole : ⦇-⦈ ▸prod ⦇-⦈ ⊠ ⦇-⦈
    MPProd : {τ1 τ2 : htyp} → τ1 ⊠ τ2 ▸prod τ1 ⊠ τ2

  -- the type of hole contexts, i.e. Δs in the judgements
  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SNum    : {Γ : tctx} {n : Nat} →
                Γ ⊢ N n => num
      SPlus   : {Γ : tctx} {e1 e2 : hexp}  →
                Γ ⊢ e1 <= num →
                Γ ⊢ e2 <= num →
                Γ ⊢ (e1 ·+ e2) => num
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                Γ ⊢ e <= τ →
                Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {x : Nat} →
                (x , τ) ∈ Γ →
                Γ ⊢ X x => τ
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                x # Γ →
                (Γ ,, (x , τ1)) ⊢ e => τ2 →
                Γ ⊢ ·λ x ·[ τ1 ] e => τ1 ==> τ2
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                Γ ⊢ e1 => τ1 →
                τ1 ▸arr τ2 ==> τ →
                Γ ⊢ e2 <= τ2 →
                Γ ⊢ (e1 ∘ e2) => τ
      SPair   : ∀{e1 e2 τ1 τ2 Γ} →
                Γ ⊢ e1 => τ1 →
                Γ ⊢ e2 => τ2 →
                Γ ⊢ ⟨ e1 , e2 ⟩ => τ1 ⊠ τ2
      SFst    : ∀{e τ τ1 τ2 Γ} →
                Γ ⊢ e => τ →
                τ ▸prod τ1 ⊠ τ2 →
                Γ ⊢ fst e => τ1
      SSnd    : ∀{e τ τ1 τ2 Γ} →
                Γ ⊢ e => τ →
                τ ▸prod τ1 ⊠ τ2 →
                Γ ⊢ snd e => τ2
      SEHole  : {Γ : tctx} {u : Nat} →
                Γ ⊢ ⦇-⦈[ u ] => ⦇-⦈
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} →
                Γ ⊢ e => τ →
                Γ ⊢ ⦇⌜ e ⌟⦈[ u ] => ⦇-⦈

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam     : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ
      AInl     : {Γ : tctx} {e : hexp} {τ+ τ1 τ2 : htyp} →
                 τ+ ▸sum (τ1 ⊕ τ2) →
                 Γ ⊢ e <= τ1 →
                 Γ ⊢ inl e <= τ+
      AInr     : {Γ : tctx} {e : hexp} {τ+ τ1 τ2 : htyp} →
                 τ+ ▸sum (τ1 ⊕ τ2) →
                 Γ ⊢ e <= τ2 →
                 Γ ⊢ inr e <= τ+
      ACase    : {Γ : tctx} {e e1 e2 : hexp} {τ τ+ τ1 τ2 : htyp} {x y : Nat} →
                 x # Γ →
                 y # Γ →
                 τ+ ▸sum (τ1 ⊕ τ2) →
                 Γ ⊢ e => τ+ →
                 (Γ ,, (x , τ1)) ⊢ e1 <= τ →
                 (Γ ,, (y , τ2)) ⊢ e2 <= τ →
                 Γ ⊢ case e x e1 y e2 <= τ

  -- those types without holes
  data _tcomplete : htyp → Set where
    TCNum  : num tcomplete
    TCArr  : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ==> τ2) tcomplete
    TCSum  : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ⊕ τ2) tcomplete
    TCProd : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ⊠ τ2) tcomplete

  -- those external expressions without holes
  data _ecomplete : hexp → Set where
    ECNum  : ∀{n} →
             (N n) ecomplete
    ECPlus : ∀{e1 e2} →
             e1 ecomplete →
             e2 ecomplete →
             (e1 ·+ e2) ecomplete
    ECAsc  : ∀{τ e} →
             τ tcomplete →
             e ecomplete →
             (e ·: τ) ecomplete
    ECVar  : ∀{x} →
             (X x) ecomplete
    ECLam1 : ∀{x e} →
             e ecomplete →
             (·λ x e) ecomplete
    ECLam2 : ∀{x e τ} →
             e ecomplete →
             τ tcomplete →
             (·λ x ·[ τ ] e) ecomplete
    ECAp   : ∀{e1 e2} →
             e1 ecomplete →
             e2 ecomplete →
             (e1 ∘ e2) ecomplete
    ECInl  : ∀{e} →
             e ecomplete →
             (inl e) ecomplete
    ECInr  : ∀{e} →
             e ecomplete →
             (inr e) ecomplete
    ECCase : ∀{e x e1 y e2} →
             e ecomplete →
             e1 ecomplete →
             e2 ecomplete →
             (case e x e1 y e2) ecomplete
    ECPair : ∀{e1 e2} →
             e1 ecomplete →
             e2 ecomplete →
             ⟨ e1 , e2 ⟩ ecomplete
    ECFst  : ∀{e} →
             e ecomplete →
             (fst e) ecomplete
    ECSnd  : ∀{e} →
             e ecomplete →
             (snd e) ecomplete

  -- contexts that only produce complete types
  _gcomplete : tctx → Set
  Γ gcomplete = (x : Nat) (τ : htyp) → (x , τ) ∈ Γ → τ tcomplete

  -- ground types
  data _ground : htyp → Set where
    GNum      : num ground
    GArrHole  : ⦇-⦈ ==> ⦇-⦈ ground
    GSumHole  : ⦇-⦈ ⊕ ⦇-⦈ ground
    GProdHole : ⦇-⦈ ⊠ ⦇-⦈ ground


------------------------------------------------------------------------------
-- All the group theory modules
------------------------------------------------------------------------------

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

module GroupTheory.Everything where

open import GroupTheory.Base
open import GroupTheory.Base.Consistency.Axioms

open import GroupTheory.AbelianGroup.Base
open import GroupTheory.AbelianGroup.Base.Consistency.Axioms
open import GroupTheory.AbelianGroup.PropertiesATP

open import GroupTheory.Commutator
open import GroupTheory.Commutator.PropertiesATP
open import GroupTheory.Commutator.PropertiesI

open import GroupTheory.PropertiesATP
open import GroupTheory.PropertiesI


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

module Categories.Adjoint.Instance.PathsOf where

-- PathsOf is adjoint to Underlying Quiver, i.e.
-- The "Underlying Graph" (of a Category) <-> "Path Category on a Quiver" Adjunction.

-- Lots of surprises here, of various level of surprisingness
-- 1. The PathCategory rises universe levels of arrows (and equivalences); the Underlying Quiver does not
--   (due to the Transitive Closure "Star" construction)
-- 2. As a consequence of (1), the eventual Adjunction will be for all Levels being the same
-- 3. To build a Functor from Categories to Quivers, then the object/hom levels are straightforward,
--   but "Categories" has NaturalIsomorphism as the notion of equivalence of Functors. This means
--   that, for example, the 2-point Groupoid is contractible
--   (thus equivalent to the 1-point Category), and yet those two "Graphs" shouldn't be considered to
--   be the same!  This is because there isn't an equivalently natural notion of equivalence of
--   Graph (Quiver) Homomorphism.
--   Interestingly, this only shows up when trying to prove that the Underlying Functor respects
--   _≈_, which is not traditionally a requirement of a Functor! This requirement is usually left
--   implicit.  (See Categories.Function.Construction.FreeCategory for the details)
--
-- In other words, the adjunction doesn't involve Cats, but StrictCats as one of the endpoints.

open import Level
open import Function using (_$_; flip) renaming (id to id→; _∘_ to _⊚_)
import Relation.Binary.PropositionalEquality as ≡
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Data.Quiver using (Quiver)
open import Data.Quiver.Paths
import Data.Quiver.Morphism as QM
open QM using (Morphism; _≃_)

open import Categories.Adjoint using (Adjoint)
open import Categories.Category.Core using (Category)
import Categories.Category.Construction.PathCategory as PC
open import Categories.Category.Instance.Quivers
open import Categories.Functor using (Functor)
open import Categories.Functor.Construction.PathsOf using (PathsOf)
open import Categories.Functor.Instance.UnderlyingQuiver using (Underlying₀; Underlying₁; Underlying)
open import Categories.NaturalTransformation using (ntHelper)
import Categories.Morphism.Reasoning as MR

module _ (o ℓ e : Level) where

  -- the unit morphism from a Quiver X to U∘Free X.
  unit : (X : Quiver o (o ⊔ ℓ) (o ⊔ ℓ ⊔ e)) → Morphism X (Underlying₀ (PC.PathCategory X))
  unit X = let open Paths X in record { F₀ = id→ ; F₁ = return ; F-resp-≈ = _◅ ε }

  module _ (X : Category o (o ⊔ ℓ) (o ⊔ ℓ ⊔ e)) where
    open Category X
    open HomReasoning
    open Paths (Underlying₀ X)

    -- "unwind" a path by using repeated composition
    unwind : {A B : Obj} → Star _⇒_ A B → A ⇒ B
    unwind = fold _⇒_ (flip _∘_) id

    unwind-◅◅ : {A B C : Obj} {f : Star _⇒_ A B} {g : Star _⇒_ B C} →
                unwind (f ◅◅ g) ≈ (unwind g) ∘ (unwind f)
    unwind-◅◅ {f = ε} {g} = Equiv.sym identityʳ
    unwind-◅◅ {f = x ◅ f} {g} = ∘-resp-≈ˡ (unwind-◅◅ {f = f} {g}) ○ assoc

    unwind-resp-≈ : {A B : Obj} {f g : Star _⇒_ A B} → f ≈* g → unwind f ≈ unwind g
    unwind-resp-≈ ε = Equiv.refl
    unwind-resp-≈ (x ◅ eq) = ∘-resp-≈ (unwind-resp-≈ eq) x

    unwindF : Functor (PC.PathCategory (Underlying₀ X)) X
    unwindF = record
        { F₀ = id→
        ; F₁ = unwind
        ; identity = Category.Equiv.refl X
        ; homomorphism = λ { {f = f} {g} → unwind-◅◅ {f = f} {g} }
        ; F-resp-≈ = unwind-resp-≈
        }

  module _ (X : Quiver o (o ⊔ ℓ) (o ⊔ ℓ ⊔ e)) where
    open Paths X

    zig′ : {A B : Quiver.Obj X} → (f : Star (Quiver._⇒_ X) A B) →
      unwind (PC.PathCategory X) (QM.qmap (unit X) f) ≈* f
    zig′ ε        = ε
    zig′ (fs ◅ f) = Quiver.Equiv.refl X ◅ zig′ f

  module _ {X Y : Category o (o ⊔ ℓ) (o ⊔ ℓ ⊔ e)} (F : Functor X Y) where
    module X = Category X
    module Y = Category Y
    open Category.HomReasoning Y
    open Functor F
    unwind-natural : {A B : X.Obj} (f : Star X._⇒_ A B) → unwind Y (QM.qmap (Underlying₁ F) f) Y.≈ F₁ (unwind X f)
    unwind-natural ε = Y.Equiv.sym identity
    unwind-natural (x ◅ f) = Y.Equiv.sym (homomorphism ○ Category.∘-resp-≈ˡ Y (Y.Equiv.sym (unwind-natural f)))

  Free⊣Underlying : Adjoint (PathsOf {o} {o ⊔ ℓ} {o ⊔ ℓ ⊔ e}) Underlying
  Free⊣Underlying = record
    { unit = ntHelper record
      { η = unit
      ; commute = λ {X} {Y} f → let open Paths Y in record { F₀≡ = ≡.refl ; F₁≡ = Quiver.Equiv.refl Y ◅ ε }
      }
    ; counit = ntHelper record
      { η = unwindF
      ; commute = λ {_} {Y} F → record
        { eq₀ = λ _ → ≡.refl
        ; eq₁ = λ f → toSquare Y (unwind-natural F f)
        }
      }
    ; zig = λ {G} → record
      { eq₀ = λ _ → ≡.refl
      ; eq₁ = λ f → toSquare (PC.PathCategory G) (zig′ G f)
      }
    ; zag = λ {B} → record { F₀≡ = ≡.refl ; F₁≡ = Category.identityˡ B  }
    }
    where
    open MR using (toSquare)


{-# OPTIONS --universe-polymorphism #-}

module UniversePolymorphicFunctor where

postulate
  Level : Set
  zero : Level
  suc  : (i : Level) → Level
  _⊔_ : Level → Level → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}

infixl 6 _⊔_

record IsEquivalence {a ℓ} {A : Set a}
                     (_≈_ : A → A → Set ℓ) : Set (a ⊔ ℓ) where
  field
    refl  : ∀ {x} → x ≈ x
    sym   : ∀ {i j} → i ≈ j → j ≈ i
    trans : ∀ {i j k} → i ≈ j → j ≈ k → i ≈ k

record Setoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infix 4 _≈_
  field
    Carrier       : Set c
    _≈_           : Carrier → Carrier → Set ℓ
    isEquivalence : IsEquivalence _≈_

  open IsEquivalence isEquivalence public

infixr 0 _⟶_

record _⟶_ {f₁ f₂ t₁ t₂}
           (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
           Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
  infixl 5 _⟨$⟩_
  field
    _⟨$⟩_ : Setoid.Carrier From → Setoid.Carrier To
    cong  : ∀ {x y} →
            Setoid._≈_ From x y → Setoid._≈_ To (_⟨$⟩_ x) (_⟨$⟩_ y)

open _⟶_ public

id : ∀ {a₁ a₂} {A : Setoid a₁ a₂} → A ⟶ A
id = record { _⟨$⟩_ = λ x → x; cong = λ x≈y → x≈y }

infixr 9 _∘_

_∘_ : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
        {b₁ b₂} {B : Setoid b₁ b₂}
        {c₁ c₂} {C : Setoid c₁ c₂} →
      B ⟶ C → A ⟶ B → A ⟶ C
f ∘ g = record
  { _⟨$⟩_ = λ x → f ⟨$⟩ (g ⟨$⟩ x)
  ; cong  = λ x≈y → cong f (cong g x≈y)
  }

_⇨_ : ∀ {f₁ f₂ t₁ t₂} → Setoid f₁ f₂ → Setoid t₁ t₂ → Setoid _ _
From ⇨ To = record
  { Carrier       = From ⟶ To
  ; _≈_           = λ f g → ∀ {x y} → x ≈₁ y → f ⟨$⟩ x ≈₂ g ⟨$⟩ y
  ; isEquivalence = record
    { refl  = λ {f} → cong f
    ; sym   = λ f∼g x∼y → To.sym (f∼g (From.sym x∼y))
    ; trans = λ f∼g g∼h x∼y → To.trans (f∼g From.refl) (g∼h x∼y)
    }
  }
  where
  open module From = Setoid From using () renaming (_≈_ to _≈₁_)
  open module To   = Setoid To   using () renaming (_≈_ to _≈₂_)

record Functor {f₁ f₂ f₃ f₄}
               (F : Setoid f₁ f₂ → Setoid f₃ f₄) :
               Set (suc (f₁ ⊔ f₂) ⊔ f₃ ⊔ f₄) where
  field
    map : ∀ {A B} → (A ⇨ B) ⟶ (F A ⇨ F B)

    identity : ∀ {A} →
      let open Setoid (F A ⇨ F A) in
      map ⟨$⟩ id ≈ id

    composition : ∀ {A B C} (f : B ⟶ C) (g : A ⟶ B) →
      let open Setoid (F A ⇨ F C) in
      map ⟨$⟩ (f ∘ g) ≈ (map ⟨$⟩ f) ∘ (map ⟨$⟩ g)


-- Intuitionistic propositional logic, PHOAS approach, final encoding

module Pf.Ip where

-- Types

infixl 2 _&&_
infixl 1 _||_
infixr 0 _=>_
data Ty : Set where
  UNIT  :             Ty
  _=>_  : Ty -> Ty -> Ty
  _&&_  : Ty -> Ty -> Ty
  _||_  : Ty -> Ty -> Ty
  FALSE :             Ty

infixr 0 _<=>_
_<=>_ : Ty -> Ty -> Ty
a <=> b = (a => b) && (b => a)

NOT : Ty -> Ty
NOT a = a => FALSE

TRUE : Ty
TRUE = FALSE => FALSE

-- Context and truth judgement

Cx : Set1
Cx = Ty -> Set

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

-- Terms

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

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

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

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

module Mp where
  record Tm (tr : TmRepr) : Set1 where
    field
      pair' : forall {tc a b}   -> tr tc a        -> tr tc b -> tr tc (a && b)
      fst   : forall {tc a b}   -> tr tc (a && b)            -> tr tc a
      snd   : forall {tc a b}   -> tr tc (a && b)            -> tr tc b
      left  : forall {tc a b}   -> tr tc a                   -> tr tc (a || b)
      right : forall {tc a b}   -> tr tc b                   -> tr tc (a || b)
      case' : forall {tc a b c} -> tr tc (a || b) -> (isTrue a tc -> tr tc c) -> (isTrue b tc -> tr tc c) -> tr tc c

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

    case'' : forall {tc a b c} -> tr tc (a || b) -> (tr tc a -> tr tc c) -> (tr tc b -> tr tc c) -> tr tc c
    case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y))

    syntax pair'  x y = [ x , y ]
    syntax case'' xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2
  open Tm {{...}} public

module Ip where
  record Tm (tr : TmRepr) : Set1 where
    field
      abort : forall {tc a} -> tr tc FALSE -> tr tc a

      isMp : Mp.Tm tr
    open Mp.Tm isMp public
  open Tm {{...}} public

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

-- Example theorems

t1 : forall {a b} -> Thm (a => NOT a => b)
t1 =
  lam x =>
    lam f => abort (f $ x)

t2 : forall {a b} -> Thm (NOT a => a => b)
t2 =
  lam f =>
    lam x => abort (f $ x)

t3 : forall {a} -> Thm (a => NOT (NOT a))
t3 =
  lam x =>
    lam f => f $ x

t4 : forall {a} -> Thm (NOT a <=> NOT (NOT (NOT a)))
t4 =
  [ lam f =>
      lam g => g $ f
  , lam g =>
      lam x => g $ (lam f => f $ x)
  ]


module PreludeList where

open import AlonzoPrelude as Prelude
open import PreludeNat

infixr 50 _::_ _++_

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

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  []   #-}
{-# BUILTIN CONS _::_ #-}

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

length : {A : Set} -> List A -> Nat
length []        = 0
length (_ :: xs) = 1 + length xs

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

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

zipWith : {A B C : Set} -> (A -> B -> C) -> List A -> List B -> List C
zipWith f []        []        = []
zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys
zipWith f []        (_ :: _)  = []
zipWith f (_ :: _)  []        = []

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

foldl : {A B : Set} -> (B -> A -> B) -> B -> List A -> B
foldl f z []        = z
foldl f z (x :: xs) = foldl f (f z x) xs

replicate : {A : Set} -> Nat -> A -> List A
replicate  zero   x = []
replicate (suc n) x = x :: replicate n x

iterate : {A : Set} -> Nat -> (A -> A) -> A -> List A
iterate  zero   f x = []
iterate (suc n) f x = x :: iterate n f (f x)

splitAt : {A : Set} -> Nat -> List A -> List A × List A
splitAt  zero   xs        = < [] , xs >
splitAt (suc n) []        = < [] , [] >
splitAt (suc n) (x :: xs) = add x $ splitAt n xs
  where
    add : _ -> List _ × List _ -> List _ × List _
    add x < ys , zs > = < x :: ys , zs >

reverse : {A : Set} -> List A -> List A
reverse xs = foldl (flip _::_) [] xs


-- {-# OPTIONS -v tc.lhs.unify:50 #-}
module Issue81 where

data ⊥ : Set where

data D : Set where
  d : D
  c : D

data E : Set where
  e : E

⌜_⌝ : E -> D
⌜ e ⌝ = c

data R : D -> E -> Set where
  Val : (v : E) -> R ⌜ v ⌝ v

foo : R d e -> ⊥
foo ()


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

open import HoTT

module homotopy.elims.Lemmas where

fill-upper-right : ∀ {i j} {A : Type i} {B : A → Type j}
  {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  {b₀₀ : B a₀₀} {b₀₁ : B a₀₁} {b₁₀ b₁₀' : B a₁₀} {b₁₁ : B a₁₁}
  (q₀₋ : b₀₀ == b₀₁ [ B ↓ p₀₋ ]) (q₋₀ : b₀₀ == b₁₀ [ B ↓ p₋₀ ])
  (q₋₁ : b₀₁ == b₁₁ [ B ↓ p₋₁ ]) (q₁₋ : b₁₀' == b₁₁ [ B ↓ p₁₋ ])
  → Σ (b₁₀ == b₁₀')
      (λ r → SquareOver B sq q₀₋ q₋₀ q₋₁ (r ◃ q₁₋))
fill-upper-right ids idp idp idp idp = (idp , ids)

fill-upper-right-unique : ∀ {i j} {A : Type i} {B : A → Type j}
  {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  {b₀₀ : B a₀₀} {b₀₁ : B a₀₁} {b₁₀ b₁₀' : B a₁₀} {b₁₁ : B a₁₁}
  (q₀₋ : b₀₀ == b₀₁ [ B ↓ p₀₋ ]) (q₋₀ : b₀₀ == b₁₀ [ B ↓ p₋₀ ])
  (q₋₁ : b₀₁ == b₁₁ [ B ↓ p₋₁ ]) (q₁₋ : b₁₀' == b₁₁ [ B ↓ p₁₋ ])
  (r : b₁₀ == b₁₀')
  → SquareOver B sq q₀₋ q₋₀ q₋₁ (r ◃ q₁₋)
  → r == fst (fill-upper-right sq q₀₋ q₋₀ q₋₁ q₁₋)
fill-upper-right-unique {B = B} ids idp idp idp idp r sq' =
  ! (◃idp {B = B} r) ∙ ! (horiz-degen-path sq')


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

-- This is unfortunate, but Arch doesn't have the cubical stuff
-- in the stdlib package it comes with (and cabal on Arch is
-- significantly worse).
open import Agda.Builtin.Cubical.Id
open import Agda.Builtin.Cubical.Path

-- Other builtins
open import Agda.Builtin.List
open import Agda.Builtin.Bool

open import Axiom.Extensionality.Propositional

-- I understand it better calling stuff "UU" from Egbert's notes.
open import 00-preamble
-- Same for + types -- too lazy to find the builtin
open import 04-inductive-types

-- https://dl.acm.org/doi/pdf/10.1145/3341691 page 11
-- set quotient (truncate the quotient)
-- ≡ is from Agda.Builtin.Id
data Quot {i : Level} (A : UU i) (R : A → A → UU i): UU i where
  cls : A → Quot A R
  eq : (a b : A) → (r : R a b) → (cls a) ≡ (cls b)
  trunc : (x y : Quot A R) → (p q : x ≡ y) → p ≡ q

-- First definition of a group: List(A + A) / R. Some oddity:
-- 1) f : A → A → Bool is an equality predicate (Eq in Haskell), but I'm not sure how to
--    insist that (f a₁ a₂ = true) ≅ (a₁ = a₂) or just say "if the identity type is
--    inhabited." Also encode-decode seems to use information from the type, so defining
--    f should be a reasonable requirement (it's just code, but using true for 𝟙 and false
--    for 𝟘).
-- 2) I promise it terminates. Otherwise it insists that the first recursive call is
--    uncertain but the list is clearly one element shorter.
-- 3) I think the warning isn't all that important (but I'm a programmer, don't trust me).
--    My understanding is that the warning means "the definitional equalities Agda has can
--    be surprising" but I don't see how it's bad yet.
{-# TERMINATING #-}
cancelList : {i : Level} {A : UU i} (eq : A → A → Bool) (l : List (coprod A A)) → List (coprod A A)
cancelList e [] = []
cancelList e ((inl a₁) ∷ (inr a₂) ∷ xs) with e a₁ a₂
...                                      | true = cancelList e xs
...                                      | false = (inl a₁) ∷ (cancelList e ((inr a₂) ∷ xs))
cancelList e ((inr a₁) ∷ (inl a₂) ∷ xs) with e a₁ a₂
...                                      | true = cancelList e xs
...                                      | false = (inr a₁) ∷ (cancelList e ((inl a₂) ∷ xs))
cancelList e (x ∷ xs) = x ∷ (cancelList e xs)

-- Proof that cancel list is idempotent (done on sets bc why the #$%^ does the built-in
-- funext need a #$%^ing level as an explicit param?)
-- Note that oddity 1 from above is relevant -- I'm just going to be lazy and prove for all
-- equality-like things.
cancelList-idempotent : {A : UU (lsuc lzero)} (e : A → A → Bool)
                        → ((λ x → cancelList e (cancelList e x)) ≡ (cancelList e))
cancelList-idempotent e =


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Maybe.Base where

open import Cubical.Core.Everything

private
  variable
    ℓ : Level
    A B : Type ℓ

data Maybe (A : Type ℓ) : Type ℓ where
  nothing : Maybe A
  just    : A → Maybe A

caseMaybe : (n j : B) → Maybe A → B
caseMaybe n _ nothing  = n
caseMaybe _ j (just _) = j

map-Maybe : (A → B) → Maybe A → Maybe B
map-Maybe _ nothing  = nothing
map-Maybe f (just x) = just (f x)

rec : B → (A → B) → Maybe A → B
rec n j nothing = n
rec n j (just a) = j a