---------------------------------------------------------------------
-- This file contains the definition of heterogenous equality and  --
-- related facts.  A lot of this code is old, and could be written --
-- better.   This equality is mainly used for object equivalence.  --
--                                                                 --
-- Some of it came from the paper:                                 --
--   "Monads Need Not Be Endofunctors" by Altenkirch et al.        --
--                                                                 --
-- See: http://www.cs.nott.ac.uk/~txa/publ/Relative_Monads.pdf     --
---------------------------------------------------------------------

module Equality.Eq where

open import Level

open import Relation.Relation

open import Relation.Binary.PropositionalEquality public renaming (sym to prop-sym ; trans to prop-trans; refl to prop-refl)

data _≅_ {l : Level} {A : Set l} (a : A) : {A' : Set l} → A' → Set l where
  refl : a ≅ a

postulate ext : ∀{i j}{A : Set i}{B B' : A → Set j}{f : ∀ a → B a}{g : ∀ a → B' a} →
                (∀ a → f a ≅ g a) → f ≅ g

postulate prop-ext : ∀{i j}{A : Set i}{B : A → Set j}{f : ∀ a → B a}{g : ∀ a → B a} →
                (∀ a → f a ≡ g a) → f ≡ g

≅-to-≡ : ∀{l : Level}{A : Set l}{a b : A} → a ≅ b → a ≡ b
≅-to-≡ refl = prop-refl

-- this could just be derived from ext
postulate iext : ∀{i j}{A : Set i}{B B' : A → Set j}{f : ∀ {a} → B a}{g : ∀{a} → B' a} →
                 (∀ a → f {a} ≅ g {a}) →
                 _≅_ {_}{ {a : A} → B a} f { {a : A} → B' a} g

sym : ∀{l : Level}{A : Set l }{a b : A} → a ≅ b → b ≅ a
sym refl = refl

trans : ∀{l : Level}{A : Set l}{a b c : A} → a ≅ b → b ≅ c → a ≅ c
trans refl refl = refl

isEqRel : ∀{l : Level}{A : Set l} → EqRel {A = A}  (λ x y → x ≅ y)
isEqRel {l} {A} = record { parEqPf = record { symPf = sym; transPf = trans }; refPf = refl }

ir : ∀{l : Level}{A A' : Set l}{a : A}{a' : A'}{p q : a ≅ a'} → p ≅ q
ir {p = refl}{q = refl} = refl

eqApp : ∀{l l' : Level}{A : Set l}{B : Set l'}{f : A → B}{b c : A} → b ≅ c → (f b) ≅ (f c)
eqApp refl = refl

subst≅ : {l l' : Level}{A : Set l}{a b : A}{P : A → Set l'} → a ≅ b → P a → P b
subst≅ refl x = x

-- Cite from relative monads paper.
deqApp : ∀{l : Level}{A : Set l}{B : A → Set l}(f : ∀ a → B a){a a' : A}
  → a ≅ a' → f a ≅ f a'
deqApp f refl = refl

feqApp : ∀{l l' : Level}{A : Set l}{B : Set l'}{f f' : A → B}{b c : A} → f ≅ f' → b ≅ c → (f b) ≅ (f' c)
feqApp refl refl = refl

ifeqApp : ∀{i j}{A : Set i}{B : A → Set j}{f f' : {x : A} → B x}(a : A) → _≅_ {_}{ {a : A} → B a} f { {a : A} → B a} f' → f {a} ≅ f' {a}
ifeqApp a refl = refl

ieqApp : ∀{x y}{A : Set x}{B : A → Set y}(f : ∀ {a} → B a){a a' : A} → a ≅ a' → f {a} ≅ f {a'}
ieqApp f refl = refl

-- Cite from relative monads paper.
eqApp2 : ∀{i j k}{A : Set i}{B : A → Set j}{C : Set k}{a a' : A} → a ≅ a' → {b : B a}{b' : B a'} → b ≅ b' →
            (f : (a : A) → B a → C) → f a b ≅ f a' b'
eqApp2 refl refl f = refl

eqApp3 : ∀{x y z w}{A : Set x}{B : A → Set y}{C : (a : A) → B a → Set z}{E : Set w}
             (f : (a : A)(b : B a)(c : C a b) → E) →
             {a a' : A} → a ≅ a' →
             {b : B a}{b' : B a'} → b ≅ b' →
             {c : C a b}{c' : C a' b'} → c ≅ c' →
             f a b c ≅ f a' b' c'
eqApp3 f refl refl refl = refl

depfeqApp3a : ∀{l}{A : Set l}{B : Set (suc l)}{C : A → Set (suc l)}{D : Set (suc l)}
        (f  : (x : A)(y : B)(z : C x) → D) →
        (f' : (x : A)(y : B)(z : C x) → D) →
        f ≅ f' →
        {a : A}{b : B} {c : C a} →
        f a b c ≅ f' a b c
depfeqApp3a {_}{A}{B}{C} f f' p {a}{b}{c} =
        feqApp {f = f a b} {f' = f' a b} (feqApp {f = f a} {f' = f' a} (eqApp {f = λ h → h a} p) refl) refl

depfeqApp3b : ∀{l}{A : Set l}{B : A → Set (suc l)}{C : A → Set (suc l)}{D : Set (suc l)}
        (f  : (x : A)(y : B x)(z : C x) → D) →
        (f' : (x : A)(y : B x)(z : C x) → D) →
        f ≅ f' →
        {a : A}{b : B a} {c : C a} →
        f a b c ≅ f' a b c
depfeqApp3b {_}{A}{B}{C} f f' p {a}{b}{c} =
        feqApp {f = f a b} {f' = f' a b} (feqApp {f = f a} {f' = f' a} (eqApp {f = λ h → h a} p) refl) refl

depfeqApp3c : ∀{l}{A : Set l}{B : A → A → Set (suc l)}{C : A → Set (suc l)}{D : Set (suc l)}
        (f  : (x : A)(y : B x x)(z : C x) → D) →
        (f' : (x : A)(y : B x x)(z : C x) → D) →
        f ≅ f' →
        {a : A}{b : B a a} {c : C a} →
        f a b c ≅ f' a b c
depfeqApp3c {_}{A}{B}{C} f f' p {a}{b}{c} =
            feqApp {f = f a b} {f' = f' a b} (feqApp {f = f a} {f' = f' a} (eqApp {f = λ h → h a} p) refl) refl

depfeqApp3d : ∀{l}{A : Set l}{B : A → A → Set (suc l)}{C : A → A → Set (suc l)}{D : Set (suc l)}
        (f  : (x : A)(y : B x x)(z : C x x) → D) →
        (f' : (x : A)(y : B x x)(z : C x x) → D) →
        f ≅ f' →
        {a : A}{b : B a a} {c : C a a} →
        f a b c ≅ f' a b c
depfeqApp3d {_}{A}{B}{C} f f' p {a}{b}{c} =
            feqApp {f = f a b} {f' = f' a b} (feqApp {f = f a} {f' = f' a} (eqApp {f = λ h → h a} p) refl) refl

depfeqApp3e : ∀{l}{A : Set l}{B : Set (suc l)}{C : A → A → Set (suc l)}{D : Set (suc l)}
        (f  : (x : A)(y : B)(z : C x x) → D) →
        (f' : (x : A)(y : B)(z : C x x) → D) →
        f ≅ f' →
        {a : A}{b : B} {c : C a a} →
        f a b c ≅ f' a b c
depfeqApp3e {_}{A}{B}{C} f f' p {a}{b}{c} =
            feqApp {f = f a b} {f' = f' a b} (feqApp {f = f a} {f' = f' a} (eqApp {f = λ h → h a} p) refl) refl

depfeqAppa : ∀{l l' l'' l'''}{A : Set l}{B : Set l'}{C : A → B → Set l''}{D : A → B → Set  l'''}{a : A}
        (f  : (x : A)(y : B)(z : C x y) → D x y) →
        (f' : (x : A)(y : B)(z : C x y) → D x y) →
        f ≅ f' →
        f a ≅ f' a
depfeqAppa {l}{l'}{l''}{l'''}{A}{B}{C}{D}{a} f f' p = eqApp {f = λ h → h a} p

depfeqApp2a : ∀{l l' l'' l'''}{A : Set l}{B : Set  l'}{C : A → B → Set  l''}{D : A → B → Set l'''}{a : A}
        (f  : (y : B)(z : C a y) → D a y) →
        (f' : (y : B)(z : C a y) → D a y) →
        f ≅ f' →
        {b : B} {c : C a b} →
        f b c ≅ f' b c
depfeqApp2a f f' p {b} {c} = feqApp {f = f b} {f' = f' b} (eqApp {f = λ h → h b} p) refl

depfeqApp3f : ∀{l l' l'' l'''}{A : Set l}{B : Set l'}{C : A → B → Set l''}{D : A → B → Set l'''}
        (f  : (x : A)(y : B)(z : C x y) → D x y) →
        (f' : (x : A)(y : B)(z : C x y) → D x y) →
        f ≅ f' →
        {a : A}{b : B} {c : C a b} →
        f a b c ≅ f' a b c
depfeqApp3f {_}{_}{_}{_}{A}{B}{C}{D} f f' p {a}{b}{c} =
                         depfeqApp2a {A = A} {B = B}{C = λ o1 o2 → C o1 o2}
                           {D = λ o1₁ o2₁ → D o1₁ o2₁} (f a) (f' a) (eqApp {f = λ h → h a} p) {b} {c}

depfeqApp3g : ∀{l l' l'' l'''}{A : Set l}{B : Set l'}{C : A → B → Set l''}{D D' : A → B → Set l'''}
        (f  : (x : A)(y : B)(z : C x y) → D x y) →
        (f' : (x : A)(y : B)(z : C x y) → D' x y) →
        D ≅ D' →
        f ≅ f' →
        {a : A}{b : B} {c : C a b} →
        f a b c ≅ f' a b c
depfeqApp3g {_}{_}{_}{_}{A}{B}{C}{D} f f' refl p {a}{b}{c} =
                         depfeqApp2a {A = A} {B = B} {C = λ o1₁ o2₁ → C o1₁ o2₁} {D = λ o1 o2 → D o1 o2} (f a) (f' a) (eqApp {f = λ h → h a} p) {b} {c}

idepfeqApp2a : ∀{l l' l'' l''' l''''}{A : Set l}{B : Set  l'}{C : Set l''}{D : A → B → C → Set  l'''}{E : A → B → C → Set l''''}{a : A}
        (f  : {x : B}{y : C}(z : D a x y) → E a x y) →
        (f' : {x : B}{y : C}(z : D a x y) → E a x y) →
        (∀{x y} → f {x}{y}  ≅ f' {x}{y}) →
        {b : B}{c : C}{m : D a b c} →
        f {b}{c} m ≅ f' {b} {c} m
idepfeqApp2a {l}{l'}{l''}{l'''}{l''''}{A}{B}{C}{D}{E}{a} f f' p {b}{c}{m} =
             feqApp {f = f {b} {c}} {f' = f' {b} {c}} {m} {m} (ext (λ h → feqApp {f = f {b} {c}} {f' = f' {b} {c}} {h} {h} (p {b}{c}) refl)) refl

depfeqApp2b : ∀{l l' l''}{A : Set l}{D : A → A → Set l'}{E E' : A → A → Set l''}
        (f  : (x : A)(y : A)(z : A) → (m1 : D y z) → (m2 : D x y) → E x z) →
        {f'  : (x : A)(y : A)(z : A) → (m1 : D y z) → (m2 : D x y) → E' x z} →
        E ≅ E' →
        f ≅ f' →
        {a a' b b' c c' : A}{m1 : D b c}{m2 : D a b}{m1' : D  b' c'}{m2' : D a' b'} →
        a ≅ a' → b ≅ b' → c ≅ c' → m1 ≅ m1' → m2 ≅ m2' →
        f a b c m1 m2 ≅ f' a' b' c' m1' m2'
depfeqApp2b {_}{_}{_}{A}{D}{E} f refl refl {a = a}{b = b}{c = c}{m1 = m1}{m2 = m2}  refl refl refl refl refl =
  eqApp {f = f a b c m1} {m2}{m2} refl

feqApp3 : ∀{l}{A : Set l}{B : A → Set (suc l)}{C : A → Set (suc l)}{D : Set (suc l)}
        (f  : (x : A)(y : B x)(z : C x) → D) →
        (f' : (x : A)(y : B x)(z : C x) → D) →
        f ≅ f' →
        {a : A}{b : B a} {c : C a} →
        f a b c ≅ f' a b c
feqApp3 {_}{A}{B}{C} f f' p {a}{b}{c} =
        feqApp {f = f a b} {f' = f' a b} (feqApp {f = f a} {f' = f' a} (eqApp {f = λ h → h a} p) refl) refl

coerce : ∀{l}{A B : Set l} → A ≅ B → A → B
coerce refl a = a

p : ∀{m}{A B : Set m}{a : A}{b : B} → (q : B ≅ A) → _≅_ {m} {A} a {A} (coerce q b) → _≅_ {m} {A} a {B} b
p refl refl = refl

eqApp4 : ∀{x y z v w}{A : Set x}{B : A → Set y}{C : (a : A) → B a → Set z}{D : (a : A)(b : B a) → C a b  → Set v}{E : Set w}
             (f : (a : A)(b : B a)(c : C a b) → D a b c → E) →
             {a a' : A} → a ≅ a' →
             {b : B a}{b' : B a'} → b ≅ b' →
             {c : C a b}{c' : C a' b'} → c ≅ c' →
             {d : D a b c}{d' : D a' b' c'} → d ≅ d' →
             f a b c d ≅ f a' b' c' d'
eqApp4 f refl refl refl refl = refl

funCong : ∀{l m : Level}{A : Set l}{B : Set m}{f g : A → B}{a : A}{b : B}
  → (p : f ≅ g) → (q : f a ≅ b)
  → (w : g a ≅ b) → q ≅ w
funCong refl q w = ir

funCong2 : ∀{l : Level}{A B B' X Y : Set l}{f : ∀{X Y} → A → B}{g : ∀{X Y} → A → B'}{a : A}{b : B}
  → (r : B ≅ B') → (p : (λ {X}{Y} → f {X}{Y}) ≅ (λ {X}{Y} → g {X}{Y})) → (q : f {X}{Y} a ≅ b)
  → (w : g {X}{Y} a ≅ b) → q ≅ w
funCong2 refl refl q w = ir

fixtypes : ∀{x}{A A' : Set x}{a a' : A}{a'' a''' : A'}{p : a ≅ a'}{q : a'' ≅ a'''} → a ≅ a'' → a' ≅ a''' → p ≅ q
fixtypes refl refl = ir


------------------------------------------------------------------------
-- The Agda standard library
--
-- A solver for proving that one list is a sublist of the other.
------------------------------------------------------------------------

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

open import Relation.Binary using (DecSetoid)

module Data.List.Relation.Binary.Sublist.DecSetoid.Solver {c ℓ} (S : DecSetoid c ℓ) where

open DecSetoid S

open import Data.List.Relation.Binary.Sublist.Heterogeneous.Solver _≈_ refl _≟_
  using (Item; module Item; TList; module TList; prove) public


module MultipleIdentifiersOneSignature where

data Bool : Set where
  false true : Bool

data Suit : Set where
  ♥ ♢ ♠ ♣ : Suit

record R : Set₁ where
  field
    A B C : Set

postulate
  A Char : Set
  B C    : Set

{-# BUILTIN CHAR  Char  #-}
{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

primitive
  primIsDigit primIsSpace : Char → Bool


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Everything where

open import Cubical.Data.BinNat public
open import Cubical.Data.Bool public
open import Cubical.Data.Empty public
open import Cubical.Data.Fin public
open import Cubical.Data.Nat public
open import Cubical.Data.Int public renaming (_+_ to _+Int_ ; +-assoc to +Int-assoc; +-comm to +Int-comm)
open import Cubical.Data.Sum public
open import Cubical.Data.Prod public
open import Cubical.Data.Unit public
open import Cubical.Data.Sigma public
open import Cubical.Data.DiffInt public
open import Cubical.Data.Group public hiding (_≃_)
open import Cubical.Data.HomotopyGroup public
open import Cubical.Data.List public
open import Cubical.Data.Graph public


module _ where

infixr 5 _⇒_
infixl 6 _▻_
infix  3 _⊢_ _∈_
infixr 5 vs_
infixr 4 ƛ_
infixl 6 _·_

data Type : Set where
  ι   : Type
  _⇒_ : Type → Type → Type

data Con : Set where
  ε   : Con
  _▻_ : Con → Type → Con

data _∈_ σ : Con → Set where
  vz  : ∀ {Γ}   → σ ∈ Γ ▻ σ
  vs_ : ∀ {Γ τ} → σ ∈ Γ     → σ ∈ Γ ▻ τ

data _⊢_ Γ : Type → Set where
  var : ∀ {σ}   → σ ∈ Γ     → Γ ⊢ σ
  ƛ_  : ∀ {σ τ} → Γ ▻ σ ⊢ τ → Γ ⊢ σ ⇒ τ
  _·_ : ∀ {σ τ} → Γ ⊢ σ ⇒ τ → Γ ⊢ σ     → Γ ⊢ τ

Term : Type → Set
Term σ = ε ⊢ σ

postulate
  _extends_ : Con → Con → Set

  instance
    extends-stop : ∀ {Γ} → Γ extends Γ
    extends-skip : ∀ {Γ Δ σ} {{_ : Δ extends Γ}} → (Δ ▻ σ) extends Γ

  lam : ∀ {Γ σ τ} → ((∀ {Δ} {{_ : Δ extends (Γ ▻ σ)}} → Δ ⊢ σ) → Γ ▻ σ ⊢ τ) → Γ ⊢ σ ⇒ τ

I : Term (ι ⇒ ι)
I = lam λ x → x

K : Term (ι ⇒ ι ⇒ ι)
K = lam λ x → lam λ y → x

A : Term ((ι ⇒ ι) ⇒ ι ⇒ ι)
A = lam λ f → lam λ x → f {{extends-skip {{extends-stop}}}} · x
                            {{extends-stop}}

loop : Term ((ι ⇒ ι) ⇒ ι ⇒ ι)
loop = lam λ f → lam λ x → f · x


{-# OPTIONS --verbose=10 #-}

module lemmas where

  open import Data.Nat
  import Relation.Binary.PropositionalEquality as Eq
  open Eq using (_≡_; refl; trans; sym; cong; cong-app; subst)

  +-suc : (n₁ n₂ : ℕ) -> (n₁ + (1 + n₂)) ≡ (1 + (n₁ + n₂))
  +-suc zero n2 = refl
  +-suc (suc n1) n2 rewrite +-suc n1 n2 = refl


module examplesPaperJFP.triangleRightOperator where

_▹_    :  ∀{A B : Set} → A → (A → B) → B
a ▹ f  =  f a


module LRTree {A : Set} where

open import Data.List

data Tag : Set where
  left : Tag
  right : Tag

data LRTree : Set where
  empty : LRTree
  leaf : A → LRTree
  node : Tag → LRTree → LRTree → LRTree

insert : A → LRTree → LRTree
insert x empty = leaf x
insert x (leaf y) = node left (leaf y) (leaf x)
insert x (node left l r) = node right (insert x l) r
insert x (node right l r) = node left l (insert x r)

flatten : LRTree → List A
flatten empty = []
flatten (leaf x) = x ∷ []
flatten (node _ l r) = flatten l ++ flatten r


-- Andreas, 2011-04-14
module UnificationUndecidedForNonStronglyRigidOccurrence where

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

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

i : (f : Nat -> Nat)(n : Nat) -> n ≡ f n -> Nat
i f n ()
-- this should fail, since n ≡ f n is not always empty, only in case of f=suc
-- thus, an occurrence does not always mean no match, only strict occurrences
-- mean that.


------------------------------------------------------------------------
-- The Agda standard library
--
-- A Categorical view of the Sum type (Left-biased)
------------------------------------------------------------------------

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

open import Level

module Data.Sum.Categorical.Left {a} (A : Set a) (b : Level) where

open import Data.Sum
open import Category.Functor
open import Category.Applicative
open import Category.Monad
import Function.Identity.Categorical as Id
open import Function

-- To minimize the universe level of the RawFunctor, we require that elements of
-- B are "lifted" to a copy of B at a higher universe level (a ⊔ b). See the
-- examples for how this is done.

------------------------------------------------------------------------
-- Left-biased monad instance for _⊎_

Sumₗ : Set (a ⊔ b) → Set (a ⊔ b)
Sumₗ B = A ⊎ B

functor : RawFunctor Sumₗ
functor = record { _<$>_ = map₂ }

applicative : RawApplicative Sumₗ
applicative = record
  { pure = inj₂
  ; _⊛_ = [ const ∘ inj₁ , map₂ ]′
  }

-- The monad instance also requires some mucking about with universe levels.
monadT : RawMonadT (_∘′ Sumₗ)
monadT M = record
  { return = M.pure ∘ inj₂
  ; _>>=_  = λ ma f → ma M.>>= [ M.pure ∘′ inj₁ , f ]′
  } where module M = RawMonad M

monad : RawMonad Sumₗ
monad = monadT Id.monad

------------------------------------------------------------------------
-- Get access to other monadic functions

module _ {F} (App : RawApplicative {a ⊔ b} F) where

  open RawApplicative App

  sequenceA : ∀ {A} → Sumₗ (F A) → F (Sumₗ A)
  sequenceA (inj₁ a) = pure (inj₁ a)
  sequenceA (inj₂ x) = inj₂ <$> x

  mapA : ∀ {A B} → (A → F B) → Sumₗ A → F (Sumₗ B)
  mapA f = sequenceA ∘ map₂ f

  forA : ∀ {A B} → Sumₗ A → (A → F B) → F (Sumₗ B)
  forA = flip mapA

module _ {M} (Mon : RawMonad {a ⊔ b} M) where

  private App = RawMonad.rawIApplicative Mon

  sequenceM : ∀ {A} → Sumₗ (M A) → M (Sumₗ A)
  sequenceM = sequenceA App

  mapM : ∀ {A B} → (A → M B) → Sumₗ A → M (Sumₗ B)
  mapM = mapA App

  forM : ∀ {A B} → Sumₗ A → (A → M B) → M (Sumₗ B)
  forM = forA App


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

open import Base

module Homotopy.Skeleton where

private
  module Graveyard {i} {A B : Set i} {f : A → B} where
    private
      data #skeleton₁ : Set i where
        #point : A → #skeleton₁

    skeleton₁ : Set i
    skeleton₁ = #skeleton₁

    point : A → skeleton₁
    point = #point

    postulate  -- HIT
      link : ∀ a₁ a₂ → f a₁ ≡ f a₂ → point a₁ ≡ point a₂

    skeleton₁-rec : ∀ {l} (P : skeleton₁ → Set l)
      (point* : ∀ a → P (point a))
      (link* : ∀ a₁ a₂ (p : f a₁ ≡ f a₂)
        → transport P (link a₁ a₂ p) (point* a₁) ≡ point* a₂)
      → (x : skeleton₁) → P x
    skeleton₁-rec P point* link* (#point a) = point* a

    postulate  -- HIT
      skeleton₁-β-link : ∀ {l} (P : skeleton₁ → Set l)
        (point* : ∀ a → P (point a))
        (link* : ∀ a₁ a₂ (p : f a₁ ≡ f a₂)
          → transport P (link a₁ a₂ p) (point* a₁) ≡ point* a₂)
        a₁ a₂ (p : f a₁ ≡ f a₂)
        → apd (skeleton₁-rec {l} P point* link*) (link a₁ a₂ p)
        ≡ link* a₁ a₂ p

    skeleton₁-rec-nondep : ∀ {l} (P : Set l) (point* : A → P)
      (link* : ∀ a₁ a₂ → f a₁ ≡ f a₂ → point* a₁ ≡ point* a₂)
      → (skeleton₁ → P)
    skeleton₁-rec-nondep P point* link* (#point a) = point* a

    postulate  -- HIT
      skeleton₁-β-link-nondep : ∀ {l} (P : Set l) (point* : A → P)
        (link* : ∀ a₁ a₂ → f a₁ ≡ f a₂ → point* a₁ ≡ point* a₂)
        a₁ a₂ (p : f a₁ ≡ f a₂)
        → ap (skeleton₁-rec-nondep P point* link*) (link a₁ a₂ p)
        ≡ link* a₁ a₂ p

open Graveyard public hiding (skeleton₁)

module _ {i} {A B : Set i} where
  skeleton₁ : (A → B) → Set i
  skeleton₁ f = Graveyard.skeleton₁ {i} {A} {B} {f}

  skeleton₁-lifted : ∀ {f} → skeleton₁ f → B
  skeleton₁-lifted {f} = skeleton₁-rec-nondep B f (λ _ _ p → p)


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

module Control.Monad.Levels.Zipping where

open import Prelude
open import Control.Monad.Levels.Definition
open import Control.Monad.Levels.Eliminators
open import Data.Bag
open import Path.Reasoning

open import Cubical.Foundations.HLevels using (isOfHLevelΠ)

zip₂-alg : Levels-ϕ[ A ](⟅ A ⟆ → (Levels A → Levels A) → Levels A)
[ zip₂-alg ]-set = isOfHLevelΠ 2 λ _ → isOfHLevelΠ 2 λ _ → trunc
[ zip₂-alg ] y ∷ ys ⟨ _ ⟩ x xs = (x ∪ y) ∷ xs ys
[ zip₂-alg ][] x xs = x ∷ xs []
[ zip₂-alg ]-trail i x xs = ∪-idʳ x i ∷ xs []

zip₂-alg-id : Levels-ψ[ xs ⦂ A ]≡ ((zip₂-alg ↓ xs) [] id ⊜ xs)
⟦ zip₂-alg-id ⟧≡ x ∷ xs ⟨ Pxs ⟩ = refl
⟦ zip₂-alg-id ⟧≡[] = trail

zip-alg : Levels-ϕ[ A ] (Levels A → Levels A)
[ zip-alg ]-set = isOfHLevelΠ 2 λ _ → trunc
[ zip-alg ] x ∷ _ ⟨ k ⟩ ys = (zip₂-alg ↓ ys) x k
[ zip-alg ][] ys = ys
[ zip-alg ]-trail = funExt (zip₂-alg-id ⇓≡_)

zip : Levels A → Levels A → Levels A
zip xs = zip-alg ↓ xs

zip-idʳ : Levels-ψ[ xs ⦂ A ]≡ zip xs [] ⊜ xs
⟦ zip-idʳ ⟧≡ x ∷ xs ⟨ Pxs ⟩ = cong (x ∷_) Pxs
⟦ zip-idʳ ⟧≡[] = refl

mutual
  zip₂-comm : (x : ⟅ A ⟆) (xs : Levels A) (pxs : ∀ ys → zip xs ys ≡ zip ys xs) → Levels-ψ[ ys ⦂ A ]≡  (zip (x ∷ xs) ys ⊜ zip ys (x ∷ xs))
  ⟦ zip₂-comm x xs pxs ⟧≡[] = zip-idʳ ⇓≡ (x ∷ xs)
  ⟦ zip₂-comm x xs pxs ⟧≡ y ∷ ys ⟨ Pys ⟩ = cong₂ _∷_ (∪-comm x y) (pxs ys)

  zip-comm : Levels-ψ[ xs ⦂ A ] (∀ ys → zip xs ys ≡ zip ys xs)
  ∥ zip-comm ∥-prop = isOfHLevelΠ 1 λ _ → trunc _ _
  ∥ zip-comm ∥[] ys = sym (zip-idʳ ⇓≡ ys)
  ∥ zip-comm ∥ x ∷ xs ⟨ Pxs ⟩ ys = zip₂-comm x xs Pxs ⇓≡ ys

zip₃-assoc : (x : ⟅ A ⟆) (xs : Levels A) (pxs : ∀ ys zs → zip (zip xs ys) zs ≡ zip xs (zip ys zs)) →
             (y : ⟅ A ⟆) (ys : Levels A) →
             Levels-ψ[ zs ⦂ A ]≡ (zip (zip (x ∷ xs) (y ∷ ys)) zs ⊜ zip (x ∷ xs) (zip (y ∷ ys) zs))
⟦ zip₃-assoc x xs pxs y ys ⟧≡[] = (zip-idʳ ⇓≡ (zip (x ∷ xs) (y ∷ ys))) ; cong (zip (x ∷ xs)) (sym (zip-idʳ ⇓≡ (y ∷ ys)))
⟦ zip₃-assoc x xs pxs y ys ⟧≡ z ∷ zs ⟨ _ ⟩ = cong₂ _∷_ (∪-assoc x y z) (pxs ys zs)

zip₂-assoc : (x : ⟅ A ⟆) (xs : Levels A) (pxs : ∀ ys zs → zip (zip xs ys) zs ≡ zip xs (zip ys zs)) →
             Levels-ψ[ ys ⦂ A ] (∀ zs → zip (zip (x ∷ xs) ys) zs ≡ zip (x ∷ xs) (zip ys zs))
∥ zip₂-assoc x xs pxs ∥-prop = isOfHLevelΠ 1 λ _ → trunc _ _
∥ zip₂-assoc x xs pxs ∥[] zs = cong (λ xs → zip xs zs) (zip-idʳ ⇓≡ (x ∷ xs))
∥ zip₂-assoc x xs pxs ∥ y ∷ ys ⟨ _ ⟩ zs = zip₃-assoc x xs pxs y ys ⇓≡ zs

zip-assoc : Levels-ψ[ xs ⦂ A ] (∀ ys zs → zip (zip xs ys) zs ≡ zip xs (zip ys zs))
∥ zip-assoc ∥-prop = isOfHLevelΠ 1 λ _ → isOfHLevelΠ 1 λ _ → trunc _ _
∥ zip-assoc ∥ x ∷ xs ⟨ Pxs ⟩ ys zs = ∥ zip₂-assoc x xs Pxs ∥⇓ ys zs
∥ zip-assoc ∥[] _ _ = refl

open import Algebra

module _ {a} {A : Type a} where
  levels-cmon : CommutativeMonoid a
  Monoid.𝑆 (CommutativeMonoid.monoid levels-cmon) = Levels A
  Monoid._∙_ (CommutativeMonoid.monoid levels-cmon) = zip
  Monoid.ε (CommutativeMonoid.monoid levels-cmon) = []
  Monoid.assoc (CommutativeMonoid.monoid levels-cmon) = ∥ zip-assoc ∥⇓
  Monoid.ε∙ (CommutativeMonoid.monoid levels-cmon) _ = refl
  Monoid.∙ε (CommutativeMonoid.monoid levels-cmon) xs = zip-idʳ ⇓≡ xs
  CommutativeMonoid.comm levels-cmon = ∥ zip-comm ∥⇓


module FRP.LTL.RSet where

open import FRP.LTL.RSet.Core public using ( RSet ; ⟨_⟩ ; ⟦_⟧ )

-- Propositional logic

open import FRP.LTL.RSet.Unit public using ( T )
open import FRP.LTL.RSet.Empty public using ( F )
open import FRP.LTL.RSet.Product public using ( _∧_ ; fst ; snd ; _&&&_ )
open import FRP.LTL.RSet.Sum public using ( _∨_ )
open import FRP.LTL.RSet.Stateless public using ( _⇒_ )

-- LTL

open import FRP.LTL.RSet.Next public using ( ○ )
open import FRP.LTL.RSet.Future public using ( ◇ )
open import FRP.LTL.RSet.Globally public using ( □ ; [_] )
open import FRP.LTL.RSet.Until public using ( _U_ )
open import FRP.LTL.RSet.Causal public using ( _⊵_ ; arr ; identity ; _⋙_ )
open import FRP.LTL.RSet.Decoupled public using ( _▹_ )


-- Andreas, 2018-08-14, re issue #1558
-- Termination checking functions over inductive-inductive types

-- {-# OPTIONS -v term:40 #-}

mutual
  data Cxt : Set where
    ε    :  Cxt
    _,_  :  (Γ : Cxt) (A : Ty Γ) → Cxt

  data Ty : (Γ : Cxt) → Set where
    u  :  ∀ Γ → Ty Γ
    Π  :  ∀ Γ (A : Ty Γ) (B : Ty (Γ , A)) → Ty Γ

mutual
  f : Cxt → Cxt
  f ε        =  ε
  f (Γ , T)  =  (f Γ , g Γ T)

  g : ∀ Γ → Ty Γ → Ty (f Γ)
  g Γ (u .Γ)      =  u (f Γ)
  g Γ (Π .Γ A B)  =  Π (f Γ) (g Γ A) (g (Γ , A) B)

-- The type of g contains a call
--
--   g Γ _ --> f Γ
--
-- which is now recorded by the termination checker.

-- Should pass termination.


module SystemF.BigStep.Intrinsic where

open import Prelude hiding (⊥)

open import SystemF.BigStep.Types

open import Data.List hiding ([_])
open import Data.List.Any.Membership
open import Data.List.Any hiding (map)
open import Data.Fin.Substitution

-- intrinsically typed syntax for System F
infix 100 _[_]
data Term {n}(Γ : Ctx n) : Type n → Set where
  unit : Term Γ Unit
  ƛ : ∀ {b} (a : Type n) → Term (Γ +tm a) b → Term Γ (a ⇒ b)
  Λ : ∀ {a} → Term (Γ +ty) a → Term Γ (∀' a)
  _·_ : ∀ {a b} → Term Γ (a ⇒ b) → Term Γ a → Term Γ b
  _[_] : ∀ {a} → Term Γ (∀' a) → ∀ b → Term Γ (a / sub b)
  var : ∀ {a} → Var Γ a → Term Γ a

_tm/_ : ∀ {n m}{Γ : Ctx n}{a} → Term Γ a → (ρ : Sub Type n m) → Term (Γ ctx/ ρ) (a / ρ)
unit tm/ ρ = unit
ƛ a t tm/ ρ = ƛ (a / ρ) (t tm/ ρ)
Λ t tm/ ρ = Λ (subst (λ Γ → Term Γ _) (sym $ CtxLemmas.ctx/-wk-comm _ ρ) (t tm/ (ρ ↑)))
(f · e) tm/ ρ = (f tm/ ρ) · (e tm/ ρ)
(_[_] {a = a} t b) tm/ ρ =
  subst (λ a → Term _ a) (sym $ Lemmas.sub-commutes a) ((t tm/ ρ) [ b / ρ ])
var x tm/ ρ = var (Inverse.to map-∈↔ ⟨$⟩ (, (x , refl)))
  where
    open import Function.Equality
    open import Function.Inverse

module Semantics where

  Env : ∀ {n} → Ctx n → Set
  data Val {n} : Type n → Set where
    unit : Val {n} Unit
    clos  : ∀ {a b Γ} → Env Γ → Term (Γ +tm a) b → Val (a ⇒ b)
    tclos : ∀ {a Γ} → Env Γ → Term (Γ +ty) a → Val (∀' a)

  open import Data.List
  open import Data.List.All as All hiding (map)

  Env Γ = All Val Γ

  open import Category.Monad.Partiality
  open import Coinduction

  private
    open Workaround

    _⊢_⇓P : ∀ {n}{Γ : Ctx n}{a} → Env Γ → Term Γ a → (Val a) ⊥P
    C ⊢ unit ⇓P = now unit
    C ⊢ ƛ a t ⇓P = now (clos C t)
    C ⊢ Λ t ⇓P = now (tclos C t)
    C ⊢ t [ ty ] ⇓P =
      (C ⊢ t ⇓P >>= λ{
        -- We have to substitute a type into the body here
        -- and proof that weakening + substitution disappears on the context.
        -- The context lemma is computationally irrelevant, but the
        -- type-in-term substitution is not as trivially irrelevant
        (tclos C' b) → later (♯ (
         (subst Env (sym $ CtxLemmas.ctx/-wk-sub≡id _ ty) C') ⊢ b tm/ sub ty ⇓P
        ))
      })
    C ⊢ f · e ⇓P =
      (C ⊢ f ⇓P) >>= λ{
        (clos C' fb) → (C ⊢ e ⇓P) >>= λ v → later (♯ ((v ∷ C') ⊢ fb ⇓P))
      }
    C ⊢ var x ⇓P = now (lookup C x)

  -- definitional interpreter in the partiality monad
  _⊢_⇓ : ∀ {n}{Γ : Ctx n}{a} → Env Γ → Term Γ a → (Val a) ⊥
  C ⊢ t ⇓ = ⟦ C ⊢ t ⇓P ⟧P

module Example where

  open import Data.Fin renaming (zero to z; suc to s)
  open import Data.List hiding ([_])
  open import Data.List.Any
  open import Data.List.All
  open import Category.Monad.Partiality
  open Semantics

  id' : Term {0} [] (∀' (ν zero ⇒ ν zero))
  id' = Λ (ƛ (ν z) (var (here refl)))

  test = run ([] ⊢ ((id' [ Unit ]) · unit) ⇓) for 10 steps


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Structures.Type where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels

open import Cubical.Functions.FunExtEquiv
open import Cubical.Foundations.Univalence

open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.Relation.Binary

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Properties

private
  variable
    ℓ ℓ' ℓ'' ℓ₁ ℓ₁' ℓ₁'' ℓ₂ ℓA ℓ≅A ℓB ℓ≅B ℓ≅ᴰ ℓP : Level

-- a type is a URGStr with the relation given by its identity type
𝒮-type : (A : Type ℓ) → URGStr A ℓ
𝒮-type A = make-𝒮 {_≅_ = _≡_} (λ _ → refl) isContrSingl

𝒮ᴰ-type : {A : Type ℓA} (B : A → Type ℓB)
          → URGStrᴰ (𝒮-type A) B ℓB
𝒮ᴰ-type {A = A} B = make-𝒮ᴰ (λ b p b' → PathP (λ i → B (p i)) b b')
                    (λ _ → refl)
                    λ _ b → isContrSingl b

-- subtypes are displayed structures
𝒮ᴰ-subtype : {A : Type ℓ} (P : A → hProp ℓ')
             → URGStrᴰ (𝒮-type A)
                       (λ a → P a .fst)
                       ℓ-zero
𝒮ᴰ-subtype P
  = make-𝒮ᴰ (λ _ _ _ → Unit)
            (λ _ → tt)
            λ a p → isContrRespectEquiv (invEquiv (Σ-contractSnd (λ _ → isContrUnit)))
                                        (inhProp→isContr p (P a .snd))

-- a subtype induces a URG structure on itself
Subtype→Sub-𝒮ᴰ : {A : Type ℓA} (P : A → hProp ℓP)
                 (StrA : URGStr A ℓ≅A)
                 → URGStrᴰ StrA (λ a → P a .fst) ℓ-zero
Subtype→Sub-𝒮ᴰ P StrA =
  make-𝒮ᴰ (λ _ _ _ → Unit)
          (λ _ → tt)
          (λ a p → isContrRespectEquiv (invEquiv (Σ-contractSnd (λ _ → isContrUnit)))
                                        (inhProp→isContr p (P a .snd)))

-- uniqueness of small URG structures
private
  module _ {A : Type ℓA} (𝒮 : URGStr A ℓA) where
    open URGStr
    𝒮' = 𝒮-type A

    ≅-≡ : _≅_ 𝒮' ≡ _≅_ 𝒮
    ≅-≡ = funExt₂ (λ a a' → ua (isUnivalent→isUnivalent' (_≅_ 𝒮) (ρ 𝒮) (uni 𝒮) a a'))

    ρ-≡ : PathP (λ i → isRefl (≅-≡ i)) (ρ 𝒮') (ρ 𝒮)
    ρ-≡ = funExt (λ a → toPathP (p a))
      where
        p : (a : A) → transport (λ i → ≅-≡ i a a) refl ≡ (ρ 𝒮 a)
        p a = uaβ (isUnivalent→isUnivalent' (_≅_ 𝒮) (ρ 𝒮) (uni 𝒮) a a) refl ∙ transportRefl (ρ 𝒮 a)

        u : (a : A) → (transport (λ i → ≅-≡ i a a) refl) ≡ (subst (λ a' → (_≅_ 𝒮) a a') refl (ρ 𝒮 a))
        u a =  uaβ (isUnivalent→isUnivalent' (_≅_ 𝒮) (ρ 𝒮) (uni 𝒮) a a) refl

    uni-≡ : PathP (λ i → isUnivalent (≅-≡ i) (ρ-≡ i)) (uni 𝒮') (uni 𝒮)
    uni-≡ = isProp→PathP (λ i → isPropΠ2 (λ a a' → isPropIsEquiv (≡→R (≅-≡ i) (ρ-≡ i)))) (uni 𝒮') (uni 𝒮)

𝒮-uniqueness : (A : Type ℓA) → isContr (URGStr A ℓA)
𝒮-uniqueness A .fst = 𝒮-type A
𝒮-uniqueness A .snd 𝒮 = sym (η-URGStr (𝒮-type A)) ∙∙ (λ i → p i) ∙∙ η-URGStr 𝒮
  where
    p = λ (i : I) → urgstr (≅-≡ 𝒮 i) (ρ-≡ 𝒮 i) (uni-≡ 𝒮 i)


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

module 07-finite-sets where

import 06-universes
open 06-universes public

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

{- Section 7.1 The finite types -}

{- Definition 7.1.1 -}

{- We introduce the finite types as a family indexed by ℕ. -}

Fin : ℕ → UU lzero
Fin zero-ℕ = empty
Fin (succ-ℕ k) = coprod (Fin k) unit

inl-Fin :
  (k : ℕ) → Fin k → Fin (succ-ℕ k)
inl-Fin k = inl

neg-one-Fin : {k : ℕ} → Fin (succ-ℕ k)
neg-one-Fin {k} = inr star

{- Definition 7.1.4 -}

zero-Fin : {k : ℕ} → Fin (succ-ℕ k)
zero-Fin {zero-ℕ} = inr star
zero-Fin {succ-ℕ k} = inl zero-Fin

{- Definition 7.1.5 -}

-- We define the successor function on finite sets.

succ-Fin : {k : ℕ} → Fin k → Fin k
succ-Fin {succ-ℕ k} (inr star) = zero-Fin
succ-Fin {succ-ℕ (succ-ℕ k)} (inl (inr star)) = neg-one-Fin
succ-Fin {succ-ℕ (succ-ℕ k)} (inl (inl x)) = inl (succ-Fin (inl x))

-- We define the predecessor function on finite sets.

skip-neg-two-Fin :
  {k : ℕ} → Fin k → Fin (succ-ℕ k)
skip-neg-two-Fin {succ-ℕ k} (inl x) = inl (inl x)
skip-neg-two-Fin {succ-ℕ k} (inr x) = neg-one-Fin {succ-ℕ k}

pred-Fin : {k : ℕ} → Fin k → Fin k
pred-Fin {succ-ℕ zero-ℕ} x = zero-Fin
pred-Fin {succ-ℕ (succ-ℕ k)} (inl x) = skip-neg-two-Fin (pred-Fin x)
pred-Fin {succ-ℕ (succ-ℕ k)} (inr x) = inl neg-one-Fin

{- Definition 7.1.6 -}

{- The modulo function -}

mod-succ-ℕ : (k : ℕ) → ℕ → Fin (succ-ℕ k)
mod-succ-ℕ k zero-ℕ = zero-Fin
mod-succ-ℕ k (succ-ℕ n) = succ-Fin (mod-succ-ℕ k n)

mod-two-ℕ : ℕ → Fin two-ℕ
mod-two-ℕ = mod-succ-ℕ one-ℕ

mod-three-ℕ : ℕ → Fin three-ℕ
mod-three-ℕ = mod-succ-ℕ two-ℕ

-- We show that mod-succ-ℕ is a periodic function with period succ-ℕ n --

{- Definition 7.1.7 -}

is-periodic-ℕ :
  (k : ℕ) {l : Level} {A : UU l} (f : ℕ → A) → UU l
is-periodic-ℕ k f = (x : ℕ) → Id (f x) (f (add-ℕ k x))

{- Lemma 7.1.8 -}

{- Our first goal is to show that mod-succ-ℕ is a periodic function. We will
   first prove some intermediate lemmas. -}

successor-law-mod-succ-ℕ :
  (k x : ℕ) → leq-ℕ x k →
  Id (mod-succ-ℕ (succ-ℕ k) x) (inl (mod-succ-ℕ k x))
successor-law-mod-succ-ℕ k zero-ℕ star = refl
successor-law-mod-succ-ℕ (succ-ℕ k) (succ-ℕ x) p =
  ( ( ap succ-Fin
      ( successor-law-mod-succ-ℕ (succ-ℕ k) x
        ( preserves-leq-succ-ℕ x k p))) ∙
    ( ap succ-Fin (ap inl (successor-law-mod-succ-ℕ k x p)))) ∙
  ( ap inl (ap succ-Fin (inv (successor-law-mod-succ-ℕ k x p))))

{- Corollary 7.1.9 -}

neg-one-law-mod-succ-ℕ :
  (k : ℕ) → Id (mod-succ-ℕ k k) neg-one-Fin
neg-one-law-mod-succ-ℕ zero-ℕ = refl
neg-one-law-mod-succ-ℕ (succ-ℕ k) =
  ap succ-Fin
    ( ( successor-law-mod-succ-ℕ k k (reflexive-leq-ℕ k)) ∙
      ( ap inl (neg-one-law-mod-succ-ℕ k)))

base-case-is-periodic-mod-succ-ℕ :
  (k : ℕ) → Id (mod-succ-ℕ k (succ-ℕ k)) zero-Fin
base-case-is-periodic-mod-succ-ℕ zero-ℕ = refl
base-case-is-periodic-mod-succ-ℕ (succ-ℕ k) =
  ap succ-Fin (neg-one-law-mod-succ-ℕ (succ-ℕ k))

{- Proposition 7.1.10 -}

is-periodic-mod-succ-ℕ :
  (k : ℕ) → is-periodic-ℕ (succ-ℕ k) (mod-succ-ℕ k)
is-periodic-mod-succ-ℕ k zero-ℕ =
  inv (base-case-is-periodic-mod-succ-ℕ k)
is-periodic-mod-succ-ℕ k (succ-ℕ x) =
  ap succ-Fin (is-periodic-mod-succ-ℕ k x)

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

{- Section 7.2 Decidability -}

{- Definition 7.2.1 -}

is-decidable : {l : Level} (A : UU l) → UU l
is-decidable A = coprod A (¬ A)

{- Example 7.2.2 -}

is-decidable-unit : is-decidable unit
is-decidable-unit = inl star

is-decidable-empty : is-decidable empty
is-decidable-empty = inr id

{- Definition 7.2.3 -}

{- We say that a type has decidable equality if we can decide whether
   x = y holds for any x, y : A. -}

has-decidable-equality : {l : Level} (A : UU l) → UU l
has-decidable-equality A = (x y : A) → is-decidable (Id x y)

{- Lemma 7.2.5 -}

is-decidable-iff :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} →
  (A → B) → (B → A) → is-decidable A → is-decidable B
is-decidable-iff f g =
  functor-coprod f (functor-neg g)

{- Proposition 7.2.6 -}

{- The type ℕ is an example of a type with decidable equality. -}

is-decidable-Eq-ℕ :
  (m n : ℕ) → is-decidable (Eq-ℕ m n)
is-decidable-Eq-ℕ zero-ℕ zero-ℕ = inl star
is-decidable-Eq-ℕ zero-ℕ (succ-ℕ n) = inr id
is-decidable-Eq-ℕ (succ-ℕ m) zero-ℕ = inr id
is-decidable-Eq-ℕ (succ-ℕ m) (succ-ℕ n) = is-decidable-Eq-ℕ m n

has-decidable-equality-ℕ : has-decidable-equality ℕ
has-decidable-equality-ℕ x y =
  is-decidable-iff (eq-Eq-ℕ x y) Eq-ℕ-eq (is-decidable-Eq-ℕ x y)

{- Definition 7.2.7 -}

{- Observational equality on finite sets -}

Eq-Fin : (k : ℕ) → Fin k → Fin k → UU lzero
Eq-Fin (succ-ℕ k) (inl x) (inl y) = Eq-Fin k x y
Eq-Fin (succ-ℕ k) (inl x) (inr y) = empty
Eq-Fin (succ-ℕ k) (inr x) (inl y) = empty
Eq-Fin (succ-ℕ k) (inr x) (inr y) = unit

{- Proposition 7.2.8 -}

refl-Eq-Fin : {k : ℕ} (x : Fin k) → Eq-Fin k x x
refl-Eq-Fin {succ-ℕ k} (inl x) = refl-Eq-Fin x
refl-Eq-Fin {succ-ℕ k} (inr x) = star

Eq-Fin-eq : {k : ℕ} {x y : Fin k} → Id x y → Eq-Fin k x y
Eq-Fin-eq {k} refl = refl-Eq-Fin {k} _

eq-Eq-Fin :
  {k : ℕ} {x y : Fin k} → Eq-Fin k x y → Id x y
eq-Eq-Fin {succ-ℕ k} {inl x} {inl y} e = ap inl (eq-Eq-Fin e)
eq-Eq-Fin {succ-ℕ k} {inr star} {inr star} star = refl

{- Proposition 7.2.9 -}

{- We show that Fin k has decidable equality, for each n : ℕ. -}

is-decidable-Eq-Fin :
  (k : ℕ) (x y : Fin k) → is-decidable (Eq-Fin k x y)
is-decidable-Eq-Fin (succ-ℕ k) (inl x) (inl y) = is-decidable-Eq-Fin k x y
is-decidable-Eq-Fin (succ-ℕ k) (inl x) (inr y) = inr id
is-decidable-Eq-Fin (succ-ℕ k) (inr x) (inl y) = inr id
is-decidable-Eq-Fin (succ-ℕ k) (inr x) (inr y) = inl star

is-decidable-eq-Fin :
  (k : ℕ) (x y : Fin k) → is-decidable (Id x y)
is-decidable-eq-Fin k x y =
  functor-coprod eq-Eq-Fin (functor-neg Eq-Fin-eq) (is-decidable-Eq-Fin k x y)

{- Proposition 7.2.10 -}

{- The inclusion function Fin k → Fin (succ-ℕ k) is injective. -}

is-injective-inl-Fin :
  {k : ℕ} {x y : Fin k} → Id (inl-Fin k x) (inl-Fin k y) → Id x y
is-injective-inl-Fin p = eq-Eq-Fin (Eq-Fin-eq p)

{- Lemma 7.2.11 -}

neq-zero-succ-Fin :
  {k : ℕ} {x : Fin k} → ¬ (Id (succ-Fin (inl-Fin k x)) zero-Fin)
neq-zero-succ-Fin {succ-ℕ k} {inl x} p =
  neq-zero-succ-Fin (is-injective-inl-Fin p)
neq-zero-succ-Fin {succ-ℕ k} {inr star} p =
  Eq-Fin-eq {succ-ℕ (succ-ℕ k)} {inr star} {zero-Fin} p

{- Proposition 7.2.12 -}

{- The successor function Fin k → Fin k is injective. -}

is-injective-succ-Fin :
  {k : ℕ} {x y : Fin k} → Id (succ-Fin x) (succ-Fin y) → Id x y
is-injective-succ-Fin {succ-ℕ k} {inr star} {inr star} p = refl
is-injective-succ-Fin {succ-ℕ k} {inl x} {inr star} p =
  ex-falso (neq-zero-succ-Fin {succ-ℕ k} {inl x} (ap inl p))
is-injective-succ-Fin {succ-ℕ k} {inr star} {inl y} p =
  ex-falso (neq-zero-succ-Fin {succ-ℕ k} {inl y} (ap inl (inv p)))
is-injective-succ-Fin {succ-ℕ (succ-ℕ k)} {inl (inr star)} {inl (inr star)} p =
  refl
is-injective-succ-Fin {succ-ℕ (succ-ℕ k)} {inl (inl x)} {inl (inr star)} p =
  ex-falso (Eq-Fin-eq p)
is-injective-succ-Fin {succ-ℕ (succ-ℕ k)} {inl (inr star)} {inl (inl y)} p =
  ex-falso (Eq-Fin-eq p)
is-injective-succ-Fin {succ-ℕ (succ-ℕ k)} {inl (inl x)} {inl (inl y)} p =
  ap inl (is-injective-succ-Fin (is-injective-inl-Fin p))

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

{- Section 7.3 Definitions by case analysis -}

{- We define an alternative definition of the predecessor function with manual
   with-abstraction. -}

cases-pred-Fin-2 :
  {k : ℕ} (x : Fin (succ-ℕ k))
  (d : is-decidable (Eq-Fin (succ-ℕ k) x zero-Fin)) → Fin (succ-ℕ k)
cases-pred-Fin-2 {zero-ℕ} (inr star) d = zero-Fin
cases-pred-Fin-2 {succ-ℕ k} (inl x) (inl e) = neg-one-Fin
cases-pred-Fin-2 {succ-ℕ k} (inl x) (inr f) =
  inl (cases-pred-Fin-2 {k} x (inr f))
cases-pred-Fin-2 {succ-ℕ k} (inr star) (inr f) = inl neg-one-Fin

pred-Fin-2 : {k : ℕ} → Fin k → Fin k
pred-Fin-2 {succ-ℕ k} x =
  cases-pred-Fin-2 {k} x (is-decidable-Eq-Fin (succ-ℕ k) x zero-Fin)

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

{- Section 7.4 The congruence relations modulo k -}

-- We introduce the divisibility relation. --

div-ℕ : ℕ → ℕ → UU lzero
div-ℕ m n = Σ ℕ (λ k → Id (mul-ℕ k m) n)

-- We show some basic properties of the divisibility relation --

{- In the following three constructions we show that if any two of the three
   numbers x, y, and x + y, is divisible by d, then so is the third. -}

div-add-ℕ :
  (d x y : ℕ) → div-ℕ d x → div-ℕ d y → div-ℕ d (add-ℕ x y)
div-add-ℕ d x y (pair n p) (pair m q) =
  pair
    ( add-ℕ n m)
    ( ( right-distributive-mul-add-ℕ n m d) ∙
      ( ap-add-ℕ p q))

div-left-summand-ℕ :
  (d x y : ℕ) → div-ℕ d y → div-ℕ d (add-ℕ x y) → div-ℕ d x
div-left-summand-ℕ zero-ℕ x y (pair m q) (pair n p) =
  pair zero-ℕ
    ( ( inv (right-zero-law-mul-ℕ n)) ∙
      ( p ∙ (ap (add-ℕ x) ((inv q) ∙ (right-zero-law-mul-ℕ m)))))
div-left-summand-ℕ (succ-ℕ d) x y (pair m q) (pair n p) =
  pair
    ( dist-ℕ m n)
    ( is-injective-add-ℕ (mul-ℕ m (succ-ℕ d)) (mul-ℕ (dist-ℕ m n) (succ-ℕ d)) x
      ( ( inv
          ( ( right-distributive-mul-add-ℕ m (dist-ℕ m n) (succ-ℕ d)) ∙
            ( commutative-add-ℕ
              ( mul-ℕ m (succ-ℕ d))
              ( mul-ℕ (dist-ℕ m n) (succ-ℕ d))))) ∙
        ( ( ap
            ( mul-ℕ' (succ-ℕ d))
            ( leq-dist-ℕ m n
              ( leq-leq-mul-ℕ' m n d
                ( concatenate-eq-leq-eq-ℕ q
                  ( leq-add-ℕ' y x)
                  ( inv p))))) ∙
          ( p ∙ (ap (add-ℕ x) (inv q))))))

div-right-summand-ℕ :
  (d x y : ℕ) → div-ℕ d x → div-ℕ d (add-ℕ x y) → div-ℕ d y
div-right-summand-ℕ d x y H1 H2 =
  div-left-summand-ℕ d y x H1 (tr (div-ℕ d) (commutative-add-ℕ x y) H2)

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

-- Some lemmas that will help us showing that cong is an equivalence relation

order-two-elements-ℕ :
  (x y : ℕ) → coprod (leq-ℕ x y) (leq-ℕ y x)
order-two-elements-ℕ zero-ℕ zero-ℕ = inl star
order-two-elements-ℕ zero-ℕ (succ-ℕ y) = inl star
order-two-elements-ℕ (succ-ℕ x) zero-ℕ = inr star
order-two-elements-ℕ (succ-ℕ x) (succ-ℕ y) = order-two-elements-ℕ x y

cases-order-three-elements-ℕ :
  (x y z : ℕ) → UU lzero
cases-order-three-elements-ℕ x y z =
  coprod
    ( coprod ((leq-ℕ x y) × (leq-ℕ y z)) ((leq-ℕ x z) × (leq-ℕ z y)))
    ( coprod
      ( coprod ((leq-ℕ y z) × (leq-ℕ z x)) ((leq-ℕ y x) × (leq-ℕ x z)))
      ( coprod ((leq-ℕ z x) × (leq-ℕ x y)) ((leq-ℕ z y) × (leq-ℕ y x))))

order-three-elements-ℕ :
  (x y z : ℕ) → cases-order-three-elements-ℕ x y z
order-three-elements-ℕ zero-ℕ zero-ℕ zero-ℕ = inl (inl (pair star star))
order-three-elements-ℕ zero-ℕ zero-ℕ (succ-ℕ z) = inl (inl (pair star star))
order-three-elements-ℕ zero-ℕ (succ-ℕ y) zero-ℕ = inl (inr (pair star star))
order-three-elements-ℕ zero-ℕ (succ-ℕ y) (succ-ℕ z) =
  inl (functor-coprod (pair star) (pair star) (order-two-elements-ℕ y z))
order-three-elements-ℕ (succ-ℕ x) zero-ℕ zero-ℕ =
  inr (inl (inl (pair star star)))
order-three-elements-ℕ (succ-ℕ x) zero-ℕ (succ-ℕ z) =
  inr (inl (functor-coprod (pair star) (pair star) (order-two-elements-ℕ z x)))
order-three-elements-ℕ (succ-ℕ x) (succ-ℕ y) zero-ℕ =
  inr (inr (functor-coprod (pair star) (pair star) (order-two-elements-ℕ x y)))
order-three-elements-ℕ (succ-ℕ x) (succ-ℕ y) (succ-ℕ z) =
  order-three-elements-ℕ x y z

triangle-equality-dist-ℕ :
  (x y z : ℕ) → (leq-ℕ x y) → (leq-ℕ y z) →
  Id (add-ℕ (dist-ℕ x y) (dist-ℕ y z)) (dist-ℕ x z)
triangle-equality-dist-ℕ zero-ℕ zero-ℕ zero-ℕ H1 H2 = refl
triangle-equality-dist-ℕ zero-ℕ zero-ℕ (succ-ℕ z) star star =
  ap succ-ℕ (left-unit-law-add-ℕ z)
triangle-equality-dist-ℕ zero-ℕ (succ-ℕ y) (succ-ℕ z) star H2 =
  left-successor-law-add-ℕ y (dist-ℕ y z) ∙
  ap succ-ℕ (leq-dist-ℕ y z H2)
triangle-equality-dist-ℕ (succ-ℕ x) (succ-ℕ y) (succ-ℕ z) H1 H2 =
  triangle-equality-dist-ℕ x y z H1 H2

cases-dist-ℕ :
  (x y z : ℕ) → UU lzero
cases-dist-ℕ x y z =
  coprod
    ( Id (add-ℕ (dist-ℕ x y) (dist-ℕ y z)) (dist-ℕ x z))
    ( coprod
      ( Id (add-ℕ (dist-ℕ y z) (dist-ℕ x z)) (dist-ℕ x y))
      ( Id (add-ℕ (dist-ℕ x z) (dist-ℕ x y)) (dist-ℕ y z)))

is-total-dist-ℕ :
  (x y z : ℕ) → cases-dist-ℕ x y z
is-total-dist-ℕ x y z with order-three-elements-ℕ x y z
is-total-dist-ℕ x y z | inl (inl (pair H1 H2)) =
  inl (triangle-equality-dist-ℕ x y z H1 H2)
is-total-dist-ℕ x y z | inl (inr (pair H1 H2)) =
  inr
    ( inl
      ( ( commutative-add-ℕ (dist-ℕ y z) (dist-ℕ x z)) ∙
        ( ( ap (add-ℕ (dist-ℕ x z)) (symmetric-dist-ℕ y z)) ∙
          ( triangle-equality-dist-ℕ x z y H1 H2))))
is-total-dist-ℕ x y z | inr (inl (inl (pair H1 H2))) =
  inr
    ( inl
      ( ( ap (add-ℕ (dist-ℕ y z)) (symmetric-dist-ℕ x z)) ∙
        ( ( triangle-equality-dist-ℕ y z x H1 H2) ∙
          ( symmetric-dist-ℕ y x))))
is-total-dist-ℕ x y z | inr (inl (inr (pair H1 H2))) =
  inr
    ( inr
      ( ( ap (add-ℕ (dist-ℕ x z)) (symmetric-dist-ℕ x y)) ∙
        ( ( commutative-add-ℕ (dist-ℕ x z) (dist-ℕ y x)) ∙
          ( triangle-equality-dist-ℕ y x z H1 H2))))
is-total-dist-ℕ x y z | inr (inr (inl (pair H1 H2))) =
  inr
    ( inr
      ( ( ap (add-ℕ' (dist-ℕ x y)) (symmetric-dist-ℕ x z)) ∙
        ( ( triangle-equality-dist-ℕ z x y H1 H2) ∙
          ( symmetric-dist-ℕ z y))))
is-total-dist-ℕ x y z | inr (inr (inr (pair H1 H2))) =
  inl
    ( ( ap-add-ℕ (symmetric-dist-ℕ x y) (symmetric-dist-ℕ y z)) ∙
      ( ( commutative-add-ℕ (dist-ℕ y x) (dist-ℕ z y)) ∙
        ( ( triangle-equality-dist-ℕ z y x H1 H2) ∙
          ( symmetric-dist-ℕ z x))))

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

{- We define the congruence relation on ℕ and show that it is an equivalence
   relation on ℕ. -}

cong-ℕ :
  ℕ → ℕ → ℕ → UU lzero
cong-ℕ k x y = div-ℕ k (dist-ℕ x y)

eq-cong-eq-ℕ :
  (k : ℕ) {x1 x2 x3 x4 : ℕ} →
  Id x1 x2 → cong-ℕ k x2 x3 → Id x3 x4 → cong-ℕ k x1 x4
eq-cong-eq-ℕ k refl H refl = H

reflexive-cong-ℕ :
  (k x : ℕ) → cong-ℕ k x x
reflexive-cong-ℕ k x =
  pair zero-ℕ ((left-zero-law-mul-ℕ (succ-ℕ k)) ∙ (dist-eq-ℕ x x refl))

cong-identification-ℕ :
  (k : ℕ) {x y : ℕ} → Id x y → cong-ℕ k x y
cong-identification-ℕ k {x} refl = reflexive-cong-ℕ k x

symmetric-cong-ℕ :
  (k x y : ℕ) → cong-ℕ k x y → cong-ℕ k y x
symmetric-cong-ℕ k x y (pair d p) =
  pair d (p ∙ (symmetric-dist-ℕ x y))

transitive-cong-ℕ :
  (k x y z : ℕ) →
  cong-ℕ k x y → cong-ℕ k y z → cong-ℕ k x z
transitive-cong-ℕ k x y z d e with is-total-dist-ℕ x y z
transitive-cong-ℕ k x y z d e | inl α =
  tr (div-ℕ k) α (div-add-ℕ k (dist-ℕ x y) (dist-ℕ y z) d e)
transitive-cong-ℕ k x y z d e | inr (inl α) =
  div-right-summand-ℕ k (dist-ℕ y z) (dist-ℕ x z) e (tr (div-ℕ k) (inv α) d)
transitive-cong-ℕ k x y z d e | inr (inr α) =
  div-left-summand-ℕ k (dist-ℕ x z) (dist-ℕ x y) d (tr (div-ℕ k) (inv α) e)

concatenate-cong-eq-cong-ℕ :
  {k x1 x2 x3 x4 : ℕ} →
  cong-ℕ k x1 x2 → Id x2 x3 → cong-ℕ k x3 x4 → cong-ℕ k x1 x4
concatenate-cong-eq-cong-ℕ {k} {x} {y} {.y} {z} H refl K =
  transitive-cong-ℕ k x y z H K

eq-cong-eq-cong-eq-ℕ :
  (k : ℕ) {x1 x2 x3 x4 x5 x6 : ℕ} →
  Id x1 x2 → cong-ℕ k x2 x3 → Id x3 x4 →
  cong-ℕ k x4 x5 → Id x5 x6 → cong-ℕ k x1 x6
eq-cong-eq-cong-eq-ℕ k {x} {.x} {y} {.y} {z} {.z} refl H refl K refl =
  transitive-cong-ℕ k x y z H K

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

-- We show that cong-ℕ zero-ℕ is the discrete equivalence relation --

is-discrete-cong-zero-ℕ :
  (x y : ℕ) → cong-ℕ zero-ℕ x y → Id x y
is-discrete-cong-zero-ℕ x y (pair k p) =
  eq-dist-ℕ x y ((inv (right-zero-law-mul-ℕ k)) ∙ p)

-- We show that cong-ℕ one-ℕ is the indiscrete equivalence relation --

div-one-ℕ :
  (x : ℕ) → div-ℕ one-ℕ x
div-one-ℕ x = pair x (right-unit-law-mul-ℕ x)

is-indiscrete-cong-one-ℕ :
  (x y : ℕ) → cong-ℕ one-ℕ x y
is-indiscrete-cong-one-ℕ x y = div-one-ℕ (dist-ℕ x y)

-- We show that zero-ℕ is congruent to n modulo n.

cong-zero-ℕ :
  (k : ℕ) → cong-ℕ k k zero-ℕ
cong-zero-ℕ k =
  pair one-ℕ ((left-unit-law-mul-ℕ k) ∙ (inv (right-zero-law-dist-ℕ k)))

-- We show that congruence is translation invariant --

translation-invariant-cong-ℕ :
  (k x y z : ℕ) → cong-ℕ k x y → cong-ℕ k (add-ℕ z x) (add-ℕ z y)
translation-invariant-cong-ℕ k x y z (pair d p) =
  pair d (p ∙ inv (translation-invariant-dist-ℕ z x y))

translation-invariant-cong-ℕ' :
  (k x y z : ℕ) → cong-ℕ k x y → cong-ℕ k (add-ℕ x z) (add-ℕ y z)
translation-invariant-cong-ℕ' k x y z H =
  eq-cong-eq-ℕ k
    ( commutative-add-ℕ x z)
    ( translation-invariant-cong-ℕ k x y z H)
    ( commutative-add-ℕ z y)

step-invariant-cong-ℕ :
  (k x y : ℕ) → cong-ℕ k x y → cong-ℕ k (succ-ℕ x) (succ-ℕ y)
step-invariant-cong-ℕ k x y = translation-invariant-cong-ℕ' k x y one-ℕ

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

-- We show that mod-succ-ℕ sends congruent elements to equal elements --

zero-class-mod-succ-ℕ :
  (k x : ℕ) (d : div-ℕ (succ-ℕ k) x) → Id (mod-succ-ℕ k x) zero-Fin
zero-class-mod-succ-ℕ k .zero-ℕ (pair zero-ℕ refl) = refl
zero-class-mod-succ-ℕ k x (pair (succ-ℕ d) p) =
  ( inv (ap (mod-succ-ℕ k) p)) ∙
  ( ( ap (mod-succ-ℕ k) (commutative-add-ℕ (mul-ℕ d (succ-ℕ k)) (succ-ℕ k))) ∙
    ( ( inv (is-periodic-mod-succ-ℕ k (mul-ℕ d (succ-ℕ k)))) ∙
      ( zero-class-mod-succ-ℕ k (mul-ℕ d (succ-ℕ k)) (pair d refl))))

eq-cong-ℕ :
  (k x y : ℕ) → cong-ℕ (succ-ℕ k) x y → Id (mod-succ-ℕ k x) (mod-succ-ℕ k y)
eq-cong-ℕ k zero-ℕ zero-ℕ H = refl
eq-cong-ℕ k zero-ℕ (succ-ℕ y) H =
  inv (zero-class-mod-succ-ℕ k (succ-ℕ y) H)
eq-cong-ℕ k (succ-ℕ x) zero-ℕ H =
  zero-class-mod-succ-ℕ k (succ-ℕ x) H
eq-cong-ℕ k (succ-ℕ x) (succ-ℕ y) H =
  ap succ-Fin (eq-cong-ℕ k x y H)

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

{- We define the inclusion of Fin k into ℕ. -}

nat-Fin : {k : ℕ} → Fin k → ℕ
nat-Fin {succ-ℕ k} (inl x) = nat-Fin x
nat-Fin {succ-ℕ k} (inr x) = k

zero-law-nat-Fin :
  {k : ℕ} → Id (nat-Fin (zero-Fin {k})) zero-ℕ
zero-law-nat-Fin {zero-ℕ} = refl
zero-law-nat-Fin {succ-ℕ k} = zero-law-nat-Fin {k}

{- We show that nat-Fin x ≤ k. -}

upper-bound-nat-Fin : {k : ℕ} (x : Fin (succ-ℕ k)) → leq-ℕ (nat-Fin x) k
upper-bound-nat-Fin {zero-ℕ} (inr star) = star
upper-bound-nat-Fin {succ-ℕ k} (inl x) =
  preserves-leq-succ-ℕ (nat-Fin x) k (upper-bound-nat-Fin x)
upper-bound-nat-Fin {succ-ℕ k} (inr star) = reflexive-leq-ℕ (succ-ℕ k)

{- Now we show that Fin (succ-ℕ k) is a retract of ℕ -}

issec-nat-Fin : (k : ℕ) (x : Fin (succ-ℕ k)) → Id (mod-succ-ℕ k (nat-Fin x)) x
issec-nat-Fin zero-ℕ (inr star) = refl
issec-nat-Fin (succ-ℕ k) (inl x) =
  ( successor-law-mod-succ-ℕ k (nat-Fin x) (upper-bound-nat-Fin x)) ∙
  ( ap inl (issec-nat-Fin k x))
issec-nat-Fin (succ-ℕ k) (inr star) = neg-one-law-mod-succ-ℕ (succ-ℕ k)

-- We show that nat-Fin is an injective function --

neq-leq-ℕ : {m n : ℕ} → leq-ℕ m n → ¬ (Id m (succ-ℕ n))
neq-leq-ℕ {zero-ℕ} {n} p q = Eq-ℕ-eq q
neq-leq-ℕ {succ-ℕ m} {succ-ℕ n} p q =
  neq-leq-ℕ p (is-injective-succ-ℕ m (succ-ℕ n) q)

is-injective-nat-Fin : {k : ℕ} {x y : Fin (succ-ℕ k)} →
  Id (nat-Fin x) (nat-Fin y) → Id x y
is-injective-nat-Fin {zero-ℕ} {inr star} {inr star} p = refl
is-injective-nat-Fin {succ-ℕ k} {inl x} {inl y} p =
  ap inl (is-injective-nat-Fin p)
is-injective-nat-Fin {succ-ℕ k} {inl x} {inr star} p =
  ex-falso (neq-leq-ℕ (upper-bound-nat-Fin x) p)
is-injective-nat-Fin {succ-ℕ k} {inr star} {inl y} p =
  ex-falso (neq-leq-ℕ (upper-bound-nat-Fin y) (inv p))
is-injective-nat-Fin {succ-ℕ k} {inr star} {inr star} p = refl

-- We show that nat-Fin commutes with the successor for x ≠ neg-one-Fin --

nat-succ-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) (p : ¬ (Eq-Fin (succ-ℕ k) x neg-one-Fin)) →
  Id (nat-Fin (succ-Fin x)) (succ-ℕ (nat-Fin x))
nat-succ-Fin {k} (inr star) p = ex-falso (p star)
nat-succ-Fin {succ-ℕ k} (inl (inr star)) p = refl
nat-succ-Fin {succ-ℕ k} (inl (inl x)) p =
  nat-succ-Fin (inl x) id

-- We show that (nat-Fin (mod-succ-ℕ n x)) is congruent to x modulo n+1. --

cong-nat-mod-succ-ℕ :
  (k x : ℕ) → cong-ℕ (succ-ℕ k) (nat-Fin (mod-succ-ℕ k x)) x
cong-nat-mod-succ-ℕ k x with
  is-decidable-eq-Fin (succ-ℕ k) (mod-succ-ℕ k x) zero-Fin
cong-nat-mod-succ-ℕ zero-ℕ zero-ℕ | d =
  pair zero-ℕ refl
cong-nat-mod-succ-ℕ zero-ℕ (succ-ℕ x) | d =
  div-one-ℕ (dist-ℕ (nat-Fin (mod-succ-ℕ zero-ℕ (succ-ℕ x))) (succ-ℕ x))
cong-nat-mod-succ-ℕ (succ-ℕ k) zero-ℕ | d =
  eq-cong-eq-ℕ (succ-ℕ (succ-ℕ k))
    ( zero-law-nat-Fin {succ-ℕ k})
    ( reflexive-cong-ℕ (succ-ℕ (succ-ℕ k)) zero-ℕ)
    ( refl)
cong-nat-mod-succ-ℕ (succ-ℕ k) (succ-ℕ x) | inl p =
  eq-cong-eq-cong-eq-ℕ
    ( succ-ℕ (succ-ℕ k))
    ( ap nat-Fin {x = mod-succ-ℕ (succ-ℕ k) (succ-ℕ x)} p ∙
      zero-law-nat-Fin {succ-ℕ k})
    ( symmetric-cong-ℕ
      ( succ-ℕ (succ-ℕ k))
      ( zero-ℕ)
      ( succ-ℕ (succ-ℕ k))
      ( cong-zero-ℕ (succ-ℕ (succ-ℕ k))))
    ( ap
      ( succ-ℕ ∘ nat-Fin)
      { x = neg-one-Fin}
      { y = mod-succ-ℕ (succ-ℕ k) x}
      ( is-injective-succ-Fin (inv p)))
    ( step-invariant-cong-ℕ
      ( succ-ℕ (succ-ℕ k))
      ( nat-Fin (mod-succ-ℕ (succ-ℕ k) x))
      ( x)
      ( cong-nat-mod-succ-ℕ (succ-ℕ k) x))
    ( refl)
cong-nat-mod-succ-ℕ (succ-ℕ k) (succ-ℕ x) | inr f =
  eq-cong-eq-ℕ
    ( succ-ℕ (succ-ℕ k))
    ( nat-succ-Fin
      ( mod-succ-ℕ (succ-ℕ k) x)
      ( (f ∘ ap succ-Fin) ∘
        ( eq-Eq-Fin
          { succ-ℕ (succ-ℕ k)}
          { x = mod-succ-ℕ (succ-ℕ k) x}
          { y = neg-one-Fin})))
    ( step-invariant-cong-ℕ
      ( succ-ℕ (succ-ℕ k))
      ( nat-Fin (mod-succ-ℕ (succ-ℕ k) x))
      ( x)
      ( cong-nat-mod-succ-ℕ (succ-ℕ k) x))
    ( refl)

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

{- We show that if mod-succ-ℕ n = is mod-succ-ℕ n x, then x and y must be
   congruent modulo succ-ℕ n. -}

cong-eq-ℕ :
  (k x y : ℕ) → Id (mod-succ-ℕ k x) (mod-succ-ℕ k y) → cong-ℕ (succ-ℕ k) x y
cong-eq-ℕ k x y p =
  concatenate-cong-eq-cong-ℕ {succ-ℕ k} {x}
    ( symmetric-cong-ℕ (succ-ℕ k) (nat-Fin (mod-succ-ℕ k x)) x
      ( cong-nat-mod-succ-ℕ k x))
    ( ap nat-Fin p)
    ( cong-nat-mod-succ-ℕ k y)

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

{- We show that if x and y are congruent modulo (succ-ℕ n), then we will have
   an identification mod-succ-ℕ n x = mod-succ-ℕ n y. -}

upper-bound-dist-ℕ :
  (b x y : ℕ) → leq-ℕ x b → leq-ℕ y b → leq-ℕ (dist-ℕ x y) b
upper-bound-dist-ℕ zero-ℕ zero-ℕ zero-ℕ H K = star
upper-bound-dist-ℕ (succ-ℕ b) zero-ℕ zero-ℕ H K = star
upper-bound-dist-ℕ (succ-ℕ b) zero-ℕ (succ-ℕ y) H K = K
upper-bound-dist-ℕ (succ-ℕ b) (succ-ℕ x) zero-ℕ H K = H
upper-bound-dist-ℕ (succ-ℕ b) (succ-ℕ x) (succ-ℕ y) H K =
  preserves-leq-succ-ℕ (dist-ℕ x y) b (upper-bound-dist-ℕ b x y H K)

contradiction-leq-ℕ :
  (x y : ℕ) → leq-ℕ x y → leq-ℕ (succ-ℕ y) x → empty
contradiction-leq-ℕ (succ-ℕ x) (succ-ℕ y) H K = contradiction-leq-ℕ x y H K

eq-zero-div-ℕ :
  (d x : ℕ) → leq-ℕ x d → div-ℕ (succ-ℕ d) x → Id x zero-ℕ
eq-zero-div-ℕ d zero-ℕ H D = refl
eq-zero-div-ℕ d (succ-ℕ x) H (pair (succ-ℕ k) p) =
  ex-falso
    ( contradiction-leq-ℕ d x
      ( concatenate-eq-leq-eq-ℕ
        { x1 = succ-ℕ d}
        { x2 = succ-ℕ d}
        { x3 = succ-ℕ (add-ℕ (mul-ℕ k (succ-ℕ d)) d)}
        { x4 = succ-ℕ x}
        ( refl)
        ( leq-add-ℕ' d (mul-ℕ k (succ-ℕ d)))
        ( p)) H)

eq-cong-nat-Fin :
  (k : ℕ) (x y : Fin k) → cong-ℕ k (nat-Fin x) (nat-Fin y) → Id x y
eq-cong-nat-Fin (succ-ℕ k) x y H =
  is-injective-nat-Fin
    ( eq-dist-ℕ
      ( nat-Fin x)
      ( nat-Fin y)
      ( inv
        ( eq-zero-div-ℕ k
          ( dist-ℕ (nat-Fin x) (nat-Fin y))
          ( upper-bound-dist-ℕ k
            ( nat-Fin x)
            ( nat-Fin y)
            ( upper-bound-nat-Fin x)
            ( upper-bound-nat-Fin y))
          ( H))))

eq-mod-succ-ℕ :
  (k x y : ℕ) → cong-ℕ (succ-ℕ k) x y → Id (mod-succ-ℕ k x) (mod-succ-ℕ k y)
eq-mod-succ-ℕ k x y H =
  eq-cong-nat-Fin
    ( succ-ℕ k)
    ( mod-succ-ℕ k x)
    ( mod-succ-ℕ k y)
    ( transitive-cong-ℕ
      ( succ-ℕ k)
      ( nat-Fin (mod-succ-ℕ k x))
      ( x)
      ( nat-Fin (mod-succ-ℕ k y))
      ( cong-nat-mod-succ-ℕ k x)
      ( transitive-cong-ℕ (succ-ℕ k) x y (nat-Fin (mod-succ-ℕ k y)) H
        ( symmetric-cong-ℕ (succ-ℕ k) (nat-Fin (mod-succ-ℕ k y)) y
          ( cong-nat-mod-succ-ℕ k y))))

{- This completes the proof that

   (mod-succ-ℕ n x = mod-succ-ℕ n y) ↔ (cong-ℕ (succ-ℕ n) x y). -}

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

{- Section 7.7 Modular arithmetic -}

-- We show that congruence is invariant under scalar multiplication --

scalar-invariant-cong-ℕ :
  (k x y z : ℕ) → cong-ℕ k x y →  cong-ℕ k (mul-ℕ z x) (mul-ℕ z y)
scalar-invariant-cong-ℕ k x y z (pair d p) =
  pair
    ( mul-ℕ z d)
    ( ( associative-mul-ℕ z d k) ∙
      ( ( ap (mul-ℕ z) p) ∙
        ( inv (linear-dist-ℕ x y z))))

scalar-invariant-cong-ℕ' :
  (k x y z : ℕ) → cong-ℕ k x y → cong-ℕ k (mul-ℕ x z) (mul-ℕ y z)
scalar-invariant-cong-ℕ' k x y z H =
  eq-cong-eq-ℕ k
    ( commutative-mul-ℕ x z)
    ( scalar-invariant-cong-ℕ k x y z H)
    ( commutative-mul-ℕ z y)

-- We show that addition respects the congruence relation --

congruence-add-ℕ :
  (k : ℕ) {x y x' y' : ℕ} →
  cong-ℕ k x x' → cong-ℕ k y y' → cong-ℕ k (add-ℕ x y) (add-ℕ x' y')
congruence-add-ℕ k {x} {y} {x'} {y'} H K =
  transitive-cong-ℕ k (add-ℕ x y) (add-ℕ x y') (add-ℕ x' y')
    ( translation-invariant-cong-ℕ k y y' x K)
    ( translation-invariant-cong-ℕ' k x x' y' H)

-- We show that multiplication respects the congruence relation --

congruence-mul-ℕ :
  (k : ℕ) {x y x' y' : ℕ} →
  cong-ℕ  k x x' → cong-ℕ k y y' → cong-ℕ k (mul-ℕ x y) (mul-ℕ x' y')
congruence-mul-ℕ k {x} {y} {x'} {y'} H K =
  transitive-cong-ℕ k (mul-ℕ x y) (mul-ℕ x y') (mul-ℕ x' y')
    ( scalar-invariant-cong-ℕ k y y' x K)
    ( scalar-invariant-cong-ℕ' k x x' y' H)

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

-- Now we start defining the finite cyclic groups ℤ/n.

-- Addition on finite sets --

add-Fin : {k : ℕ} → Fin k → Fin k → Fin k
add-Fin {succ-ℕ k} x y = mod-succ-ℕ k (add-ℕ (nat-Fin x) (nat-Fin y))

add-Fin' : {k : ℕ} → Fin k → Fin k → Fin k
add-Fin' x y = add-Fin y x

ap-add-Fin :
  {k : ℕ} {x y x' y' : Fin k} →
  Id x x' → Id y y' → Id (add-Fin x y) (add-Fin x' y')
ap-add-Fin refl refl = refl

cong-add-Fin :
  {k : ℕ} (x y : Fin k) →
  cong-ℕ k (nat-Fin (add-Fin x y)) (add-ℕ (nat-Fin x) (nat-Fin y))
cong-add-Fin {succ-ℕ k} x y =
  cong-nat-mod-succ-ℕ k (add-ℕ (nat-Fin x) (nat-Fin y))

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

-- We show that addition is associative --

associative-add-Fin :
  {k : ℕ} (x y z : Fin k) →
  Id (add-Fin (add-Fin x y) z) (add-Fin x (add-Fin y z))
associative-add-Fin {succ-ℕ k} x y z =
  eq-cong-ℕ k
    ( add-ℕ (nat-Fin (add-Fin x y)) (nat-Fin z))
    ( add-ℕ (nat-Fin x) (nat-Fin (add-Fin y z)))
    ( concatenate-cong-eq-cong-ℕ
      { x1 = add-ℕ (nat-Fin (add-Fin x y)) (nat-Fin z)}
      { x2 = add-ℕ (add-ℕ (nat-Fin x) (nat-Fin y)) (nat-Fin z)}
      { x3 = add-ℕ (nat-Fin x) (add-ℕ (nat-Fin y) (nat-Fin z))}
      { x4 = add-ℕ (nat-Fin x) (nat-Fin (add-Fin y z))}
      ( congruence-add-ℕ
        ( succ-ℕ k)
        { x = nat-Fin (add-Fin x y)}
        { y = nat-Fin z}
        { x' = add-ℕ (nat-Fin x) (nat-Fin y)}
        { y' = nat-Fin z}
        ( cong-add-Fin x y)
        ( reflexive-cong-ℕ (succ-ℕ k) (nat-Fin z)))
      ( associative-add-ℕ (nat-Fin x) (nat-Fin y) (nat-Fin z))
      ( congruence-add-ℕ
        ( succ-ℕ k)
        { x = nat-Fin x}
        { y = add-ℕ (nat-Fin y) (nat-Fin z)}
        { x' = nat-Fin x}
        { y' = nat-Fin (add-Fin y z)}
        ( reflexive-cong-ℕ (succ-ℕ k) (nat-Fin x))
        ( symmetric-cong-ℕ
          ( succ-ℕ k)
          ( nat-Fin (add-Fin y z))
          ( add-ℕ (nat-Fin y) (nat-Fin z))
          ( cong-add-Fin y z))))

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

-- addition is commutative --

commutative-add-Fin : {k : ℕ} (x y : Fin k) → Id (add-Fin x y) (add-Fin y x)
commutative-add-Fin {succ-ℕ k} x y =
  ap (mod-succ-ℕ k) (commutative-add-ℕ (nat-Fin x) (nat-Fin y))

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

-- We prove the unit laws for add-Fin --

nat-zero-Fin :
  {k : ℕ} → cong-ℕ (succ-ℕ k) (nat-Fin (zero-Fin {k})) zero-ℕ
nat-zero-Fin {k} = cong-nat-mod-succ-ℕ k zero-ℕ

right-unit-law-add-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) → Id (add-Fin x zero-Fin) x
right-unit-law-add-Fin {k} x =
  ( eq-cong-ℕ k
    ( add-ℕ (nat-Fin x) (nat-Fin {succ-ℕ k} zero-Fin))
    ( add-ℕ (nat-Fin x) zero-ℕ)
    ( congruence-add-ℕ
      ( succ-ℕ k)
      { x = nat-Fin {succ-ℕ k} x}
      { y = nat-Fin {succ-ℕ k} zero-Fin}
      { x' = nat-Fin x}
      { y' = zero-ℕ}
      ( reflexive-cong-ℕ (succ-ℕ k) (nat-Fin {succ-ℕ k} x))
      ( nat-zero-Fin {k}))) ∙
  ( issec-nat-Fin k x)

left-unit-law-add-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) → Id (add-Fin zero-Fin x) x
left-unit-law-add-Fin {k} x =
  ( commutative-add-Fin zero-Fin x) ∙
  ( right-unit-law-add-Fin x)

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

-- We define the negative of x : Fin (succ-ℕ k) --

neg-Fin :
  {k : ℕ} → Fin k → Fin k
neg-Fin {succ-ℕ k} x =
  mod-succ-ℕ k (dist-ℕ (nat-Fin x) (succ-ℕ k))

cong-neg-Fin :
  {k : ℕ} (x : Fin k) →
  cong-ℕ k (nat-Fin (neg-Fin x)) (dist-ℕ (nat-Fin x) k)
cong-neg-Fin {succ-ℕ k} x =
  cong-nat-mod-succ-ℕ k (dist-ℕ (nat-Fin x) (succ-ℕ k))

left-inverse-law-add-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) → Id (add-Fin (neg-Fin x) x) zero-Fin
left-inverse-law-add-Fin {k} x =
  eq-cong-ℕ k (add-ℕ (nat-Fin (neg-Fin x)) (nat-Fin x)) zero-ℕ
    ( concatenate-cong-eq-cong-ℕ
      { succ-ℕ k}
      { x1 = add-ℕ (nat-Fin (neg-Fin x)) (nat-Fin x)}
      { x2 = add-ℕ (dist-ℕ (nat-Fin x) (succ-ℕ k)) (nat-Fin x)}
      { x3 = succ-ℕ k}
      { x4 = zero-ℕ}
      ( congruence-add-ℕ
        ( succ-ℕ k)
        { x = nat-Fin (neg-Fin x)}
        { y = nat-Fin x}
        ( cong-neg-Fin x)
        ( reflexive-cong-ℕ (succ-ℕ k) (nat-Fin x)))
      ( ( ap ( add-ℕ (dist-ℕ (nat-Fin x) (succ-ℕ k)))
             ( inv (left-zero-law-dist-ℕ (nat-Fin x)))) ∙
        ( ( commutative-add-ℕ
            ( dist-ℕ (nat-Fin x) (succ-ℕ k))
            ( dist-ℕ zero-ℕ (nat-Fin x))) ∙
          ( triangle-equality-dist-ℕ zero-ℕ (nat-Fin x) (succ-ℕ k) star
            ( preserves-leq-succ-ℕ (nat-Fin x) k (upper-bound-nat-Fin x)))))
      ( symmetric-cong-ℕ
          ( succ-ℕ k)
          ( zero-ℕ)
          ( succ-ℕ k)
          ( cong-zero-ℕ (succ-ℕ k))))

right-inverse-law-add-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) → Id (add-Fin x (neg-Fin x)) zero-Fin
right-inverse-law-add-Fin x =
  ( commutative-add-Fin x (neg-Fin x)) ∙ (left-inverse-law-add-Fin x)

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

{- Exercises -}

-- Exercise 7.1

{- We give a first solution of this exercise using the definition of pred-Fin
   that doesn't use with-abstraction. -}

pred-zero-Fin :
  {k : ℕ} → Id (pred-Fin {succ-ℕ k} zero-Fin) neg-one-Fin
pred-zero-Fin {zero-ℕ} = refl
pred-zero-Fin {succ-ℕ k} = ap skip-neg-two-Fin (pred-zero-Fin {k})

succ-skip-neg-two-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) →
  Id (succ-Fin (skip-neg-two-Fin x)) (inl (succ-Fin x))
succ-skip-neg-two-Fin {zero-ℕ} (inr star) = refl
succ-skip-neg-two-Fin {succ-ℕ k} (inl x) = refl
succ-skip-neg-two-Fin {succ-ℕ k} (inr star) = refl

succ-pred-Fin :
  {k : ℕ} (x : Fin k) → Id (succ-Fin (pred-Fin x)) x
succ-pred-Fin {succ-ℕ zero-ℕ} (inr star) = refl
succ-pred-Fin {succ-ℕ (succ-ℕ k)} (inl x) =
  succ-skip-neg-two-Fin (pred-Fin x) ∙ ap inl (succ-pred-Fin x)
succ-pred-Fin {succ-ℕ (succ-ℕ k)} (inr star) = refl

pred-succ-Fin :
  {k : ℕ} (x : Fin k) → Id (pred-Fin (succ-Fin x)) x
pred-succ-Fin {succ-ℕ zero-ℕ} (inr star) = refl
pred-succ-Fin {succ-ℕ (succ-ℕ k)} (inl (inl x)) =
  ap skip-neg-two-Fin (pred-succ-Fin (inl x))
pred-succ-Fin {succ-ℕ (succ-ℕ k)} (inl (inr star)) = refl
pred-succ-Fin {succ-ℕ (succ-ℕ k)} (inr star) = pred-zero-Fin

{- We give a solution to the exercise for the alternative definition of the
   predecessor function, using with-abstraction. -}

pred-zero-Fin-2 :
  {k : ℕ} → Id (pred-Fin-2 {succ-ℕ k} zero-Fin) neg-one-Fin
pred-zero-Fin-2 {k} with is-decidable-Eq-Fin (succ-ℕ k) zero-Fin zero-Fin
pred-zero-Fin-2 {zero-ℕ} | d = refl
pred-zero-Fin-2 {succ-ℕ k} | inl e = refl
pred-zero-Fin-2 {succ-ℕ k} | inr f =
  ex-falso (f (refl-Eq-Fin {succ-ℕ k} zero-Fin))

cases-succ-pred-Fin-2 :
  {k : ℕ} (x : Fin (succ-ℕ k))
  (d : is-decidable (Eq-Fin (succ-ℕ k) x zero-Fin)) →
  Id (succ-Fin (cases-pred-Fin-2 x d)) x
cases-succ-pred-Fin-2 {zero-ℕ} (inr star) d =
  refl
cases-succ-pred-Fin-2 {succ-ℕ k} (inl x) (inl e) =
  inv (eq-Eq-Fin e)
cases-succ-pred-Fin-2 {succ-ℕ zero-ℕ} (inl (inr x)) (inr f) =
  ex-falso (f star)
cases-succ-pred-Fin-2 {succ-ℕ (succ-ℕ k)} (inl (inl x)) (inr f) =
  ap inl (cases-succ-pred-Fin-2 (inl x) (inr f))
cases-succ-pred-Fin-2 {succ-ℕ (succ-ℕ k)} (inl (inr star)) (inr f) =
  refl
cases-succ-pred-Fin-2 {succ-ℕ k} (inr star) (inr f) =
  refl

succ-pred-Fin-2 :
  {k : ℕ} (x : Fin k) → Id (succ-Fin (pred-Fin-2 x)) x
succ-pred-Fin-2 {succ-ℕ k} x =
  cases-succ-pred-Fin-2 x (is-decidable-Eq-Fin (succ-ℕ k) x zero-Fin)

pred-inl-Fin-2 :
  {k : ℕ} (x : Fin (succ-ℕ k)) (f : ¬ (Eq-Fin (succ-ℕ k) x zero-Fin)) →
  Id (pred-Fin-2 (inl x)) (inl (pred-Fin-2 x))
pred-inl-Fin-2 {k} x f with is-decidable-Eq-Fin (succ-ℕ k) x zero-Fin
... | inl e = ex-falso (f e)
... | inr f' = refl

nEq-zero-succ-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) →
  ¬ (Eq-Fin (succ-ℕ (succ-ℕ k)) (succ-Fin (inl x)) zero-Fin)
nEq-zero-succ-Fin {succ-ℕ k} (inl (inl x)) e = nEq-zero-succ-Fin (inl x) e
nEq-zero-succ-Fin {succ-ℕ k} (inl (inr star)) ()
nEq-zero-succ-Fin {succ-ℕ k} (inr star) ()

pred-succ-Fin-2 :
  {k : ℕ} (x : Fin (succ-ℕ k)) → Id (pred-Fin-2 (succ-Fin x)) x
pred-succ-Fin-2 {zero-ℕ} (inr star) = refl
pred-succ-Fin-2 {succ-ℕ zero-ℕ} (inl (inr star)) = refl
pred-succ-Fin-2 {succ-ℕ zero-ℕ} (inr star) = refl
pred-succ-Fin-2 {succ-ℕ (succ-ℕ k)} (inl (inl (inl x))) =
  ( pred-inl-Fin-2 (inl (succ-Fin (inl x))) (nEq-zero-succ-Fin (inl x))) ∙
  ( ( ap inl (pred-inl-Fin-2 (succ-Fin (inl x)) (nEq-zero-succ-Fin (inl x)))) ∙
    ( ap (inl ∘ inl) (pred-succ-Fin-2 (inl x))))
pred-succ-Fin-2 {succ-ℕ (succ-ℕ k)} (inl (inl (inr star))) = refl
pred-succ-Fin-2 {succ-ℕ (succ-ℕ k)} (inl (inr star)) = refl
pred-succ-Fin-2 {succ-ℕ (succ-ℕ k)} (inr star) = pred-zero-Fin-2

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

{- We define the multiplication on the types Fin k. -}

mul-Fin :
  {k : ℕ} → Fin k → Fin k → Fin k
mul-Fin {succ-ℕ k} x y = mod-succ-ℕ k (mul-ℕ (nat-Fin x) (nat-Fin y))

ap-mul-Fin :
  {k : ℕ} {x y x' y' : Fin k} →
  Id x x' → Id y y' → Id (mul-Fin x y) (mul-Fin x' y')
ap-mul-Fin refl refl = refl

cong-mul-Fin :
  {k : ℕ} (x y : Fin k) →
  cong-ℕ k (nat-Fin (mul-Fin x y)) (mul-ℕ (nat-Fin x) (nat-Fin y))
cong-mul-Fin {succ-ℕ k} x y =
  cong-nat-mod-succ-ℕ k (mul-ℕ (nat-Fin x) (nat-Fin y))

associative-mul-Fin :
  {k : ℕ} (x y z : Fin k) →
  Id (mul-Fin (mul-Fin x y) z) (mul-Fin x (mul-Fin y z))
associative-mul-Fin {succ-ℕ k} x y z =
  eq-cong-ℕ k
    ( mul-ℕ (nat-Fin (mul-Fin x y)) (nat-Fin z))
    ( mul-ℕ (nat-Fin x) (nat-Fin (mul-Fin y z)))
    ( concatenate-cong-eq-cong-ℕ
      { x1 = mul-ℕ (nat-Fin (mul-Fin x y)) (nat-Fin z)}
      { x2 = mul-ℕ (mul-ℕ (nat-Fin x) (nat-Fin y)) (nat-Fin z)}
      { x3 = mul-ℕ (nat-Fin x) (mul-ℕ (nat-Fin y) (nat-Fin z))}
      { x4 = mul-ℕ (nat-Fin x) (nat-Fin (mul-Fin y z))}
      ( congruence-mul-ℕ
        ( succ-ℕ k)
        { x = nat-Fin (mul-Fin x y)}
        { y = nat-Fin z}
        ( cong-mul-Fin x y)
        ( reflexive-cong-ℕ (succ-ℕ k) (nat-Fin z)))
      ( associative-mul-ℕ (nat-Fin x) (nat-Fin y) (nat-Fin z))
      ( symmetric-cong-ℕ
        ( succ-ℕ k)
        ( mul-ℕ (nat-Fin x) (nat-Fin (mul-Fin y z)))
        ( mul-ℕ (nat-Fin x) (mul-ℕ (nat-Fin y) (nat-Fin z)))
        ( congruence-mul-ℕ
          ( succ-ℕ k)
          { x = nat-Fin x}
          { y = nat-Fin (mul-Fin y z)}
          ( reflexive-cong-ℕ (succ-ℕ k) (nat-Fin x))
          ( cong-mul-Fin y z))))

commutative-mul-Fin :
  {k : ℕ} (x y : Fin k) → Id (mul-Fin x y) (mul-Fin y x)
commutative-mul-Fin {succ-ℕ k} x y =
  eq-cong-ℕ k
    ( mul-ℕ (nat-Fin x) (nat-Fin y))
    ( mul-ℕ (nat-Fin y) (nat-Fin x))
    ( cong-identification-ℕ
      ( succ-ℕ k)
      ( commutative-mul-ℕ (nat-Fin x) (nat-Fin y)))

one-Fin : {k : ℕ} → Fin (succ-ℕ k)
one-Fin {k} = mod-succ-ℕ k one-ℕ

nat-one-Fin : {k : ℕ} → Id (nat-Fin (one-Fin {succ-ℕ k})) one-ℕ
nat-one-Fin {zero-ℕ} = refl
nat-one-Fin {succ-ℕ k} = nat-one-Fin {k}

left-unit-law-mul-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) → Id (mul-Fin one-Fin x) x
left-unit-law-mul-Fin {zero-ℕ} (inr star) = refl
left-unit-law-mul-Fin {succ-ℕ k} x =
  ( eq-cong-ℕ (succ-ℕ k)
    ( mul-ℕ (nat-Fin (one-Fin {succ-ℕ k})) (nat-Fin x))
    ( nat-Fin x)
    ( cong-identification-ℕ
      ( succ-ℕ (succ-ℕ k))
      ( ( ap ( mul-ℕ' (nat-Fin x))
             ( nat-one-Fin {k})) ∙
        ( left-unit-law-mul-ℕ (nat-Fin x))))) ∙
  ( issec-nat-Fin (succ-ℕ k) x)

right-unit-law-mul-Fin :
  {k : ℕ} (x : Fin (succ-ℕ k)) → Id (mul-Fin x one-Fin) x
right-unit-law-mul-Fin x =
  ( commutative-mul-Fin x one-Fin) ∙
  ( left-unit-law-mul-Fin x)

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

left-distributive-mul-add-Fin :
  {k : ℕ} (x y z : Fin k) →
  Id (mul-Fin x (add-Fin y z)) (add-Fin (mul-Fin x y) (mul-Fin x z))
left-distributive-mul-add-Fin {succ-ℕ k} x y z =
  eq-cong-ℕ k
    ( mul-ℕ (nat-Fin x) (nat-Fin (add-Fin y z)))
    ( add-ℕ (nat-Fin (mul-Fin x y)) (nat-Fin (mul-Fin x z)))
    ( concatenate-cong-eq-cong-ℕ
      { k = succ-ℕ k}
      { x1 = mul-ℕ ( nat-Fin x) (nat-Fin (add-Fin y z))}
      { x2 = mul-ℕ ( nat-Fin x) (add-ℕ (nat-Fin y) (nat-Fin z))}
      { x3 = add-ℕ ( mul-ℕ (nat-Fin x) (nat-Fin y))
                   ( mul-ℕ (nat-Fin x) (nat-Fin z))}
      { x4 = add-ℕ (nat-Fin (mul-Fin x y)) (nat-Fin (mul-Fin x z))}
      ( congruence-mul-ℕ
        ( succ-ℕ k)
        { x = nat-Fin x}
        { y = nat-Fin (add-Fin y z)}
        { x' = nat-Fin x}
        { y' = add-ℕ (nat-Fin y) (nat-Fin z)}
        ( reflexive-cong-ℕ (succ-ℕ k) (nat-Fin x))
        ( cong-add-Fin y z))
      ( left-distributive-mul-add-ℕ (nat-Fin x) (nat-Fin y) (nat-Fin z))
      ( symmetric-cong-ℕ (succ-ℕ k)
        ( add-ℕ ( nat-Fin (mul-Fin x y))
                ( nat-Fin (mul-Fin x z)))
        ( add-ℕ ( mul-ℕ (nat-Fin x) (nat-Fin y))
                ( mul-ℕ (nat-Fin x) (nat-Fin z)))
        ( congruence-add-ℕ
          ( succ-ℕ k)
          { x = nat-Fin (mul-Fin x y)}
          { y = nat-Fin (mul-Fin x z)}
          { x' = mul-ℕ (nat-Fin x) (nat-Fin y)}
          { y' = mul-ℕ (nat-Fin x) (nat-Fin z)}
          ( cong-mul-Fin x y)
          ( cong-mul-Fin x z))))

right-distributive-mul-add-Fin :
  {k : ℕ} (x y z : Fin k) →
  Id (mul-Fin (add-Fin x y) z) (add-Fin (mul-Fin x z) (mul-Fin y z))
right-distributive-mul-add-Fin {k} x y z =
  ( commutative-mul-Fin (add-Fin x y) z) ∙
  ( ( left-distributive-mul-add-Fin z x y) ∙
    ( ap-add-Fin (commutative-mul-Fin z x) (commutative-mul-Fin z y)))

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

{-
-- We introduce the absolute value of an integer. --

abs-ℤ : ℤ → ℕ
abs-ℤ (inl x) = succ-ℕ x
abs-ℤ (inr (inl star)) = zero-ℕ
abs-ℤ (inr (inr x)) = succ-ℕ x

int-abs-ℤ : ℤ → ℤ
int-abs-ℤ = int-ℕ ∘ abs-ℤ

eq-abs-ℤ : (x : ℤ) → Id zero-ℕ (abs-ℤ x) → Id zero-ℤ x
eq-abs-ℤ (inl x) p = ex-falso (Peano-8 x p)
eq-abs-ℤ (inr (inl star)) p = refl
eq-abs-ℤ (inr (inr x)) p = ex-falso (Peano-8 x p)

abs-eq-ℤ : (x : ℤ) → Id zero-ℤ x → Id zero-ℕ (abs-ℤ x)
abs-eq-ℤ .zero-ℤ refl = refl

negatives-add-ℤ :
  (x y : ℕ) → Id (add-ℤ (in-neg x) (in-neg y)) (in-neg (succ-ℕ (add-ℕ x y)))
negatives-add-ℤ zero-ℕ y = ap (inl ∘ succ-ℕ) (inv (left-unit-law-add-ℕ y))
negatives-add-ℤ (succ-ℕ x) y =
  ( ap pred-ℤ (negatives-add-ℤ x y)) ∙
  ( ap (inl ∘ succ-ℕ) (inv (left-successor-law-add-ℕ x y)))

subadditive-abs-ℤ :
  (x y : ℤ) → leq-ℕ (abs-ℤ (add-ℤ x y)) (add-ℕ (abs-ℤ x) (abs-ℤ y))
subadditive-abs-ℤ (inl x) (inl y) =
  leq-eq-ℕ
    ( abs-ℤ (add-ℤ (inl x) (inl y)))
    ( add-ℕ (succ-ℕ x) (succ-ℕ y))
    ( ( ap abs-ℤ (negatives-add-ℤ x y)) ∙
      ( ap succ-ℕ (inv (left-successor-law-add-ℕ x y))))
subadditive-abs-ℤ (inl x) (inr (inl star)) =
  leq-eq-ℕ
    ( abs-ℤ (add-ℤ (inl x) zero-ℤ))
    ( add-ℕ (succ-ℕ x) zero-ℕ)
    ( ap abs-ℤ (right-unit-law-add-ℤ (inl x)))
subadditive-abs-ℤ (inl zero-ℕ) (inr (inr zero-ℕ)) = star
subadditive-abs-ℤ (inl zero-ℕ) (inr (inr (succ-ℕ y))) =
  concatenate-leq-eq-ℕ
    ( succ-ℕ y)
    ( preserves-leq-succ-ℕ (succ-ℕ y) (succ-ℕ (succ-ℕ y)) (succ-leq-ℕ y))
    ( inv
      ( ( left-successor-law-add-ℕ zero-ℕ (succ-ℕ (succ-ℕ y))) ∙
        ( ap succ-ℕ (left-unit-law-add-ℕ (succ-ℕ (succ-ℕ y))))))
subadditive-abs-ℤ (inl (succ-ℕ x)) (inr (inr zero-ℕ)) = {!!}
subadditive-abs-ℤ (inl (succ-ℕ x)) (inr (inr (succ-ℕ y))) = {!!}
subadditive-abs-ℤ (inr x) (inl y) = {!!}
subadditive-abs-ℤ (inr x) (inr y) = {!!}

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

dist-ℤ : ℤ → ℤ → ℕ
dist-ℤ (inl x) (inl y) = dist-ℕ x y
dist-ℤ (inl x) (inr (inl star)) = succ-ℕ x
dist-ℤ (inl x) (inr (inr y)) = succ-ℕ (succ-ℕ (add-ℕ x y))
dist-ℤ (inr (inl star)) (inl y) = succ-ℕ y
dist-ℤ (inr (inr x)) (inl y) = succ-ℕ (succ-ℕ (add-ℕ x y))
dist-ℤ (inr (inl star)) (inr (inl star)) = zero-ℕ
dist-ℤ (inr (inl star)) (inr (inr y)) = succ-ℕ y
dist-ℤ (inr (inr x)) (inr (inl star)) = succ-ℕ x
dist-ℤ (inr (inr x)) (inr (inr y)) = dist-ℕ x y

dist-ℤ' : ℤ → ℤ → ℕ
dist-ℤ' x y = dist-ℤ y x

ap-dist-ℤ :
  {x y x' y' : ℤ} → Id x x' → Id y y' → Id (dist-ℤ x y) (dist-ℤ x' y')
ap-dist-ℤ refl refl = refl

eq-dist-ℤ :
  (x y : ℤ) → Id zero-ℕ (dist-ℤ x y) → Id x y
eq-dist-ℤ (inl x) (inl y) p = ap inl (eq-dist-ℕ x y p)
eq-dist-ℤ (inl x) (inr (inl star)) p = ex-falso (Peano-8 x p)
eq-dist-ℤ (inr (inl star)) (inl y) p = ex-falso (Peano-8 y p)
eq-dist-ℤ (inr (inl star)) (inr (inl star)) p = refl
eq-dist-ℤ (inr (inl star)) (inr (inr y)) p = ex-falso (Peano-8 y p)
eq-dist-ℤ (inr (inr x)) (inr (inl star)) p = ex-falso (Peano-8 x p)
eq-dist-ℤ (inr (inr x)) (inr (inr y)) p = ap (inr ∘ inr) (eq-dist-ℕ x y p)

dist-eq-ℤ' :
  (x : ℤ) → Id zero-ℕ (dist-ℤ x x)
dist-eq-ℤ' (inl x) = dist-eq-ℕ' x
dist-eq-ℤ' (inr (inl star)) = refl
dist-eq-ℤ' (inr (inr x)) = dist-eq-ℕ' x

dist-eq-ℤ :
  (x y : ℤ) → Id x y → Id zero-ℕ (dist-ℤ x y)
dist-eq-ℤ x .x refl = dist-eq-ℤ' x

{- The distance function on ℤ is symmetric. -}

symmetric-dist-ℤ :
  (x y : ℤ) → Id (dist-ℤ x y) (dist-ℤ y x)
symmetric-dist-ℤ (inl x) (inl y) = symmetric-dist-ℕ x y
symmetric-dist-ℤ (inl x) (inr (inl star)) = refl
symmetric-dist-ℤ (inl x) (inr (inr y)) =
  ap (succ-ℕ ∘ succ-ℕ) (commutative-add-ℕ x y)
symmetric-dist-ℤ (inr (inl star)) (inl y) = refl
symmetric-dist-ℤ (inr (inr x)) (inl y) =
  ap (succ-ℕ ∘ succ-ℕ) (commutative-add-ℕ x y)
symmetric-dist-ℤ (inr (inl star)) (inr (inl star)) = refl
symmetric-dist-ℤ (inr (inl star)) (inr (inr y)) = refl
symmetric-dist-ℤ (inr (inr x)) (inr (inl star)) = refl
symmetric-dist-ℤ (inr (inr x)) (inr (inr y)) = symmetric-dist-ℕ x y

-- We compute the distance from zero --

left-zero-law-dist-ℤ :
  (x : ℤ) → Id (dist-ℤ zero-ℤ x) (abs-ℤ x)
left-zero-law-dist-ℤ (inl x) = refl
left-zero-law-dist-ℤ (inr (inl star)) = refl
left-zero-law-dist-ℤ (inr (inr x)) = refl

right-zero-law-dist-ℤ :
  (x : ℤ) → Id (dist-ℤ x zero-ℤ) (abs-ℤ x)
right-zero-law-dist-ℤ (inl x) = refl
right-zero-law-dist-ℤ (inr (inl star)) = refl
right-zero-law-dist-ℤ (inr (inr x)) = refl

-- We prove the triangle inequality --

triangle-inequality-dist-ℤ :
  (x y z : ℤ) → leq-ℕ (dist-ℤ x y) (add-ℕ (dist-ℤ x z) (dist-ℤ z y))
triangle-inequality-dist-ℤ (inl x) (inl y) (inl z) =
  triangle-inequality-dist-ℕ x y z
triangle-inequality-dist-ℤ (inl x) (inl y) (inr (inl star)) =
  triangle-inequality-dist-ℕ (succ-ℕ x) (succ-ℕ y) zero-ℕ
triangle-inequality-dist-ℤ (inl x) (inl y) (inr (inr z)) = {!!}
triangle-inequality-dist-ℤ (inl x) (inr y) (inl z) = {!!}
triangle-inequality-dist-ℤ (inl x) (inr y) (inr z) = {!!}
triangle-inequality-dist-ℤ (inr x) (inl y) (inl z) = {!!}
triangle-inequality-dist-ℤ (inr x) (inl y) (inr z) = {!!}
triangle-inequality-dist-ℤ (inr x) (inr y) (inl z) = {!!}
triangle-inequality-dist-ℤ (inr x) (inr y) (inr z) = {!!}

{-

triangle-inequality-dist-ℕ :
  (m n k : ℕ) → leq-ℕ (dist-ℕ m n) (add-ℕ (dist-ℕ m k) (dist-ℕ k n))
triangle-inequality-dist-ℕ zero-ℕ zero-ℕ zero-ℕ = star
triangle-inequality-dist-ℕ zero-ℕ zero-ℕ (succ-ℕ k) = star
triangle-inequality-dist-ℕ zero-ℕ (succ-ℕ n) zero-ℕ =
  tr ( leq-ℕ (succ-ℕ n))
     ( inv (left-unit-law-add-ℕ (succ-ℕ n)))
     ( reflexive-leq-ℕ (succ-ℕ n))
triangle-inequality-dist-ℕ zero-ℕ (succ-ℕ n) (succ-ℕ k) =
  concatenate-eq-leq-eq-ℕ
    ( inv (ap succ-ℕ (left-zero-law-dist-ℕ n)))
    ( triangle-inequality-dist-ℕ zero-ℕ n k)
    ( ( ap (succ-ℕ ∘ (add-ℕ' (dist-ℕ k n))) (left-zero-law-dist-ℕ k)) ∙
      ( inv (left-successor-law-add-ℕ k (dist-ℕ k n))))
triangle-inequality-dist-ℕ (succ-ℕ m) zero-ℕ zero-ℕ = reflexive-leq-ℕ (succ-ℕ m)
triangle-inequality-dist-ℕ (succ-ℕ m) zero-ℕ (succ-ℕ k) =
  concatenate-eq-leq-eq-ℕ
    ( inv (ap succ-ℕ (right-zero-law-dist-ℕ m)))
    ( triangle-inequality-dist-ℕ m zero-ℕ k)
    ( ap (succ-ℕ ∘ (add-ℕ (dist-ℕ m k))) (right-zero-law-dist-ℕ k))
triangle-inequality-dist-ℕ (succ-ℕ m) (succ-ℕ n) zero-ℕ =
  concatenate-leq-eq-ℕ
    ( dist-ℕ m n)
    ( transitive-leq-ℕ
      ( dist-ℕ m n)
      ( succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n)))
      ( succ-ℕ (succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n))))
      ( transitive-leq-ℕ
        ( dist-ℕ m n)
        ( add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n))
        ( succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n)))
        ( triangle-inequality-dist-ℕ m n zero-ℕ)
        ( succ-leq-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n))))
      ( succ-leq-ℕ (succ-ℕ (add-ℕ (dist-ℕ m zero-ℕ) (dist-ℕ zero-ℕ n)))))
    ( ( ap (succ-ℕ ∘ succ-ℕ)
           ( ap-add-ℕ (right-zero-law-dist-ℕ m) (left-zero-law-dist-ℕ n))) ∙
      ( inv (left-successor-law-add-ℕ m (succ-ℕ n))))
triangle-inequality-dist-ℕ (succ-ℕ m) (succ-ℕ n) (succ-ℕ k) =
  triangle-inequality-dist-ℕ m n k

-- We show that dist-ℕ x y is a solution to a simple equation.

leq-dist-ℕ :
  (x y : ℕ) → leq-ℕ x y → Id (add-ℕ x (dist-ℕ x y)) y
leq-dist-ℕ zero-ℕ zero-ℕ H = refl
leq-dist-ℕ zero-ℕ (succ-ℕ y) star = left-unit-law-add-ℕ (succ-ℕ y)
leq-dist-ℕ (succ-ℕ x) (succ-ℕ y) H =
  ( left-successor-law-add-ℕ x (dist-ℕ x y)) ∙
  ( ap succ-ℕ (leq-dist-ℕ x y H))

rewrite-left-add-dist-ℕ :
  (x y z : ℕ) → Id (add-ℕ x y) z → Id x (dist-ℕ y z)
rewrite-left-add-dist-ℕ zero-ℕ zero-ℕ .zero-ℕ refl = refl
rewrite-left-add-dist-ℕ zero-ℕ (succ-ℕ y) .(succ-ℕ (add-ℕ zero-ℕ y)) refl =
  ( dist-eq-ℕ' y) ∙
  ( inv (ap (dist-ℕ (succ-ℕ y)) (left-unit-law-add-ℕ (succ-ℕ y))))
rewrite-left-add-dist-ℕ (succ-ℕ x) zero-ℕ .(succ-ℕ x) refl = refl
rewrite-left-add-dist-ℕ
  (succ-ℕ x) (succ-ℕ y) .(succ-ℕ (add-ℕ (succ-ℕ x) y)) refl =
  rewrite-left-add-dist-ℕ (succ-ℕ x) y (add-ℕ (succ-ℕ x) y) refl

rewrite-left-dist-add-ℕ :
  (x y z : ℕ) → leq-ℕ y z → Id x (dist-ℕ y z) → Id (add-ℕ x y) z
rewrite-left-dist-add-ℕ .(dist-ℕ y z) y z H refl =
  ( commutative-add-ℕ (dist-ℕ y z) y) ∙
  ( leq-dist-ℕ y z H)

rewrite-right-add-dist-ℕ :
  (x y z : ℕ) → Id (add-ℕ x y) z → Id y (dist-ℕ x z)
rewrite-right-add-dist-ℕ x y z p =
  rewrite-left-add-dist-ℕ y x z (commutative-add-ℕ y x ∙ p)

rewrite-right-dist-add-ℕ :
  (x y z : ℕ) → leq-ℕ x z → Id y (dist-ℕ x z) → Id (add-ℕ x y) z
rewrite-right-dist-add-ℕ x .(dist-ℕ x z) z H refl =
  leq-dist-ℕ x z H

-- We show that dist-ℕ is translation invariant

translation-invariant-dist-ℕ :
  (k m n : ℕ) → Id (dist-ℕ (add-ℕ k m) (add-ℕ k n)) (dist-ℕ m n)
translation-invariant-dist-ℕ zero-ℕ m n =
  ap-dist-ℕ (left-unit-law-add-ℕ m) (left-unit-law-add-ℕ n)
translation-invariant-dist-ℕ (succ-ℕ k)  m n =
  ( ap-dist-ℕ (left-successor-law-add-ℕ k m) (left-successor-law-add-ℕ k n)) ∙
  ( translation-invariant-dist-ℕ k m n)

-- We show that dist-ℕ is linear with respect to scalar multiplication

linear-dist-ℕ :
  (m n k : ℕ) → Id (dist-ℕ (mul-ℕ k m) (mul-ℕ k n)) (mul-ℕ k (dist-ℕ m n))
linear-dist-ℕ zero-ℕ zero-ℕ zero-ℕ = refl
linear-dist-ℕ zero-ℕ zero-ℕ (succ-ℕ k) = linear-dist-ℕ zero-ℕ zero-ℕ k
linear-dist-ℕ zero-ℕ (succ-ℕ n) zero-ℕ = refl
linear-dist-ℕ zero-ℕ (succ-ℕ n) (succ-ℕ k) =
  ap (dist-ℕ' (mul-ℕ (succ-ℕ k) (succ-ℕ n))) (right-zero-law-mul-ℕ (succ-ℕ k))
linear-dist-ℕ (succ-ℕ m) zero-ℕ zero-ℕ = refl
linear-dist-ℕ (succ-ℕ m) zero-ℕ (succ-ℕ k) =
  ap (dist-ℕ (mul-ℕ (succ-ℕ k) (succ-ℕ m))) (right-zero-law-mul-ℕ (succ-ℕ k))
linear-dist-ℕ (succ-ℕ m) (succ-ℕ n) zero-ℕ = refl
linear-dist-ℕ (succ-ℕ m) (succ-ℕ n) (succ-ℕ k) =
  ( ap-dist-ℕ
    ( right-successor-law-mul-ℕ (succ-ℕ k) m)
    ( right-successor-law-mul-ℕ (succ-ℕ k) n)) ∙
  ( ( translation-invariant-dist-ℕ
      ( succ-ℕ k)
      ( mul-ℕ (succ-ℕ k) m)
      ( mul-ℕ (succ-ℕ k) n)) ∙
    ( linear-dist-ℕ m n (succ-ℕ k)))
-}
-}


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

open import Categories.Category.Monoidal.Structure
  using (BraidedMonoidalCategory)

module Categories.Functor.Monoidal.Braided {o o′ ℓ ℓ′ e e′}
  (C : BraidedMonoidalCategory o ℓ e) (D : BraidedMonoidalCategory o′ ℓ′ e′)
  where

open import Level
open import Data.Product using (_,_)

open import Categories.Category using (module Commutation)
open import Categories.Functor using (Functor)
open import Categories.Functor.Monoidal
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism)

open NaturalIsomorphism

private
  module C = BraidedMonoidalCategory C
  module D = BraidedMonoidalCategory D

module Lax where

  -- Lax braided monoidal functors.

  record IsBraidedMonoidalFunctor (F : Functor C.U D.U)
         : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where
    open Functor F

    field
      isMonoidal : IsMonoidalFunctor C.monoidalCategory D.monoidalCategory F

    open IsMonoidalFunctor isMonoidal public
    open D
    open Commutation D.U

    -- coherence condition

    field
      braiding-compat : ∀ {X Y} →
                        [ F₀ X ⊗₀ F₀ Y                  ⇒ F₀ (Y C.⊗₀ X) ]⟨
                          ⊗-homo.η (X , Y)              ⇒⟨ F₀ (X C.⊗₀ Y) ⟩
                          F₁ (C.braiding.⇒.η (X , Y))
                        ≈ D.braiding.⇒.η (F₀ X , F₀ Y)  ⇒⟨ F₀ Y ⊗₀ F₀ X ⟩
                          ⊗-homo.η (Y , X)
                        ⟩

  record BraidedMonoidalFunctor : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    field
      F                   : Functor C.U D.U
      isBraidedMonoidal : IsBraidedMonoidalFunctor F

    open Functor F public
    open IsBraidedMonoidalFunctor isBraidedMonoidal public

    monoidalFunctor : MonoidalFunctor C.monoidalCategory D.monoidalCategory
    monoidalFunctor = record { isMonoidal = isMonoidal }

module Strong where

  -- Strong braided monoidal functors.

  record IsBraidedMonoidalFunctor (F : Functor C.U D.U)
         : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where
    open Functor F

    field
      isStrongMonoidal : IsStrongMonoidalFunctor C.monoidalCategory
                                                 D.monoidalCategory F

    open IsStrongMonoidalFunctor isStrongMonoidal public
    open D
    open Commutation D.U

    -- coherence condition

    field
      braiding-compat : ∀ {X Y} →
                        [ F₀ X ⊗₀ F₀ Y                  ⇒ F₀ (Y C.⊗₀ X) ]⟨
                          ⊗-homo.⇒.η (X , Y)            ⇒⟨ F₀ (X C.⊗₀ Y) ⟩
                          F₁ (C.braiding.⇒.η (X , Y))
                        ≈ D.braiding.⇒.η (F₀ X , F₀ Y)  ⇒⟨ F₀ Y ⊗₀ F₀ X ⟩
                          ⊗-homo.⇒.η (Y , X)
                        ⟩

    isLaxBraidedMonoidal : Lax.IsBraidedMonoidalFunctor F
    isLaxBraidedMonoidal = record
      { isMonoidal      = isMonoidal
      ; braiding-compat = braiding-compat
      }

  record BraidedMonoidalFunctor : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    field
      F                   : Functor C.U D.U
      isBraidedMonoidal : IsBraidedMonoidalFunctor F

    open Functor F public
    open IsBraidedMonoidalFunctor isBraidedMonoidal public

    monoidalFunctor : StrongMonoidalFunctor C.monoidalCategory
                                            D.monoidalCategory
    monoidalFunctor = record { isStrongMonoidal = isStrongMonoidal }


module Basics where

_%_ : {A B : Set}{C : B -> Set}
      (f : (x : B) -> C x)(g : A -> B)(x : A) -> C (g x)
f % g = \x -> f (g x)

-- Logic

data   False : Set where
record True  : Set where

tt : True
tt = _

¬_ : Set -> Set
¬ A = A -> False

record ∃ {A : Set}(P : A -> Set) : Set where
  field
    witness : A
    proof   : P witness

∃-intro : {A : Set}{P : A -> Set}(x : A) -> P x -> ∃ P
∃-intro x p = record { witness = x; proof = p }

infixr 15 _/\_ _×_

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

_/\_ = _×_

-- Maybe

data Lift (A : Set) : Set where
  bot  : Lift A
  lift : A -> Lift A

_=<<_ : {A B : Set} -> (A -> Lift B) -> Lift A -> Lift B
f =<< bot    = bot
f =<< lift v = f v

-- Nat

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

-- Identity

infix 10 _==_

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

data Id {A : Set}(x : A) : Set where
  it : (y : A) -> x == y -> Id x

-- Booleans

data Bool : Set where
  true  : Bool
  false : Bool

data LR : Set where
  left  : LR
  right : LR

if_then_else_ : {A : Set} -> Bool -> A -> A -> A
if true  then x else y = x
if false then x else y = y

-- Lists

infixr 50 _::_

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

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