{-# OPTIONS --copatterns #-}

module Control.Category.Slice where

open import Level using (suc; _⊔_)
open import Relation.Binary hiding (_⇒_)

open import Control.Category
open Category using () renaming (Obj to obj)

-- Given a category C and an object Tgt in C we can define a new category
-- whose objects S are pairs of an object Src in C
-- and a morphism out from Src to Tgt.

record SliceObj {o h e} (C : Category o h e) (Tgt : obj C) : Set (o ⊔ h ⊔ e) where
  constructor sliceObj
  open Category C -- public
  field
    Src : Obj
    out : Src ⇒ Tgt

-- In the following, we fix a category C and an object Tgt.

module _ {o h e} {C : Category o h e} {Tgt : obj C} where

  -- We use _⇒_ for C's morphisms and _∘_ for their composition.
  private
    open module C = Category C hiding (id; ops)

    Slice = SliceObj C Tgt
    open module Slice = SliceObj {C = C} {Tgt = Tgt}

  -- A morphism in the slice category into Tgt
  -- from slice (S, s) to (T, t)
  -- is a morphism f : S ⇒ T such that t ∘ f ≡ s.

  record SliceMorphism (S T : Slice) : Set (h ⊔ e)
    where
    constructor sliceMorphism
    field
      mor      : Src S ⇒ Src T
      triangle : (mor ⟫ out T) ≈ out S

  -- Two morphisms in the slice category are equal
  -- iff they are equal in the underlying category C.

  SliceHom : (S T : Slice) → Setoid _ _
  SliceHom S T = record
    { Carrier       = SliceMorphism S T
    ; _≈_           = λ f g → SliceMorphism.mor f ≈ SliceMorphism.mor g
    ; isEquivalence = record
      { refl  = refl
      ; sym   = sym
      ; trans = trans
      }
    } where open IsEquivalence (≈-equiv {Src S} {Src T})

  -- We write S ⇉ T for a morphism from slice S to slice T

  open HomSet SliceHom using () renaming (_⇒_ to _⇉_; _≈_ to _≐_)

  -- The identity slice morphism is just the identity morphism.

  slice-id : ∀ {P} → P ⇉ P
  slice-id = record { mor = C.id; triangle = C.id-first }

  -- The composition of slice morphims is just the composition in C.

  comp : ∀ {S T U} → S ⇉ T → T ⇉ U → S ⇉ U
  comp (sliceMorphism f tri-f) (sliceMorphism g tri-g) = record
    { mor      = f ⟫ g
    ; triangle = ≈-trans (C.∘-assoc f) (≈-trans (C.∘-cong ≈-refl tri-g) tri-f)
    }

  ops : CategoryOps SliceHom
  ops = record { id = slice-id ; _⟫_ = comp}

  sliceIsCategory : IsCategory SliceHom
  sliceIsCategory = record
    { ops = ops
    ; laws = record
      { id-first = C.id-first -- id-first
      ; id-last  = C.id-last
      ; ∘-assoc  = λ f → C.∘-assoc _
      ; ∘-cong   = C.∘-cong
      }
    }

-- The slice category.

module _  {o h e} (C : Category o h e) (Tgt : obj C) where

  module C = Category C

  _/_ : Category (o ⊔ h ⊔ e) (e ⊔ h) e
  _/_ = record
    { Obj = SliceObj C Tgt
    ; Hom = SliceHom
    ; isCategory = sliceIsCategory
    }

  open Category _/_

-- The terminal object in C / Tgt is (Tgt, id).

  terminalSlice : Obj
  terminalSlice = record { Src = Tgt; out = C.id }

  open IsFinal

  isTerminalSlice : IsFinal Hom terminalSlice
  final           isTerminalSlice {sliceObj Src f}
    = sliceMorphism f C.id-last
  final-universal isTerminalSlice {sliceObj Src f} {sliceMorphism g tri}
    = C.≈-trans (C.≈-sym C.id-last) tri

-- The initial object in C / Tgt is (0, initial)

  module _ {⊥ : obj C} (⊥-initial : IsInitial C.Hom ⊥) where

    open IsInitial ⊥-initial
      renaming (initial to abort; initial-universal to abort-unique)

    initialSlice : Obj
    initialSlice = record { Src = ⊥; out = abort }

    open IsInitial

    isInitialSlice : IsInitial Hom initialSlice
    initial           isInitialSlice = sliceMorphism abort abort-unique
    initial-universal isInitialSlice = abort-unique


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong)
open Eq.≡-Reasoning
open import Function using (_∘_)
open import Data.Product using (_×_) using (_,_; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)

postulate
  extensionality : ∀ {A B : Set} {f g : A → B} → (∀ (x : A) → f x ≡ g x) → f ≡ g

β-×₁ : ∀ {A B : Set} (x : A) (y : B) → proj₁ (x , y) ≡ x
β-×₁ x y = refl

β-×₂ : ∀ {A B : Set} (x : A) (y : B) → proj₂ (x , y) ≡ y
β-×₂ x y = refl

η-× : ∀ {A B : Set} (w : A × B) → (proj₁ w , proj₂ w) ≡ w
η-× (x , y) = refl

uniq-× : ∀ {A B C : Set} (h : C → A × B) (v : C) → (proj₁ (h v) , proj₂ (h v)) ≡ h v
uniq-× h v = η-× (h v)

⊎-elim : ∀ {A B C : Set} → (A → C) → (B → C) → (A ⊎ B → C)
⊎-elim f g (inj₁ x) = f x
⊎-elim f g (inj₂ y) = g y

β-⊎₁ : ∀ {A B C : Set} (f : A → C) (g : B → C) (x : A) → ⊎-elim f g (inj₁ x) ≡ f x
β-⊎₁ f g x = refl

β-⊎₂ : ∀ {A B C : Set} (f : A → C) (g : B → C) (y : B) → ⊎-elim f g (inj₂ y) ≡ g y
β-⊎₂ f g x = refl

η-⊎ : ∀ {A B : Set} (w : A ⊎ B) → ⊎-elim inj₁ inj₂ w ≡ w
η-⊎ (inj₁ x) = refl
η-⊎ (inj₂ y) = refl

natural-⊎ : ∀ {A B C D : Set} (f : A → C) (g : B → C) (h : C → D) (w : A ⊎ B) → ⊎-elim (h ∘ f) (h ∘ g) w ≡ (h ∘ ⊎-elim f g) w
natural-⊎ f g h (inj₁ x) = refl
natural-⊎ f g h (inj₂ y) = refl

uniq-⊎ : ∀ {A B C  : Set} (h : A ⊎ B → C) (w : A ⊎ B) → ⊎-elim (h ∘ inj₁) (h ∘ inj₂) w ≡ h w
uniq-⊎ h w rewrite natural-⊎ inj₁ inj₂ h w | η-⊎ w = refl

η-⊤ : ∀ (w : ⊤) → tt ≡ w
η-⊤ tt = refl

uniq-⊤ : ∀ {C : Set} (h : C → ⊤) (v : C) → tt ≡ h v
uniq-⊤ h v = η-⊤ (h v)

η-⊥ : ∀ (w : ⊥) → ⊥-elim w ≡ w
η-⊥ ()

natural-⊥ : ∀ {C D : Set} (h : C → D) (w : ⊥) → ⊥-elim w ≡ (h ∘ ⊥-elim) w
natural-⊥ h ()

uniq-⊥ : ∀ {C : Set} (h : ⊥ → C) (w : ⊥) → ⊥-elim w ≡ h w
uniq-⊥ h w rewrite natural-⊥ h w | η-⊥ w = refl

η-→ : ∀ {A B : Set} (f : A → B) → (λ{x → f x}) ≡ f
η-→ {A} {B} f = extensionality η-helper
  where
  η-lhs : A → B
  η-lhs = λ{x → f x}

  η-helper : (x : A) → η-lhs x ≡ f x
  η-helper x = refl


open import Oscar.Prelude
open import Oscar.Data.¶
open import Oscar.Data.Fin
open import Oscar.Data.Term

module Oscar.Data.Substitunction where

module Substitunction {𝔭} (𝔓 : Ø 𝔭) where

  open Term 𝔓

  Substitunction : ¶ → ¶ → Ø 𝔭
  Substitunction m n = ¶⟨< m ⟩ → Term n

module SubstitunctionOperator {𝔭} (𝔓 : Ø 𝔭) where

  open Substitunction 𝔓

  _⊸_ = Substitunction


-- Andreas, 2015-05-01
-- With clauses for functions with flexible arity.

-- {-# OPTIONS -v tc.with:40 #-}

open import Common.Prelude
open import Common.Equality

mutual
  even : Nat → Bool
  even 0       = true
  even (suc n) = odd n

  odd  : Nat → Bool
  odd 0 = false
  odd (suc n) = even n

NPred : Nat → Set
NPred 0       = Bool
NPred (suc n) = Nat → NPred n

const : Bool → ∀{n} → NPred n
const b {0}       = b
const b {suc n} m = const b {n}

allOdd : ∀ n → NPred n
allOdd 0 = true
allOdd (suc n) m with even m
... | true  = const false
... | false = allOdd n

test : allOdd 4 1 3 5 7 ≡ true
test = refl


------------------------------------------------------------------------
-- agda-combinatorics
-- All modules
------------------------------------------------------------------------

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

module AgdaCombinatoricsEverything where

import Math.BinomialTheorem.Generic

-- Proof of the binomial theorem
import Math.BinomialTheorem.Nat

-- Definitions of combinatorial functions
import Math.Combinatorics.Function

-- Properties of combinatorial functions
import Math.Combinatorics.Function.Properties

-- Definitions of combinatorial functions on integer
import Math.Combinatorics.IntegerFunction

-- Properties of combinatorial functions on integer
import Math.Combinatorics.IntegerFunction.Properties

import Math.Combinatorics.ListFunction

import Math.Combinatorics.ListFunction.Properties

import Math.Combinatorics.VecFunction


------------------------------------------------------------------------------
-- Arithmetic properties (using induction on the FOTC natural numbers type)
------------------------------------------------------------------------------

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

-- Usually our proofs use pattern matching instead of the induction
-- principle associated with the FOTC natural numbers. The following
-- examples show some proofs using it.

module FOTC.Data.Nat.PropertiesByInductionATP where

open import FOTC.Base
open import FOTC.Data.Nat

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

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

-- See Issue https://github.com/asr/apia/issues/81 .
+-rightIdentityA : D → Set
+-rightIdentityA i = i + zero ≡ i
{-# ATP definition +-rightIdentityA #-}

+-rightIdentity : ∀ {n} → N n → n + zero ≡ n
+-rightIdentity Nn = N-ind +-rightIdentityA A0 is Nn
  where
  postulate A0 : +-rightIdentityA zero
  {-# ATP prove A0 #-}

  postulate is : ∀ {i} → +-rightIdentityA i → +-rightIdentityA (succ₁ i)
  {-# ATP prove is #-}

-- See Issue https://github.com/asr/apia/issues/81 .
+-NA : D → D → Set
+-NA n i = N (i + n)
{-# ATP definition +-NA #-}

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} Nm Nn = N-ind (+-NA n) A0 is Nm
  where
  postulate A0 : +-NA n zero
  {-# ATP prove A0 #-}

  postulate is : ∀ {i} → +-NA n i → +-NA n (succ₁ i)
  {-# ATP prove is #-}

-- See Issue https://github.com/asr/apia/issues/81 .
+-assocA : D → D → D → Set
+-assocA n o i = i + n + o ≡ i + (n + o)
{-# ATP definition +-assocA #-}

+-assoc : ∀ {m} → N m → ∀ n o → m + n + o ≡ m + (n + o)
+-assoc Nm n o = N-ind (+-assocA n o) A0 is Nm
  where
  postulate A0 : +-assocA n o zero
  {-# ATP prove A0 #-}

  postulate is : ∀ {i} → +-assocA n o i → +-assocA n o (succ₁ i)
  {-# ATP prove is #-}

-- A proof without use ATPs definitions.
+-assoc' : ∀ {m} → N m → ∀ n o → m + n + o ≡ m + (n + o)
+-assoc' Nm n o = N-ind A A0 is Nm
  where
  A : D → Set
  A i = i + n + o ≡ i + (n + o)

  postulate A0 : zero + n + o ≡ zero + (n + o)
  {-# ATP prove A0 #-}

  postulate is : ∀ {i} →
                 i + n + o ≡ i + (n + o) →
                 succ₁ i + n + o ≡ succ₁ i + (n + o)
  {-# ATP prove is #-}

-- See Issue https://github.com/asr/apia/issues/81 .
x+Sy≡S[x+y]A : D → D → Set
x+Sy≡S[x+y]A n i = i + succ₁ n ≡ succ₁ (i + n)
{-# ATP definition x+Sy≡S[x+y]A #-}

x+Sy≡S[x+y] : ∀ {m} → N m → ∀ n → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] Nm n = N-ind (x+Sy≡S[x+y]A n) A0 is Nm
  where
  postulate A0 : x+Sy≡S[x+y]A n zero
  {-# ATP prove A0 #-}

  postulate is : ∀ {i} → x+Sy≡S[x+y]A n i → x+Sy≡S[x+y]A n (succ₁ i)
  {-# ATP prove is #-}

-- See Issue https://github.com/asr/apia/issues/81 .
+-commA : D → D → Set
+-commA n i = i + n ≡ n + i
{-# ATP definition +-commA #-}

+-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
+-comm {n = n} Nm Nn = N-ind (+-commA n) A0 is Nm
  where
  postulate A0 : +-commA n zero
  {-# ATP prove A0 +-rightIdentity #-}

  postulate is : ∀ {i} → +-commA n i → +-commA n (succ₁ i)
  {-# ATP prove is x+Sy≡S[x+y] #-}


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

module Dodo.Unary.Empty where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Data.Product using (∃-syntax)
open import Relation.Nullary using (¬_)
open import Relation.Unary using (Pred)

-- # Definitions

Empty₁ : ∀ {a ℓ : Level} {A : Set a} → Pred A ℓ → Set (a ⊔ ℓ)
Empty₁ {A = A} P = ∀ (x : A) → ¬ P x

NonEmpty₁ : ∀ {a ℓ : Level} {A : Set a} → Pred A ℓ → Set (a ⊔ ℓ)
NonEmpty₁ P = ∃[ x ] P x

¬₁_ : ∀ {a ℓ : Level} {A : Set a} → Pred A ℓ → Pred A ℓ
¬₁_ P x = ¬ P x


module Basics where

data Zero : Set where
record One : Set where constructor <>
data Two : Set where tt ff : Two

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data _+_ (S T : Set) : Set where
  inl : S -> S + T
  inr : T -> S + T

record Sg (S : Set)(T : S -> Set) : Set where
  constructor _,_
  field
    fst : S
    snd : T fst
open Sg public
_*_ : Set -> Set -> Set
S * T = Sg S \ _ -> T
infixr 4 _,_ _*_

data _==_ {X : Set}(x : X) : X -> Set where
  refl : x == x


{-# OPTIONS --cubical #-}

module Multidimensional.Data.NNat.Base where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Unit
open import Cubical.Data.Nat
open import Cubical.Data.Prod
open import Cubical.Data.Bool

open import Cubical.Relation.Nullary

open import Multidimensional.Data.Extra.Nat
open import Multidimensional.Data.Dir
open import Multidimensional.Data.DirNum

data N (r : ℕ) : Type₀ where
  bn : DirNum r → N r
  xr : DirNum r → N r → N r

-- should define induction principle for N r

-- we have 2ⁿ "unary" constructors, analogous to BNat with 2¹ (b0 and b1)
-- rename n to r
-- this likely introduces inefficiencies compared
-- to BinNat, with the max? check etc.
sucN : ∀ {n} → N n → N n
sucN {zero} (bn tt) = xr tt (bn tt)
sucN {zero} (xr tt x) = xr tt (sucN x)
sucN {suc n} (bn (↓ , ds)) = (bn (↑ , ds))
sucN {suc n} (bn (↑ , ds)) with max? ds
... | no _ = (bn (↓ , next ds))
... | yes _ = xr (zero-n (suc n)) (bn (one-n (suc n)))
sucN {suc n} (xr d x) with max? d
... | no _ = xr (next d) x
... | yes _ = xr (zero-n (suc n)) (sucN x)

sucnN : {r : ℕ} → (n : ℕ) → (N r → N r)
sucnN n = iter n sucN

doubleN : (r : ℕ) → N r → N r
doubleN zero (bn tt) = bn tt
doubleN zero (xr d x) = sucN (sucN (doubleN zero x))
doubleN (suc r) (bn x) with zero-n? x
... | yes _    = bn x
            -- bad:
... | no _ = caseBool (bn (doubleDirNum (suc r) x)) (xr (zero-n (suc r)) (bn x)) (doubleable-n? x)
-- ... | no _  | doubleable  = {!bn (doubleDirNum x)!}
-- ... | no _  | notdoubleable = xr (zero-n (suc r)) (bn x)
doubleN (suc r) (xr x x₁) = sucN (sucN (doubleN (suc r) x₁))

doublesN : (r : ℕ) → ℕ → N r → N r
doublesN r zero m = m
doublesN r (suc n) m = doublesN r n (doubleN r m)

N→ℕ : (r : ℕ) (x : N r) → ℕ
N→ℕ zero (bn tt) = zero
N→ℕ zero (xr tt x) = suc (N→ℕ zero x)
N→ℕ (suc r) (bn x) = DirNum→ℕ x
N→ℕ (suc r) (xr d x) = sucn (DirNum→ℕ d) (doublesℕ (suc r) (N→ℕ (suc r) x))

ℕ→N : (r : ℕ) → (n : ℕ) → N r
ℕ→N r zero = bn (zero-n r)
ℕ→N zero (suc n) = xr tt (ℕ→N zero n)
ℕ→N (suc r) (suc n) = sucN (ℕ→N (suc r) n)


-- Testcase for #2028 by Ulf

record ⊤ : Set where
  constructor tt

data Either (A B : Set) : Set where
  inl : A → Either A B
  inr : B → Either A B

Subset : Set → Set₁
Subset X = X → Set

U : ∀ {X} → Subset X
U _ = {!⊤!}

_⊆_ : ∀ {X} → Subset X → Subset X → Set
A ⊆ B = ∀ {x} → A x → B x

_∪_ : ∀ {X} → Subset X → Subset X → Subset X
(A ∪ B) x = Either (A x) (B x)

∪-bound : ∀ {X} {A : Subset X} → (A ∪ U) ⊆ U
∪-bound {X} {A} = aux
  where
    aux : _ → _
    aux (inl _) = tt
    aux (inr tt) = tt


{-# OPTIONS --show-implicit #-}
open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Agda.Builtin.Equality

postulate
  funext : {X : Set} {Y : X → Set} {f g : (x : X) → Y x} → (∀ x → f x ≡ g x) → f ≡ g

_::_ : {X : ℕ → Set} → X 0 → ((n : ℕ) → X (suc n)) → ((n : ℕ) → X n)
(x :: α) 0 = x
(x :: α) (suc n) = α n

hd : {X : ℕ → Set} → ((n : ℕ) → X n) → X 0
hd α = α 0

tl : {X : ℕ → Set} → ((n : ℕ) → X n) → ((n : ℕ) → X (suc n))
tl α n = α(suc n)

-- Needed to add the implicit arguments for funext in Agda 2.5.2:

hd-tl-eta : (X : ℕ → Set) {α : (n : ℕ) → X n} → (hd α :: tl α) ≡ α
hd-tl-eta X {α} = funext {Y = _} lemma
 where
  lemma : ∀ {α} → ∀ i → _::_ {_} (hd α) (tl α) i ≡ α i
  lemma 0 = refl
  lemma (suc i) = refl


{-# OPTIONS --safe #-}
module Cubical.Algebra.MonoidSolver.Solver where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Structure

open import Cubical.Data.FinData using (Fin)
open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.List
open import Cubical.Data.Vec using (Vec; lookup)

open import Cubical.Algebra.Monoid

open import Cubical.Algebra.MonoidSolver.MonoidExpression

private
  variable
    ℓ : Level

module Eval (M : Monoid ℓ) where
  open MonoidStr (snd M)

  Env : ℕ → Type ℓ
  Env n = Vec ⟨ M ⟩ n

  -- evaluation of an expression (without normalization)
  ⟦_⟧ : ∀{n} → Expr ⟨ M ⟩ n → Env n → ⟨ M ⟩
  ⟦ ε⊗ ⟧ v      = ε
  ⟦ ∣ i ⟧ v     = lookup i v
  ⟦ e₁ ⊗ e₂ ⟧ v = ⟦ e₁ ⟧ v · ⟦ e₂ ⟧ v

  NormalForm : ℕ → Type _
  NormalForm n = List (Fin n)

  -- normalization of an expression
  normalize : ∀{n} → Expr ⟨ M ⟩ n → NormalForm n
  normalize (∣ i)     = i ∷ []
  normalize ε⊗        = []
  normalize (e₁ ⊗ e₂) = (normalize e₁) ++ (normalize e₂)

  -- evaluation of normalform
  eval : ∀ {n} → NormalForm n → Env n → ⟨ M ⟩
  eval [] v       = ε
  eval (x ∷ xs) v = (lookup x v) · (eval xs v)

  -- some calculation
  evalIsHom : ∀ {n} (x y : NormalForm n) (v : Env n)
            → eval (x ++ y) v ≡ eval x v · eval y v
  evalIsHom [] y v       = sym (·IdL _)
  evalIsHom (x ∷ xs) y v =
    cong (λ m → (lookup x v) · m) (evalIsHom xs y v) ∙ ·Assoc _ _ _

module EqualityToNormalform (M : Monoid ℓ) where
  open Eval M
  open MonoidStr (snd M)

  -- proof that evaluation of an expression is invariant under normalization
  isEqualToNormalform : (n : ℕ)
                      → (e : Expr ⟨ M ⟩ n)
                      → (v : Env n)
                      → eval (normalize e) v ≡ ⟦ e ⟧ v
  isEqualToNormalform n (∣ i) v     = ·IdR _
  isEqualToNormalform n ε⊗ v        = refl
  isEqualToNormalform n (e₁ ⊗ e₂) v =
    eval ((normalize e₁) ++ (normalize e₂)) v         ≡⟨ evalIsHom (normalize e₁) (normalize e₂) v ⟩
    (eval (normalize e₁) v) · (eval (normalize e₂) v) ≡⟨ cong₂ _·_ (isEqualToNormalform n e₁ v) (isEqualToNormalform n e₂ v) ⟩
    ⟦ e₁ ⟧ v · ⟦ e₂ ⟧ v                               ∎

  solve : {n : ℕ}
        → (e₁ e₂ : Expr ⟨ M ⟩ n)
        → (v : Env n)
        → (p : eval (normalize e₁) v ≡ eval (normalize e₂) v)
        → ⟦ e₁ ⟧ v ≡ ⟦ e₂ ⟧ v
  solve e₁ e₂ v p =
    ⟦ e₁ ⟧ v              ≡⟨ sym (isEqualToNormalform _ e₁ v) ⟩
    eval (normalize e₁) v ≡⟨ p ⟩
    eval (normalize e₂) v ≡⟨ isEqualToNormalform _ e₂ v ⟩
    ⟦ e₂ ⟧ v              ∎

solve : (M : Monoid ℓ)
        {n : ℕ} (e₁ e₂ : Expr ⟨ M ⟩ n) (v : Eval.Env M n)
        (p :  Eval.eval M (Eval.normalize M e₁) v ≡ Eval.eval M (Eval.normalize M e₂) v)
        → _
solve M = EqualityToNormalform.solve M


------------------------------------------------------------------------
-- The Agda standard library
--
-- A binary representation of natural numbers
------------------------------------------------------------------------

module Data.Bin where

open import Data.Nat as Nat
  using (ℕ; zero; z≤n; s≤s) renaming (suc to 1+_)
open Nat.≤-Reasoning
import Data.Nat.Properties as NP
open import Data.Digit
open import Data.Fin as Fin using (Fin; zero) renaming (suc to 1+_)
open import Data.Fin.Properties as FP using (_+′_)
open import Data.List as List hiding (downFrom)
open import Function
open import Data.Product
open import Algebra
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; sym)
open import Relation.Nullary
private
  module BitOrd = StrictTotalOrder (FP.strictTotalOrder 2)

------------------------------------------------------------------------
-- The type

-- A representation of binary natural numbers in which there is
-- exactly one representative for every number.

-- The function toℕ below defines the meaning of Bin.

infix 8 _1#

-- bs stands for the binary number 1<reverse bs>, which is positive.

Bin⁺ : Set
Bin⁺ = List Bit

data Bin : Set where
  -- Zero.
  0#  : Bin
  -- bs 1# stands for the binary number 1<reverse bs>.
  _1# : (bs : Bin⁺) → Bin

------------------------------------------------------------------------
-- Conversion functions

-- Converting to a list of bits starting with the _least_ significant
-- one.

toBits : Bin → List Bit
toBits 0#      = [ 0b ]
toBits (bs 1#) = bs ++ [ 1b ]

-- Converting to a natural number.

toℕ : Bin → ℕ
toℕ = fromDigits ∘ toBits

-- Converting from a list of bits, starting with the _least_
-- significant one.

fromBits : List Bit → Bin
fromBits []              = 0#
fromBits (b        ∷ bs) with fromBits bs
fromBits (b        ∷ bs) | bs′ 1# = (b ∷ bs′) 1#
fromBits (zero     ∷ bs) | 0#     = 0#
fromBits (1+ zero  ∷ bs) | 0#     = [] 1#
fromBits (1+ 1+ () ∷ bs) | _

-- Converting from a natural number.

fromℕ : ℕ → Bin
fromℕ n = fromBits $ proj₁ $ toDigits 2 n

------------------------------------------------------------------------
-- (Bin, _≡_, _<_) is a strict total order

infix 4 _<_

-- Order relation. Wrapped so that the parameters can be inferred.

data _<_ (b₁ b₂ : Bin) : Set where
  less : (lt : (Nat._<_ on toℕ) b₁ b₂) → b₁ < b₂

private
  <-trans : Transitive _<_
  <-trans (less lt₁) (less lt₂) = less (NP.<-trans lt₁ lt₂)

  asym : ∀ {b₁ b₂} → b₁ < b₂ → ¬ b₂ < b₁
  asym {b₁} {b₂} (less lt) (less gt) = tri⟶asym cmp lt gt
    where cmp = StrictTotalOrder.compare NP.strictTotalOrder

  irr : ∀ {b₁ b₂} → b₁ < b₂ → b₁ ≢ b₂
  irr lt eq = asym⟶irr (PropEq.resp₂ _<_) sym asym eq lt

  irr′ : ∀ {b} → ¬ b < b
  irr′ lt = irr lt refl

  ∷∙ : ∀ {b₁ b₂ bs₁ bs₂} →
       bs₁ 1# < bs₂ 1# → (b₁ ∷ bs₁) 1# < (b₂ ∷ bs₂) 1#
  ∷∙ {b₁} {b₂} {bs₁} {bs₂} (less lt) = less (begin
      1 + (m₁ + n₁ * 2)  ≤⟨ ≤-refl {x = 1} +-mono
                              (≤-pred (FP.bounded b₁) +-mono ≤-refl) ⟩
      1 + (1  + n₁ * 2)  ≡⟨ refl ⟩
            suc n₁ * 2   ≤⟨ lt *-mono ≤-refl ⟩
                n₂ * 2   ≤⟨ n≤m+n m₂ (n₂ * 2) ⟩
           m₂ + n₂ * 2   ∎
    )
    where
    open Nat; open NP
    open DecTotalOrder decTotalOrder renaming (refl to ≤-refl)
    m₁ = Fin.toℕ b₁;   m₂ = Fin.toℕ b₂
    n₁ = toℕ (bs₁ 1#); n₂ = toℕ (bs₂ 1#)

  ∙∷ : ∀ {b₁ b₂ bs} →
       Fin._<_ b₁ b₂ → (b₁ ∷ bs) 1# < (b₂ ∷ bs) 1#
  ∙∷ {b₁} {b₂} {bs} lt = less (begin
    1 + (m₁  + n * 2)  ≡⟨ sym (+-assoc 1 m₁ (n * 2)) ⟩
    (1 + m₁) + n * 2   ≤⟨ lt +-mono ≤-refl ⟩
         m₂  + n * 2   ∎)
    where
    open Nat; open NP
    open DecTotalOrder decTotalOrder renaming (refl to ≤-refl)
    open CommutativeSemiring commutativeSemiring using (+-assoc)
    m₁ = Fin.toℕ b₁; m₂ = Fin.toℕ b₂; n = toℕ (bs 1#)

  1<[23] : ∀ {b} → [] 1# < (b ∷ []) 1#
  1<[23] {b} = less (NP.n≤m+n (Fin.toℕ b) 2)

  1<2+ : ∀ {bs b} → [] 1# < (b ∷ bs) 1#
  1<2+ {[]}     = 1<[23]
  1<2+ {b ∷ bs} = <-trans 1<[23] (∷∙ {b₁ = b} (1<2+ {bs}))

  0<1 : 0# < [] 1#
  0<1 = less (s≤s z≤n)

  0<+ : ∀ {bs} → 0# < bs 1#
  0<+ {[]}     = 0<1
  0<+ {b ∷ bs} = <-trans 0<1 1<2+

  compare⁺ : Trichotomous (_≡_ on _1#) (_<_ on _1#)
  compare⁺ []         []         = tri≈ irr′ refl irr′
  compare⁺ []         (b ∷ bs)   = tri<       1<2+  (irr 1<2+) (asym 1<2+)
  compare⁺ (b ∷ bs)   []         = tri> (asym 1<2+) (irr 1<2+ ∘ sym) 1<2+
  compare⁺ (b₁ ∷ bs₁) (b₂ ∷ bs₂) with compare⁺ bs₁ bs₂
  ... | tri<  lt ¬eq ¬gt = tri<       (∷∙ lt)  (irr (∷∙ lt)) (asym (∷∙ lt))
  ... | tri> ¬lt ¬eq  gt = tri> (asym (∷∙ gt)) (irr (∷∙ gt) ∘ sym) (∷∙ gt)
  compare⁺ (b₁ ∷ bs) (b₂ ∷ .bs) | tri≈ ¬lt refl ¬gt with BitOrd.compare b₁ b₂
  compare⁺ (b  ∷ bs) (.b ∷ .bs) | tri≈ ¬lt refl ¬gt | tri≈ ¬lt′ refl ¬gt′ =
    tri≈ irr′ refl irr′
  ... | tri<  lt′ ¬eq ¬gt′ = tri<       (∙∷ lt′)  (irr (∙∷ lt′)) (asym (∙∷ lt′))
  ... | tri> ¬lt′ ¬eq  gt′ = tri> (asym (∙∷ gt′)) (irr (∙∷ gt′) ∘ sym) (∙∷ gt′)

  compare : Trichotomous _≡_ _<_
  compare 0#       0#       = tri≈ irr′ refl irr′
  compare 0#       (bs₂ 1#) = tri<       0<+  (irr 0<+) (asym 0<+)
  compare (bs₁ 1#) 0#       = tri> (asym 0<+) (irr 0<+ ∘ sym) 0<+
  compare (bs₁ 1#) (bs₂ 1#) = compare⁺ bs₁ bs₂

strictTotalOrder : StrictTotalOrder _ _ _
strictTotalOrder = record
  { Carrier            = Bin
  ; _≈_                = _≡_
  ; _<_                = _<_
  ; isStrictTotalOrder = record
    { isEquivalence = PropEq.isEquivalence
    ; trans         = <-trans
    ; compare       = compare
    ; <-resp-≈      = PropEq.resp₂ _<_
    }
  }

------------------------------------------------------------------------
-- (Bin, _≡_) is a decidable setoid

decSetoid : DecSetoid _ _
decSetoid = StrictTotalOrder.decSetoid strictTotalOrder

infix 4 _≟_

_≟_ : Decidable {A = Bin} _≡_
_≟_ = DecSetoid._≟_ decSetoid

------------------------------------------------------------------------
-- Arithmetic

-- Power of two.

infixr 8 2^_

2^_ : ℕ → Bin⁺
2^ 0    = []
2^ 1+ n = 0b ∷ 2^ n

-- Base 2 logarithm (rounded downwards).

⌊log₂_⌋ : Bin⁺ → ℕ
⌊log₂ (b ∷ bs) ⌋ = 1+ ⌊log₂ bs ⌋
⌊log₂ []       ⌋ = 0

-- Multiplication by 2.

infix 7 _*2 _*2+1

_*2 : Bin → Bin
0#      *2 = 0#
(bs 1#) *2 = (0b ∷ bs) 1#

_*2+1 : Bin → Bin
0#      *2+1 = [] 1#
(bs 1#) *2+1 = (1b ∷ bs) 1#

-- Division by 2, rounded downwards.

⌊_/2⌋ : Bin → Bin
⌊ 0#          /2⌋ = 0#
⌊ [] 1#       /2⌋ = 0#
⌊ (b ∷ bs) 1# /2⌋ = bs 1#

-- Addition.

Carry : Set
Carry = Bit

addBits : Carry → Bit → Bit → Carry × Bit
addBits c b₁ b₂ with c +′ (b₁ +′ b₂)
... | zero          = (0b , 0b)
... | 1+ zero       = (0b , 1b)
... | 1+ 1+ zero    = (1b , 0b)
... | 1+ 1+ 1+ zero = (1b , 1b)
... | 1+ 1+ 1+ 1+ ()

addCarryToBitList : Carry → List Bit → List Bit
addCarryToBitList zero      bs             = bs
addCarryToBitList (1+ zero) []             = 1b ∷ []
addCarryToBitList (1+ zero) (zero    ∷ bs) = 1b ∷ bs
addCarryToBitList (1+ zero) (1+ zero ∷ bs) = 0b ∷ addCarryToBitList 1b bs
addCarryToBitList (1+ 1+ ()) _
addCarryToBitList _ ((1+ 1+ ()) ∷ _)

addBitLists : Carry → List Bit → List Bit → List Bit
addBitLists c []         bs₂        = addCarryToBitList c bs₂
addBitLists c bs₁        []         = addCarryToBitList c bs₁
addBitLists c (b₁ ∷ bs₁) (b₂ ∷ bs₂) with addBits c b₁ b₂
... | (c' , b') = b' ∷ addBitLists c' bs₁ bs₂

infixl 6 _+_

_+_ : Bin → Bin → Bin
m + n = fromBits (addBitLists 0b (toBits m) (toBits n))

-- Multiplication.

infixl 7 _*_

_*_ : Bin → Bin → Bin
0#                 * n = 0#
[]              1# * n = n
-- (b + 2 * bs 1#) * n = b * n + 2 * (bs 1# * n)
(b        ∷ bs) 1# * n with bs 1# * n
(b        ∷ bs) 1# * n | 0#     = 0#
(zero     ∷ bs) 1# * n | bs' 1# = (0b ∷ bs') 1#
(1+ zero  ∷ bs) 1# * n | bs' 1# = n + (0b ∷ bs') 1#
((1+ 1+ ()) ∷ _) 1# * _ | _

-- Successor.

suc : Bin → Bin
suc n = [] 1# + n

-- Division by 2, rounded upwards.

⌈_/2⌉ : Bin → Bin
⌈ n /2⌉ = ⌊ suc n /2⌋

-- Predecessor.

pred : Bin⁺ → Bin
pred []              = 0#
pred (zero     ∷ bs) = pred bs *2+1
pred (1+ zero  ∷ bs) = (zero ∷ bs) 1#
pred (1+ 1+ () ∷ bs)

-- downFrom n enumerates all numbers from n - 1 to 0. This function is
-- linear in n. Analysis: fromℕ takes linear time, and the preds used
-- take amortised constant time (to see this, let the cost of a pred
-- be 2, and put 1 debit on every bit which is 1).

downFrom : ℕ → List Bin
downFrom n = helper n (fromℕ n)
  where
  helper : ℕ → Bin → List Bin
  helper zero   0#      = []
  helper (1+ n) (bs 1#) = n′ ∷ helper n n′
    where n′ = pred bs
  -- Impossible cases:
  helper zero   (_ 1#)  = []
  helper (1+ _) 0#      = []

------------------------------------------------------------------------
-- Tests

-- The tests below have been commented out since (at least one version
-- of) Agda is too slow or memory-hungry to type check them.

{-
-- The tests below are run when this module is type checked.

-- First some test helpers:

private

  testLimit : ℕ
  testLimit = 5

  nats : List ℕ
  nats = List.downFrom testLimit

  nats⁺ : List ℕ
  nats⁺ = filter (λ n → decToBool (Nat._≤?_ 1 n)) nats

  natPairs : List (ℕ × ℕ)
  natPairs = zip nats (reverse nats)

  _=[_]_ : (ℕ → ℕ) → List ℕ → (Bin → Bin) → Set
  f =[ ns ] g = map f ns ≡ map (toℕ ∘ g ∘ fromℕ) ns

  _=[_]₂_ : (ℕ → ℕ → ℕ) → List (ℕ × ℕ) → (Bin → Bin → Bin) → Set
  f =[ ps ]₂ g =
    map (uncurry f) ps ≡ map (toℕ ∘ uncurry (g on fromℕ)) ps

-- And then the tests:

private

  test-*2+1 : (λ n → Nat._+_ (Nat._*_ n 2) 1) =[ nats ] _*2+1
  test-*2+1 = refl

  test-*2 : (λ n → Nat._*_ n 2) =[ nats ] _*2
  test-*2 = refl

  test-⌊_/2⌋ : Nat.⌊_/2⌋ =[ nats ] ⌊_/2⌋
  test-⌊_/2⌋ = refl

  test-+ : Nat._+_ =[ natPairs ]₂ _+_
  test-+ = refl

  test-* : Nat._*_ =[ natPairs ]₂ _*_
  test-* = refl

  test-suc : 1+_ =[ nats ] suc
  test-suc = refl

  test-⌈_/2⌉ : Nat.⌈_/2⌉ =[ nats ] ⌈_/2⌉
  test-⌈_/2⌉ = refl

  drop-1# : Bin → Bin⁺
  drop-1# 0#      = []
  drop-1# (bs 1#) = bs

  test-pred : Nat.pred =[ nats⁺ ] (pred ∘ drop-1#)
  test-pred = refl

  test-downFrom : map toℕ (downFrom testLimit) ≡
                  List.downFrom testLimit
  test-downFrom = refl
-}


{-
This second-order equational theory was created from the following second-order syntax description:

syntax Monad | M

type
  T : 1-ary

term
  ret  : α  ->  T α
  bind : T α  α.(T β)  ->  T β | _>>=_ r10

theory
  (LU) a : α   b : α.(T β) |> bind (ret(a), x. b[x]) =  b[a]
  (RU) t : T α |> bind (t, x. ret(x)) = t
  (AS) t : T α  b : α.(T β)  c : β.(T γ) |> bind (bind (t, x.b[x]), y.c[y]) = bind (t, x. bind (b[x], y.c[y]))
-}

module Monad.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import Monad.Signature
open import Monad.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution M:Syn
open import SOAS.Metatheory.SecondOrder.Equality M:Syn

private
  variable
    α β γ τ : MT
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ M) α Γ → (𝔐 ▷ M) α Γ → Set where
  LU : ⁅ α ⁆ ⁅ α ⊩ T β ⁆̣               ▹ ∅ ⊢         (ret 𝔞) >>= 𝔟⟨ x₀ ⟩ ≋ₐ 𝔟⟨ 𝔞 ⟩
  RU : ⁅ T α ⁆̣                         ▹ ∅ ⊢              𝔞 >>= (ret x₀) ≋ₐ 𝔞
  AS : ⁅ T α ⁆ ⁅ α ⊩ T β ⁆ ⁅ β ⊩ T γ ⁆̣ ▹ ∅ ⊢ (𝔞 >>= 𝔟⟨ x₀ ⟩) >>= 𝔠⟨ x₀ ⟩ ≋ₐ 𝔞 >>= (𝔟⟨ x₀ ⟩ >>= 𝔠⟨ x₀ ⟩)

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning


open import Relation.Binary using (Setoid)

module Data.Vec.Any.Membership {a ℓ} (S : Setoid a ℓ) where
  open import Level using (_⊔_)
  open Setoid S renaming (Carrier to A; refl to ≈-refl; trans to ≈-trans )
  open import Relation.Nullary
  open import Relation.Binary
  open import Data.Fin
  open import Data.Nat as ℕ hiding (_⊔_)
  open import Data.Product as Prod hiding (map)
  open import Data.Vec as Vec hiding (map)
  open import Data.Vec.Equality
  open import Data.Vec.Any as Any
  open import Function using (_∘_; id; flip)
  open Equality S renaming (_≈_ to _≋_; trans to ≋-trans)

  infix 4 _∈′_ _∉′_
  _∈′_ : ∀ {n} → A → Vec A n → Set (a ⊔ ℓ)
  x ∈′ xs = Any (x ≈_) xs

  _∉′_ : ∀ {n} → A → Vec A n → Set (a ⊔ ℓ)
  x ∉′ xs = ¬ (x ∈′ xs)

  infix 4 _⊆_ _⊈_

  _⊆_  : ∀ {n m} → Vec A n → Vec A m → Set _
  xs ⊆ ys = ∀ {x} → x ∈′ xs → x ∈′ ys
  _⊈_  : ∀ {n m} → Vec A n → Vec A m → Set _
  xs ⊈ ys = ¬ (xs ⊆ ys)

  -- A variant of Vec.map.

  map-with-∈′ : ∀ {n b} {B : Set b}
             (xs : Vec A n) → (∀ {x} → x ∈′ xs → B) → Vec B n
  map-with-∈′ []       f = []
  map-with-∈′ (x ∷ xs) f = f (here ≈-refl)  ∷ map-with-∈′ xs (f ∘ there)

  -- Finds an element satisfying the predicate.

  find′ : ∀ {p n} {P : A → Set p} {xs : Vec A n} →
         Any P xs → ∃ λ x → x ∈′ xs × P x
  find′ (here px) = , here ≈-refl  , px
  find′ (there pxs) = Prod.map id (Prod.map there id) (find′ pxs)

  lose′ : ∀ {p n} {P : A → Set p} {x}{xs : Vec A n} →
         P Respects _≈_ → x ∈′ xs → P x → Any P xs
  lose′ resp x∈′xs  px = map (flip resp px) x∈′xs


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Magma.Morphism where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Functions.Embedding

open import Cubical.Algebra

private
  variable
    m n : Level

IsMagmaHom : (M : Magma m) (N : Magma n) → (⟨ M ⟩ → ⟨ N ⟩) → Type (ℓ-max m n)
IsMagmaHom M N fun = Homomorphic₂ fun (Magma._•_ M) (Magma._•_ N)

record MagmaHom (M : Magma m) (N : Magma n) : Type (ℓ-max m n) where
  constructor magmahom
  field
    fun : ⟨ M ⟩ → ⟨ N ⟩
    isHom : IsMagmaHom M N fun

record MagmaEquiv (M : Magma m) (N : Magma n) : Type (ℓ-max m n) where
  constructor magmaequiv
  field
    eq : ⟨ M ⟩ ≃ ⟨ N ⟩
    isHom : IsMagmaHom M N (equivFun eq)

  hom : MagmaHom M N
  hom = record { isHom = isHom }

instance
  MagmaHomOperators : HomOperators (Magma m) (Magma n) (ℓ-max m n)
  MagmaHomOperators = record { _⟶ᴴ_ = MagmaHom; _≃ᴴ_ = MagmaEquiv }


module stateDependentObjects where

open import Size renaming (Size to AgdaSize)
open import Agda.Builtin.Equality
open import Data.Nat.Base as N hiding (_⊔_)
open import Data.Product
open import Data.Vec as Vec using (Vec; []; _∷_; head; tail)
open import Function
open import NativeIO
open import Relation.Binary.PropositionalEquality
open import interactiveProgramsAgda
-- open import SizedIO.Base

{- State dependent interfaces, objects -}

record Interfaceˢ : Set₁ where
  field  Stateˢ  : Set
         Methodˢ : (s : Stateˢ) → Set
         Resultˢ : (s : Stateˢ) → (m : Methodˢ s) → Set
         nextˢ   : (s : Stateˢ) → (m : Methodˢ s) → (r : Resultˢ s m)
                   → Stateˢ

open Interfaceˢ public

{- State-Dependent Objects -}

record Objectˢ (I : Interfaceˢ) (s : Stateˢ I) : Set where
  coinductive
  field objectMethod :  (m : Methodˢ I s) →
                        Σ[ r ∈ Resultˢ I s m ] Objectˢ I (nextˢ I s m r)

open Objectˢ public

record IOObjectˢ (Iᵢₒ : IOInterface) (I : Interfaceˢ) (s : Stateˢ I) : Set where
  coinductive
  field method :  (m : Methodˢ I s) →
                  IO Iᵢₒ ∞ (Σ[ r ∈ Resultˢ I s m ] IOObjectˢ Iᵢₒ I (nextˢ I s m r))

{- Example of a Stack -}

StackStateˢ : Set
StackStateˢ = ℕ

data StackMethodˢ (A : Set) : (n : StackStateˢ) → Set where
  push  :  ∀ {n}  →  A  →  StackMethodˢ A n
  pop   :  ∀ {n}         →  StackMethodˢ A (suc n)

StackResultˢ : (A : Set) → (s : StackStateˢ) → StackMethodˢ A s → Set
StackResultˢ A _  (push _)  =  Unit
StackResultˢ A _  pop       =  A

stackNextˢ  :  ∀ A n (m : StackMethodˢ A n) (r : StackResultˢ A n m) →  StackStateˢ
stackNextˢ A  n        (push x)  r  =  suc n
stackNextˢ A  (suc n)  pop       r  =  n

StackInterfaceˢ : (A : Set)  →  Interfaceˢ
Stateˢ   (StackInterfaceˢ A)  =  StackStateˢ
Methodˢ  (StackInterfaceˢ A)  =  StackMethodˢ A
Resultˢ  (StackInterfaceˢ A)  =  StackResultˢ A
nextˢ    (StackInterfaceˢ A)  =  stackNextˢ A

stack  :  ∀{A}{n : ℕ} (as : Vec A n) →  Objectˢ (StackInterfaceˢ A) n
objectMethod (stack as)        (push a)  =  _  ,  stack (a ∷ as)
objectMethod (stack (a ∷ as))  pop       =  a  ,  stack as

{- Reasoning about Stateful Objects -}

{- Bisimiliarity -}

module Bisim (I : Interfaceˢ)
             (let S = Stateˢ I)   (let M = Methodˢ I) (let R = Resultˢ I)
             (let next = nextˢ I) (let O = Objectˢ I)
  where

  data  ΣR     {A : Set} {B : A → Set} (R : ∀{a} (b b' : B a) → Set)
               :  (p p' : Σ A B) → Set
        where
        eqΣ    :  ∀{a}{b b' : B a} → R b b' → ΣR R (a , b) (a , b')

  record _≅_ {s : S} (o o' : O s) : Set where
    coinductive
    field  bisimMethod  :  (m : M s) →
                           ΣR (_≅_) (objectMethod o m) (objectMethod o' m)

  open _≅_ public

  refl≅ :  ∀{s} (o : O s) → o ≅ o
  bisimMethod (refl≅ o) m  =  let  (r , o') =  objectMethod o m
                              in   eqΣ (refl≅ o')

module _ {E : Set} where
  private
    I = StackInterfaceˢ E
    S = Stateˢ I
    O = Objectˢ I
  open Bisim I

{-  Verifying Stack laws -}

  pop-after-push : ∀{n} {v : Vec E n} {e : E} →
    let  st          =  stack v
         (_ , st₁)   =  objectMethod  st   (push e)
         (e₂ , st₂)  =  objectMethod  st₁  pop

    in   (e ≡ e₂) × (st ≅ st₂)

  pop-after-push = refl , refl≅ _

  push-after-pop : ∀{n} {v : Vec E n} {e : E} →
    let  st            =  stack (e ∷ v)
         (e₁  ,  st₁)  =  objectMethod st   pop
         (_   ,  st₂)  =  objectMethod st₁  (push e₁)

    in   st ≅ st₂
  push-after-pop = refl≅ _

{- Bisimilarity of different stack implementations -}

  stackFState = ℕ → E

  pushStackF : E → stackFState → stackFState
  pushStackF e f = λ { 0       → e ;
                       (suc m) → f m}

  popStackFe : stackFState → E
  popStackFe f = f 0

  popStackFf  :  stackFState → stackFState
  popStackFf f = f ∘ suc

  tabulate  :  ∀ (n : ℕ) → stackFState → Vec E n
  tabulate  0        f  =  []
  tabulate  (suc n)  f  =  popStackFe f ∷ tabulate n (popStackFf f)

  stackF : ∀ (n : ℕ) (f : ℕ → E) → Objectˢ (StackInterfaceˢ E) n
  objectMethod (stackF n       f) (push e) = _ ,
                                             stackF (suc n) (pushStackF e f)
  objectMethod (stackF (suc n) f) pop      = popStackFe f ,
                                             stackF n (popStackFf f)

  impl-bisim : ∀{n f} v (p : tabulate n f ≡ v) → stackF n f ≅ stack v
  bisimMethod (impl-bisim v        p) (push e) =
    eqΣ (impl-bisim (e ∷ v)  (cong (_∷_ e)  p))

  bisimMethod (impl-bisim (e ∷ v)  p) pop rewrite cong head p =
    eqΣ (impl-bisim v        (cong tail     p))


module plfa-code.Connectives where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ)
open import Function using (_∘_)
open import plfa-code.Isomorphism using (_≃_; _≲_; extensionality)
open plfa-code.Isomorphism.≃-Reasoning

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

  ⟨_,_⟩ :
      A
    → B
      -----
    → A × B

proj₁ : ∀ {A B : Set}
  → A × B
    -----
  → A
proj₁ ⟨ x , y ⟩ = x

proj₂ : ∀ {A B : Set}
  → A × B
    -----
  → B
proj₂ ⟨ x , y ⟩ = y

record _×′_ (A B : Set) : Set where
  field
    proj₁′ : A
    proj₂′ : B
open _×′_

η-× : ∀ {A B : Set} (w : A × B) → ⟨ proj₁ w , proj₂ w ⟩ ≡ w
η-× ⟨ x , y ⟩ = refl

infixr 2 _×_

data Bool : Set where
  true  : Bool
  false : Bool

data Tri : Set where
  aa : Tri
  bb : Tri
  cc : Tri

×-count : Bool × Tri → ℕ
×-count ⟨ true  , aa ⟩  =  1
×-count ⟨ true  , bb ⟩  =  2
×-count ⟨ true  , cc ⟩  =  3
×-count ⟨ false , aa ⟩  =  4
×-count ⟨ false , bb ⟩  =  5
×-count ⟨ false , cc ⟩  =  6

×-comm : ∀ {A B : Set} → A × B ≃ B × A
×-comm =
  record
    { to       =  λ{ ⟨ x , y ⟩ → ⟨ y , x ⟩ }
    ; from     =  λ{ ⟨ y , x ⟩ → ⟨ x , y ⟩ }
    ; from∘to  =  λ{ ⟨ x , y ⟩ → refl }
    ; to∘from  =  λ{ ⟨ y , x ⟩ → refl }
    }

×-assoc : ∀ {A B C : Set} → (A × B) × C ≃ A × (B × C)
×-assoc =
  record
    { to      = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → ⟨ x , ⟨ y , z ⟩ ⟩ }
    ; from    = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → ⟨ ⟨ x , y ⟩ , z ⟩ }
    ; from∘to = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → refl }
    ; to∘from = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → refl }
    }

---------- practice ----------
open plfa-code.Isomorphism using (_⇔_)
open _⇔_

⇔-≃-→×→ : ∀ {A B : Set} → A ⇔ B ≃ (A → B) × (B → A)
⇔-≃-→×→ =
  record
  { to      = λ x → ⟨ to x , from x ⟩
  ; from    = λ{ ⟨ A→B , B→A ⟩ → record { to = A→B ; from = B→A } }
  ; from∘to = λ x → refl
  ; to∘from = λ{ ⟨ A→B , B→A ⟩ → refl }
  }

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

data ⊤ : Set where

  tt :
    --
    ⊤

η-⊤ : ∀ (w : ⊤) → tt ≡ w
η-⊤ tt = refl

⊤-count : ⊤ → ℕ
⊤-count tt = 1

⊤-identityˡ : ∀ {A : Set} → ⊤ × A ≃ A
⊤-identityˡ =
  record
    { to      = λ{ ⟨ tt , x ⟩ → x }
    ; from    = λ x → ⟨ tt , x ⟩
    ; from∘to = λ{ ⟨ tt , x ⟩ → refl }
    ; to∘from = λ x → refl
    }

⊤-identityʳ : ∀ {A : Set} → (A × ⊤) ≃ A
⊤-identityʳ {A} =
  ≃-begin
    (A × ⊤)
  ≃⟨ ×-comm ⟩
    (⊤ × A)
  ≃⟨ ⊤-identityˡ ⟩
    A
  ≃-∎

data _⊎_ (A B : Set) : Set where

  inj₁ :
      A
      -----
    → A ⊎ B

  inj₂ :
      B
      -----
    → A ⊎ B

case-⊎ : ∀ {A B C : Set}
  → (A → C)
  → (B → C)
  → A ⊎ B
    -----------
  → C
case-⊎ f g (inj₁ x) = f x
case-⊎ f g (inj₂ y) = g y

η-⊎ : ∀ {A B : Set} (w : A ⊎ B) → case-⊎ inj₁ inj₂ w ≡ w
η-⊎ (inj₁ x) = refl
η-⊎ (inj₂ y) = refl

uniq-⊎ : ∀ {A B C : Set} (h : A ⊎ B → C) (w : A ⊎ B) →
  case-⊎ (h ∘ inj₁) (h ∘ inj₂) w ≡ h w
uniq-⊎ h (inj₁ x) = refl
uniq-⊎ h (inj₂ y) = refl

infix 1 _⊎_

⊎-count : Bool ⊎ Tri → ℕ
⊎-count (inj₁ true)  =  1
⊎-count (inj₁ false) =  2
⊎-count (inj₂ aa)    =  3
⊎-count (inj₂ bb)    =  4
⊎-count (inj₂ cc)    =  5

---------- practice ----------
⊎-comm : ∀ {A B : Set} → A ⊎ B ≃ B ⊎ A
⊎-comm =
  record
  { to      = λ{(inj₁ a) → inj₂ a ; (inj₂ b) → inj₁ b }
  ; from    = λ{(inj₁ b) → inj₂ b ; (inj₂ a) → inj₁ a }
  ; from∘to = λ{(inj₁ a) → refl ; (inj₂ b) → refl }
  ; to∘from = λ{(inj₁ b) → refl ; (inj₂ a) → refl }
  }

⊎-assoc : ∀ {A B C : Set} → (A ⊎ B) ⊎ C ≃ A ⊎ (B ⊎ C)
⊎-assoc =
  record
  { to      = to′
  ; from    = from′
  ; from∘to = from∘to′
  ; to∘from = to∘from′
  }
  where
    to′ : ∀ {A B C : Set} → (A ⊎ B) ⊎ C → A ⊎ (B ⊎ C)
    to′ (inj₁ (inj₁ a)) = inj₁ a
    to′ (inj₁ (inj₂ b)) = inj₂ (inj₁ b)
    to′ (inj₂ c) = inj₂ (inj₂ c)
    from′ : ∀ {A B C : Set} → A ⊎ (B ⊎ C) → (A ⊎ B) ⊎ C
    from′ (inj₁ a) = inj₁ (inj₁ a)
    from′ (inj₂ (inj₁ b)) = inj₁ (inj₂ b)
    from′ (inj₂ (inj₂ c)) = inj₂ c
    from∘to′ : ∀ (x) → from′ (to′ x) ≡ x
    from∘to′ (inj₁ (inj₁ a)) = refl
    from∘to′ (inj₁ (inj₂ b)) = refl
    from∘to′ (inj₂ c) = refl
    to∘from′ : ∀ (x) → to′ (from′ x) ≡ x
    to∘from′ (inj₁ a) = refl
    to∘from′ (inj₂ (inj₁ b)) = refl
    to∘from′ (inj₂ (inj₂ c)) = refl

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

data ⊥ : Set where
  -- no clauses!

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

uniq-⊥ : ∀ {C : Set} (h : ⊥ → C) (w : ⊥) → ⊥-elim w ≡ h w
uniq-⊥ h ()

⊥-count : ⊥ → ℕ
⊥-count ()

---------- practice ----------
⊥-identityˡ : ∀ {A : Set} → ⊥ ⊎ A ≃ A
⊥-identityˡ =
  record
  { to      = λ{ (inj₂ a) → a }
  ; from    = inj₂
  ; from∘to = λ{ (inj₂ a) → refl }
  ; to∘from = λ a → refl
  }

⊥-identityʳ : ∀ {A : Set} → A ⊎ ⊥ ≃ A
⊥-identityʳ {A} =
  ≃-begin
    (A ⊎ ⊥)
  ≃⟨ ⊎-comm ⟩
    (⊥ ⊎ A)
  ≃⟨ ⊥-identityˡ ⟩
    A
  ≃-∎

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

→-elim : ∀ {A B : Set}
  → (A → B)
  → A
    -------
  → B
→-elim L M = L M

η-→ : ∀ {A B : Set} (f : A → B) → (λ (x : A) → f x) ≡ f
η-→ f = refl

→-count : (Bool → Tri) → ℕ
→-count f with f true | f false
...          | aa     | aa      =   1
...          | aa     | bb      =   2
...          | aa     | cc      =   3
...          | bb     | aa      =   4
...          | bb     | bb      =   5
...          | bb     | cc      =   6
...          | cc     | aa      =   7
...          | cc     | bb      =   8
...          | cc     | cc      =   9

currying : ∀ {A B C : Set} → (A → B → C) ≃ (A × B → C)
currying =
  record
    { to      = λ f → λ{ ⟨ x , y ⟩ → f x y }
    ; from    = λ g x y → g ⟨ x , y ⟩
    ; from∘to = λ x → refl
    ; to∘from = λ{ g → extensionality λ{ ⟨ x , y ⟩ → refl } }
    }

→-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B → C) ≃ ((A → C) × (B → C))
→-distrib-⊎ =
  record
    { to      = λ{ f → ⟨ f ∘ inj₁ , f ∘ inj₂ ⟩ }
    ; from    = λ{ ⟨ g , h ⟩ → λ{ (inj₁ x) → g x ; (inj₂ y) → h y } }
    ; from∘to = λ{ f → extensionality λ{ (inj₁ x) → refl ; (inj₂ y) → refl } }
    ; to∘from = λ{ ⟨ g , h ⟩ → refl }
    }

→-distrib-× : ∀ {A B C : Set} → (A → B × C) ≃ (A → B) × (A → C)
→-distrib-× =
  record
    { to      = λ{ f → ⟨ proj₁ ∘ f , proj₂ ∘ f ⟩ }
    ; from    = λ{ ⟨ g , h ⟩ → λ x → ⟨ g x , h x ⟩ }
    ; from∘to = λ{ f → extensionality λ{ x → η-× (f x) } }
    ; to∘from = λ{ ⟨ g , h ⟩ → refl }
    }

×-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B) × C ≃ (A × C) ⊎ (B × C)
×-distrib-⊎ =
  record
    { to      = λ{ ⟨ inj₁ x , z ⟩ → (inj₁ ⟨ x , z ⟩)
                 ; ⟨ inj₂ y , z ⟩ → (inj₂ ⟨ y , z ⟩)
                 }
    ; from    = λ{ (inj₁ ⟨ x , z ⟩) → ⟨ inj₁ x , z ⟩
                 ; (inj₂ ⟨ y , z ⟩) → ⟨ inj₂ y , z ⟩
                 }
    ; from∘to = λ{ ⟨ inj₁ x , z ⟩ → refl
                 ; ⟨ inj₂ y , z ⟩ → refl
                 }
    ; to∘from = λ{ (inj₁ ⟨ x , z ⟩) → refl
                 ; (inj₂ ⟨ y , z ⟩) → refl
                 }
    }

⊎-distrib-× : ∀ {A B C : Set} → (A × B) ⊎ C ≲ (A ⊎ C) × (B ⊎ C)
⊎-distrib-× =
  record
    { to      = λ{ (inj₁ ⟨ x , y ⟩) → ⟨ inj₁ x , inj₁ y ⟩
                 ; (inj₂ z)         → ⟨ inj₂ z , inj₂ z ⟩
                 }
    ; from    = λ{ ⟨ inj₁ x , inj₁ y ⟩ → (inj₁ ⟨ x , y ⟩)
                 ; ⟨ inj₁ x , inj₂ z ⟩ → (inj₂ z)
                 ; ⟨ inj₂ z , _      ⟩ → (inj₂ z)
                 }
    ; from∘to = λ{ (inj₁ ⟨ x , y ⟩) → refl
                 ; (inj₂ z)         → refl
                 }
    }

---------- practice ----------
⊎-weak-× : ∀ {A B C : Set} → (A ⊎ B) × C → A ⊎ (B × C)
⊎-weak-× ⟨ inj₁ a , c ⟩ = inj₁ a
⊎-weak-× ⟨ inj₂ b , c ⟩ = inj₂ ⟨ b , c ⟩
-- the corresponding distributive law is ×-distrib-⊎, ×-distrib-⊎ is more strong

⊎×-implies-×⊎ : ∀ {A B C D : Set} → (A × B) ⊎ (C × D) → (A ⊎ C) × (B ⊎ D)
⊎×-implies-×⊎ (inj₁ ⟨ a , b ⟩) = ⟨ inj₁ a , inj₁ b ⟩
⊎×-implies-×⊎ (inj₂ ⟨ c , d ⟩) = ⟨ inj₂ c , inj₂ d ⟩
-- the converse doesn't hold. ⟨ inj₁ a , inj₂ d ⟩ could not build a
-- (A × B) ⊎ (C × D) value

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


------------------------------------------------------------------------------
-- The relation of divisibility on partial natural numbers
------------------------------------------------------------------------------

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

module FOTC.Data.Nat.Divisibility.NotBy0 where

open import FOTC.Base
open import FOTC.Data.Nat

infix 4 _∣_

------------------------------------------------------------------------------
-- The relation of divisibility (the symbol is '\mid' not '|')
--
-- (See documentation in FOTC.Data.Nat.Divisibility.By0)
--
-- In our definition 0∤0, which is used to prove properties of the gcd
-- as it is in GHC ≤ 7.0.4, where gcd 0 0 = undefined (see
-- http://hackage.haskell.org/trac/ghc/ticket/3304).

-- Note that @k@ should be a total natural number.
_∣_ : D → D → Set
m ∣ n =  (m ≢ zero) ∧ (∃[ k ] N k ∧ n ≡ k * m)
{-# ATP definition _∣_ #-}


-- Some proposition constructors.

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

module Tools.Nullary where

open import Tools.Empty

-- Negation.

infix 3 ¬_

¬_ : Set → Set
¬ P = P → ⊥

-- Decidable propositions.

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

-- If A and B are logically equivalent, then so are Dec A and Dec B.

map : ∀ {A B} → (A → B) → (B → A) → Dec A → Dec B
map f g (yes p) = yes (f p)
map f g (no ¬p) = no (λ x → ¬p (g x))


module GGT.Group.Bundles
  {a b ℓ}
  where

open import Algebra.Bundles using (Group)
open import Relation.Unary
open import Relation.Binary
open import Level
open import GGT.Group.Structures

record SubGroup (G : Group a ℓ) : Set (a ⊔ suc b ⊔ ℓ) where
  open Group G public
  field
    P : Pred Carrier b
    isSubGroup : IsSubGroup G P

  open IsSubGroup isSubGroup public
  -- imports ~
  -- xy-1 ∈ H => xy-1 = h => h'xy-1 = h'' => h'x = h''y -- right cosets
  -- x ↦ ω · x = ω · yx-1 · x = ω · y

cosetʳRel : {G : Group a ℓ} → (SubGroup G) → Setoid a b

cosetʳRel {G} H = record { Carrier = Carrier;
                           _≈_ = _∼_;
                           isEquivalence = iseq} where
                  open SubGroup H
                  open import GGT.Group.Facts G
                  iseq = record {refl  = cosetRelRefl isSubGroup ;
                                 sym   = cosetRelSym isSubGroup ;
                                 trans = cosetRelTrans isSubGroup }

syntax cosetʳRel {G} H = H \\ G


module Algebra.LabelledGraph.Reasoning where

open import Algebra.Dioid
open import Algebra.LabelledGraph

-- Standard syntax sugar for writing equational proofs
infix 4 _≈_
data _≈_ {A B eq} {d : Dioid B eq} (x y : LabelledGraph d A) : Set where
    prove : x ≡ y -> x ≈ y

infix 1 begin_
begin_ : ∀ {A B eq} {d : Dioid B eq} {x y : LabelledGraph d A} -> x ≈ y -> x ≡ y
begin prove p = p

infixr 2 _≡⟨_⟩_
_≡⟨_⟩_ : ∀ {A B eq} {d : Dioid B eq} (x : LabelledGraph d A) {y z : LabelledGraph d A} -> x ≡ y -> y ≈ z -> x ≈ z
_ ≡⟨ p ⟩ prove q = prove (transitivity p q)

infix 3 _∎
_∎ : ∀ {A B eq} {d : Dioid B eq} (x : LabelledGraph d A) -> x ≈ x
_∎ _ = prove reflexivity

infixl 8 _>>_
_>>_ : ∀ {A B eq} {d : Dioid B eq} {x y z : LabelledGraph d A} -> x ≡ y -> y ≡ z -> x ≡ z
_>>_ = transitivity

L : ∀ {A B eq} {d : Dioid B eq} {x y z : LabelledGraph d A} {r : B} -> x ≡ y -> x [ r ]> z ≡ y [ r ]> z
L = left-congruence

R : ∀ {A B eq} {d : Dioid B eq} {x y z : LabelledGraph d A} {r : B} -> x ≡ y -> z [ r ]> x ≡ z [ r ]> y
R = right-congruence


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc)
open import Relation.Nullary using (Dec; yes; no)

data _≤_ : ℕ → ℕ → Set where
  z≤n : ∀ {n : ℕ} → zero ≤ n
  s≤s : ∀ {m n : ℕ} → m ≤ n → suc m ≤ suc n

_≤?_ : ∀ (m n : ℕ) → Dec (m ≤ n)
zero ≤? n = yes z≤n
suc m ≤? zero = no λ()
suc m ≤? suc n with m ≤? n
... | yes m≤n = yes (s≤s m≤n)
... | no ¬m≤n = no λ{ (s≤s m≤n) → ¬m≤n m≤n }

_ : 2 ≤? 4 ≡ yes (s≤s (s≤s z≤n))
_ = refl

_ : 4 ≤? 2 ≡ no {!!}
_ = refl

{-
Using ^C ^N, the term
  4 ≤? 2
evaluates to
  no (λ { (s≤s m≤n) → (λ { (s≤s m≤n) → (λ ()) 1 m≤n }) m≤n })
The 1 is spurious.
-}


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

module Cubical.Homotopy.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv.Properties

private
  variable
    ℓ ℓ' : Level

_∼_ : {X : Type ℓ} {Y : X → Type ℓ'} → (f g : (x : X) → Y x) → Type (ℓ-max ℓ ℓ')
_∼_ {X = X} f g = (x : X) → f x ≡ g x

funExt∼ : {X : Type ℓ} {Y : X → Type ℓ'} {f g : (x : X) → Y x} (H : f ∼ g) → f ≡ g
funExt∼ = funExt

∼-refl : {X : Type ℓ} {Y : X → Type ℓ'} {f : (x : X) → Y x} → f ∼ f
∼-refl {f = f} = λ x → refl {x = f x}


module Serializer where

open import Data.List
open import Data.Fin hiding (_+_)
open import Data.Nat
open import Data.Product
open import Data.Bool
open import Function using (_∘_ ; _$_ ; _∋_)
open import Function.Injection hiding (_∘_)
open import Function.Surjection hiding (_∘_)
open import Function.Bijection hiding (_∘_)
open import Relation.Binary.PropositionalEquality hiding ( [_] )
open import Reflection

open import Helper.Fin
open import Helper.CodeGeneration

-----------------------------------
-- Generic
-----------------------------------

-- Finite

record Serializer (T : Set) : Set where
  constructor serializer
  field
    size : ℕ
    from : T -> Fin size
    to : Fin size -> T
    bijection : Bijection (setoid T) (setoid (Fin size))


{-# OPTIONS --cubical --safe #-}
module Cubical.ZCohomology.S1.S1 where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.HITs.S1
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.HITs.SetTruncation
open import Cubical.HITs.Nullification
open import Cubical.Data.Int
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation

----  H⁰(S¹) = ℤ  ----

coHom0-S1 : coHom zero S¹ ≡ Int
coHom0-S1 = (λ i → ∥ helpLemma i ∥₀ ) ∙ setId isSetInt
  where
  helpLemma : (S¹ → Int) ≡ Int
  helpLemma = isoToPath (iso fun funinv (λ _ → refl) (λ f → funExt (rinvLemma f)))
    where
    fun : (S¹ → Int) → Int
    fun f = f base

    funinv : Int → (S¹ → Int)
    funinv a base = a
    funinv a (loop i) = a

    rinvLemma : (f : S¹ → Int) → (x : S¹) → funinv (fun f) x ≡ f x
    rinvLemma f  base = refl
    rinvLemma f  (loop i) j = isSetInt (f base) (f base) (λ k → f (loop k)) refl (~ j) i

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

{- TODO : give Hᵏ(S¹) for all k -}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some derivable properties
------------------------------------------------------------------------

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

open import Algebra.Bundles

module Algebra.Properties.Lattice {l₁ l₂} (L : Lattice l₁ l₂) where

open Lattice L
open import Algebra.Structures _≈_
open import Algebra.Definitions _≈_
import Algebra.Properties.Semilattice as SemilatticeProperties
open import Relation.Binary
import Relation.Binary.Lattice as R
open import Relation.Binary.Reasoning.Setoid  setoid
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence using (_⇔_; module Equivalence)
open import Data.Product using (_,_; swap)

------------------------------------------------------------------------
-- _∧_ is a semilattice

∧-idem : Idempotent _∧_
∧-idem x = begin
  x ∧ x            ≈⟨ ∧-congˡ (sym (∨-absorbs-∧ _ _)) ⟩
  x ∧ (x ∨ x ∧ x)  ≈⟨ ∧-absorbs-∨ _ _ ⟩
  x                ∎

∧-isMagma : IsMagma _∧_
∧-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = ∧-cong
  }

∧-isSemigroup : IsSemigroup _∧_
∧-isSemigroup = record
  { isMagma = ∧-isMagma
  ; assoc   = ∧-assoc
  }

∧-isBand : IsBand _∧_
∧-isBand = record
  { isSemigroup = ∧-isSemigroup
  ; idem        = ∧-idem
  }

∧-isSemilattice : IsSemilattice _∧_
∧-isSemilattice = record
  { isBand = ∧-isBand
  ; comm   = ∧-comm
  }

∧-semilattice : Semilattice l₁ l₂
∧-semilattice = record
  { isSemilattice = ∧-isSemilattice
  }

open SemilatticeProperties ∧-semilattice public
  using
  ( ∧-isOrderTheoreticMeetSemilattice
  ; ∧-isOrderTheoreticJoinSemilattice
  ; ∧-orderTheoreticMeetSemilattice
  ; ∧-orderTheoreticJoinSemilattice
  )

------------------------------------------------------------------------
-- _∨_ is a semilattice

∨-idem : Idempotent _∨_
∨-idem x = begin
  x ∨ x      ≈⟨ ∨-congˡ (sym (∧-idem _)) ⟩
  x ∨ x ∧ x  ≈⟨ ∨-absorbs-∧ _ _ ⟩
  x          ∎

∨-isMagma : IsMagma _∨_
∨-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = ∨-cong
  }

∨-isSemigroup : IsSemigroup _∨_
∨-isSemigroup = record
  { isMagma = ∨-isMagma
  ; assoc   = ∨-assoc
  }

∨-isBand : IsBand _∨_
∨-isBand = record
  { isSemigroup = ∨-isSemigroup
  ; idem        = ∨-idem
  }

∨-isSemilattice : IsSemilattice _∨_
∨-isSemilattice = record
  { isBand = ∨-isBand
  ; comm   = ∨-comm
  }

∨-semilattice : Semilattice l₁ l₂
∨-semilattice = record
  { isSemilattice = ∨-isSemilattice
  }

open SemilatticeProperties ∨-semilattice public
  using ()
  renaming
  ( ∧-isOrderTheoreticMeetSemilattice to ∨-isOrderTheoreticMeetSemilattice
  ; ∧-isOrderTheoreticJoinSemilattice to ∨-isOrderTheoreticJoinSemilattice
  ; ∧-orderTheoreticMeetSemilattice   to ∨-orderTheoreticMeetSemilattice
  ; ∧-orderTheoreticJoinSemilattice   to ∨-orderTheoreticJoinSemilattice
  )

------------------------------------------------------------------------
-- The dual construction is also a lattice.

∧-∨-isLattice : IsLattice _∧_ _∨_
∧-∨-isLattice = record
  { isEquivalence = isEquivalence
  ; ∨-comm        = ∧-comm
  ; ∨-assoc       = ∧-assoc
  ; ∨-cong        = ∧-cong
  ; ∧-comm        = ∨-comm
  ; ∧-assoc       = ∨-assoc
  ; ∧-cong        = ∨-cong
  ; absorptive    = swap absorptive
  }

∧-∨-lattice : Lattice _ _
∧-∨-lattice = record
  { isLattice = ∧-∨-isLattice
  }

------------------------------------------------------------------------
-- Every algebraic lattice can be turned into an order-theoretic one.

open SemilatticeProperties ∧-semilattice public using (poset)
open Poset poset using (_≤_; isPartialOrder)

∨-∧-isOrderTheoreticLattice : R.IsLattice _≈_ _≤_ _∨_ _∧_
∨-∧-isOrderTheoreticLattice = record
  { isPartialOrder = isPartialOrder
  ; supremum       = supremum
  ; infimum        = infimum
  }
  where
  open R.MeetSemilattice ∧-orderTheoreticMeetSemilattice using (infimum)
  open R.JoinSemilattice ∨-orderTheoreticJoinSemilattice using (x≤x∨y; y≤x∨y; ∨-least)
    renaming (_≤_ to _≤′_)

  -- An alternative but equivalent interpretation of the order _≤_.

  sound : ∀ {x y} → x ≤′ y → x ≤ y
  sound {x} {y} y≈y∨x = sym $ begin
    x ∧ y        ≈⟨ ∧-congˡ y≈y∨x ⟩
    x ∧ (y ∨ x)  ≈⟨ ∧-congˡ (∨-comm y x) ⟩
    x ∧ (x ∨ y)  ≈⟨ ∧-absorbs-∨ x y ⟩
    x            ∎

  complete : ∀ {x y} → x ≤ y → x ≤′ y
  complete {x} {y} x≈x∧y = sym $ begin
    y ∨ x        ≈⟨ ∨-congˡ x≈x∧y ⟩
    y ∨ (x ∧ y)  ≈⟨ ∨-congˡ (∧-comm x y) ⟩
    y ∨ (y ∧ x)  ≈⟨ ∨-absorbs-∧ y x ⟩
    y            ∎

  supremum : R.Supremum _≤_ _∨_
  supremum x y =
     sound (x≤x∨y x y) ,
     sound (y≤x∨y x y) ,
     λ z x≤z y≤z → sound (∨-least (complete x≤z) (complete y≤z))

∨-∧-orderTheoreticLattice : R.Lattice _ _ _
∨-∧-orderTheoreticLattice = record
  { isLattice = ∨-∧-isOrderTheoreticLattice
  }

------------------------------------------------------------------------
-- One can replace the underlying equality with an equivalent one.

replace-equality : {_≈′_ : Rel Carrier l₂} →
                   (∀ {x y} → x ≈ y ⇔ (x ≈′ y)) → Lattice _ _
replace-equality {_≈′_} ≈⇔≈′ = record
  { _≈_       = _≈′_
  ; _∧_       = _∧_
  ; _∨_       = _∨_
  ; isLattice = record
    { isEquivalence = record
      { refl  = to ⟨$⟩ refl
      ; sym   = λ x≈y → to ⟨$⟩ sym (from ⟨$⟩ x≈y)
      ; trans = λ x≈y y≈z → to ⟨$⟩ trans (from ⟨$⟩ x≈y) (from ⟨$⟩ y≈z)
      }
    ; ∨-comm     = λ x y → to ⟨$⟩ ∨-comm x y
    ; ∨-assoc    = λ x y z → to ⟨$⟩ ∨-assoc x y z
    ; ∨-cong     = λ x≈y u≈v → to ⟨$⟩ ∨-cong (from ⟨$⟩ x≈y) (from ⟨$⟩ u≈v)
    ; ∧-comm     = λ x y → to ⟨$⟩ ∧-comm x y
    ; ∧-assoc    = λ x y z → to ⟨$⟩ ∧-assoc x y z
    ; ∧-cong     = λ x≈y u≈v → to ⟨$⟩ ∧-cong (from ⟨$⟩ x≈y) (from ⟨$⟩ u≈v)
    ; absorptive = (λ x y → to ⟨$⟩ ∨-absorbs-∧ x y)
                 , (λ x y → to ⟨$⟩ ∧-absorbs-∨ x y)
    }
  } where open module E {x y} = Equivalence (≈⇔≈′ {x} {y})

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

-- Version 1.1

∧-idempotent = ∧-idem
{-# WARNING_ON_USAGE ∧-idempotent
"Warning: ∧-idempotent was deprecated in v1.1.
Please use ∧-idem instead."
#-}
∨-idempotent = ∨-idem
{-# WARNING_ON_USAGE ∨-idempotent
"Warning: ∨-idempotent was deprecated in v1.1.
Please use ∨-idem instead."
#-}
isOrderTheoreticLattice = ∨-∧-isOrderTheoreticLattice
{-# WARNING_ON_USAGE isOrderTheoreticLattice
"Warning: isOrderTheoreticLattice was deprecated in v1.1.
Please use ∨-∧-isOrderTheoreticLattice instead."
#-}
orderTheoreticLattice = ∨-∧-orderTheoreticLattice
{-# WARNING_ON_USAGE orderTheoreticLattice
"Warning: orderTheoreticLattice was deprecated in v1.1.
Please use ∨-∧-orderTheoreticLattice instead."
#-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of right-scaling
------------------------------------------------------------------------

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

open import Relation.Binary

-- The properties are parameterised by the two carriers and
-- the result equality.

module Algebra.Module.Definitions.Right
  {a b ℓb} (A : Set a) {B : Set b} (_≈_ : Rel B ℓb)
  where

open import Data.Product
open import Data.Sum

------------------------------------------------------------------------
-- Binary operations

open import Algebra.Core

------------------------------------------------------------------------
-- Properties of operations

RightIdentity : A → Opᵣ A B → Set _
RightIdentity a _∙ᴮ_ = ∀ m → (m ∙ᴮ a) ≈ m

Associative : Op₂ A → Opᵣ A B → Set _
Associative _∙ᴬ_ _∙ᴮ_ = ∀ m x y → ((m ∙ᴮ x) ∙ᴮ y) ≈ (m ∙ᴮ (x ∙ᴬ y))

_DistributesOverˡ_⟶_ : Opᵣ A B → Op₂ A → Op₂ B → Set _
_*_ DistributesOverˡ _+ᴬ_ ⟶ _+ᴮ_ =
  ∀ m x y → (m * (x +ᴬ y)) ≈ ((m * x) +ᴮ (m * y))

_DistributesOverʳ_ : Opᵣ A B → Op₂ B → Set _
_*_ DistributesOverʳ _+_ =
  ∀ x m n → ((m + n) * x) ≈ ((m * x) + (n * x))

LeftZero : B → Opᵣ A B → Set _
LeftZero z _∙_ = ∀ x → (z ∙ x) ≈ z

RightZero : A → B → Opᵣ A B → Set _
RightZero zᴬ zᴮ _∙_ = ∀ x → (x ∙ zᴬ) ≈ zᴮ

Commutative : Opᵣ A B → Set _
Commutative _∙_ = ∀ m x y → ((m ∙ x) ∙ y) ≈ ((m ∙ y) ∙ x)

LeftCongruent : ∀ {ℓa} → Rel A ℓa → Opᵣ A B → Set _
LeftCongruent ≈ᴬ _∙_ = ∀ {m} → (m ∙_) Preserves ≈ᴬ ⟶ _≈_

RightCongruent : Opᵣ A B → Set _
RightCongruent _∙_ = ∀ {x} → (_∙ x) Preserves _≈_ ⟶ _≈_

Congruent : ∀ {ℓa} → Rel A ℓa → Opᵣ A B → Set _
Congruent ≈ᴬ ∙ = ∙ Preserves₂ _≈_ ⟶ ≈ᴬ ⟶ _≈_


module Prelude where

infixr 50 _,_
infixl 40 _◄_
infix  30 _∈_

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

data List (A : Set) : Set where
  ε   : List A
  _◄_ : List A -> A -> List A

data _∈_ {A : Set}(x : A) : List A -> Set where
  hd : forall {xs}   ->           x ∈ xs ◄ x
  tl : forall {y xs} -> x ∈ xs -> x ∈ xs ◄ y

data Box {A : Set}(P : A -> Set) : List A -> Set where
  ⟨⟩  : Box P ε
  _◃_ : forall {xs x} -> Box P xs -> P x -> Box P (xs ◄ x)

_!_ : {A : Set}{P : A -> Set}{xs : List A}{x : A} ->
      Box P xs -> x ∈ xs -> P x
⟨⟩      ! ()
(_ ◃ v) ! hd   = v
(ρ ◃ _) ! tl x = ρ ! x


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

open import Categories.Category

module Categories.Category.Topos {o ℓ e} (C : Category o ℓ e) where

open import Level

open import Categories.Category.CartesianClosed C
open import Categories.Category.Complete.Finitely C
open import Categories.Diagram.Equalizer C
open import Categories.Diagram.SubobjectClassifier C

open Category C

record Topos : Set (levelOfTerm C) where
  field
    cartesianClosed     : CartesianClosed
    subobjectClassifier : SubobjectClassifier
    equalizer           : ∀ {A B} (f g : A ⇒ B) → Equalizer f g

  open CartesianClosed cartesianClosed public

  module subobjectClassifier = SubobjectClassifier subobjectClassifier

  finitelyComplete : FinitelyComplete
  finitelyComplete = record
    { cartesian = cartesian
    ; equalizer = equalizer
    }

  open FinitelyComplete finitelyComplete using (module equalizer; pullback) public


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

open import Base
open import Algebra.Groups
open import Integers

module Algebra.GroupIntegers where

_+_ : ℤ → ℤ → ℤ
O + m = m
pos O + m = succ m
pos (S n) + m = succ (pos n + m)
neg O + m = pred m
neg (S n) + m = pred (neg n + m)

-_ : ℤ → ℤ
- O = O
- (pos m) = neg m
- (neg m) = pos m

+-succ : (m n : ℤ) → succ m + n ≡ succ (m + n)
+-succ O n = refl _
+-succ (pos m) n = refl _
+-succ (neg O) n = ! (succ-pred n)
+-succ (neg (S m)) n = ! (succ-pred _)

+-pred : (m n : ℤ) → pred m + n ≡ pred (m + n)
+-pred O n = refl _
+-pred (pos O) n = ! (pred-succ n)
+-pred (pos (S m)) n = ! (pred-succ _)
+-pred (neg m) n = refl _

+-assoc : (m n p : ℤ) → (m + n) + p ≡ m + (n + p)
+-assoc O n p = refl _
+-assoc (pos O) n p = +-succ n p
+-assoc (pos (S m)) n p = +-succ (pos m + n) p ∘ map succ (+-assoc (pos m) n p)
+-assoc (neg O) n p = +-pred n p
+-assoc (neg (S m)) n p = +-pred (neg m + n) p ∘ map pred (+-assoc (neg m) n p)

O-right-unit : (m : ℤ) → m + O ≡ m
O-right-unit O = refl _
O-right-unit (pos O) = refl _
O-right-unit (pos (S m)) = map succ (O-right-unit (pos m))
O-right-unit (neg O) = refl _
O-right-unit (neg (S m)) = map pred (O-right-unit (neg m))

succ-+-right : (m n : ℤ) → succ (m + n) ≡ m + succ n
succ-+-right O n = refl _
succ-+-right (pos O) n = refl _
succ-+-right (pos (S m)) n = map succ (succ-+-right (pos m) n)
succ-+-right (neg O) n = succ-pred n ∘ ! (pred-succ n)
succ-+-right (neg (S m)) n = (succ-pred (neg m + n) ∘ ! (pred-succ (neg m + n)))
                             ∘ map pred (succ-+-right (neg m) n)

pred-+-right : (m n : ℤ) → pred (m + n) ≡ m + pred n
pred-+-right O n = refl _
pred-+-right (pos O) n = pred-succ n ∘ ! (succ-pred n)
pred-+-right (pos (S m)) n = (pred-succ (pos m + n) ∘ ! (succ-pred (pos m + n)))
                             ∘ map succ (pred-+-right (pos m) n)
pred-+-right (neg O) n = refl _
pred-+-right (neg (S m)) n = map pred (pred-+-right (neg m) n)

opp-right-inverse : (m : ℤ) → m + (- m) ≡ O
opp-right-inverse O = refl O
opp-right-inverse (pos O) = refl O
opp-right-inverse (pos (S m)) = succ-+-right (pos m) (neg (S m))
                                ∘ opp-right-inverse (pos m)
opp-right-inverse (neg O) = refl O
opp-right-inverse (neg (S m)) = pred-+-right (neg m) (pos (S m))
                                ∘ opp-right-inverse (neg m)

opp-left-inverse : (m : ℤ) → (- m) + m ≡ O
opp-left-inverse O = refl O
opp-left-inverse (pos O) = refl O
opp-left-inverse (pos (S m)) = pred-+-right (neg m) (pos (S m))
                               ∘ opp-left-inverse (pos m)
opp-left-inverse (neg O) = refl O
opp-left-inverse (neg (S m)) = succ-+-right (pos m) (neg (S m))
                               ∘ opp-left-inverse (neg m)
                 -- pred-+-right (neg m) (pos (S m)) ∘ opp-left-inverse (pos m)

ℤ-group : Group _
ℤ-group = group (pregroup
  ℤ
  _+_ O -_
  +-assoc O-right-unit (λ m → refl _) opp-right-inverse opp-left-inverse)
  ℤ-is-set


module Sets.PredicateSet.Listable where

import      Lvl
open import Data.List as List using (List)
open import Data.List.Functions renaming (_++_ to _∪ₗ_) using (singleton)
open import Data.List.Relation.Membership renaming (_∈_ to _∈ₗ_ ; _∈!_ to _∈!ₗ_) using (use ; skip)
open import Data.List.Relation.Permutation
open import Data.List.Relation.Quantification using (∀ₗᵢₛₜ ; module AllElements ; ExistsElement ; ExistsElementEquivalence ; module ExistsElementEquivalence)
open import Functional
open import Lang.Instance
open import Logic.Propositional
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Sets.PredicateSet using (PredSet ; _∈_ ; ∅ ; _∪_ ; •_)
open        Sets.PredicateSet.BoundedQuantifiers
open import Type.Properties.Singleton
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T : Type{ℓ}
private variable S S₁ S₂ : PredSet{ℓ}(T)
private variable x : T

module _ (S : PredSet{ℓ}(T)) where
  record Listable : Type{Lvl.of(T) Lvl.⊔ ℓ} where
    field
      list : List(T)
      unique : ∀ₛ(S) (_∈!ₗ list)
      restrict : ∀ₗᵢₛₜ(list)  (_∈ S)

    proof : ∀ₛ(S) (_∈ₗ list)
    proof = IsUnit.unit ∘ unique
  list = inst-fn Listable.list

private variable l l₁ l₂ l₁₂ : Listable(S)

∅-listable : Listable{ℓ = ℓ}{T = T}(∅)
Listable.list     ∅-listable = List.∅
Listable.unique   ∅-listable ()
Listable.restrict ∅-listable = AllElements.∅

singleton-listable : Listable(•_ ⦃ [≡]-equiv ⦄ x)
Listable.list     singleton-listable           = singleton _
Listable.unique   singleton-listable [≡]-intro = intro (use [≡]-intro) (\{ {ExistsElement.• x} → ExistsElementEquivalence.use})
Listable.restrict singleton-listable           = [≡]-intro AllElements.⊰ AllElements.∅

{- TODO: Will not satisfy Listable because (_++_) may yield multiples which Listable does not allow, and therefore list-[∪] below is also incorrect.
∪-listable : ⦃ Listable(S₁) ⦄ → ⦃ Listable(S₂) ⦄ → Listable(S₁ ∪ S₂)
Listable.list (∪-listable {S₁ = S₁} {S₂ = S₂}) = list(S₁) ∪ₗ list(S₂)
Listable.unique   ∪-listable = {!!}
Listable.restrict ∪-listable = {!!}-}

-- list-[∪] : ∀{Γ₁ : PredSet{ℓ₁}(Formula(P))}{Γ₂ : PredSet{ℓ₂}(Formula(P))}{l₁₂ : Listable(Γ₁ PredSet.∪ Γ₂)} → Logic.∃{Obj = Listable(Γ₁) ⨯ Listable(Γ₂)}(\(l₁ , l₂) → (list(Γ₁ PredSet.∪ Γ₂) ⦃ l₁₂ ⦄ ≡ (list Γ₁ ⦃ l₁ ⦄) ∪ (list Γ₂ ⦃ l₂ ⦄)))
postulate list-[∪] : (list(S₁ ∪ S₂) ⦃ l₁₂ ⦄ permutes (list S₁ ⦃ l₁ ⦄) ∪ₗ (list S₂ ⦃ l₂ ⦄))
postulate list-[∪·] : (list(S ∪ (•_ ⦃ [≡]-equiv ⦄ x)) ⦃ l₁₂ ⦄ permutes (list S ⦃ l ⦄) ∪ₗ singleton(x))


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

open import Sets.EquivalenceRelations
open import Setoids.Setoids
open import Groups.FreeGroup.Definition
open import Groups.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas
open import Groups.Definition
open import Decidable.Sets
open import Numbers.Naturals.Order
open import LogicalFormulae
open import Semirings.Definition
open import Groups.Lemmas

module Groups.FreeGroup.UniversalProperty {a : _} {A : Set a} (decA : DecidableSet A) where

open import Groups.FreeGroup.Word decA
open import Groups.FreeGroup.Group decA

universalPropertyFunction : {c d : _} {C : Set c} {S : Setoid {c} {d} C} {_+_ : C → C → C} (G : Group S _+_) → (f : A → C) → ReducedWord → C
universalPropertyFunction G f empty = Group.0G G
universalPropertyFunction {_+_ = _+_} G f (prependLetter (ofLetter l) w x) = (f l) + universalPropertyFunction G f w
universalPropertyFunction {_+_ = _+_} G f (prependLetter (ofInv l) w x) = (Group.inverse G (f l)) + universalPropertyFunction G f w

private
  prepLemma : {c d : _} {C : Set c} {S : Setoid {c} {d} C} {_+_ : C → C → C} → (G : Group S _+_) → (f : A → C) → (x : ReducedWord) (l : _) → Setoid._∼_ S (universalPropertyFunction G f (prepend x (ofLetter l))) ((f l) + universalPropertyFunction G f x)
  prepLemma {S = S} G f empty l = reflexive
    where
      open Setoid S
      open Equivalence eq
  prepLemma {S = S} G f (prependLetter (ofLetter x) w pr) l = reflexive
    where
      open Setoid S
      open Equivalence eq
  prepLemma {S = S} G f (prependLetter (ofInv x) w pr) l with decA l x
  ... | inl refl = transitive (symmetric identLeft) (transitive (+WellDefined (symmetric invRight) reflexive) (symmetric +Associative))
    where
      open Group G
      open Setoid S
      open Equivalence eq
  ... | inr l!=x = reflexive
    where
      open Setoid S
      open Equivalence eq

  prepLemma' : {c d : _} {C : Set c} {S : Setoid {c} {d} C} {_+_ : C → C → C} → (G : Group S _+_) → (f : A → C) → (x : ReducedWord) (l : _) → Setoid._∼_ S (universalPropertyFunction G f (prepend x (ofInv l))) (Group.inverse G (f l) + universalPropertyFunction G f x)
  prepLemma' {S = S} G f empty l = reflexive
    where
      open Setoid S
      open Equivalence eq
  prepLemma' {S = S} G f (prependLetter (ofLetter x) w pr) l with decA l x
  ... | inl refl = symmetric (transitive +Associative (transitive (+WellDefined invLeft reflexive) identLeft))
    where
      open Group G
      open Setoid S
      open Equivalence eq
  ... | inr l!=x = reflexive
    where
      open Setoid S
      open Equivalence eq
  prepLemma' {S = S} G f (prependLetter (ofInv x) w pr) l = reflexive
    where
      open Setoid S
      open Equivalence eq

  homLemma : {c d : _} {C : Set c} {S : Setoid {c} {d} C} {_+_ : C → C → C} → (G : Group S _+_) → (f : A → C) → (x y : ReducedWord) → Setoid._∼_ S (universalPropertyFunction G f (x +W y)) (universalPropertyFunction G f x + universalPropertyFunction G f y)
  homLemma {S = S} G f empty y = symmetric identLeft
    where
      open Setoid S
      open Equivalence eq
      open Group G
  homLemma {S = S} G f (prependLetter (ofLetter l) x pr) y = transitive (transitive (prepLemma G f (x +W y) l) (+WellDefined reflexive (homLemma G f x y))) (+Associative {f l})
    where
      open Setoid S
      open Equivalence eq
      open Group G
  homLemma {S = S} G f (prependLetter (ofInv l) x pr) y = transitive (transitive (prepLemma' G f (x +W y) l) (+WellDefined reflexive (homLemma G f x y))) +Associative
    where
      open Setoid S
      open Equivalence eq
      open Group G

universalPropertyHom : {c d : _} {C : Set c} {S : Setoid {c} {d} C} {_+_ : C → C → C} (G : Group S _+_) → (f : A → C) → GroupHom freeGroup G (universalPropertyFunction G f)
GroupHom.groupHom (universalPropertyHom {S = S} G f) {x} {y} = homLemma G f x y
GroupHom.wellDefined (universalPropertyHom {S = S} G f) refl = Equivalence.reflexive (Setoid.eq S)

freeEmbedding : A → ReducedWord
freeEmbedding a = prependLetter (ofLetter a) empty (wordEmpty refl)

freeEmbeddingInjective : {a b : A} → freeEmbedding a ≡ freeEmbedding b → a ≡ b
freeEmbeddingInjective {a} {b} pr = ofLetterInjective (prependLetterInjective' pr)

universalPropertyDiagram : {c d : _} {C : Set c} {S : Setoid {c} {d} C} → {_+_ : C → C → C} → (G : Group S _+_) → (f : A → C) → (x : A) → Setoid._∼_ S (f x) (universalPropertyFunction G f (freeEmbedding x))
universalPropertyDiagram {S = S} G f x = symmetric (Group.identRight G)
  where
    open Setoid S
    open Equivalence eq

universalPropertyUniqueness : {c d : _} {C : Set c} {S : Setoid {c} {d} C} → {_+_ : C → C → C} → (G : Group S _+_) → (f : A → C) → {f' : ReducedWord → C} → (GroupHom freeGroup G f') → ((x : A) → Setoid._∼_ S (f x) (f' (freeEmbedding x))) → (x : ReducedWord) → Setoid._∼_ S (f' x) (universalPropertyFunction G f x)
universalPropertyUniqueness {S = S} G f {f'} f'IsHom commutes empty = imageOfIdentityIsIdentity f'IsHom
universalPropertyUniqueness {S = S} G f {f'} f'IsHom commutes (prependLetter (ofLetter a) w pr) = transitive (transitive (GroupHom.wellDefined f'IsHom (equalityCommutative (prependValid w a pr))) (GroupHom.groupHom f'IsHom)) (+WellDefined (symmetric (commutes a)) (universalPropertyUniqueness G f f'IsHom commutes w))
  where
    open Setoid S
    open Equivalence eq
    open Group G
universalPropertyUniqueness {S = S} G f {f'} f'IsHom commutes (prependLetter (ofInv a) w pr) = transitive (transitive (GroupHom.wellDefined f'IsHom (equalityCommutative (prependValid' w a pr))) (transitive (GroupHom.groupHom f'IsHom) (+WellDefined (homRespectsInverse f'IsHom) reflexive))) (+WellDefined (symmetric (inverseWellDefined G (commutes a))) (universalPropertyUniqueness G f f'IsHom commutes w))
  where
    open Setoid S
    open Equivalence eq
    open Group G


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

module Categories.Functor.Instance.0-Truncation where

-- 0-trucation of groupoids as a functor from Groupoids to Setoids.
--
-- This is the right-adjoint of the inclusion functor from Setoids to
-- Groupoids (see Categories.Functor.Adjoint.Instance.ZeroTruncation)

import Function
open import Function.Equality using (_⟶_)
open import Relation.Binary using (Setoid)

open import Categories.Category using (Category; _[_≈_])
open import Categories.Functor hiding (id)
open import Categories.Category.Groupoid using (Groupoid)
open import Categories.Category.Instance.Groupoids using (Groupoids)
open import Categories.Category.Instance.Setoids using (Setoids)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; _≃_)

Trunc : ∀ {o ℓ e} → Functor (Groupoids o ℓ e) (Setoids o ℓ)
Trunc {o} {ℓ} {e} = record
   { F₀           = TruncSetoid
   ; F₁           = λ {G H} F → TruncMap {G} {H} F
   ; identity     = Function.id
   ; homomorphism = λ {_ _ _ F G} f → F₁ G (F₁ F f)
   ; F-resp-≈     = λ {G H} → TruncRespNI {G} {H}
   }
   where
     open Groupoid using (category)
     open Functor

     TruncSetoid : Groupoid o ℓ e → Setoid o ℓ
     TruncSetoid G = record
       { Carrier       = Obj
       ; _≈_           = _⇒_
       ; isEquivalence = record
         { refl  = id
         ; sym   = _⁻¹
         ; trans = λ f g → g ∘ f
         }
       }
       where open Groupoid G

     TruncMap : ∀ {G H} → Functor (category G) (category H) →
                TruncSetoid G ⟶ TruncSetoid H
     TruncMap F = record { _⟨$⟩_ = F₀ F ; cong  = F₁ F }

     TruncRespNI : ∀ {G H : Groupoid o ℓ e}
                   {E F : Functor (category G) (category H)} →
                   E ≃ F → Setoids o ℓ [ TruncMap {G} {H} E ≈ TruncMap {G} {H} F ]
     TruncRespNI {_} {H} {_} {F} μ {a} f = F₁ F f ∘ ⇒.η a
       where
         open Groupoid H
         open NaturalIsomorphism μ


{-

          Types Summer School 2007

                 Bertinoro
             Aug 19 - 31, 2007

                   Agda

                Ulf Norell

-}

-- Let's have a closer look at the module system

module Modules where

{-

  Importing and opening modules

-}

-- You can import a module defined in a different file.
import Nat

-- This will bring the module into scope and allows you to
-- access its contents using qualified names.
plusTwo : Nat.Nat -> Nat.Nat
plusTwo n = Nat._+_ n 2

-- To bring everything from a module into scope you can open
-- the module.
open Nat

z : Nat
z = zero

-- There's also a short-hand to import and open at the same time
open import Bool

_&&_ : Bool -> Bool -> Bool
x && y = if x then y else false

-- Sometimes it's nice to be able to control what is brought
-- into scope when you open a module. There are three modifiers
-- that affect this: using, hiding and renaming.

module DifferentWaysOfOpeningNat where

  -- nothing but Nat
  open Nat using (Nat)

  -- everything but zero
  open Nat hiding (zero)

  -- everything, but zero and suc under different names
  open Nat renaming (zero to ZZ; suc to S_S)

  two : Nat
  two = S S zero S S

  -- you can combine using or hiding with renaming, but not using
  -- with hiding (for obvious reasons).

-- To re-export something opened use the public modifier.
module A where
  open Nat public using (Nat)

N = A.Nat -- now Nat is a visible name in module A

{-

  Parameterised modules

-}

-- A very useful feature is parameterised modules.

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

infixr 40 _::_

module Sort {A : Set}(_≤_ : A -> A -> Bool) where

  insert : {n : Nat} -> A -> Vec A n -> Vec A (suc n)
  insert x [] = x :: []
  insert x (y :: ys) = if x ≤ y
                       then x :: y :: ys
                       else y :: insert x ys

  sort : {n : Nat} -> Vec A n -> Vec A n
  sort []        = []
  sort (x :: xs) = insert x (sort xs)

_≤_ : Nat -> Nat -> Bool
zero  ≤ m     = true
suc n ≤ zero  = false
suc n ≤ suc m = n ≤ m

-- When used directly, functions from parameterised modules
-- take the parameters as extra arguments.
test = Sort.sort _≤_ (6 :: 2 :: 0 :: 4 :: [])

-- But, you can also apply the entire module to its arguments.
-- Let's open the new module while we're at it.
open module SortNat = Sort _≤_

test' = sort (3 :: 2 :: 4 :: 0 :: [])

{-

  Local definitions

-}

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

subst : {A : Set}(C : A -> Set){x y : A} -> x == y -> C x -> C y
subst C refl cx = cx

cong : {A B : Set}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

lem₁ : (n : Nat) -> n + 0 == n
lem₁ zero    = refl
lem₁ (suc n) = cong suc (lem₁ n)

lem₂ : (n m : Nat) -> n + suc m == suc n + m
lem₂ n  zero   = refl
lem₂ n (suc m) = cong suc (lem₂ n m)

{-

  What's next?

-}

-- The final thing on the agenda is records.

-- Move on to: Records.agda


module Category where

open import Prelude

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

record Category {ℓ ℓ′}
                (𝒪 : Set ℓ) (_▹_ : 𝒪 → 𝒪 → Set ℓ′)
              : Set (ℓ ⊔ ℓ′) where
  field
    idₓ    : ∀ {x} → x ▹ x

    _⋄_    : ∀ {x y z} → y ▹ x → z ▹ y → z ▹ x

    lid⋄   : ∀ {x y} → (f : y ▹ x)
                     → idₓ ⋄ f ≡ f

    rid⋄   : ∀ {x y} → (f : y ▹ x)
                     → f ⋄ idₓ ≡ f

    assoc⋄ : ∀ {x y z a} → (h : a ▹ z) (g : z ▹ y) (f : y ▹ x)
                         → (f ⋄ g) ⋄ h ≡ f ⋄ (g ⋄ h)

𝗦𝗲𝘁 : (ℓ : Level) → Category (Set ℓ) Π
𝗦𝗲𝘁 ℓ =
  record
    { idₓ    = id
    ; _⋄_    = _∘_
    ; lid⋄   = λ f → refl
    ; rid⋄   = λ f → refl
    ; assoc⋄ = λ h g f → refl
    }

𝗦𝗲𝘁₀ : Category (Set ℓ₀) Π
𝗦𝗲𝘁₀ = 𝗦𝗲𝘁 ℓ₀

record Functor {ℓ₁ ℓ₁′ ℓ₂ ℓ₂′}
               {𝒪₁ : Set ℓ₁} {_▹₁_ : 𝒪₁ → 𝒪₁ → Set ℓ₁′}
               {𝒪₂ : Set ℓ₂} {_▹₂_ : 𝒪₂ → 𝒪₂ → Set ℓ₂′}
               (𝗖 : Category 𝒪₁ _▹₁_) (𝗗 : Category 𝒪₂ _▹₂_)
             : Set (ℓ₁ ⊔ ℓ₁′ ⊔ ℓ₂ ⊔ ℓ₂′) where
  private
    module C = Category 𝗖
    module D = Category 𝗗

  field
    Fₓ  : 𝒪₁ → 𝒪₂

    F   : ∀ {x y} → y ▹₁ x → Fₓ y ▹₂ Fₓ x

    idF : ∀ {x} → F (C.idₓ {x = x}) ≡ D.idₓ

    F⋄  : ∀ {x y z} → (g : z ▹₁ y) (f : y ▹₁ x)
                    → F (f C.⋄ g) ≡ F f D.⋄ F g

record NaturalTransformation {ℓ₁ ℓ₁′ ℓ₂ ℓ₂′}
                             {𝒪₁ : Set ℓ₁} {_▹₁_ : 𝒪₁ → 𝒪₁ → Set ℓ₁′}
                             {𝒪₂ : Set ℓ₂} {_▹₂_ : 𝒪₂ → 𝒪₂ → Set ℓ₂′}
                             {𝗖 : Category 𝒪₁ _▹₁_} {𝗗 : Category 𝒪₂ _▹₂_}
                             (𝗙 𝗚 : Functor 𝗖 𝗗)
                           : Set (ℓ₁ ⊔ ℓ₁′ ⊔ ℓ₂ ⊔ ℓ₂′) where
  private
    open module D = Category 𝗗 using (_⋄_)
    open module F = Functor 𝗙 using (Fₓ ; F)
    open module G = Functor 𝗚 using () renaming (Fₓ to Gₓ ; F to G)

  field
    N    : ∀ {x} → Fₓ x ▹₂ Gₓ x

    natN : ∀ {x y} → (f : y ▹₁ x)
                   → (N ⋄ F f) ≡ (G f ⋄ N)

Opposite : ∀ {ℓ ℓ′} → {𝒪 : Set ℓ} {_▹_ : 𝒪 → 𝒪 → Set ℓ′}
                    → Category 𝒪 _▹_
                    → Category 𝒪 (flip _▹_)
Opposite 𝗖 =
  record
    { idₓ    = C.idₓ
    ; _⋄_    = flip C._⋄_
    ; lid⋄   = C.rid⋄
    ; rid⋄   = C.lid⋄
    ; assoc⋄ = λ f g h → C.assoc⋄ h g f ⁻¹
    }
  where
    module C = Category 𝗖

Presheaf : ∀ ℓ {ℓ′ ℓ″} → {𝒪 : Set ℓ′} {_▹_ : 𝒪 → 𝒪 → Set ℓ″}
                       → (𝗖 : Category 𝒪 _▹_)
                       → Set _
Presheaf ℓ 𝗖 = Functor (Opposite 𝗖) (𝗦𝗲𝘁 ℓ)

Presheaf₀ : ∀ {ℓ ℓ′} → {𝒪 : Set ℓ} {_▹_ : 𝒪 → 𝒪 → Set ℓ′}
                     → (𝗖 : Category 𝒪 _▹_)
                     → Set _
Presheaf₀ 𝗖 = Presheaf ℓ₀ 𝗖

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


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

module PiU where

open import Data.Nat using (ℕ; _+_; _*_)

------------------------------------------------------------------------------
-- Define the ``universe'' for Pi.  All versions of Pi share the same
-- universe.  Where they differ is in what combinators exist between
-- members of the universe.
--
-- ZERO is a type with no elements
-- ONE is a type with one element 'tt'
-- PLUS ONE ONE is a type with elements 'false' and 'true'
-- and so on for all finite types built from ZERO, ONE, PLUS, and TIMES
--
-- We also have that U is a type with elements ZERO, ONE, PLUS ONE ONE,
--   TIMES BOOL BOOL, etc.

data U : Set where
  ZERO  : U
  ONE   : U
  PLUS  : U → U → U
  TIMES : U → U → U

-- defines the size of a finite type

toℕ : U → ℕ
toℕ ZERO = 0
toℕ ONE = 1
toℕ (PLUS t₁ t₂) = toℕ t₁ + toℕ t₂
toℕ (TIMES t₁ t₂) = toℕ t₁ * toℕ t₂

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


module Structure.Relator.Equivalence.Proofs where

import      Lvl
open import Functional
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties.Proofs
open import Type

private variable ℓ : Lvl.Level
private variable T A B : Type{ℓ}
private variable _▫_ : T → T → Type{ℓ}
private variable f : A → B

on₂-equivalence : ⦃ eq : Equivalence(_▫_) ⦄ → Equivalence((_▫_) on₂ f)
Equivalence.reflexivity  (on₂-equivalence {_▫_ = _▫_}) = on₂-reflexivity
Equivalence.symmetry     (on₂-equivalence {_▫_ = _▫_}) = on₂-symmetry
Equivalence.transitivity (on₂-equivalence {_▫_ = _▫_}) = on₂-transitivity


{-# OPTIONS --cubical --safe #-}

module Relation.Nullary.Discrete.Properties where

open import Relation.Nullary.Discrete
open import Relation.Nullary.Stable.Properties using (Stable≡→isSet)
open import Relation.Nullary.Decidable.Properties using (Dec→Stable; isPropDec)

open import HLevels
open import Level
open import Path

Discrete→isSet :
  Discrete A → isSet A
Discrete→isSet d = Stable≡→isSet (λ x y → Dec→Stable (x ≡ y) (d x y))

isPropDiscrete :
  isProp (Discrete A)
isPropDiscrete f g i x y = isPropDec (Discrete→isSet f x y) (f x y) (g x y) i


{-# OPTIONS --without-K --safe #-}
module Categories.Functor.Bifunctor where

-- Bifunctor, aka a Functor from C × D to E
open import Level

open import Categories.Category
open import Categories.Functor
open import Categories.Functor.Construction.Constant
open import Categories.Category.Product

private
  variable
    o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ : Level
    C D D₁ D₂ E E₁ E₂ : Category o ℓ e

Bifunctor : Category o ℓ e → Category o′ ℓ′ e′ → Category o″ ℓ″ e″ → Set _
Bifunctor C D E = Functor (Product C D) E

overlap-× : ∀ (H : Bifunctor D₁ D₂ C) (F : Functor E D₁) (G : Functor E D₂) → Functor E C
overlap-× H F G = H ∘F (F ※ G)

reduce-× : ∀ (H : Bifunctor D₁ D₂ C) (F : Functor E₁ D₁) (G : Functor E₂ D₂) → Bifunctor E₁ E₂ C
reduce-× H F G = H ∘F (F ⁂ G)

flip-bifunctor : Bifunctor C D E → Bifunctor D C E
flip-bifunctor b = b ∘F Swap

appˡ : Bifunctor C D E → Category.Obj C → Functor D E
appˡ F c = F ∘F constˡ c

appʳ : Bifunctor C D E → Category.Obj D → Functor C E
appʳ F d = F ∘F constʳ d


module MetaId where

  data Nat : Set where
    zero : Nat
    suc  : Nat -> Nat

  expr = (\ (a : Set) (x : a) -> x) _ zero


module Cats.Util.Logic.Classical where

open import Cats.Util.Logic.Constructive public

-- (Strong) law of the excluded middle
postulate lem : ∀ {p} (P : Set p) → P ∨ ¬ P

-- Double negation elimination
¬¬-elim : ∀ {p} {P : Set p} → ¬ ¬ P → P
¬¬-elim {P = P} ¬¬p with lem P
... | ∨-introl  p = p
... | ∨-intror ¬p = ⊥-elim (¬¬p ¬p)

-- Contrapositive
contrapositive : ∀ {p q} {P : Set p} {Q : Set q}
  → (¬ Q → ¬ P) → P → Q
contrapositive {P = P} {Q} contra p with lem Q
... | ∨-introl q = q
... | ∨-intror ¬q = ⊥-elim (contra ¬q p)

-- De Morgan's nonconstructive rule
¬∧→¬∨¬ : ∀ {p q} {P : Set p} {Q : Set q}
  → ¬ (P ∧ Q) → ¬ P ∨ ¬ Q
¬∧→¬∨¬ {P = P} {Q} ¬p∧q with lem P | lem Q
... | ∨-introl p  | ∨-introl q  = ⊥-elim (¬p∧q (p , q))
... | ∨-introl _  | ∨-intror ¬q = ∨-intror ¬q
... | ∨-intror ¬p | _           = ∨-introl ¬p

-- Negation and ∀
¬∀→∃¬ : ∀ {u p} {U : Set u} {P : U → Set p}
  → ¬ (∀ u → P u) → ∃[ u ] (¬ P u)
¬∀→∃¬ ¬∀ = ¬¬-elim (λ ¬∃¬ → ¬∀ (λ u → ¬¬-elim (λ pu → ¬∃¬ (u , pu))))


open import Level using (Level; suc; zero; _⊔_)
open import Function using (const)
open import Algebra
open import Algebra.Structures
open import Algebra.OrderedMonoid
open import Algebra.FunctionProperties as FunctionProperties using (Op₁; Op₂)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Relation.Binary
open import Relation.Binary.PartialOrderReasoning as ≤-Reasoning using ()

module Algebra.Pregroup where

-- Definition of the properties of left and right contraction and
-- expansion for usage in the below definition of pregroups.
module AdjointProperties {a ℓ} {A : Set a} (_≤_ : Rel A ℓ) (_∙_ : Op₂ A) (ε : A) where

  LeftContract : Op₁ A → Set _
  LeftContract _ˡ = ∀ x → (x ˡ ∙ x) ≤ ε

  LeftExpand : Op₁ A → Set _
  LeftExpand _ˡ = ∀ x → ε ≤ (x ∙ x ˡ)

  RightContract : Op₁ A → Set _
  RightContract _ʳ = ∀ x → (x ∙ x ʳ) ≤ ε

  RightExpand : Op₁ A → Set _
  RightExpand _ʳ = ∀ x → ε ≤ (x ʳ ∙ x)

  -- define shorthand notation for a term being the left/right adjoint
  -- of another term, which can be proven to be unique.
  _LeftAdjointOf_ : ∀ y x → Set _
  _LeftAdjointOf_ y x = (y ∙ x) ≤ ε × ε ≤ (x ∙ y)

  _RightAdjointOf_ : ∀ y x → Set _
  _RightAdjointOf_ y x = (x ∙ y) ≤ ε × ε ≤ (y ∙ x)

-- Definition of a pregroup, which adds a left and a right adjoint to
-- an ordered monoid.
record IsPregroup {a ℓ₁ ℓ₂} {A : Set a} (≈ : Rel A ℓ₁) (≤ : Rel A ℓ₂)
                  (∙ : Op₂ A) (ε : A) (ˡ : Op₁ A) (ʳ : Op₁ A) : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where

  open AdjointProperties ≤ ∙ ε
  field
    isOrderedMonoid : IsOrderedMonoid ≈ ≤ ∙ ε
    ˡ-cong          : ˡ Preserves ≈ ⟶ ≈
    ʳ-cong          : ʳ Preserves ≈ ⟶ ≈
    ˡ-contract      : LeftContract ˡ
    ˡ-expand        : LeftExpand ˡ
    ʳ-contract      : RightContract ʳ
    ʳ-expand        : RightExpand ʳ

  open IsOrderedMonoid isOrderedMonoid public
  open AdjointProperties ≤ ∙ ε public

record Pregroup c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where
  infixl 7 _∙_
  infix  4 _≈_
  infix  4 _≤_
  field
    Carrier    : Set c
    _≈_        : Rel Carrier ℓ₁
    _≤_        : Rel Carrier ℓ₂
    _∙_        : Op₂ Carrier
    _ˡ         : Op₁ Carrier
    _ʳ         : Op₁ Carrier
    ε          : Carrier
    isPregroup : IsPregroup _≈_ _≤_ _∙_ ε _ˡ _ʳ

  open IsPregroup isPregroup public

  private
    -- for usage with ≤-Reasoning
    poset : Poset c ℓ₁ ℓ₂
    poset = record { isPartialOrder = isPartialOrder }
    open ≤-Reasoning poset

    -- for usage of substitutivity (which is not defined in IsPregroup)
    orderedMonoid : OrderedMonoid _ _ _
    orderedMonoid = record { isOrderedMonoid = isOrderedMonoid }
    open OrderedMonoid orderedMonoid public using (substitutivity)

  ˡ-unique : ∀ {x y} → y LeftAdjointOf x → y ≈ x ˡ
  ˡ-unique {x} {y} (y-contract , y-expand) = antisym y≤xˡ xˡ≤y
    where
      y≤xˡ : y ≤ x ˡ
      y≤xˡ =
        begin
          y             ≈⟨ sym (proj₂ identity y) ⟩
          y ∙ ε         ≤⟨ compatibility ≤-refl (ˡ-expand x) ⟩
          y ∙ (x ∙ x ˡ) ≈⟨ sym (assoc y x (x ˡ)) ⟩
          (y ∙ x) ∙ x ˡ ≤⟨ compatibility y-contract ≤-refl ⟩
          ε ∙ x ˡ       ≈⟨ proj₁ identity (x ˡ) ⟩
          x ˡ
        ∎
      xˡ≤y : x ˡ ≤ y
      xˡ≤y =
        begin
          x ˡ             ≈⟨ sym (proj₂ identity (x ˡ)) ⟩
          x ˡ ∙ ε         ≤⟨ compatibility ≤-refl y-expand ⟩
          x ˡ ∙ (x ∙ y)   ≈⟨ sym (assoc (x ˡ) x y) ⟩
          (x ˡ  ∙ x) ∙ y  ≤⟨ compatibility (ˡ-contract x) ≤-refl ⟩
          ε ∙ y           ≈⟨ proj₁ identity y ⟩
          y
        ∎

  ʳ-unique : ∀ {x y} → y RightAdjointOf x → y ≈ x ʳ
  ʳ-unique {x} {y} (y-contract , y-expand) = antisym y≤xʳ xʳ≤y
    where
      xʳ≤y : x ʳ ≤ y
      xʳ≤y =
        begin
          x ʳ             ≈⟨ sym (proj₁ identity (x ʳ)) ⟩
          ε ∙ x ʳ         ≤⟨ compatibility y-expand ≤-refl ⟩
          (y ∙ x) ∙ x ʳ ≈⟨ assoc  y x (x ʳ) ⟩
          y ∙ (x ∙ x ʳ) ≤⟨ compatibility ≤-refl (ʳ-contract x) ⟩
          y ∙ ε         ≈⟨ proj₂ identity y ⟩
          y
        ∎
      y≤xʳ : y ≤ x ʳ
      y≤xʳ =
        begin
          y             ≈⟨ sym (proj₁ identity y) ⟩
          ε ∙ y         ≤⟨ compatibility (ʳ-expand x) ≤-refl ⟩
          (x ʳ ∙ x) ∙ y ≈⟨ assoc (x ʳ) x y ⟩
          x ʳ ∙ (x ∙ y) ≤⟨ compatibility ≤-refl y-contract ⟩
          x ʳ ∙ ε       ≈⟨ proj₂ identity (x ʳ) ⟩
          x ʳ
        ∎

  ˡ-identity : ε ˡ ≈ ε
  ˡ-identity = antisym εˡ≤ε ε≤εˡ
    where
      εˡ≤ε : ε ˡ ≤ ε
      εˡ≤ε =
        begin
          ε ˡ     ≈⟨ sym (proj₂ identity (ε ˡ)) ⟩
          ε ˡ ∙ ε ≤⟨ ˡ-contract ε ⟩
          ε
        ∎
      ε≤εˡ : ε ≤ ε ˡ
      ε≤εˡ =
        begin
          ε       ≤⟨ ˡ-expand ε ⟩
          ε ∙ ε ˡ ≈⟨ proj₁ identity (ε ˡ) ⟩
          ε ˡ
        ∎

  ʳ-identity : ε ʳ ≈ ε
  ʳ-identity = antisym εʳ≤ε ε≤εʳ
    where
      εʳ≤ε : ε ʳ ≤ ε
      εʳ≤ε =
        begin
          ε ʳ     ≈⟨ sym (proj₁ identity (ε ʳ)) ⟩
          ε ∙ ε ʳ ≤⟨ ʳ-contract ε ⟩
          ε
        ∎
      ε≤εʳ : ε ≤ ε ʳ
      ε≤εʳ =
        begin
          ε       ≤⟨ ʳ-expand ε ⟩
          ε ʳ ∙ ε ≈⟨ proj₂ identity (ε ʳ) ⟩
          ε ʳ
        ∎

  ˡ-distrib : ∀ x y → y ˡ ∙ x ˡ ≈ (x ∙ y) ˡ
  ˡ-distrib x y = ˡ-unique ([yˡxˡ][xy]≤ε , ε≤[xy][yˡxˡ])
    where
      [yˡxˡ][xy]≤ε : (y ˡ ∙ x ˡ) ∙ (x ∙ y) ≤ ε
      [yˡxˡ][xy]≤ε =
        begin
          (y ˡ ∙ x ˡ) ∙ (x ∙ y) ≈⟨ sym (assoc (y ˡ ∙ x ˡ) x y) ⟩
          ((y ˡ ∙ x ˡ) ∙ x) ∙ y ≈⟨ ∙-cong (assoc (y ˡ) (x ˡ) x) refl ⟩
          (y ˡ ∙ (x ˡ ∙ x)) ∙ y ≤⟨ compatibility (compatibility ≤-refl (ˡ-contract x)) ≤-refl ⟩
          y ˡ ∙ ε ∙ y           ≈⟨ ∙-cong (proj₂ identity (y ˡ)) refl ⟩
          y ˡ ∙ y               ≤⟨ ˡ-contract y ⟩
          ε
        ∎
      ε≤[xy][yˡxˡ] : ε ≤ (x ∙ y) ∙ (y ˡ ∙ x ˡ)
      ε≤[xy][yˡxˡ] =
        begin
          ε                     ≤⟨ ˡ-expand x ⟩
          x ∙ x ˡ               ≈⟨ ∙-cong (sym (proj₂ identity x)) refl ⟩
          x ∙ ε ∙ x ˡ           ≤⟨ compatibility (compatibility ≤-refl (ˡ-expand y)) ≤-refl ⟩
          (x ∙ (y ∙ y ˡ) ∙ x ˡ) ≈⟨ ∙-cong (sym (assoc x y (y ˡ))) refl ⟩
          ((x ∙ y) ∙ y ˡ) ∙ x ˡ ≈⟨ assoc (x ∙ y) (y ˡ) (x ˡ) ⟩
          (x ∙ y) ∙ (y ˡ ∙ x ˡ)
        ∎

  ʳ-distrib : ∀ x y → y ʳ ∙ x ʳ ≈ (x ∙ y) ʳ
  ʳ-distrib x y = ʳ-unique ([xy][yʳxʳ]≤ε , ε≤[xy][yʳxʳ])
    where
      [xy][yʳxʳ]≤ε : (x ∙ y) ∙ (y ʳ ∙ x ʳ) ≤ ε
      [xy][yʳxʳ]≤ε =
        begin
          (x ∙ y) ∙ (y ʳ ∙ x ʳ) ≈⟨ sym (assoc (x ∙ y) (y ʳ) (x ʳ)) ⟩
          ((x ∙ y) ∙ y ʳ) ∙ x ʳ ≈⟨ ∙-cong (assoc x y (y ʳ)) refl ⟩
          (x ∙ (y ∙ y ʳ) ∙ x ʳ) ≤⟨ compatibility (compatibility ≤-refl (ʳ-contract y)) ≤-refl ⟩
          x ∙ ε ∙ x ʳ           ≈⟨ ∙-cong (proj₂ identity x) refl ⟩
          x ∙ x ʳ               ≤⟨ ʳ-contract x ⟩
          ε
        ∎
      ε≤[xy][yʳxʳ] : ε ≤ (y ʳ ∙ x ʳ) ∙ (x ∙ y)
      ε≤[xy][yʳxʳ] =
        begin
          ε                     ≤⟨ ʳ-expand y ⟩
          y ʳ ∙ y               ≈⟨ ∙-cong refl (sym (proj₁ identity y)) ⟩
          y ʳ ∙ (ε ∙ y)         ≤⟨ compatibility ≤-refl (compatibility (ʳ-expand x) ≤-refl) ⟩
          y ʳ ∙ ((x ʳ ∙ x) ∙ y) ≈⟨ ∙-cong refl (assoc (x ʳ) x y) ⟩
          y ʳ ∙ (x ʳ ∙ (x ∙ y)) ≈⟨ sym (assoc (y ʳ) (x ʳ) (x ∙ y)) ⟩
          (y ʳ ∙ x ʳ) ∙ (x ∙ y)
        ∎

  ˡ-contra : ∀ {x y} → x ≤ y → y ˡ ≤ x ˡ
  ˡ-contra {x} {y} x≤y =
    begin
      y ˡ             ≈⟨ sym (proj₂ identity (y ˡ)) ⟩
      y ˡ ∙ ε         ≤⟨ compatibility ≤-refl (ˡ-expand x) ⟩
      y ˡ ∙ (x ∙ x ˡ) ≈⟨ sym (assoc (y ˡ) x (x ˡ)) ⟩
      (y ˡ ∙ x) ∙ x ˡ ≤⟨ substitutivity x≤y ⟩
      (y ˡ ∙ y) ∙ x ˡ ≤⟨ compatibility (ˡ-contract y) ≤-refl ⟩
      ε ∙ x ˡ         ≈⟨ proj₁ identity (x ˡ) ⟩
      x ˡ
    ∎

  ʳ-contra : ∀ {x y} → x ≤ y → y ʳ ≤ x ʳ
  ʳ-contra {x} {y} x≤y =
    begin
      y ʳ             ≈⟨ sym (proj₁ identity (y ʳ)) ⟩
      ε ∙ y ʳ         ≤⟨ compatibility (ʳ-expand x) ≤-refl ⟩
      (x ʳ ∙ x) ∙ y ʳ ≤⟨ substitutivity x≤y ⟩
      (x ʳ ∙ y) ∙ y ʳ ≈⟨ assoc (x ʳ) y (y ʳ) ⟩
      x ʳ ∙ (y ∙ y ʳ) ≤⟨ compatibility ≤-refl (ʳ-contract y) ⟩
      x ʳ ∙ ε         ≈⟨ proj₂ identity (x ʳ) ⟩
      x ʳ
    ∎

  ʳˡ-cancel : ∀ x → x ʳ ˡ ≈ x
  ʳˡ-cancel x = sym (ˡ-unique (ʳ-contract x , ʳ-expand x))

  ˡʳ-cancel : ∀ x → x ˡ ʳ ≈ x
  ˡʳ-cancel x = sym (ʳ-unique (ˡ-contract x , ˡ-expand x))


module Section1 where

-- 1. Introduction
-- ===============
--
-- 1.1. Outline of the formalisation
-- ---------------------------------
--
-- -   We formalize terms-in-context, `Γ ⊢ t ∷ A`, as a calculus of proof trees, `Γ ⊢ A`, for
--     implicational logic, i.e., term `t` is seen as a proof tree that derives `A` from the assumptions
--     contained in `Γ`.  A notion of equivalence of terms-in-context (including, e.g., β-reduction
--     and η-conversion) is then defined with a conversion relation `_≅_` on these proof trees.
--
-- -   We give a Kripke model with an ordered set of worlds and define when a proposition `A` is
--     true for a world `w` in the model, `w ⊩ A`.  We also define an extensional equality between
--     objects in the model.
--
-- -   We define an interpreter `⟦_⟧` that maps a proof tree in the theory to its semantics in the
--     Kripke model.  According to the Curry-Howard correspondence of programs to proofs
--     and types to propositions, the type of the interpreter expresses soundness of the theory of
--     proof trees with respect to the Kripke model.  Consequently, the interpreter can be seen
--     as a constructive soundness proof.
--
-- -   We also define an inversion function, `reify`, which returns a proof tre corresponding to
--     a given semantic object, yielding—again by the Curry-Howard isomorphism—a
--     completeness proof.
--
--     The inversion function is based on the principle of normalization by evaluation [3].
--     Obviously, for proof trees `M` and `N` with the same semantics, inversion yields the same proof
--     tree `reify ⟦ M ⟧ = reify ⟦ N ⟧`.  Consequently, we define a normalization function, `nf`, as
--     the composition of the interpreter and the inversion function.  We prove that if `M` is a proof
--     tree, then `M ≅ nf M`; together with the soundness result, this yields a decision algorithm
--     for convertibility.  We further show that `nf` returns a proof term in long η-normal form.
--
-- -   We prove that the convertibility relation on proof trees is sound and complete.  The proof
--     of soundness, i.e., convertible proof trees have the same semantics, is straightforward by
--     induction on the structure of the trees.  The completeness proof, i.e., if `⟦ M ⟧` and `⟦ N ⟧` are
--     equal, then `M` and `N` are convertible, uses the fact that `reify ⟦ M ⟧` is exactly the same as
--     `reify ⟦ N ⟧`, and since `M ≅ nf M ≡ reify ⟦ M ⟧` and vice versa for `N`, we get that `M ≅ N`.
--
-- -   We define a calculus of simply typed ƛterms, a typed convertibility relation on the terms,
--     and a deterministic reduction, `_⇓_`.  We also define an erasure function on proof trees that
--     maps a proof tree `M` into a well-typed term `M ⁻`.  For every well-typed term there is at
--     least one proof tree that erases to this term; for defining the semantics of well-typed terms
--     through that of proof trees, it suffices to show that all proof trees that erase to the same
--     well-typed term have the same semantics.
--
-- -   Because we know that convertible proof trees have the same semantics, it remains to
--     show that all proof trees that erase to a given well-typed term are convertible.  We use an
--     argument due to Streicher [19]: we first prove that if `nf M ⁻` and `nf N ⁻` are the same,
--     then `M ≅ N`.  Secondly, we prove that if a proof tree `M` erases to a well-typed term `t`,
--     then `t ⇓ nf M ⁻`.  Now, if two proof trees `M` and `N` erase to the same well-typed term
--     `t`, then `t ⇓ nf M ⁻` and `t ⇓ nf N ⁻`.  Since the reduction is deterministic we have that
--     `nf M ⁻` and `nf N ⁻` are the same, and hence `M ≅ N`.
--
-- -   We prove that the convertibility relation on proof trees is sound and complete, and give
--     a decision algorithm for checking convertibility of two well-typed terms.
--
-- (…)

open import Agda.Builtin.FromString public
  using (IsString ; fromString)

open import Data.Bool public
  using (Bool ; T ; true ; false ; not)
  renaming (_∧_ to and)

open import Data.Empty public
  using (⊥)
  renaming (⊥-elim to elim⊥)

open import Data.Product public
  using (Σ ; _,_ ; _×_ ; proj₁ ; proj₂)

open import Data.Unit public
  using (⊤ ; tt)

import Data.String as Str
open Str
  using (String)

open import Function public
  using (_∘_ ; case_of_ ; flip ; id)

open import Relation.Binary.PropositionalEquality public
  using (_≡_ ; _≢_ ; refl ; cong ; subst ; sym ; trans)
  renaming (cong₂ to cong²)

open import Relation.Nullary public
  using (¬_ ; Dec ; yes ; no)

import Relation.Nullary.Decidable as Decidable
open Decidable using (⌊_⌋) public

open import Relation.Nullary.Negation public
  renaming (contradiction to _↯_)

module _ where
  data Name : Set where
    name : String → Name

  module _ where
    inj-name : ∀ {s s′} → name s ≡ name s′ → s ≡ s′
    inj-name refl = refl

    _≟_ : (x x′ : Name) → Dec (x ≡ x′)
    name s ≟ name s′ = Decidable.map′ (cong name) inj-name (s Str.≟ s′)

    _≠_ : Name → Name → Bool
    x ≠ x′ = not ⌊ x ≟ x′ ⌋

  instance
    str-Name : IsString Name
    str-Name = record
      { Constraint = λ s → ⊤
      ; fromString = λ s → name s
      }

module _ where
  record Raiseable
      {World : Set}
      (_⊩◌  : World → Set)
      {_⊒_   : World → World → Set} : Set₁ where
    field
      ↑⟨_⟩  : ∀ {w w′} → w′ ⊒ w → w ⊩◌ → w′ ⊩◌
  open Raiseable {{…}} public

  record Lowerable
      {World : Set}
      (◌⊩_  : World → Set)
      {_⊒_   : World → World → Set} : Set₁ where
    field
      ↓⟨_⟩  : ∀ {w w′} → w′ ⊒ w → ◌⊩ w′ → ◌⊩ w
  open Lowerable {{…}} public