module x06-747Connectives-hc where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ)
open import Function using (_∘_)

------------------------------------------------------------------------------
-- BEGIN : Copied from 747Isomorphism.

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

infix 0 _≃_
record _≃_ (A B : Set) : Set where
  constructor mk-≃  -- This has been added, not in PLFA
  field
    to   : A → B
    from : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
    to∘from : ∀ (y : B) → to (from y) ≡ y
open _≃_

infix 0 _≲_
record _≲_ (A B : Set) : Set where
  field
    to      : A → B
    from    : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
open _≲_

record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
open _⇔_

-- You may copy over the various reasoning modules if you wish.

-- END : Copied from 747Isomorphism.
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- logical AND is Cartesian product.

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

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

-- destructors (aka eliminators) for ×.

proj₁ : ∀ {A B : Set}
  → A × B
    -----
  → A

proj₁ ⟨ a , _ ⟩ = a

proj₂ : ∀ {A B : Set}
  → A × B
    -----
  →     B

proj₂ ⟨ _ , b ⟩ = b

-- equivalent construction using records
record _×′_ (A B : Set) : Set where
  field
    proj₁′ : A
    proj₂′ : B
open _×′_

-- eta-equivalence relates constructors and destructors
η-× : ∀ {A B : Set} (w : A × B) → ⟨ proj₁ w , proj₂ w ⟩ ≡ w
η-× ⟨ a , b ⟩ = refl

-- type with two members
infixr 2 _×_
data Bool : Set where
  true  : Bool
  false : Bool

-- type with three members (used in examples)
data Tri : Set where
  aa : Tri
  bb : Tri
  cc : Tri

-- Bool × Tri has six members
×-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

-- Cartesian product is commutative and associative up to isomorphism.

swap : ∀ {A B : Set} → A × B → B × A
swap ⟨ a , b ⟩ = ⟨ b , a ⟩

×-comm : ∀ {A B : Set} → A × B ≃ B × A
to      ×-comm = swap
from    ×-comm = swap
from∘to ×-comm ⟨ _ , _ ⟩ = refl
to∘from ×-comm ⟨ _ , _ ⟩ = refl

×-assoc : ∀ {A B C : Set} → (A × B) × C ≃ A × (B × C)
to      ×-assoc ⟨ ⟨ a ,   b ⟩ , c ⟩   = ⟨   a , ⟨ b ,   c ⟩ ⟩
from    ×-assoc ⟨   a , ⟨ b ,   c ⟩ ⟩ = ⟨ ⟨ a ,   b ⟩ , c ⟩
from∘to ×-assoc ⟨ ⟨ _ ,   _ ⟩ , _ ⟩   = refl
to∘from ×-assoc ⟨   _ , ⟨ _ ,   _ ⟩ ⟩ = refl

-- A ⇔ B is isomorphic to (A → B) × (B → A)
iff-iso-if-onlyif : ∀ {A B : Set} → A ⇔ B ≃ (A → B) × (B → A)
_≃_.to         iff-iso-if-onlyif record { to = to ; from = from } = ⟨ to , from ⟩
to   (_≃_.from iff-iso-if-onlyif            ⟨ A→B , B→A ⟩)        = A→B
from (_≃_.from iff-iso-if-onlyif            ⟨ A→B , B→A ⟩)        = B→A
from∘to        iff-iso-if-onlyif record { to = to ; from = from } = refl
to∘from        iff-iso-if-onlyif            ⟨ A→B , B→A ⟩         = refl

------------------------------------------------------------------------------
-- logical True is a type with one member (unit)
data ⊤ : Set where
  tt :
    --
    ⊤

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

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

-- Unit is the left and right identity of product.

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

⊤-identityʳ : ∀ {A : Set} → (A × ⊤) ≃ A
to      ⊤-identityʳ ⟨ a , ⊤  ⟩ =   a
from    ⊤-identityʳ   a        = ⟨ a , tt ⟩
from∘to ⊤-identityʳ ⟨ a , tt ⟩ = refl
to∘from ⊤-identityʳ   a        = refl

------------------------------------------------------------------------------
-- logical OR (disjunction) is sum (disjoint union)

data _⊎_ : Set → Set → Set where

  inj₁ : ∀ {A B : Set}
    → A
      -----
    → A ⊎ B

  inj₂ : ∀ {A B : Set}
    →     B
      -----
    → A ⊎ B

-- a way to eliminate a sum (but easier to use pattern-matching to eliminate sums)
case-⊎ : ∀ {A B C : Set}
  → (A → C)
  → (B → C)
  →  A ⊎ B
    -----------
  →      C
case-⊎ f g (inj₁ x) = f x
case-⊎ f g (inj₂ x) = g x

-- eta equivalence for sums
η-⊎ : ∀ {A B : Set} (w : A ⊎ B) → case-⊎ inj₁ inj₂ w ≡ w
η-⊎ (inj₁ _) = refl
η-⊎ (inj₂ _) = refl

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

infix 1 _⊎_

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

-- Sum is commutative up to isomorphism.
⊎-comm : ∀ {A B : Set} → A ⊎ B ≃ B ⊎ A
to      ⊎-comm (inj₁ a) = inj₂ a
to      ⊎-comm (inj₂ b) = inj₁ b
from    ⊎-comm (inj₁ b) = inj₂ b
from    ⊎-comm (inj₂ a) = inj₁ a
from∘to ⊎-comm (inj₁ _) = refl
from∘to ⊎-comm (inj₂ _) = refl
to∘from ⊎-comm (inj₁ _) = refl
to∘from ⊎-comm (inj₂ _) = refl

-- Sum is associative up to isomorphism.
⊎-assoc : ∀ {A B C : Set} → (A ⊎ B) ⊎ C ≃ A ⊎ (B ⊎ C)
to      ⊎-assoc (inj₁ (inj₁ a)) = inj₁ a
to      ⊎-assoc (inj₁ (inj₂ b)) = inj₂ (inj₁ b)
to      ⊎-assoc (inj₂ c)        = inj₂ (inj₂ c)
from    ⊎-assoc (inj₁ a)        = inj₁ (inj₁ a)
from    ⊎-assoc (inj₂ (inj₁ b)) = inj₁ (inj₂ b)
from    ⊎-assoc (inj₂ (inj₂ c)) = inj₂ c
from∘to ⊎-assoc (inj₁ (inj₁ _)) = refl
from∘to ⊎-assoc (inj₁ (inj₂ _)) = refl
from∘to ⊎-assoc (inj₂ _)        = refl
to∘from ⊎-assoc (inj₁ _)        = refl
to∘from ⊎-assoc (inj₂ (inj₁ _)) = refl
to∘from ⊎-assoc (inj₂ (inj₂ _)) = refl

------------------------------------------------------------------------------
-- logical False is the empty type ("bottom", "empty")

data ⊥ : Set where
  -- no clauses

-- Ex falso quodlibet "from falsehood, anything follows".
⊥-elim : ∀ {A : Set}
  → ⊥
    --
  → A

⊥-elim ()

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

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

-- Empty is the left unit of sum up to isomorphism.
⊎-identityˡ : ∀ {A : Set} → ⊥ ⊎ A ≃ A
to      ⊎-identityˡ (inj₂ a) = a
from    ⊎-identityˡ       a  = inj₂ a
from∘to ⊎-identityˡ (inj₂ _) = refl
to∘from ⊎-identityˡ       _  = refl

-- Empty is the right unit of sum up to isomorphism.
⊎-identityʳ : ∀ {A : Set} → A ⊎ ⊥ ≃ A
to      ⊎-identityʳ (inj₁ a) = a
from    ⊎-identityʳ       a  = inj₁ a
from∘to ⊎-identityʳ (inj₁ _) = refl
to∘from ⊎-identityʳ       _  = refl

------------------------------------------------------------------------------
-- logical implication (if-then) is the function TYPE constructor.
-- Eliminating an if-then (modus ponens) is function application.

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

→-elim L M = L M

-- →-elim works because eta-reduction for → is built in

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

-- The function space A → B is called the exponential Bᴬ.
-- Bool → Tri has 3² (9) members.
→-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" : functions of multiple parameters
-- math  : (p ^ n) ^ m = p ^ (n * m)
-- types : (A ^ B) ^ C ≃ A ^ (B × C)
currying : ∀ {A B C : Set} → (A → B → C) ≃ (A × B → C)
to      currying f = λ { ⟨ a , b ⟩ → f a b }
from    currying f = λ a b →  f ⟨ a , b ⟩
from∘to currying _ = refl
to∘from currying f = extensionality λ { ⟨ x , y ⟩ → refl }

-- math, : p ^ (n + m) =  (p ^ n) * (p ^ m)
-- types : (A ⊎ B → C) ≃ ((A → C) × (B → C))
→-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B → C) ≃ ((A → C) × (B → C))
to      →-distrib-⊎ f             = ⟨ (λ a → f (inj₁ a)) , (λ b → f (inj₂ b)) ⟩
from    →-distrib-⊎ ⟨ A→C , B→C ⟩ = λ { (inj₁ a) → A→C a ; (inj₂ b) → B→C b }
from∘to →-distrib-⊎ _             = extensionality λ { (inj₁ x) → refl ; (inj₂ x) → refl }
to∘from →-distrib-⊎               = λ{ ⟨ g , h ⟩ → refl }

-- math  : (p * n) ^ m = (p ^ m) * (n ^ m)
-- types : (A → B × C) ≃ (A → B) × (A → C)
→-distrib-× : ∀ {A B C : Set} → (A → B × C) ≃ (A → B) × (A → C)
to      →-distrib-× f = ⟨ (λ a → proj₁ (f a)) , (λ a → proj₂ (f a)) ⟩
from    →-distrib-× f = λ a → ⟨ proj₁ f a , proj₂ f a ⟩
from∘to →-distrib-×   = λ a→b×c → extensionality λ a → η-× (a→b×c a)
to∘from →-distrib-×   = λ { ⟨ _ , _ ⟩ → refl }

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

-- Think of a counterexample to show this is not an isomorphism. TODO
⊎-distrib-× : ∀ {A B C : Set} → (A × B) ⊎ C ≲ (A ⊎ C) × (B ⊎ C)
to      ⊎-distrib-× (inj₁ ⟨ a , b ⟩)    = ⟨ inj₁ a , inj₁ b ⟩
to      ⊎-distrib-× (inj₂ c)            = ⟨ inj₂ c , inj₂ c ⟩
from    ⊎-distrib-× ⟨ inj₁ a , inj₁ b ⟩ = inj₁ ⟨ a , b ⟩
from    ⊎-distrib-× ⟨ inj₁ a , inj₂ c ⟩ = inj₂ c
from    ⊎-distrib-× ⟨ inj₂ c , inj₁ b ⟩ = inj₂ c
from    ⊎-distrib-× ⟨ inj₂ c , inj₂ C ⟩ = inj₂ c -- inj₂ C also valid (loses info)
from∘to ⊎-distrib-×                     = λ { (inj₁ ⟨ a , b ⟩) → refl ; (inj₂ c) → refl }

×-distrib-→ : ∀ {A B C : Set} → (C → (A × B)) ≃ (C → A) × (C → B)
to      ×-distrib-→ f = ⟨ (λ c →   proj₁ (f c)) , (λ c → proj₂ (f c)) ⟩
from    ×-distrib-→ f =    λ c → ⟨ proj₁  f c   ,        proj₂  f c   ⟩
from∘to ×-distrib-→   =    λ { c→a×b → extensionality λ c → η-× (c→a×b c) }
to∘from ×-distrib-→   =    λ { ⟨ c→a , c→b ⟩ → refl }

⊎-distrib-→ : ∀ {A B C : Set} → ((A ⊎ B) → C) ≃ (A → C) × (B → C)
to      ⊎-distrib-→ f = ⟨ (λ a →  f (inj₁ a)) , (λ b → f (inj₂ b)) ⟩
from    ⊎-distrib-→ f = λ { (inj₁ a) → (proj₁ f a) ; (inj₂ b) → (proj₂ f b) }
--from∘to ⊎-distrib-→ f = extensionality λ a⊎b → {!!} -- TODO
from∘to ⊎-distrib-→   = λ { a⊎b→c → extensionality λ { (inj₁ a) → refl ; (inj₂ b) → refl } }
to∘from ⊎-distrib-→   = λ { ⟨ a→c , b→c ⟩ → refl }

-- PLFA exercise: a weak distributive law.
⊎-weak-× : ∀ {A B C : Set} → (A ⊎ B) × C → A ⊎ (B × C)
⊎-weak-× ⟨ inj₁ a , c ⟩ = inj₁ a
⊎-weak-× ⟨ inj₂ b , c ⟩ = inj₂ ⟨ b , c ⟩
-- State and prove the strong law, and explain the relationship. TODO

-- SumOfProdImpProdOfSum : disjunct of conjuncts implies a conjunct of disjuncts.
⊎×-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 is NOT true
×⊎-implies-⊎×-not : ∀ {A B C D : Set}
                  → (A ⊎ C) × (B ⊎ D)
                  → (A × B) ⊎ (C × D)
×⊎-implies-⊎×-not ⟨ inj₁ a , inj₁ b ⟩ = inj₁ ⟨ a , b ⟩
×⊎-implies-⊎×-not ⟨ inj₁ a , inj₂ d ⟩ = {!!} -- A × B ⊎ C × D -- not possible
×⊎-implies-⊎×-not ⟨ inj₂ c , inj₁ b ⟩ = {!!} -- A × B ⊎ C × D -- not possible
×⊎-implies-⊎×-not ⟨ inj₂ c , inj₂ d ⟩ = inj₂ ⟨ c , d ⟩


------------------------------------------------------------------------
-- The Agda standard library
--
-- Several kinds of "relatedness" for containers such as equivalences,
-- surjections and bijections
------------------------------------------------------------------------

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

module Data.Container.Related where

open import Level using (_⊔_)
open import Data.Container.Core
import Function.Related as Related
open import Relation.Binary
open import Data.Container.Membership

open Related public
  using (Kind; Symmetric-kind)
  renaming ( implication         to subset
           ; reverse-implication to superset
           ; equivalence         to set
           ; injection           to subbag
           ; reverse-injection   to superbag
           ; bijection           to bag
           )

[_]-Order : ∀ {s p ℓ} → Kind → Container s p → Set ℓ →
            Preorder (s ⊔ p ⊔ ℓ) (s ⊔ p ⊔ ℓ) (p ⊔ ℓ)
[ k ]-Order C X = Related.InducedPreorder₂ k (_∈_ {C = C} {X = X})

[_]-Equality : ∀ {s p ℓ} → Symmetric-kind → Container s p → Set ℓ →
               Setoid (s ⊔ p ⊔ ℓ) (p ⊔ ℓ)
[ k ]-Equality C X = Related.InducedEquivalence₂ k (_∈_ {C = C} {X = X})

infix 4 _∼[_]_
_∼[_]_ : ∀ {s p x} {C : Container s p} {X : Set x} →
         ⟦ C ⟧ X → Kind → ⟦ C ⟧ X → Set (p ⊔ x)
_∼[_]_ {C = C} {X} xs k ys = Preorder._∼_ ([ k ]-Order C X) xs ys


-- Example usage of solver

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

open import Categories.Category
open import Categories.Category.Cartesian

module Experiment.Categories.Solver.Category.Cartesian.Example
  {o ℓ e} {𝒞 : Category o ℓ e} (cartesian : Cartesian 𝒞) where

open import Experiment.Categories.Solver.Category.Cartesian cartesian

open Category 𝒞
open Cartesian cartesian
open HomReasoning

private
  variable
    A B C D E F : Obj

module _ {f : D ⇒ E} {g : C ⇒ D} {h : B ⇒ C} {i : A ⇒ B} where
  _ : (f ∘ g) ∘ id ∘ h ∘ i ≈ f ∘ (g ∘ h) ∘ i
  _ = solve ((∥-∥ :∘ ∥-∥) :∘ :id :∘ ∥-∥ :∘ ∥-∥) (∥-∥ :∘ (∥-∥ :∘ ∥-∥) :∘ ∥-∥) refl

swap∘swap≈id :
  ∀ {A B} → swap {A}{B} ∘ swap {B}{A} ≈ id
swap∘swap≈id {A} {B} =
  solve (:swap {∥ A ∥} {∥ B ∥} :∘ :swap)
        :id
        refl

assocʳ∘assocˡ≈id : ∀ {A B C} → assocʳ {A}{B}{C} ∘ assocˡ {A}{B}{C} ≈ id
assocʳ∘assocˡ≈id = solve (:assocʳ {∥ _ ∥} {∥ _ ∥} {∥ _ ∥} :∘ :assocˡ) :id refl

module _ {f : B ⇒ C} (f′ : A ⇒ B) {g : E ⇒ F} {g′ : D ⇒ E} where
  ⁂-∘ : (f ⁂ g) ∘ (f′ ⁂ g′) ≈ (f ∘ f′) ⁂ (g ∘ g′)
  ⁂-∘ = solve lhs rhs refl where
    lhs = (∥ f ∥ :⁂ ∥ g ∥) :∘ (∥ f′ ∥ :⁂ ∥ g′ ∥)
    rhs = (∥ f ∥ :∘ ∥ f′ ∥) :⁂ (∥ g ∥ :∘ ∥ g′ ∥)

module _ {A B C D} where
  pentagon′ : (id ⁂ assocˡ) ∘ assocˡ ∘ (assocˡ ⁂ id) ≈
              assocˡ ∘ assocˡ {A × B} {C} {D}
  pentagon′ = solve lhs rhs refl where
    lhs = (:id :⁂ :assocˡ) :∘ :assocˡ :∘ (:assocˡ :⁂ :id)
    rhs = :assocˡ :∘ :assocˡ {∥ A ∥ :× ∥ B ∥} {∥ C ∥} {∥ D ∥}

module _ {A B C} where
  hexagon₁′ : (id ⁂ swap) ∘ assocˡ ∘ (swap ⁂ id) ≈
              assocˡ ∘ swap ∘ assocˡ {A}{B}{C}
  hexagon₁′ = solve lhs rhs refl where
    lhs = (:id :⁂ :swap) :∘ :assocˡ :∘ (:swap :⁂ :id)
    rhs = :assocˡ :∘ :swap :∘ :assocˡ {∥ A ∥}{∥ B ∥}{∥ C ∥}

module _ {f : A ⇒ B} where
  commute : ⟨ ! , id ⟩ ∘ f ≈ ⟨ id ∘ π₁ , f ∘ π₂ ⟩ ∘ ⟨ ! , id ⟩
  commute = solve (:⟨ :! , :id ⟩ :∘ ∥ f ∥)
                  (:⟨ :id :∘ :π₁ , ∥ f ∥ :∘ :π₂ ⟩ :∘ :⟨ :! , :id ⟩)
                  refl

_ : id {⊤} ≈ !
_ = solve (∥ id !∥) :! refl

_ : π₁ {⊤} {⊤} ≈ π₂
_ = solve (:π₁ {:⊤} {:⊤}) :π₂ refl

module _ {f : A ⇒ B} {g : C ⇒ D} where
  first↔second′ : first f ∘ second g ≈ second g ∘ first f
  first↔second′ = solve (:first ∥ f ∥ :∘ :second ∥ g ∥)
                        (:second ∥ g ∥ :∘ :first ∥ f ∥)
                        refl


{-# OPTIONS -v treeless.opt:20 #-}
module _ where

open import Agda.Builtin.Nat renaming (_<_ to _<?_)
open import Common.Prelude
open import Common.Equality

data _<_ (a b : Nat) : Set where
  diff : (k : Nat) → b ≡ suc k + a → a < b

data Comparison {a} {A : Set a} (_<_ : A → A → Set a) (x y : A) : Set a where
  less    : x < y → Comparison _<_ x y
  equal   : x ≡ y → Comparison _<_ x y
  greater : y < x → Comparison _<_ x y

compare : (a b : Nat) → Comparison _<_ a b
compare a b with a <? b
... | true  = less (diff (b ∸ suc a) primTrustMe)
... | false with b <? a
...   | true  = greater (diff (a ∸ suc b) primTrustMe)
...   | false = equal primTrustMe

{-# INLINE compare #-}

-- This should compile to two calls of _<?_ and only the possible cases.
compare-lots : (a b : Nat) → String
compare-lots a b with compare a b | compare (suc a) (suc b)
compare-lots a b | less (diff k eq) | less (diff k₁ eq₁) = "less-less"
compare-lots a .a | less (diff k eq) | equal refl = "less-equal"
compare-lots a _ | less (diff k refl) | greater (diff j eq) = "less-greater"
compare-lots a .a | equal refl | less (diff k eq₁) = "equal-less"
compare-lots a b | equal eq | equal eq₁ = "equal-equal"
compare-lots a .a | equal refl | greater (diff k eq₁) = "equal-greater"
compare-lots _ b | greater (diff k refl) | less (diff j eq) = "greater-less"
compare-lots _ b | greater (diff k refl) | equal eq = "greater-equal"
compare-lots a b | greater (diff k eq) | greater (diff k₁ eq₁) = "greater-greater"

main : IO Unit
main = putStrLn (compare-lots 1500 2000) ,,
       putStrLn (compare-lots 2000 1500) ,,
       putStrLn (compare-lots 2000 2000)


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

open import lib.Basics
open import lib.NType2
open import lib.NConnected
open import lib.types.Nat
open import lib.types.Subtype
open import lib.types.Truncation

-- classifying types of automorphism groups of types
module lib.types.BAut where

BAut : ∀ {i} → Type i → Type (lsucc i)
BAut {i} A = Σ (Type i) λ X → Trunc -1 (A == X)

BAut-prop : ∀ {i} (A : Type i) → SubtypeProp (Type i) (lsucc i)
BAut-prop A = ((λ X → Trunc -1 (A == X)) , (λ X → Trunc-level))

pBAut : ∀ {i} → Type i → Ptd (lsucc i)
de⊙ (pBAut A) = BAut A
pt (pBAut A) = A , [ idp ]

BAut-trunc-path : ∀ {i} (A X : Type i) → (tp : Trunc -1 (A == X))
                  → Trunc -1 ((A , [ idp ]) == (X , tp) :> BAut A)
BAut-trunc-path {i} A X = Trunc-elim λ p → [ pair= p prop-has-all-paths-↓ ]

BAut-conn : ∀ {i} (A : Type i) → is-connected 0 (BAut A)
fst (has-level-apply (BAut-conn A)) = [ pt (pBAut A) ]
snd (has-level-apply (BAut-conn A)) = Trunc-elim (λ { (X , tp) → <– (=ₜ-equiv [ A , [ idp ] ] [ X , tp ])
                                                                    (BAut-trunc-path A X tp) })


-----------------------------------------------------------------------------------
-- This file contains facts about equational reasoning pertaining to categories. --
-----------------------------------------------------------------------------------
module Category.CatEq where

open import Level

open import Category.Category
open import Setoid.Total

-- The following models the communative square:
--
--  A ---f₁---> C
--  |           |
--  f₃          f₂
--  |           |
--  V           V
--  D ---f₄---> D
--
-- However, as an equation.
comm-square : {l : Level}{ℂ : Cat {l}}{A B D C : Obj ℂ}
            → el (Hom ℂ A B)
            → el (Hom ℂ B C)
            → el (Hom ℂ A D)
            → el (Hom ℂ D C)
            → Set l
comm-square {ℂ = ℂ}{A}{C = C} f₁ f₂ f₃ f₄ = ⟨ Hom ℂ A C ⟩[ f₁ ○[ comp ℂ ] f₂ ≡ f₃ ○[ comp ℂ ] f₄ ]


module WarningOnUsage where

id : {A : Set} → A → A
id x = x

-- Deprecated names

λx→x = id

{-# WARNING_ON_USAGE λx→x "DEPRECATED: Use `id` instead of `λx→x`" #-}

open import Agda.Builtin.Equality

_ : {A : Set} {x : A} → λx→x x ≡ x
_ = refl


------------------------------------------------------------------------------
-- Agda-Prop Library.
-- Theorems of ⇔ connective.
------------------------------------------------------------------------------

open import Data.Nat using ( ℕ )

module Data.PropFormula.Theorems.Biimplication ( n : ℕ ) where

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

open import Data.PropFormula.Theorems.Classical n
open import Data.PropFormula.Theorems.Implication n
  using ( ⊃-to-¬∨; ⊃⊃-to-∧⊃; ∧⊃-to-⊃⊃ )
open import Data.PropFormula.Theorems.Negation n
  using ( ¬-equiv₁ ; ¬-equiv₂; ¬∨-to-⊃; ¬¬-equiv₁; ¬¬-equiv₂ )
open import Data.PropFormula.Syntax n

open import Function using ( _$_ )

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

-- Theorem.
⇔-equiv₁
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ⇔ ψ
  → Γ ⊢ (φ ⊃ ψ) ∧ (ψ ⊃ φ)

-- Proof.
⇔-equiv₁ {Γ}{φ}{ψ} Γ⊢φ⇔ψ =
  ∧-intro
    (⊃-intro
      (⇔-elim₁
        (assume φ)
        (weaken φ Γ⊢φ⇔ψ)))
    (⊃-intro
      (⇔-elim₂
        (assume ψ)
         (weaken ψ Γ⊢φ⇔ψ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
⇔-equiv₂
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ (φ ⊃ ψ) ∧ (ψ ⊃ φ)
  → Γ ⊢ φ ⇔ ψ

-- Proof.
⇔-equiv₂ {φ = φ}{ψ} Γ⊢⟪φ⊃ψ⟫∧⟪ψ⊃φ⟫ =
  ⇔-intro
    (⊃-elim
      (weaken φ (∧-proj₁ Γ⊢⟪φ⊃ψ⟫∧⟪ψ⊃φ⟫))
      (assume φ))
    (⊃-elim
      (weaken ψ (∧-proj₂ Γ⊢⟪φ⊃ψ⟫∧⟪ψ⊃φ⟫))
      (assume ψ))
-------------------------------------------------------------------------- ∎

-- Theorem.
⇔-equiv
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ (φ ⇔ ψ) ⇔ ((φ ⊃ ψ) ∧ (ψ ⊃ φ))

-- Proof.
⇔-equiv {Γ}{φ}{ψ} =
  ⇔-intro
    (⇔-equiv₁
      (assume (φ ⇔ ψ)))
    (⇔-equiv₂
      (assume ((φ ⊃ ψ) ∧ (ψ ⊃ φ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
⇔-assoc₁
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ φ ⇔ (ψ ⇔ γ)
  → Γ ⊢ (φ ⇔ ψ) ⇔ γ

-- Proof.
⇔-assoc₁ {Γ}{φ = φ}{ψ}{γ} thm =
  ⇔-intro
    (RAA
      (¬-elim
        (¬-intro
          (¬-elim
            (¬-intro
              (¬-elim
                (weaken φ $ weaken (ψ ⇔ γ) $ assume {Γ = Γ , φ ⇔ ψ} (¬ γ))
                (⇔-elim₁
                  (⇔-elim₁
                    (assume {Γ = Γ , φ ⇔ ψ , ¬ γ , ψ ⇔ γ} φ)
                    (weaken φ $ weaken (ψ ⇔ γ)
                        (weaken (¬ γ) $ assume (φ ⇔ ψ))))
                  (⇔-elim₁
                    (assume {Γ = Γ , φ ⇔ ψ , ¬ γ , ψ ⇔ γ} φ)
                    (weaken φ $ weaken (ψ ⇔ γ) $ weaken (¬ γ) $
                      weaken (φ ⇔ ψ) thm)))))
            (⇔-elim₂
              (assume {Γ = Γ , φ ⇔ ψ , ¬ γ} (ψ ⇔ γ))
              (weaken (ψ ⇔ γ) $ weaken (¬ γ) $ weaken (φ ⇔ ψ) thm))))
        (⇔-intro
          (⊥-elim γ
            (¬-elim
              (⊥-elim (¬ ψ)
                (¬-elim
                  (¬-intro -- ¬ φ
                    (¬-elim
                      (weaken φ $ weaken ψ $ assume {Γ = Γ , φ ⇔ ψ} (¬ γ))
                      (⇔-elim₁
                        (⇔-elim₁
                          (assume {Γ = Γ , φ ⇔ ψ , ¬ γ , ψ} φ)
                          (weaken φ
                            (weaken ψ
                              (weaken (¬ γ)
                                (assume (φ ⇔ ψ))))))
                        (⇔-elim₁
                          (assume {Γ = Γ , φ ⇔ ψ , ¬ γ , ψ} φ)
                          (weaken φ $
                            weaken ψ $ weaken (¬ γ) $ weaken (φ ⇔ ψ) thm)))))
                  (⇔-elim₂ -- φ
                    (assume {Γ = Γ , φ ⇔ ψ , ¬  γ} ψ)
                    (weaken ψ (weaken (¬ γ) (assume (φ ⇔ ψ)))))))
              (assume {Γ = Γ , φ ⇔ ψ , ¬ γ} ψ)))
          (⊥-elim ψ
            (¬-elim
              (weaken γ $ assume {Γ = Γ , φ ⇔ ψ} (¬ γ))
              (assume {Γ = Γ , φ ⇔ ψ , ¬ γ} γ))))))
    (⇔-intro
      (⇔-elim₂
        (weaken φ $ assume γ)
        (⇔-elim₁
          (assume {Γ = Γ , γ} φ)
          (weaken φ $ weaken γ thm)))
      (⇔-elim₂
        (⇔-intro
          (weaken ψ $ weaken ψ $ assume γ)
          (weaken γ $ assume {Γ = Γ , γ} ψ))
        (weaken ψ $ weaken γ thm)))
-------------------------------------------------------------------------- ∎

-- Theorem.
⇔-assoc₂
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ⇔ ψ) ⇔ γ
  → Γ ⊢ φ ⇔ (ψ ⇔ γ)

-- Proof.
⇔-assoc₂ {Γ}{φ}{ψ}{γ} thm =
  ⇔-intro
    (⇔-intro
      (⇔-elim₁
        (⇔-intro
          (weaken φ (assume {Γ = Γ , φ} ψ))
          (weaken ψ (weaken ψ (assume φ))))
        (weaken ψ (weaken φ thm)))
      (⇔-elim₁
        (weaken γ (assume φ))
          (⇔-elim₂
            (assume {Γ = Γ , φ} γ)
            (weaken γ (weaken φ thm)))))
    (RAA
      (¬-elim
        (¬-intro
          (¬-elim
            (¬-intro
              (¬-elim
                (weaken γ $ weaken (φ ⇔ ψ) $ assume {Γ = Γ , ψ ⇔ γ} (¬ φ))
                (⇔-elim₂
                  (⇔-elim₂
                    (assume {Γ = Γ , ψ ⇔ γ , ¬ φ , (φ ⇔ ψ)} γ)
                    (weaken γ $ weaken (φ ⇔ ψ) $ weaken (¬ φ) $
                      assume (ψ ⇔ γ)))
                  (⇔-elim₂
                    (assume {Γ = Γ , ψ ⇔ γ , ¬ φ , (φ ⇔ ψ)} γ)
                    (weaken γ $ weaken (φ ⇔ ψ) $ weaken (¬ φ) $
                      weaken (ψ ⇔ γ) thm)))))
            (⇔-elim₁
              (assume {Γ = Γ , ψ ⇔ γ , ¬ φ} (φ ⇔ ψ))
              (weaken (φ ⇔ ψ) (weaken (¬ φ) (weaken (ψ ⇔ γ) thm))))))
        (⇔-intro
          (⊥-elim ψ
            (¬-elim
              (weaken φ $ assume {Γ = Γ , ψ ⇔ γ} (¬ φ))
              (assume {Γ = Γ , ψ ⇔ γ , ¬ φ} φ)))
          (⊥-elim φ
            (¬-elim
              (⊥-elim (¬ ψ)
                (¬-elim
                  (¬-intro
                    (¬-elim
                      (weaken γ $ weaken ψ $ assume {Γ = Γ , ψ ⇔ γ} (¬ φ))
                      (⇔-elim₂
                        (weaken γ $ assume {Γ = Γ , ψ ⇔ γ , ¬ φ} ψ)
                        (⇔-elim₂
                          (assume {Γ = Γ , ψ ⇔ γ , ¬ φ , ψ} γ)
                          (weaken γ $ weaken ψ $ weaken (¬ φ) $
                            weaken (ψ ⇔ γ) thm)))))
                  (⇔-elim₁
                    (assume {Γ = Γ , ψ ⇔ γ , ¬ φ} ψ)
                    (weaken ψ (weaken (¬ φ) (assume (ψ ⇔ γ)))))))
              (assume {Γ = Γ , ψ ⇔ γ , ¬ φ} ψ))))))
-------------------------------------------------------------------------- ∎

-- Theorem.
⇔-assoc
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ⇔ (ψ ⇔ γ)) ⇔ ((φ ⇔ ψ) ⇔ γ)

-- Proof.
⇔-assoc {φ = φ}{ψ}{γ} =
  ⇔-intro
    (⇔-assoc₁ (assume (φ ⇔ ψ ⇔ γ)))
    (⇔-assoc₂ (assume ((φ ⇔ ψ) ⇔ γ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
⇔-comm
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ⇔ ψ
  → Γ ⊢ ψ ⇔ φ

-- Proof.
⇔-comm {Γ}{φ}{ψ} Γ⊢φ⇔ψ =
  ⇔-intro
    (⇔-elim₂ (assume ψ) (weaken ψ Γ⊢φ⇔ψ))
    (⇔-elim₁ (assume φ) (weaken φ Γ⊢φ⇔ψ))
-------------------------------------------------------------------------- ∎

-- Theorem.
⊃-⇔-¬∨
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ (φ ⊃ ψ) ⇔ (¬ φ ∨ ψ)

-- Proof.

⊃-⇔-¬∨ {Γ}{φ}{ψ} =
  ⇔-intro
    (⊃-to-¬∨ (assume (φ ⊃ ψ)))
    (¬∨-to-⊃ (assume (¬ φ ∨ ψ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
bicon₀-thm
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ⇔ ψ → Γ ⊢ ¬ φ
  → Γ ⊢ ¬ ψ
⇔-¬-to-¬ = bicon₀-thm

-- Proof.
bicon₀-thm {Γ}{φ}{ψ} Γ⊢φ⇔ψ Γ⊢¬ψ =
  ¬-equiv₂
    (⊃-intro
      (¬-elim
        (weaken ψ Γ⊢¬ψ)
      (⇔-elim₂
        (assume ψ)
        (weaken ψ Γ⊢φ⇔ψ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
bicon₁-thm
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ ¬ φ ⇔ ψ → Γ ⊢ φ
  → Γ ⊢ ¬ ψ
¬⇔-to-¬ = bicon₁-thm

-- Proof.
bicon₁-thm {Γ}{φ}{ψ} Γ⊢¬φ⇔ψ Γ⊢φ =
  ¬-equiv₂
    (⊃-intro
      (¬-elim
        (⇔-elim₂
          (assume ψ)
          (weaken ψ Γ⊢¬φ⇔ψ))
        (weaken ψ Γ⊢φ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
¬-equiv
  : ∀ {Γ} {φ}
  → Γ ⊢ ¬ φ ⇔ (φ ⊃ ⊥)

-- Proof.
¬-equiv {Γ}{φ} =
  ⇔-intro
    (¬-equiv₁ (assume (¬ φ)))
    (¬-equiv₂ (assume (φ ⊃ ⊥)))
-------------------------------------------------------------------------- ∎

-- Theorem.
¬¬-equiv
  : ∀ {Γ} {φ}
  → Γ ⊢ ¬ (¬ φ) ⇔ φ

-- Proof.
¬¬-equiv {Γ}{φ} =
  ⇔-intro
    (¬¬-equiv₁ (assume (¬ (¬ φ))))
    (¬¬-equiv₂ (assume φ))
-------------------------------------------------------------------------- ∎

-- Theorem.
⊃⊃-⇔-∧⊃
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ⊃ (ψ ⊃ γ)) ⇔ ((φ ∧ ψ) ⊃ γ)

-- Proof.
⊃⊃-⇔-∧⊃ {φ = φ}{ψ}{γ} =
  ⇔-intro
    (⊃⊃-to-∧⊃ (assume (φ ⊃ ψ ⊃ γ)))
    (∧⊃-to-⊃⊃ (assume (φ ∧ ψ ⊃ γ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
⇔-trans
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ γ ⇔ φ
  → Γ ⊢ φ ⇔ ψ
  → Γ ⊢ γ ⇔ ψ
subst⊢⇔₁ = ⇔-trans

-- Proof.
⇔-trans {φ = φ}{ψ}{γ} Γ⊢γ⇔φ Γ⊢φ⇔ψ =
  ⇔-intro
    (⇔-elim₁
      (⇔-elim₁
        (assume γ)
        (weaken γ Γ⊢γ⇔φ))
      (weaken γ Γ⊢φ⇔ψ))
    (⇔-elim₂
      (⇔-elim₂
        (assume ψ)
        (weaken ψ Γ⊢φ⇔ψ))
      (weaken ψ Γ⊢γ⇔φ))
-------------------------------------------------------------------------- ∎


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

module LogicalFramework.AdequacyTheorems where

module Example5 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁    : A → C
    f₂    : B → C

  g : (A → C) → (B → C) → A ∨ B → C
  g f₁ f₂ (inj₁ a) = f₁ a
  g f₁ f₂ (inj₂ b) = f₂ b

  g' : (A → C) → (B → C) → A ∨ B → C
  g' f₁ f₂ x = case f₁ f₂ x

module Example7 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    C  : D → D → Set
    d  : ∀ {a} → C a a

  g : ∀ {a b} → a ≡ b → C a b
  g refl = d

  g' : ∀ {a b} → a ≡ b → C a b
  g' {a} h = subst (C a) h d

module Example10 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁ : A → C
    f₂ : B → C

  f : A ∨ B → C
  f (inj₁ a) = f₁ a
  f (inj₂ b) = f₂ b

  f' : A ∨ B → C
  f' = case f₁ f₂

module Example20 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  f : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f {A} {t} {.t} refl At = d At
    where
    postulate d : A t → A t

  f' : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f' {A} h At = subst A h At

module Example30 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C E : Set
    f₁ : A → E
    f₂ : B → E
    f₃ : C → E

  g : (A ∨ B) ∨ C → E
  g (inj₁ (inj₁ a)) = f₁ a
  g (inj₁ (inj₂ b)) = f₂ b
  g (inj₂ c)        = f₃ c

  g' : (A ∨ B) ∨ C → E
  g' = case (case f₁ f₂) f₃

module Example40 where

  infixl 9  _+_ _+'_
  infix  7  _≡_

  data ℕ : Set where
    zero :     ℕ
    succ : ℕ → ℕ

  ℕ-ind : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
  ℕ-ind A A0 h zero     = A0
  ℕ-ind A A0 h (succ n) = h n (ℕ-ind A A0 h n)

  data _≡_ (x : ℕ) : ℕ → Set where
    refl : x ≡ x

  subst : (A : ℕ → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A refl Ax = Ax

  _+_ : ℕ → ℕ → ℕ
  zero   + n = n
  succ m + n = succ (m + n)

  _+'_ : ℕ → ℕ → ℕ
  m +' n = ℕ-ind (λ _ → ℕ) n (λ x y → succ y) m

  -- Properties using pattern matching.
  succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong refl = refl

  +-rightIdentity : ∀ n → n + zero ≡ n
  +-rightIdentity zero     = refl
  +-rightIdentity (succ n) = succCong (+-rightIdentity n)

  -- Properties using the basic inductive constants.
  succCong' : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong' {m} h = subst (λ x → succ m ≡ succ x) h refl

  +'-leftIdentity : ∀ n → zero +' n ≡ n
  +'-leftIdentity n = refl

  +'-rightIdentity : ∀ n → n +' zero ≡ n
  +'-rightIdentity = ℕ-ind A A0 is
    where
    A : ℕ → Set
    A n = n +' zero ≡ n

    A0 : A zero
    A0 = refl

    is : ∀ n → A n → A (succ n)
    is n ih = succCong' ih

module Example50 where

  infixl 10 _*_
  infixl 9  _+_
  infix  7  _≡_

  data ℕ : Set where
    zero :     ℕ
    succ : ℕ → ℕ

  ℕ-ind : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
  ℕ-ind A A0 h zero     = A0
  ℕ-ind A A0 h (succ n) = h n (ℕ-ind A A0 h n)

  data _≡_ (x : ℕ) : ℕ → Set where
    refl : x ≡ x

  ℕ-rec : {A : Set} → A → (ℕ → A → A) → ℕ → A
  ℕ-rec {A} = ℕ-ind (λ _ → A)

  _+_ : ℕ → ℕ → ℕ
  m + n = ℕ-rec n (λ _ x → succ x) m

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

  +-Sx : ∀ m n → succ m + n ≡ succ (m + n)
  +-Sx m n = refl

  _*_ : ℕ → ℕ → ℕ
  m * n = ℕ-rec zero (λ _ x → n + x) m

  *-0x : ∀ n → zero * n ≡ zero
  *-0x n = refl

  *-Sx : ∀ m n → succ m * n ≡ n + m * n
  *-Sx m n = refl


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

open import HoTT

{- Move (parts of) faces of a cube around -}

module lib.cubical.elims.CubeMove where

square-push-rb : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ b : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} (p₁₋ : a₁₀ == b) (q : b == a₁₁)
  → Square p₀₋ p₋₀ p₋₁ (p₁₋ ∙ q)
  → Square p₀₋ p₋₀ (p₋₁ ∙' ! q) p₁₋
square-push-rb idp idp sq = sq

private
  right-from-front-lemma : ∀ {i} {A : Type i}
    {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
    {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
    {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
    {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

    {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
    {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
    (sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁) -- right

    {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
    {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
    {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
    {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ (p₋₀₁ ∙ idp)} -- top
    {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ (p₋₁₁ ∙ idp)} -- bottom
    {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
    → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ (square-push-rb p₋₀₁ idp sq₋₀₋)
           (square-push-rb p₋₁₁ idp sq₋₁₋) (sq₁₋₋ ⊡h' !□h hid-square)
    → Cube sq₋₋₀ (sq₋₋₁ ⊡h hid-square) sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
  right-from-front-lemma ids cu = cu

cube-right-from-front : ∀ {i} {A : Type i}
  {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ b₀ b₁ : A}
  {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
  {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
  {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

  {p₀₋₁ : a₀₀₁ == a₀₁₁}
  {p₋₀₁ : a₀₀₁ == b₀} {q₋₀₁ : b₀ == a₁₀₁}
  {r : b₀ == b₁}
  {p₋₁₁ : a₀₁₁ == b₁} {q₋₁₁ : b₁ == a₁₁₁}
  {p₁₋₁ : a₁₀₁ == a₁₁₁}
  (sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ r) -- right

  {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
  {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
  {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
  {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ (p₋₀₁ ∙ q₋₀₁)} -- top
  {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ (p₋₁₁ ∙ q₋₁₁)} -- bottom
  {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
  (sq' : Square r q₋₀₁ q₋₁₁ p₁₋₁)
  → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ (square-push-rb p₋₀₁ q₋₀₁ sq₋₀₋)
         (square-push-rb p₋₁₁ q₋₁₁ sq₋₁₋) (sq₁₋₋ ⊡h' !□h sq')
  → Cube sq₋₋₀ (sq₋₋₁ ⊡h sq') sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
cube-right-from-front sq₋₋₁ ids cu = right-from-front-lemma sq₋₋₁ cu


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

open import level using (Level; _⊔_)
open import function.core

infixr 4 _,_
infixr 2 _×_
infixr 1 _⊎_

record Σ {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

_×_ : {l k : Level} (A : Set l) (B : Set k) → Set (l ⊔ k)
A × B = Σ A λ _ → B

uncurry : ∀ {a b c} {A : Set a} {B : A → Set b} {C : (x : A) → (B x) → Set c}
        → ((x : A) → (y : B x) → C x y) → ((xy : Σ A B) → C (proj₁ xy) (proj₂ xy))
uncurry f (a , b) = f a b

uncurry' : ∀ {i j k}{X : Set i}{Y : Set j}{Z : Set k}
        → (X → Y → Z)
        → (X × Y) → Z
uncurry' f (x , y) = f x y

data _⊎_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

[_,⊎_] : ∀ {i i' j}{A : Set i}{A' : Set i'}{B : Set j}
      → (A → B) → (A' → B)
      → A ⊎ A' → B
[ f ,⊎ f' ] (inj₁ a) = f a
[ f ,⊎ f' ] (inj₂ a') = f' a'

map-⊎ : ∀ {i i' j j'}{A : Set i}{A' : Set i'}
      → {B : Set j}{B' : Set j'}
      → (A → B) → (A' → B')
      → A ⊎ A' → B ⊎ B'
map-⊎ g g' = [ inj₁ ∘' g ,⊎ inj₂ ∘' g' ]


-- Category of sets and functions

module Control.Category.SetsAndFunctions where

open import Level using (zero; suc; _⊔_)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary
open import Data.Product

open import Axiom.FunctionExtensionality

open import Control.Category
open import Control.Category.Product

-- Category SET

Functions : Set → Set → Setoid _ _
Functions A B = setoid (A → B)

setIsCategory : IsCategory Functions
setIsCategory = record
  { ops = record
    { id  = λ x → x
    ; _⟫_ = λ f g x → g (f x)
    }
  ; laws = record
    { id-first = refl
    ; id-last  = refl
    ; ∘-assoc  = λ f → refl
    ; ∘-cong   = λ{ refl refl → refl }
    }
  }

SET : Category _ _ _
SET = record { Hom = Functions; isCategory = setIsCategory }

{-
timesProductStructure : (A B : Set) → ProductStructure SET A B
timesProductStructure A B = record
  { A×B = A × B
  ; fst = proj₁
  ; snd = proj₂
  }

⟨_,_⟩ :  {A B C : Set} (f : C → A) (g : C → B) → C → A × B
⟨ f , g ⟩ = λ x → f x , g x

pairIsPair : {A B C : Set} (f : C → A) (g : C → B) →
  IsPair (timesProductStructure A B) f g ⟨ f , g ⟩
pairIsPair f g = record
  { β-fst = refl
  ; β-snd = refl
  }

open IsPair

pairPair : {A B C : Set} (f : C → A) (g : C → B) →
  Pair (timesProductStructure A B) f g
pairPair f g = record
  { ⟨f,g⟩  = ⟨ f , g ⟩
  ; isPair = pairIsPair f g
  ; unique =  λ p → fun-ext (λ x → cong₂ (λ f g → f x , g x) (β-fst p) (β-snd p))
  }

timesIsProduct : (A B : Set) → Product SET A B
timesIsProduct A B = record
  { productStructure = timesProductStructure A B
  ; isProduct = record { pair = pairPair }
  }

-- -}


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

open import lib.Basics

module lib.types.FreeGroup where

module _ {i} where

  private
    data #FreeGroup-aux (A : Type i) : Type i where
      #fg-nil : #FreeGroup-aux A
      _#fg::_ : A → #FreeGroup-aux A → #FreeGroup-aux A
      _#fg-inv::_ : A → #FreeGroup-aux A → #FreeGroup-aux A

    {- Is this okay?  The template is to have 'data' here,
     - but then the β rules for paths will not typecheck.
     -}
    record #FreeGroup (A : Type i) : Type i where
      constructor
        #freegroup
      field
        #freegroup-proj : #FreeGroup-aux A
        #freegroup-unit : Unit → Unit

  FreeGroup : (A : Type i) → Type i
  FreeGroup A = #FreeGroup A

  module _ {A : Type i} where

    fg-nil : FreeGroup A
    fg-nil = #freegroup #fg-nil _

    infixr 60 _fg::_
    _fg::_ : A → FreeGroup A → FreeGroup A
    a fg:: (#freegroup fg _) = #freegroup (a #fg:: fg) _

    infixr 60 _fg-inv::_
    _fg-inv::_ : A → FreeGroup A → FreeGroup A
    a fg-inv:: (#freegroup fg _) = #freegroup (a #fg-inv:: fg) _

    postulate  -- HIT
      fg-inv-l : ∀ (a : A) → (fg : FreeGroup A) → a fg-inv:: a     fg:: fg == fg
      fg-inv-r : ∀ (a : A) → (fg : FreeGroup A) → a fg::     a fg-inv:: fg == fg

    postulate  -- HIT
      FreeGroup-level : is-set (FreeGroup A)

    FreeGroup-is-set = FreeGroup-level

    module FreeGroupElim {j} {P : FreeGroup A → Type j}
      (p : (x : FreeGroup A) → is-set (P x)) (nil* : P fg-nil)
      (_fg::*_ : ∀ a {fg} (fg* : P fg) → P (a fg:: fg))
      (_fg-inv::*_ : ∀ a {fg} (fg* : P fg) → P (a fg-inv:: fg))
      (fg-inv-l* : ∀ a {fg} (fg* : P fg) → (a fg-inv::* (a     fg::* fg*)) == fg* [ P ↓ fg-inv-l a fg ] )
      (fg-inv-r* : ∀ a {fg} (fg* : P fg) → (a fg::*     (a fg-inv::* fg*)) == fg* [ P ↓ fg-inv-r a fg ]) where

      f : Π (FreeGroup A) P
      f = f-aux phantom phantom phantom where

        f-aux* : Π (#FreeGroup-aux A) (P ∘ (λ fg → #freegroup fg _))
        f-aux* #fg-nil = nil*
        f-aux* (a #fg:: fg) = a fg::* f-aux* fg
        f-aux* (a #fg-inv:: fg) = a fg-inv::* f-aux* fg

        f-aux : Phantom p → Phantom fg-inv-l* → Phantom fg-inv-r*
          → Π (FreeGroup A) P
        f-aux phantom phantom phantom (#freegroup fg _) = f-aux* fg

      postulate  -- HIT
        fg-inv-l-β : ∀ a fg → apd f (fg-inv-l a fg) == fg-inv-l* a (f fg)
        fg-inv-r-β : ∀ a fg → apd f (fg-inv-r a fg) == fg-inv-r* a (f fg)

open FreeGroupElim public renaming (f to FreeGroup-elim)

module FreeGroupRec {i} {A : Type i} {j} {B : Type j} (p : is-set B)
  (nil* : B) (_fg::*[_]_ : A → FreeGroup A → B → B) (_fg-inv::*[_]_ : A → FreeGroup A → B → B)
  (fg-inv-l* : ∀ a {fg} fg* → (a fg-inv::*[ a     fg:: fg ] (a     fg::*[ fg ] fg*)) == fg*)
  (fg-inv-r* : ∀ a {fg} fg* → (a     fg::*[ a fg-inv:: fg ] (a fg-inv::*[ fg ] fg*)) == fg*) where

  private
    module M = FreeGroupElim (λ x → p) nil*
      (λ a {fg} fg* → a     fg::*[ fg ] fg*)
      (λ a {fg} fg* → a fg-inv::*[ fg ] fg*)
      (λ a {fg} fg* → ↓-cst-in (fg-inv-l* a {fg} fg*))
      (λ a {fg} fg* → ↓-cst-in (fg-inv-r* a {fg} fg*))

  f : FreeGroup A → B
  f = M.f

open FreeGroupRec public renaming (f to FreeGroup-rec)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Integers
------------------------------------------------------------------------

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

module Data.Integer where

import Data.Nat.Show as ℕ
open import Data.Sign as Sign using (Sign)
open import Data.String.Base using (String; _++_)

------------------------------------------------------------------------
-- Integers, basic types and operations

open import Data.Integer.Base public

------------------------------------------------------------------------
-- Re-export queries from the properties modules

open import Data.Integer.Properties public
  using (_≟_; _≤?_)

------------------------------------------------------------------------
-- Conversions

show : ℤ → String
show i = showSign (sign i) ++ ℕ.show ∣ i ∣
  where
  showSign : Sign → String
  showSign Sign.- = "-"
  showSign Sign.+ = ""

------------------------------------------------------------------------
-- Deprecated

-- Version 0.17

open import Data.Integer.Properties public
  using (◃-cong; drop‿+≤+; drop‿-≤-)
  renaming (◃-inverse to ◃-left-inverse)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Finite sets, based on AVL trees
------------------------------------------------------------------------

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

module Data.AVL.Sets
  {k ℓ} {Key : Set k} {_<_ : Rel Key ℓ}
  (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_)
  where

import Data.AVL as AVL
open import Data.Bool
open import Data.List as List using (List)
open import Data.Maybe as Maybe
open import Data.Product as Prod using (_×_; _,_; proj₁)
open import Data.Unit
open import Function
open import Level

-- The set type. (Note that Set is a reserved word.)

private
  open module S = AVL (const ⊤) isStrictTotalOrder
    public using () renaming (Tree to ⟨Set⟩)

-- Repackaged functions.

empty : ⟨Set⟩
empty = S.empty

singleton : Key → ⟨Set⟩
singleton k = S.singleton k _

insert : Key → ⟨Set⟩ → ⟨Set⟩
insert k = S.insert k _

delete : Key → ⟨Set⟩ → ⟨Set⟩
delete = S.delete

_∈?_ : Key → ⟨Set⟩ → Bool
_∈?_ = S._∈?_

headTail : ⟨Set⟩ → Maybe (Key × ⟨Set⟩)
headTail s = Maybe.map (Prod.map proj₁ id) (S.headTail s)

initLast : ⟨Set⟩ → Maybe (⟨Set⟩ × Key)
initLast s = Maybe.map (Prod.map id proj₁) (S.initLast s)

fromList : List Key → ⟨Set⟩
fromList = S.fromList ∘ List.map (λ k → (k , _))

toList : ⟨Set⟩ → List Key
toList = List.map proj₁ ∘ S.toList


module ExtractCaseSplit where

open import Data.Maybe
open import Agda.Builtin.Bool

not : Bool -> Bool
not true = false
not false = true

func : Maybe Bool -> Bool

func nothing = false
func (just x) = not x

open import Data.List

func2 : List Bool -> Bool
func2 [] = true
func2 (x ∷ x₁) = not (func2 x₁)


------------------------------------------------------------------------
-- Coinductive lists
------------------------------------------------------------------------

module Data.Colist where

open import Coinduction
open import Data.Bool          using (Bool; true; false)
open import Data.Maybe         using (Maybe; nothing; just)
open import Data.Nat           using (ℕ; zero; suc)
open import Data.Conat
open import Data.List          using (List; []; _∷_)
open import Data.List.NonEmpty using (List⁺; _∷_)
                               renaming ([_] to [_]⁺)
open import Data.BoundedVec.Inefficient as BVec
  using (BoundedVec; []; _∷_)
open import Data.Product using (_,_)
open import Data.Function
open import Relation.Binary

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

infixr 5 _∷_

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

data Any {A} (P : A → Set) : Colist A → Set where
  here  : ∀ {x xs} (px  : P x)          → Any P (x ∷ xs)
  there : ∀ {x xs} (pxs : Any P (♭ xs)) → Any P (x ∷ xs)

data All {A} (P : A → Set) : Colist A → Set where
  []  : All P []
  _∷_ : ∀ {x xs} (px : P x) (pxs : ∞ (All P (♭ xs))) → All P (x ∷ xs)

------------------------------------------------------------------------
-- Some operations

null : ∀ {A} → Colist A → Bool
null []      = true
null (_ ∷ _) = false

length : ∀ {A} → Colist A → Coℕ
length []       = zero
length (x ∷ xs) = suc (♯ length (♭ xs))

map : ∀ {A B} → (A → B) → Colist A → Colist B
map f []       = []
map f (x ∷ xs) = f x ∷ ♯ map f (♭ xs)

fromList : ∀ {A} → List A → Colist A
fromList []       = []
fromList (x ∷ xs) = x ∷ ♯ fromList xs

take : ∀ {A} (n : ℕ) → Colist A → BoundedVec A n
take zero    xs       = []
take (suc n) []       = []
take (suc n) (x ∷ xs) = x ∷ take n (♭ xs)

replicate : ∀ {A} → Coℕ → A → Colist A
replicate zero    x = []
replicate (suc n) x = x ∷ ♯ replicate (♭ n) x

lookup : ∀ {A} → ℕ → Colist A → Maybe A
lookup n       []       = nothing
lookup zero    (x ∷ xs) = just x
lookup (suc n) (x ∷ xs) = lookup n (♭ xs)

infixr 5 _++_

_++_ : ∀ {A} → Colist A → Colist A → Colist A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ ♯ (♭ xs ++ ys)

concat : ∀ {A} → Colist (List⁺ A) → Colist A
concat []               = []
concat ([ x ]⁺   ∷ xss) = x ∷ ♯ concat (♭ xss)
concat ((x ∷ xs) ∷ xss) = x ∷ ♯ concat (xs ∷ xss)

[_] : ∀ {A} → A → Colist A
[ x ] = x ∷ ♯ []

------------------------------------------------------------------------
-- Equality and other relations

-- xs ≈ ys means that xs and ys are equal.

infix 4 _≈_

data _≈_ {A} : (xs ys : Colist A) → Set where
  []  :                                       []     ≈ []
  _∷_ : ∀ x {xs ys} (xs≈ : ∞ (♭ xs ≈ ♭ ys)) → x ∷ xs ≈ x ∷ ys

-- x ∈ xs means that x is a member of xs.

infix 4 _∈_

data _∈_ {A : Set} : A → Colist A → Set where
  here  : ∀ {x   xs}                   → x ∈ x ∷ xs
  there : ∀ {x y xs} (x∈xs : x ∈ ♭ xs) → x ∈ y ∷ xs

-- xs ⊑ ys means that xs is a prefix of ys.

infix 4 _⊑_

data _⊑_ {A : Set} : Colist A → Colist A → Set where
  []  : ∀ {ys}                            → []     ⊑ ys
  _∷_ : ∀ x {xs ys} (p : ∞ (♭ xs ⊑ ♭ ys)) → x ∷ xs ⊑ x ∷ ys

------------------------------------------------------------------------
-- Some proofs

setoid : Set → Setoid
setoid A = record
  { carrier       = Colist A
  ; _≈_           = _≈_
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }
  where
  refl : Reflexive _≈_
  refl {[]}     = []
  refl {x ∷ xs} = x ∷ ♯ refl

  sym : Symmetric _≈_
  sym []        = []
  sym (x ∷ xs≈) = x ∷ ♯ sym (♭ xs≈)

  trans : Transitive _≈_
  trans []        []         = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

poset : Set → Poset
poset A = record
  { carrier        = Colist A
  ; _≈_            = _≈_
  ; _≤_            = _⊑_
  ; isPartialOrder = record
    { isPreorder = record
      { isEquivalence = Setoid.isEquivalence (setoid A)
      ; reflexive     = reflexive
      ; trans         = trans
      ; ∼-resp-≈      = ((λ {_} → ⊑-resp-≈ˡ) , λ {_} → ⊑-resp-≈ʳ)
      }
    ; antisym  = antisym
    }
  }
  where
  reflexive : _≈_ ⇒ _⊑_
  reflexive []        = []
  reflexive (x ∷ xs≈) = x ∷ ♯ reflexive (♭ xs≈)

  trans : Transitive _⊑_
  trans []        _          = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

  ⊑-resp-≈ˡ : {xs : Colist A} →  (λ ys → xs ⊑ ys) Respects _≈_
  ⊑-resp-≈ˡ _         []       = []
  ⊑-resp-≈ˡ (x ∷ xs≈) (.x ∷ p) = x ∷ ♯ ⊑-resp-≈ˡ (♭ xs≈) (♭ p)

  ⊑-resp-≈ʳ : {ys : Colist A} →  (λ xs → xs ⊑ ys) Respects _≈_
  ⊑-resp-≈ʳ []        _        = []
  ⊑-resp-≈ʳ (x ∷ xs≈) (.x ∷ p) = x ∷ ♯ ⊑-resp-≈ʳ (♭ xs≈) (♭ p)

  antisym : Antisymmetric _≈_ _⊑_
  antisym []       []        = []
  antisym (x ∷ p₁) (.x ∷ p₂) = x ∷ ♯ antisym (♭ p₁) (♭ p₂)

map-cong : ∀ {A B} (f : A → B) → _≈_ =[ map f ]⇒ _≈_
map-cong f []        = []
map-cong f (x ∷ xs≈) = f x ∷ ♯ map-cong f (♭ xs≈)

take-⊑ : ∀ {A} n (xs : Colist A) →
         let toColist = fromList ∘ BVec.toList in
         toColist (take n xs) ⊑ xs
take-⊑ zero    xs       = []
take-⊑ (suc n) []       = []
take-⊑ (suc n) (x ∷ xs) = x ∷ ♯ take-⊑ n (♭ xs)


open import Agda.Primitive
open import Agda.Builtin.Equality   renaming (_≡_ to _==_) --(( If I want to rename the built-in equality ))

-- What follows is an attempt to formalize multicategories. For this purpose, we also need to define lists, since the source of a multimap in a multicategory is a list.
-- For the moment, I do not try to prove that the lists an the associated concatenation form a monoid (because I do not know if this is useful or not).

module MultiCategories where

  -- ** Function extensionality **
  postulate
    funext : ∀ {X : Set} {Y : X → Set} {f g : ∀ (x : X) → (Y x)} → (∀ (x : X) → ((f x) == (g x))) → (f == g)

  -- ** Lists **

  -- We first define lists
  data List {l : Level} (A : Set l) : Set l where
    [] : List A
    _::_ : A → List A → List A

  infixr 30 _::_

  open List

  -- We define equality on lists, that extends the built-in equality (since for the moment, we dont need other definitions of equality → but maybe we could do something more general by asking the "equality" as a parameter ?)
  data _≡ᴸ_ {l : Level} {A : Set l} : (u v : List {l} A) → Set (lsuc l) where
    eq-nil : [] ≡ᴸ []
    eq-cons : ∀ (x y : A) (su sv : List A) → (x == y) → (su ≡ᴸ sv) → ( (x :: su) ≡ᴸ (y :: sv))

  -- We define the mapping of lists
  list-map : ∀ {l : Level} {A B : Set l} → (f : A → B) → List A → List B
  list-map f [] = []
  list-map f (x :: u) = ((f x) :: (list-map f u))

  -- We define the concatenation of lists
  _++_ : ∀ {l}{A : Set l} → List A → List A → List A
  [] ++ ys = ys
  (x :: xs) ++ ys = x :: (xs ++ ys)

  -- We define a fold function
  fold : ∀ {l : Level} {A B : Set l} → (A → B → B) → B → List A → B
  fold _⊗_ e [] =  e
  fold _⊗_ e (x :: xs)  =  x ⊗ (fold _⊗_ e xs)

  -- We define a flatten function
  flatten : ∀ {l : Level} {A : Set l} → (u : List ( List A)) → (List A)
  flatten [] = []
  flatten (x :: xs) = x ++ (flatten xs)
  --  (I wanted to do this with the above fold function, which would be more elegant, but I don't know why, I miserably failed at it - must be tired)

  -- We define a function that takes a list of functions and a list of arguments and apply the functions point to point
  list-apply : ∀ {l : Level} {A B : Set l} → (list-f : List (A → B)) → (list-arg : List A) → List B
  list-apply [] [] = []
  list-apply (f :: fs) [] = []
  list-apply [] (x :: xs) = []
  list-apply (f :: fs) (x :: xs) = (f x) :: (list-apply fs xs)
  -- The two cases in the middle should be forbidden, but I don't know how to do this

  -- ** Multicategories **

  -- -- We first define the multimaps on a set
  -- data Multimap {l : Level} {O : Setl l} : Set l where
  --   map : ()

  record MultiCategory {l : Level} : Set (lsuc l) where
    field
      -- Objects and maps
      object : Set l
      multimap : Set l
      sources : ∀ (m : multimap) → List object
      target : ∀ (m : multimap) → object
      -- Composition and associated equations / conditions
      _∘_ : ∀ (f : multimap) → (list : List multimap) → multimap
      plug : ∀ {g : multimap} → {f : multimap} → {list : List multimap} → {g == (f ∘ list)} →  (sources f) ≡ᴸ (list-map target list)
      dom-comp : ∀ {f : multimap} → {list : List multimap} → ((flatten (list-map sources list)) ≡ᴸ (sources (f ∘ list)))
      comp-codom : ∀ (f : multimap) → (list : List multimap) → (target f == target (f ∘ list))
      -- Identities and associated equations / conditions
      id : ∀ (o : object) → multimap
      id-dom-codom : ∀ (o : object) → (sources (id o) == o :: [] )
      id-codom :  ∀ (o : object) → (target (id o) == o)
      id-left : ∀ {o : object} {f : multimap} → {f == id o} → (list : List multimap) → ( (f ∘ list) == f)
      id-rigth : ∀ {f : multimap} {list : List multimap} → {list ≡ᴸ (list-map id (sources f))} → ((f ∘ list) == f)
      -- Associativity
      assoc : ∀ {f : multimap} {list-g : List multimap} {list-h : List (List multimap)} → (f ∘ (list-apply (list-map _∘_ list-g) list-h)) == ( (f ∘ list-g) ∘ (flatten list-h))

  open MultiCategory

  -- List over a list
  data ListOver {l : Level} {A : Set l} (B : A → Set l) : List A → Set l where
    [[]] : ListOver B []
    _:::_ : ∀ {x xs} → (y : B x) → (ys : ListOver B xs) → ListOver B (x :: xs)

  infixr 25 _:::_

  over-map : ∀ {l : Level} {A : Set l} {B : A → Set l} {xs} {C : Set l} → (∀ {x} → B x → C) → ListOver B xs → List C
  over-map f [[]] = []
  over-map f (y ::: ys) = f y :: over-map f ys

  over-over-map : ∀ {l : Level} {A : Set l} {B : A → Set l} {xs} {C : A → Set l} → (∀ {x} → B x → C x) → ListOver B xs → ListOver C xs
  over-over-map f [[]] = [[]]
  over-over-map f (y ::: ys) = f y ::: over-over-map f ys

  over-lift : ∀ {l : Level} {A : Set l} (list : List A) → ListOver (λ x → A) list
  over-lift [] = [[]]
  over-lift (y :: ys) = y ::: (over-lift ys)

  over-flatten : ∀ {l : Level} {A B : Set l} {list : List A} (list-ov : ListOver (λ x → List B) list) → List B
  over-flatten [[]] = []
  over-flatten (x ::: xs) = x ++ (over-flatten xs)

  -- Dependent sum
  record Σ {l} (A : Set l) (B : A → Set l) : Set l where
    constructor ⟨_,_⟩
    field
      π₁ : A
      π₂ : B π₁

  open Σ

  -- Shortcuts to map the projections on lists when the dependent sum is a "product"
  list-π₁ : ∀ {l : Level} {A : Set l} {B} (list : List ( Σ {l} A B)) → List A
  list-π₁ list = list-map π₁ list

  list-π₂ : ∀ {l : Level} {A C : Set l} (list : List ( Σ {l} A ( λ x → C))) → List C
  list-π₂ list = list-map π₂ list

  -- A more dependent attempt at multicategories
  record MultiCategory2 {l : Level} : Set (lsuc l) where
    field
      object : Set l
      multimap : List object → object → Set l
      𝟙 : ∀ {x} → multimap (x :: []) x
      _•_ : ∀ {ys x} → multimap ys x → ∀ (gs : ListOver (λ y → Σ (List object) (λ zs → multimap zs y)) ys) →
            multimap (flatten (over-map π₁ gs)) x
      -- Another attempt to define multimaps, "putting the dependance elsewhere"
      _●_ : ∀ {x : object} {ys : List (Σ (List object) (λ x → object))} → multimap (list-π₂ ys) x → ListOver (λ y → multimap (π₁ y) (π₂ y)) ys → multimap (flatten (list-π₁ ys)) x
      -- here complications start
      -- 𝟙-left : ∀ {ys x} → (f : multimap ys x) → 𝟙 • (⟨ ys , f ⟩ ::: [[]]) == f
      -- 𝟙-right : ∀ {ys x} → (f : multimap ys x) → f • (over-over-map ? (over-lift ys)) == f
      --(ListOver ( λ y → ⟨ x ::: [[]] , 𝟙 ⟩ ) ys) == f
      -- Attempt with the alternative composition
      𝟙-left-● : ∀ {x ys} → (f : multimap ys x) → 𝟙 ● (f ::: [[]]) == f -- Here it seems that we have a lemma to prove to say that ys = (ys ++ flatten (list-map π₁ [])). Do we do it locally or would it be useful to have a more genral lemma ?

-- Here I tried to fix 𝟙-left and to define 𝟙-right, but I did not manage to do it, it both cases. Maybe we should revise the definition of _•_ ?
-- Agda seems to struggle with the fact that thnigs that should be equal are not equal by definition (conversion/reduction problems). Maybe there are some lemmas to prove here.
-- Also, I do not understand why we use the "over-map" : it would feel more natural to me if, once we lift a list to a dependent one, and use dependant lists, we only use dependeant lists, that's why I defined over-lift and over-over-map. (I also defined an "over-flatten" but don't know if it's useful)


module MetaCannotDependOn where

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

postulate
  Vec : Nat -> Set -> Set
  f : (A : Set) -> ((n : Nat) -> A -> Vec n Nat) -> Nat

err : Nat
err = f _ (\ n xs -> xs)


module Ex3Lec where

----------------------------------------------------------------------------
-- EXERCISE 3 -- MONADS FOR HUTTON'S RAZOR
--
-- VALUE:     15%
-- DEADLINE:  5pm, Friday 20 November (week 9)
--
-- DON'T SUBMIT, COMMIT!
--
-- The purpose of this exercise is to introduce you to some useful
-- mathematical structures and build good tools for working with
-- vectors
----------------------------------------------------------------------------

open import CS410-Prelude
open import CS410-Monoid
open import CS410-Nat
open import CS410-Vec
open import CS410-Functor

-- HINT: your tasks are heralded with the eminently searchable tag, "???"

----------------------------------------------------------------------------
-- HUTTON'S RAZOR
----------------------------------------------------------------------------

HVal : Set   -- the set of *values* for Hutton's Razor
HVal = Two + Nat   -- Booleans or natural numbers

foo : HVal
foo = tt , ff

goo : HVal
goo = ff , 42

data HExp (X : Set) : Set where
  var        : X -> HExp X                  -- variables
  val        : HVal -> HExp X               -- values
  _+H_ _>=H_ : (e1 e2 : HExp X) -> HExp X   -- addition, comparison
  ifH_then_else_ : (e1 e2 e3 : HExp X) -> HExp X  -- conditional

_>=2_ : Nat -> Nat -> Two
x      >=2  zero   = tt
zero   >=2  suc _  = ff
suc m  >=2  suc n  = m >=2 n

----------------------------------------------------------------------------
-- ??? 3.1 the HExp syntax-with-substitution monad            (score: ? / 2)
----------------------------------------------------------------------------

-- Show that HExp is a monad, where the "bind" operation performs
-- simultaneous substitution (transforming all the variables in a term).

hExpMonad : Monad HExp
hExpMonad = record { return = {!!} ; _>>=_ = {!!} }

----------------------------------------------------------------------------
-- ??? 3.2 the error management monad                         (score: ? / 1)
----------------------------------------------------------------------------

-- show that "+ E" is monadic, generalising the "Maybe" monad by allowing
-- some sort of error report

errorMonad : (E : Set) -> Monad \ V -> V + E   -- "value or error"
errorMonad E = {!!}

----------------------------------------------------------------------------
-- ??? 3.3 the environment monad transformer                   (score: ? / 1)
----------------------------------------------------------------------------

-- show that "+ E" is monadic, generalising the "Maybe" monad by allowing
-- some sort of error report

envMonad : (G : Set){M : Set -> Set} -> Monad M ->
           Monad \ V -> G -> M V      -- "computation in an environment"
envMonad G MM = {!!} where
  open Monad MM

----------------------------------------------------------------------------
-- ??? 3.4 interpreting Hutton's Razor                        (score: ? / 3)
----------------------------------------------------------------------------

-- Implement an interpreter for Hutton's Razor.
-- You will need to construct a type to represent possible run-time errors.
-- Ensure that addition and comparison act on numbers, not Booleans.
-- Ensure that the condition in an "if" is a Boolean, not a number.

data InterpretError : Set where

-- helpful things to build

Env : Set -> Set    -- an environment for a given set of variables
Env X = X -> HVal

Compute : Set{- variables -} -> Set{- values -} -> Set
Compute X V = Env X -> V + InterpretError  -- how to compute a V

computeMonad : {X : Set} -> Monad (Compute X)
computeMonad = {!!} -- build this from the above parts

-- This operation should explain how to get the value of a variable
-- from the environment.
varVal : {X : Set} -> X -> Compute X HVal
varVal x = {!!}

-- These operations should ensure that you get the sort of value
-- that you want, in order to ensure that you don't do bogus
-- computation.
mustBeNat : {X : Set} -> HVal -> Compute X Nat
mustBeNat v = {!!}

mustBeTwo : {X : Set} -> HVal -> Compute X Two
mustBeTwo v = {!!}

-- Now, you're ready to go. Don't introduce the environent explicitly.
-- Use the monad to thread it.

interpret : {X : Set} -> HExp X -> Compute X HVal
interpret {X} = go where
  open Monad (envMonad (Env X) (errorMonad InterpretError))
  go : HExp X -> Env X -> HVal + InterpretError
  go t = {!!}


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

module Data.Binary.PerformanceTests.Addition where

open import Prelude
open import Data.Binary.Definition
open import Data.Binary.Addition using (_+_)

sum-r : 𝔹 → ℕ → 𝔹
sum-r′ : 𝔹 → ℕ → 𝔹

sum-r′ x zero    = x
sum-r′ x (suc n) = x + sum-r (2ᵇ x) n

sum-r x zero    = x
sum-r x (suc n) = x + sum-r′ (1ᵇ x) n

sum-l : 𝔹 → ℕ → 𝔹
sum-l′ : 𝔹 → ℕ → 𝔹

sum-l′ x zero    = x
sum-l′ x (suc n) = sum-l (2ᵇ x) n + x

sum-l x zero    = x
sum-l x (suc n) = sum-l′ (1ᵇ x) n + x

one-thousand : 𝔹
one-thousand = 2ᵇ 1ᵇ 1ᵇ 2ᵇ 1ᵇ 2ᵇ 2ᵇ 2ᵇ 2ᵇ 0ᵇ

f : 𝔹
f = one-thousand

n : ℕ
n = 1000

-- The actual performance test (uncomment and time how long it takes to type-check)
-- _ : sum-l one-thousand n ≡ sum-r one-thousand n
-- _ = refl


module Data.Vec.Exts where

open import Data.Fin
open import Data.Maybe
open import Data.Nat
open import Data.Vec using (Vec; []; _∷_)
open import Relation.Nullary
open import Relation.Unary
open import Data.Vec.Relation.Unary.Any

findIndex : {n : ℕ} {A : Set} {P : A -> Set} -> Decidable P -> Vec A n -> Maybe (Fin n)
findIndex P? xs with any? P? xs
... | yes ix = just (index ix)
... | no _ = nothing


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Implementation.Standard.Relation.Sets where

open import Light.Level using (_⊔_)
open import Light.Variable.Levels
open import Light.Variable.Sets
open import Light.Library.Relation using (Base ; Kind ; Style)
open import Light.Library.Data.Unit as Unit using (Unit ; unit)
open import Light.Library.Data.Empty as Empty using (Empty)
open import Light.Library.Data.Both as Both using (Both)
import Light.Library.Data.Product as Product
open import Light.Library.Data.These as These using (These)
import Light.Implementation.Standard.Data.Unit
import Light.Implementation.Standard.Data.Empty
import Light.Implementation.Standard.Data.Product
import Light.Implementation.Standard.Data.These

instance kind : Kind
kind = record { Proposition = λ ℓ → Set ℓ }

instance style : Style kind
style = record { Implementation }
      where
      module Implementation where
            true = Unit
            false = Empty

            ¬_ : Set ℓ → Set ℓ
            ¬ 𝕒 = 𝕒 → Empty

            _∧_ = Both
            _∨_ = These

            _⇢_ : Set aℓ → Set bℓ → Set (aℓ ⊔ bℓ)
            𝕒 ⇢ 𝕓 = 𝕒 → 𝕓

            True : Set ℓ → Set ℓ
            True 𝕒 = 𝕒
            False = ¬_

            true‐is‐true = unit
            false‐is‐false : _
            false‐is‐false ()

instance base : Base
base = record { kind = kind ; style = style }


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

open import HoTT
open import homotopy.PtdAdjoint
open import homotopy.SuspAdjointLoop
open import cohomology.WithCoefficients

module cohomology.SuspAdjointLoopIso where

module SuspAdjointLoopIso {i} where

  private
    hadj : HomAdjoint {i} {i} Σ⊣Ω.SuspFunctor Σ⊣Ω.LoopFunctor
    hadj = counit-unit-to-hom Σ⊣Ω.adj

    module A = HomAdjoint hadj

  module _ (X Y : Ptd i) where

    abstract
      pres-comp : (h₁ h₂ : ⊙Susp X ⊙→ ⊙Ω Y)
        → –> (A.eq X (⊙Ω Y)) (⊙Ω-∙ ⊙∘ ⊙fanout h₁ h₂)
           == ⊙Ω-∙ ⊙∘ ⊙fanout (–> (A.eq X (⊙Ω Y)) h₁) (–> (A.eq X (⊙Ω Y)) h₂)
      pres-comp h₁ h₂ =
        B.nat-cod h₁ h₂ ⊙Ω-∙
        ∙ ap (_⊙∘ ⊙fanout (–> (A.eq X (⊙Ω Y)) h₁) (–> (A.eq X (⊙Ω Y)) h₂))
             arr2-lemma
        where
        module A× = RightAdjoint× hadj
        module B = RightAdjointBinary hadj

        ap2-lemma : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
          (f : A × B → C) {r s : A × B} (p : r == s)
          → ap f p == ap2 (curry f) (ap fst p) (ap snd p)
        ap2-lemma f idp = idp

        ⊙ap2-lemma : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
          (f : X ⊙× Y ⊙→ Z)
          → ⊙Ω-fmap f == ⊙Ω-fmap2 f ⊙∘ ⊙fanout (⊙Ω-fmap ⊙fst) (⊙Ω-fmap ⊙snd)
        ⊙ap2-lemma (f , idp) = ⊙λ= (ap2-lemma f) idp

        arr2-lemma : B.arr2 ⊙Ω-∙ == ⊙Ω-∙
        arr2-lemma =
          ⊙Ω-fmap ⊙Ω-∙ ⊙∘ A×.⊙out _ _
            =⟨ ⊙ap2-lemma ⊙Ω-∙ |in-ctx _⊙∘ A×.⊙out _ _ ⟩
          (⊙Ω-fmap2 ⊙Ω-∙ ⊙∘ A×.⊙into _ _) ⊙∘ A×.⊙out _ _
            =⟨ ⊙∘-assoc (⊙Ω-fmap2 ⊙Ω-∙) (A×.⊙into _ _) (A×.⊙out _ _) ⟩
          ⊙Ω-fmap2 ⊙Ω-∙ ⊙∘ (A×.⊙into _ _ ⊙∘ A×.⊙out _ _)
            =⟨ A×.⊙into-out _ _ |in-ctx ⊙Ω-fmap2 ⊙Ω-∙ ⊙∘_ ⟩
          ⊙Ω-fmap2 ⊙Ω-∙
            =⟨ ⊙Ω-fmap2-∙ ⟩
          ⊙Ω-∙ ∎

    iso : Trunc-⊙→Ω-group (⊙Susp X) Y ≃ᴳ Trunc-⊙→Ω-group X (⊙Ω Y)
    iso = Trunc-group-emap (≃-to-≃ᴳˢ (A.eq X (⊙Ω Y)) pres-comp)

  abstract
    nat-dom : {X Y : Ptd i} (f : X ⊙→ Y) (Z : Ptd i)
      → fst (iso X Z) ∘ᴳ Trunc-⊙→Ω-group-fmap-dom (⊙Susp-fmap f) Z
        == Trunc-⊙→Ω-group-fmap-dom f (⊙Ω Z) ∘ᴳ fst (iso Y Z)
    nat-dom f Z = group-hom= $ λ= $ Trunc-elim
      (λ _ → =-preserves-level Trunc-level)
      (λ g → ap [_] (! (A.nat-dom f (⊙Ω Z) g)))


open import Everything

module Test.SubstitunctionPropId {𝔭} (𝔓 : Ø 𝔭) where

open Substitunction 𝔓

relpropid-Substitunction : ∀ {m n ℓ} {f : Substitunction m n} (P : LeftExtensionṖroperty ℓ Substitunction Proposextensequality m) (let P₀ = π₀ (π₀ P)) → P₀ f → P₀ (ε ∙ f)
relpropid-Substitunction P pf = hmap _ P pf


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

module Desc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

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

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

pair : {i j : Level}{A : Set i}{B : A -> Set j} ->
       (x : A) (y : B x) -> Sigma {i = i}{j = j} A B
pair x y = x , y

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

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

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

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

trans : {l : Level}{A : Set l}{x y z : A} -> x == y -> y == z -> x == z
trans refl refl = refl

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

postulate
  reflFun : {l m : Level}{A : Set l}{B : A -> Set m}(f : (a : A) -> B a)(g : (a : A) -> B a)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

-- In the paper, we have presented Desc as the grammar of inductive
-- types. Hence, the codes in the paper closely follow this
-- grammar:

data DescPaper : Set1 where
  oneP : DescPaper
  sigmaP : (S : Set) -> (S -> DescPaper) -> DescPaper
  indx : DescPaper -> DescPaper
  hindx : Set -> DescPaper -> DescPaper

-- We take advantage of this model to give you an alternative
-- presentation. This alternative model is the one implemented in
-- Epigram. It is also the one which inspired the code for indexed
-- descriptions.

-- With sigma, we are actually "quoting" a standard type-former,
-- namely:
--     |Sigma : (S : Set) -> (S -> Set) -> Set|
-- With:
--     |sigma : (S : Set) -> (S -> Desc) -> Desc|

-- In the alternative presentation, we go further and present all our
-- codes as quotations of standard type-formers:

data Desc {l : Level} : Set (suc l) where
  id : Desc
  const : Set l -> Desc
  prod : Desc -> Desc -> Desc
  sigma : (S : Set l) -> (S -> Desc) -> Desc
  pi : (S : Set l) -> (S -> Desc) -> Desc

-- Note that we replace |oneP| by a more general |const| code. Whereas
-- |oneP| was interpreted as the unit set, |const K| is
-- interpreted as |K|, for any |K : Set|. Extensionally,
-- |const K| and |sigma K (\_ -> Unit)| are equivalent. However,
-- |const| is *first-order*, unlike its equivalent encoding. From a
-- definitional perspective, we are giving more opportunities to the
-- type-system, hence reducing the burden on the programmer. For the same
-- reason, we introduce |prod| that overlaps with |pi|.

-- This reorganisation is strictly equivalent to the |DescPaper|. For
-- instance, we can encode |indx| and |hindx| using the following
-- code:

indx2 : {l : Level} -> Desc {l = l} -> Desc {l = l}
indx2 D = prod id D

hindx2 : Set -> Desc -> Desc
hindx2 H D = prod (pi H (\_ -> id)) D

--********************************************
-- Desc interpretation
--********************************************

[|_|]_ : {l : Level} -> Desc -> Set l -> Set l
[| id |] Z        = Z
[| const X |] Z   = X
[| prod D D' |] Z = [| D |] Z * [| D' |] Z
[| sigma S T |] Z = Sigma S (\s -> [| T s |] Z)
[| pi S T |] Z    = (s : S) -> [| T s |] Z

--********************************************
-- Fixpoint construction
--********************************************

data Mu {l : Level}(D : Desc {l = l}) : Set l where
  con : [| D |] (Mu D) -> Mu D

--********************************************
-- Predicate: All
--********************************************

All : {l : Level}(D : Desc)(X : Set)(P : X -> Set l) -> [| D |] X -> Set l
All id          X P x        = P x
All (const Z)   X P x        = Unit
All (prod D D') X P (d , d') = (All D X P d) * (All D' X P d')
All (sigma S T) X P (a , b)  = All (T a) X P b
All (pi S T)    X P f        = (s : S) -> All (T s) X P (f s)

all : {l : Level}(D : Desc)(X : Set)(P : X -> Set l)(R : (x : X) -> P x)(x : [| D |] X) -> All D X P x
all id X P R x = R x
all (const Z) X P R z = Void
all (prod D D') X P R (d , d') = all D X P R d , all D' X P R d'
all (sigma S T) X P R (a , b) = all (T a) X P R b
all (pi S T) X P R f = \ s -> all (T s) X P R (f s)

--********************************************
-- Map
--********************************************

-- This one is bonus: one could rightfully expect our so-called
-- functors to have a morphism part! Here it is.

map : {l : Level}(D : Desc)(X Y : Set l)(f : X -> Y)(v : [| D |] X) -> [| D |] Y
map id X Y sig x = sig x
map (const Z) X Y sig z = z
map (prod D D') X Y sig (d , d') = map D X Y sig d , map D' X Y sig d'
map (sigma S T) X Y sig (a , b) = (a , map (T a) X Y sig b)
map (pi S T) X Y sig f = \x -> map (T x) X Y sig (f x)

-- Together with the proof that they respect the functor laws:

-- map id = id
proof-map-id : {l : Level}(D : Desc)(X : Set l)(v : [| D |] X) -> map D X X (\x -> x) v == v
proof-map-id id X v = refl
proof-map-id (const Z) X v = refl
proof-map-id (prod D D') X (v , v') = cong2 (\x y -> (x , y)) (proof-map-id D X v) (proof-map-id D' X v')
proof-map-id (sigma S T) X (a , b) = cong (\x -> (a , x)) (proof-map-id (T a) X b)
proof-map-id (pi S T) X f = reflFun (\a -> map (T a) X X (\x -> x) (f a)) f (\a -> proof-map-id (T a) X (f a))

-- map (f . g) = map f . map g
proof-map-compos : {l : Level}(D : Desc)(X Y Z : Set l)
                   (f : X -> Y)(g : Y -> Z)
                   (v : [| D |] X) ->
                   map D X Z (\x -> g (f x)) v == map D Y Z g (map D X Y f v)
proof-map-compos id X Y Z f g v = refl
proof-map-compos (const K) X Y Z f g v = refl
proof-map-compos (prod D D') X Y Z f g (v , v') = cong2 (\x y -> (x , y))
                                                        (proof-map-compos D X Y Z f g v)
                                                        (proof-map-compos D' X Y Z f g v')
proof-map-compos (sigma S T) X Y Z f g (a , b) = cong (\x -> (a , x)) (proof-map-compos (T a) X Y Z f g b)
proof-map-compos (pi S T) X Y Z f g fc = reflFun (\a -> map (T a) X Z (\x -> g (f x)) (fc a))
                                                 (\a -> map (T a) Y Z g (map (T a) X Y f (fc a)))
                                                 (\a -> proof-map-compos (T a) X Y Z f g (fc a))

--********************************************
-- Elimination principle: induction
--********************************************

-- One would like to write the following:

{-
ind : {l : Level}
            (D : Desc)
            (P : Mu D -> Set l) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
ind D P ms (con xs) = ms xs (all D (Mu D) P (\x -> ind D P ms x) xs)
-}

-- But the termination checker is unhappy.
-- So we write the following:

module Elim {l : Level}
            (D : Desc)
            (P : Mu D -> Set l)
            (ms : (x : [| D |] (Mu D)) ->
                  All D (Mu D) P x -> P (con x))
       where

    mutual
        ind : (x : Mu D) -> P x
        ind (con xs) =  ms xs (hyps D xs)

        hyps : (D' : Desc)
               (xs : [| D' |] (Mu D)) ->
               All D' (Mu D) P xs
        hyps id x = ind x
        hyps (const Z) z = Void
        hyps (prod D D') (d , d') = hyps D d , hyps D' d'
        hyps (sigma S T) (a , b) = hyps (T a) b
        hyps (pi S T) f = \s -> hyps (T s) (f s)

ind : {l : Level}
            (D : Desc)
            (P : Mu D -> Set l) ->
            ( (x : [| D |] (Mu D)) ->
              All D (Mu D) P x -> P (con x)) ->
            (v : Mu D) ->
            P v
ind D P ms x = Elim.ind D P ms x

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> Desc
natCases Ze = const Unit
natCases Suc = id

NatD : Desc
NatD = sigma NatConst  natCases

Nat : Set
Nat = Mu NatD

ze : Nat
ze = con (Ze , Void)

su : Nat -> Nat
su n = con (Su , n)

-- Now we can get addition for example:

plusCase : (xs : [| NatD |] Nat) ->
           All NatD Nat (\_ -> Nat -> Nat) xs -> Nat -> Nat
plusCase ( Ze , Void ) hs y = y
plusCase ( Su , n ) hs y = su (hs y)

plus : Nat -> Nat -> Nat
plus x = ind NatD (\ _ -> (Nat -> Nat)) plusCase x

-- Do this thing in Epigram, you will see that this is *not*
-- hieroglyphic with a bit of elaboration.

--****************
-- List
--****************

data ListConst : Set where
  Nil : ListConst
  Cons : ListConst

listCases : Set -> ListConst -> Desc
listCases X Nil = const Unit
listCases X Cons = sigma X (\_ -> id)

ListD : Set -> Desc
ListD X = sigma ListConst (listCases X)

List : Set -> Set
List X = Mu (ListD X)

nil : {X : Set} -> List X
nil = con ( Nil , Void )

cons : {X : Set} -> X -> List X -> List X
cons x t = con ( Cons , ( x , t ))

--****************
-- Tree
--****************

data TreeConst : Set where
  Leaf : TreeConst
  Node : TreeConst

treeCases : Set -> TreeConst -> Desc
treeCases X Leaf = const Unit
treeCases X Node = sigma X (\_ -> prod id id)

TreeD : Set -> Desc
TreeD X = sigma TreeConst (treeCases X)

Tree : Set -> Set
Tree X = Mu (TreeD X)

leaf : {X : Set} -> Tree X
leaf = con (Leaf , Void)

node : {X : Set} -> X -> Tree X -> Tree X -> Tree X
node x le ri = con (Node , (x , (le , ri)))

--********************************************
-- Finite sets
--********************************************

-- If we weren't such big fans of levitating things, we would
-- implement finite sets with:

{-

data En : Set where
  nE : En
  cE : En -> En

spi : (e : En)(P : EnumT e -> Set) -> Set
spi nE P = Unit
spi (cE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : En)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nE P b ()
switch (cE e) P b EZe = fst b
switch (cE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n
-}

-- But no, we make it fly in Desc:

--****************
-- En
--****************

-- As we have no tags here, we use Nat instead of List.

EnD : Desc
EnD = NatD

En : Set
En = Nat

nE : En
nE = ze

cE : En -> En
cE e = su e

--****************
-- EnumT
--****************

-- Because I don't want to fall back on wacky unicode symbols, I will
-- write EnumT for #, EZe for 0, and ESu for 1+. Sorry about that

data EnumT : (e : En) -> Set where
  EZe : {e : En} -> EnumT (cE e)
  ESu : {e : En} -> EnumT e -> EnumT (cE e)

--****************
-- Small Pi
--****************

-- This corresponds to the small pi |\pi|.

casesSpi : {l : Level}(xs : [| EnD |] En) ->
           All EnD En (\e -> (EnumT e -> Set l) -> Set l) xs ->
           (EnumT (con xs) -> Set l) -> Set l
casesSpi (Ze , Void) hs P' = Unit
casesSpi (Su , n) hs P' = P' EZe * hs (\e -> P' (ESu e))

spi : {l : Level}(e : En)(P : EnumT e -> Set l) -> Set l
spi {x} e P =  ind EnD (\E -> (EnumT E -> Set x) -> Set x) casesSpi e P

--****************
-- Switch
--****************

casesSwitch : {l : Level}
              (xs : [| EnD |] En) ->
              All EnD En (\e -> (P' : EnumT e -> Set l)
                                (b' : spi e P')
                                (x' : EnumT e) -> P' x') xs ->
              (P' : EnumT (con xs) -> Set l)
              (b' : spi (con xs) P')
              (x' : EnumT (con xs)) -> P' x'
casesSwitch (Ze , Void) hs P' b' ()
casesSwitch (Su , n) hs P' b' EZe = fst b'
casesSwitch (Su , n) hs P' b' (ESu e') = hs (\e -> P' (ESu e)) (snd b') e'

switch : {l : Level}
         (e : En)
         (P : EnumT e -> Set l)
         (b : spi e P)
         (x : EnumT e) -> P x
switch {x} e P b xs =  ind EnD
                           (\e -> (P : EnumT e -> Set x)
                                  (b : spi e P)
                                  (xs : EnumT e) -> P xs)
                           casesSwitch e P b xs

--****************
-- Desc
--****************

-- In the following, we implement Desc in itself. As usual, we have a
-- finite set of constructors -- the name of the codes. Note that we
-- could really define these as a finite set built above. However, in
-- Agda, it's horribly verbose. For the sake of clarity, we won't do
-- that here.

data DescDef : Set1 where
  DescId : DescDef
  DescConst : DescDef
  DescProd : DescDef
  DescSigma : DescDef
  DescPi : DescDef

-- We slightly diverge here from the presentation of the paper: note
-- the presence of terminating "const Unit". Recall our Lisp-ish
-- notation for nested tuples:
--    |[a b c]|
-- Corresponds to
--    |[a , [ b , [c , []]]]|
-- So, if we want to write constructors using our Lisp-ish notation, the interpretation
-- [| DescD |] (Mu DescD) have to evaluates to [ constructor , [ arg1 , [ arg2 , []]]]

-- Hence, we define Desc's code as follow:

descCases : DescDef -> Desc
descCases DescId = const Unit
descCases DescConst = sigma Set (\_ -> const Unit)
descCases DescProd = prod id (prod id (const Unit))
descCases DescSigma = sigma Set (\S -> prod (pi (lift S) (\_ -> id)) (const Unit))
descCases DescPi = sigma Set (\S -> prod (pi (lift S) (\_ -> id)) (const Unit))

DescD : Desc
DescD = sigma DescDef descCases

DescIn : Set1
DescIn = Mu DescD

-- So that the constructors are:
-- (Note the annoying |pair|s to set the implicit levels. I could not
--  get rid of the yellow otherwise)

idIn : DescIn
idIn = con (pair {i = suc zero} {j =  suc zero} DescId Void)
constIn : Set -> DescIn
constIn K = con (pair {i = suc zero} {j = suc zero} DescConst (K , Void))
prodIn : (D D' : DescIn) -> DescIn
prodIn D D' = con (pair {i = suc zero} {j = suc zero} DescProd (D , ( D' , Void )))
sigmaIn : (S : Set)(D : S -> DescIn) -> DescIn
sigmaIn S D = con (pair {i = suc zero} {j = suc zero} DescSigma (S , ((\s -> D (unlift s)) , Void )))
piIn : (S : Set)(D : S -> DescIn) -> DescIn
piIn S D = con (pair {i = suc zero} {j = suc zero} DescPi (S , ((\s -> D (unlift s)) , Void )))

-- At this stage, we could prove the isomorphism between |DescIn| and
-- |Desc|. While not technically difficult, it is long and
-- laborious. We have carried this proof on the more complex and
-- interesting |IDesc| universe, in IDesc.agda.

--********************************************
-- Tagged description
--********************************************

TagDesc : {l : Level} -> Set (suc l)
TagDesc = Sigma En (\e -> spi e (\_ -> Desc))

de : TagDesc -> Desc
de (B , F) = sigma (EnumT B) (\E -> switch B (\_ -> Desc) F E)

--********************************************
-- Catamorphism
--********************************************

cata : (D : Desc)
       (T : Set) ->
       ([| D |] T -> T) ->
       (Mu D) -> T
cata D T phi x = ind D (\_ -> T) (\x ms -> phi (replace D T x ms)) x
  where replace : (D' : Desc)(T : Set)(xs : [| D' |] (Mu D))(ms : All D' (Mu D) (\_ -> T) xs) -> [| D' |] T
        replace id T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Free monad construction
--********************************************

_**_ : TagDesc -> (X : Set) -> TagDesc
(e , D) ** X = cE e , (const X , D)

--********************************************
-- Substitution
--********************************************

apply : (D : TagDesc)(X Y : Set) ->
        (X -> Mu (de (D ** Y))) ->
        [| de (D ** X) |] (Mu (de (D ** Y))) ->
        Mu (de (D ** Y))
apply (E , B) X Y sig (EZe , x) = sig x
apply (E , B) X Y sig (ESu n , t) = con (ESu n , t)

subst : (D : TagDesc)(X Y : Set) ->
        Mu (de (D ** X)) ->
        (X -> Mu (de (D ** Y))) ->
        Mu (de (D ** Y))
subst D X Y x sig = cata (de (D ** X)) (Mu (de (D ** Y))) (apply D X Y sig) x


-- Occurs check when unifying indices in patterns
module OccursCheck where

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

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

f : {n : Nat} -> n == suc n -> Nat
f refl = zero


{-# OPTIONS --without-K #-}
module NTypes.Nat where

open import NTypes
open import PathOperations
open import PathStructure.Nat
open import Types

ℕ-isSet : isSet ℕ
ℕ-isSet = ind
  (λ m → (n : ℕ) (p q : m ≡ n) → p ≡ q)
  (λ m-1 r → ind (λ n → (p q : suc m-1 ≡ n) → p ≡ q)
    (λ n-1 r′ p′ q′
      → split-eq p′ ⁻¹
      · ap (ap suc)
        (r _
          (merge-path m-1 n-1
            (tr (F (suc m-1)) p′ (F-lemma (suc m-1))))
          (merge-path m-1 n-1
            (tr (F (suc m-1)) q′ (F-lemma (suc m-1)))))
      · split-eq q′
      )
    (λ p q → 0-elim (split-path _ _ p)))
  (ind (λ n → (p q : 0 ≡ n) → p ≡ q)
    (λ _ _ p q → 0-elim (split-path _ _ p))
    (λ     p q → split-eq p ⁻¹ · split-eq q))
  where
  split-eq : {x y : ℕ} → _
  split-eq {x} {y} = π₂ (π₂ (π₂ (split-merge-eq {x} {y})))


-- 2018-11-02, Jesper:
-- Problem reported by Martin Escardo
-- Example by Guillaume Brunerie
-- C-c C-s was generating postfix projections
-- even with --postfix-projections disabled.

open import Agda.Builtin.Equality

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B
open _×_

postulate
  A B : Set
  p : A × B

eta : p ≡ ({!!} , snd p)
eta = refl

-- C-c C-s should fill the hole with 'fst p'.


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Transitivity

module Oscar.Class.Transitivity.Function where

module _
  {a}
  where

  instance

    𝓣ransitivityFunction : Transitivity.class Function⟦ a ⟧
    𝓣ransitivityFunction .⋆ f g = g ∘ f


module bool where

open import level

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

open import unit
open import empty

data 𝔹 : Set where
 tt : 𝔹
 ff : 𝔹

-- this is an alias for Mac users who cannot see blackboard b.
bool : Set
bool = 𝔹

{-# BUILTIN BOOL  𝔹  #-}
{-# BUILTIN TRUE  tt  #-}
{-# BUILTIN FALSE ff #-}

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infix  7 ~_
infix 6 _xor_ _nand_
infixr 6 _&&_
infixr 5 _||_
infix  4 if_then_else_   if*_then_else_
infixr 4 _imp_

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------

toSet : 𝔹 → Set
toSet tt = ⊤
toSet ff = ⊥

-- not
~_ : 𝔹 → 𝔹
~ tt = ff
~ ff = tt

-- and
_&&_ : 𝔹 → 𝔹 → 𝔹
tt && b = b
ff && b = ff

-- or
_||_ : 𝔹 → 𝔹 → 𝔹
tt || b = tt
ff || b = b

if_then_else_ : ∀ {ℓ} {A : Set ℓ} → 𝔹 → A → A → A
if tt then y else z = y
if ff then y else z = z

if*_then_else_ : ∀ {ℓ} {A B : Set ℓ} → (b : 𝔹) → A → B → if b then A else B
if* tt then a else b = a
if* ff then a else b = b

_xor_ : 𝔹 → 𝔹 → 𝔹
tt xor ff = tt
ff xor tt = tt
tt xor tt = ff
ff xor ff = ff

-- implication
_imp_ : 𝔹 → 𝔹 → 𝔹
tt imp b2 = b2
ff imp b2 = tt

-- also called the Sheffer stroke
_nand_ : 𝔹 → 𝔹 → 𝔹
tt nand tt = ff
tt nand ff = tt
ff nand tt = tt
ff nand ff = tt

_nor_ : 𝔹 → 𝔹 → 𝔹
x nor y = ~ (x || y)


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.GradedRing.Instances.CohomologyRing where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat
open import Cubical.Data.Sigma

open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Monoid.Instances.NatPlusBis
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.AbGroup.Instances.Unit
open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.GradedRing.Base
open import Cubical.Algebra.GradedRing.DirectSumHIT

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.RingLaws
open import Cubical.ZCohomology.RingStructure.GradedCommutativity

private variable
  ℓ : Level

open PlusBis
open GradedRing-⊕HIT-index
open GradedRing-⊕HIT-⋆

module _
  (A : Type ℓ)
  where

  CohomologyRing-GradedRing : GradedRing ℓ-zero ℓ
  CohomologyRing-GradedRing = makeGradedRingSelf
                              NatPlusBis-Monoid
                              (λ k → coHom k A)
                              (λ k → snd (coHomGroup k A) )
                              1⌣
                              _⌣_
                              (λ {k} {l} → 0ₕ-⌣ k l)
                              (λ {k} {l} → ⌣-0ₕ k l)
                              (λ _ _ _ → sym (ΣPathTransport→PathΣ _ _ ((sym (+'-assoc _ _ _)) , (sym (assoc-⌣ _ _ _ _ _ _)))) )
                              (λ _ → sym (ΣPathTransport→PathΣ _ _ (sym (+'-rid _) , sym (lUnit⌣ _ _))))
                              (λ _ → ΣPathTransport→PathΣ _ _ (refl , transportRefl _ ∙ rUnit⌣ _ _))
                              (λ _ _ _ → leftDistr-⌣ _ _ _ _ _)
                              ( λ _ _ _ → rightDistr-⌣ _ _ _ _ _)


{-

This file contains:

- Equivalence with the pushout definition
  Written by: Loïc Pujet, September 2019

- Associativity of the join
  Written by: Loïc Pujet, September 2019

-}

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

module Cubical.HITs.Join.Properties where

open import Cubical.Core.Glue

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Prod

open import Cubical.HITs.Join.Base
open import Cubical.HITs.Pushout

private
  variable
    ℓ ℓ' : Level

-- Alternative definition of the join using a pushout
joinPushout : (A : Type ℓ) → (B : Type ℓ') → Type (ℓ-max ℓ ℓ')
joinPushout A B = Pushout {A = A × B} proj₁ proj₂

-- Proof that it is equal
joinPushout-iso-join : (A : Type ℓ) → (B : Type ℓ') → Iso (joinPushout A B) (join A B)
joinPushout-iso-join A B = iso joinPushout→join join→joinPushout join→joinPushout→join joinPushout→join→joinPushout
  where
    joinPushout→join : joinPushout A B → join A B
    joinPushout→join (inl x) = inl x
    joinPushout→join (inr x) = inr x
    joinPushout→join (push y i) = push (proj₁ y) (proj₂ y) i

    join→joinPushout : join A B → joinPushout A B
    join→joinPushout (inl x) = inl x
    join→joinPushout (inr x) = inr x
    join→joinPushout (push a b i) = push (a , b) i

    joinPushout→join→joinPushout : ∀ x → join→joinPushout (joinPushout→join x) ≡ x
    joinPushout→join→joinPushout (inl x) = refl
    joinPushout→join→joinPushout (inr x) = refl
    joinPushout→join→joinPushout (push (a , b) j) = refl

    join→joinPushout→join : ∀ x → joinPushout→join (join→joinPushout x) ≡ x
    join→joinPushout→join (inl x) = refl
    join→joinPushout→join (inr x) = refl
    join→joinPushout→join (push a b j) = refl

-- We will need both the equivalence and path version
joinPushout≃join : (A : Type ℓ) → (B : Type ℓ') → joinPushout A B ≃ join A B
joinPushout≃join A B = isoToEquiv (joinPushout-iso-join A B)

joinPushout≡join : (A : Type ℓ) → (B : Type ℓ') → joinPushout A B ≡ join A B
joinPushout≡join A B = isoToPath (joinPushout-iso-join A B)

{-
  Proof of associativity of the join
-}
join-assoc : (A B C : Type₀) → join (join A B) C ≡ join A (join B C)
join-assoc A B C = (joinPushout≡join (join A B) C) ⁻¹
                   ∙ (spanEquivToPushoutPath sp3≃sp4) ⁻¹
                   ∙ (3x3-span.3x3-lemma span) ⁻¹
                   ∙ (spanEquivToPushoutPath sp1≃sp2)
                   ∙ (joinPushout≡join A (join B C))
  where
    -- the meat of the proof is handled by the 3x3 lemma applied to this diagram
    span : 3x3-span
    span = record {
      A00 = A;      A02 = A × B;      A04 = B;
      A20 = A × C;  A22 = A × B × C;  A24 = B × C;
      A40 = A × C;  A42 = A × C;      A44 = C;
      f10 = proj₁;   f12 = proj₁₂; f14 = proj₁;
      f30 = λ x → x; f32 = proj₁₃; f34 = proj₂;
      f01 = proj₁;   f21 = proj₁₃; f41 = λ x → x;
      f03 = proj₂;   f23 = proj₂;  f43 = proj₂;
      H11 = H11;    H13 = H13;    H31 = H31;    H33 = H33  }
      where
        proj₁₃ : A × B × C → A × C
        proj₁₃ (a , (b , c)) = a , c

        proj₁₂ : A × B × C → A × B
        proj₁₂ (a , (b , c)) = a , b

        H11 : (x : A × B × C) → proj₁ (proj₁₂ x) ≡ proj₁ (proj₁₃ x)
        H11 (a , (b , c)) = refl

        H13 : (x : A × B × C) → proj₂ (proj₁₂ x) ≡ proj₁ (proj₂ x)
        H13 (a , (b , c)) = refl

        H31 : (x : A × B × C) → proj₁₃ x ≡ proj₁₃ x
        H31 (a , (b , c)) = refl

        H33 : (x : A × B × C) → proj₂ (proj₁₃ x) ≡ proj₂ (proj₂ x)
        H33 (a , (b , c)) = refl

    -- the first pushout span appearing in the 3x3 lemma
    sp1 : 3-span
    sp1 = record {
      A0 = 3x3-span.A□0 span;
      A2 = 3x3-span.A□2 span;
      A4 = 3x3-span.A□4 span;
      f1 = 3x3-span.f□1 span;
      f3 = 3x3-span.f□3 span }

    -- the first span we are interested in
    sp2 : 3-span
    sp2 = record {
      A0 = A ;
      A2 = A × (join B C) ;
      A4 = join B C ;
      f1 = proj₁ ;
      f3 = proj₂ }

    -- proof that they are in fact equivalent
    sp1≃sp2 : 3-span-equiv sp1 sp2
    sp1≃sp2 = record {
      e0 = A□0≃A;
      e2 = A□2≃A×join;
      e4 = joinPushout≃join B C;
      H1 = H1;
      H3 = H2 }
      where
        A×join : Type₀
        A×join = A × (join B C)

        A□2→A×join : 3x3-span.A□2 span → A×join
        A□2→A×join (inl (a , b)) = a , inl b
        A□2→A×join (inr (a , c)) = a , inr c
        A□2→A×join (push (a , (b , c)) i) = a , push b c i

        A×join→A□2 : A×join → 3x3-span.A□2 span
        A×join→A□2 (a , inl b) = inl (a , b)
        A×join→A□2 (a , inr c) = inr (a , c)
        A×join→A□2 (a , push b c i) = push (a , (b , c)) i

        A×join→A□2→A×join : ∀ x → A×join→A□2 (A□2→A×join x) ≡ x
        A×join→A□2→A×join (inl (a , b)) = refl
        A×join→A□2→A×join (inr (a , c)) = refl
        A×join→A□2→A×join (push (a , (b , c)) i) = refl

        A□2→A×join→A□2 : ∀ x → A□2→A×join (A×join→A□2 x) ≡ x
        A□2→A×join→A□2 (a , inl b) = refl
        A□2→A×join→A□2 (a , inr c) = refl
        A□2→A×join→A□2 (a , push b c i) = refl

        A□2≃A×join : 3x3-span.A□2 span ≃ A×join
        A□2≃A×join = isoToEquiv (iso A□2→A×join A×join→A□2 A□2→A×join→A□2 A×join→A□2→A×join)

        A→A□0 : A → 3x3-span.A□0 span
        A→A□0 b = inl b

        A□0→A : 3x3-span.A□0 span → A
        A□0→A (inl b) = b
        A□0→A (inr a) = proj₁ a
        A□0→A (push a i) = proj₁ a

        A→A□0→A : ∀ x → A□0→A (A→A□0 x) ≡ x
        A→A□0→A x = refl

        A□0→A→A□0 : ∀ x → A→A□0 (A□0→A x) ≡ x
        A□0→A→A□0 (inl b) = refl
        A□0→A→A□0 (inr a) j = push a j
        A□0→A→A□0 (push a i) j = push a (j ∧ i)

        A□0≃A :  3x3-span.A□0 span ≃ A
        A□0≃A = isoToEquiv (iso A□0→A A→A□0 A→A□0→A A□0→A→A□0)

        H1 : (x : 3x3-span.A□2 span) → proj₁ (A□2→A×join x) ≡ A□0→A (3x3-span.f□1 span x)
        H1 (inl (a , b)) = refl
        H1 (inr (a , c)) = refl
        H1 (push (a , (b , c)) i) j = A□0→A (doubleCompPath-filler refl (λ i → push (a , c) i) refl i j)

        H2 : (x : 3x3-span.A□2 span) → proj₂ (A□2→A×join x) ≡ fst (joinPushout≃join _ _) (3x3-span.f□3 span x)
        H2 (inl (a , b)) = refl
        H2 (inr (a , c)) = refl
        H2 (push (a , (b , c)) i) j = fst (joinPushout≃join _ _) (doubleCompPath-filler refl (λ i → push (b , c) i) refl i j)

    -- the second span appearing in 3x3 lemma
    sp3 : 3-span
    sp3 = record {
      A0 = 3x3-span.A0□ span;
      A2 = 3x3-span.A2□ span;
      A4 = 3x3-span.A4□ span;
      f1 = 3x3-span.f1□ span;
      f3 = 3x3-span.f3□ span }

    -- the second span we are interested in
    sp4 : 3-span
    sp4 = record {
      A0 = join A B ;
      A2 = (join A B) × C ;
      A4 = C ;
      f1 = proj₁ ;
      f3 = proj₂ }

    -- proof that they are in fact equivalent
    sp3≃sp4 : 3-span-equiv sp3 sp4
    sp3≃sp4 = record {
      e0 = joinPushout≃join A B;
      e2 = A2□≃join×C;
      e4 = A4□≃C;
      H1 = H4;
      H3 = H3 }
      where
        join×C : Type₀
        join×C = (join A B) × C

        A2□→join×C : 3x3-span.A2□ span → join×C
        A2□→join×C (inl (a , c)) = (inl a) , c
        A2□→join×C (inr (b , c)) = (inr b) , c
        A2□→join×C (push (a , (b , c)) i) = push a b i , c

        join×C→A2□ : join×C → 3x3-span.A2□ span
        join×C→A2□ (inl a , c) = inl (a , c)
        join×C→A2□ (inr b , c) = inr (b , c)
        join×C→A2□ (push a b i , c) = push (a , (b , c)) i

        join×C→A2□→join×C : ∀ x → join×C→A2□ (A2□→join×C x) ≡ x
        join×C→A2□→join×C (inl (a , c)) = refl
        join×C→A2□→join×C (inr (b , c)) = refl
        join×C→A2□→join×C (push (a , (b , c)) j) = refl

        A2□→join×C→A2□ : ∀ x → A2□→join×C (join×C→A2□ x) ≡ x
        A2□→join×C→A2□ (inl a , c) = refl
        A2□→join×C→A2□ (inr b , c) = refl
        A2□→join×C→A2□ (push a b i , c) = refl

        A2□≃join×C : 3x3-span.A2□ span ≃ join×C
        A2□≃join×C = isoToEquiv (iso A2□→join×C join×C→A2□ A2□→join×C→A2□ join×C→A2□→join×C)

        C→A4□ : C → 3x3-span.A4□ span
        C→A4□ b = inr b

        A4□→C : 3x3-span.A4□ span → C
        A4□→C (inl x) = proj₂ x
        A4□→C (inr c) = c
        A4□→C (push x i) = proj₂ x

        C→A4□→C : ∀ x → A4□→C (C→A4□ x) ≡ x
        C→A4□→C x = refl

        A4□→C→A4□ : ∀ x → C→A4□ (A4□→C x) ≡ x
        A4□→C→A4□ (inl x) j = push x (~ j)
        A4□→C→A4□ (inr c) = refl
        A4□→C→A4□ (push x i) j = push x (~ j ∨ i)

        A4□≃C :  3x3-span.A4□ span ≃ C
        A4□≃C = isoToEquiv (iso A4□→C C→A4□ C→A4□→C A4□→C→A4□)

        H3 : (x : 3x3-span.A2□ span) → proj₂ (A2□→join×C x) ≡ A4□→C (3x3-span.f3□ span x)
        H3 (inl (a , c)) = refl
        H3 (inr (b , c)) = refl
        H3 (push (a , (b , c)) i) j = A4□→C (doubleCompPath-filler refl (λ i → push (a , c) i) refl i j)

        H4 : (x : 3x3-span.A2□ span) → proj₁ (A2□→join×C x) ≡ fst (joinPushout≃join _ _) (3x3-span.f1□ span x)
        H4 (inl (a , c)) = refl
        H4 (inr (b , c)) = refl
        H4 (push (a , (b , c)) i) j = fst (joinPushout≃join _ _) (doubleCompPath-filler refl (λ i → push (a , b) i) refl i j)