------------------------------------------------------------------------
-- Some definitions related to the binary sum type former
------------------------------------------------------------------------

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

open import Equality

module Sum {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq

open import Prelude

private
  variable
    a           : Level
    A B         : Type a
    x           : A
    f₁ f₂ g₁ g₂ : A → B

-- Functor laws.

⊎-map-id : ⊎-map id id x ≡ x
⊎-map-id {x = inj₁ _} = refl _
⊎-map-id {x = inj₂ _} = refl _

⊎-map-∘ :
  ∀ x → ⊎-map (f₁ ∘ g₁) (f₂ ∘ g₂) x ≡ ⊎-map f₁ f₂ (⊎-map g₁ g₂ x)
⊎-map-∘ = [ (λ _ → refl _) , (λ _ → refl _) ]

-- If A can be decided, then ¬ A can be decided.

dec-¬ : Dec A → Dec (¬ A)
dec-¬ (yes p) = no (_$ p)
dec-¬ (no  p) = yes p


{-# OPTIONS --sized-types #-}

module SizedTypesScopeExtrusion where

postulate
  Size : Set
  _^   : Size -> Size
  ∞    : Size

{-# BUILTIN SIZE Size  #-}
{-# BUILTIN SIZESUC _^ #-}
{-# BUILTIN SIZEINF ∞  #-}

data Nat : {size : Size} -> Set where
  zero : {size : Size} -> Nat {size ^}
  suc  : {size : Size} -> Nat {size} -> Nat {size ^}

data Empty : Set where

data Unit : Set where
  unit : Unit

Zero : (i : Size) -> Nat {i} -> Set
Zero ._ zero = Unit
Zero ._ (suc _) = Empty

bla : Set
bla = (x : Nat) -> (i : Size) -> Zero i x


------------------------------------------------------------------------
-- Properties satisfied by decidable total orders
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.Props.DecTotalOrder (dt : DecTotalOrder) where

open Relation.Binary.DecTotalOrder dt hiding (trans)
import Relation.Binary.NonStrictToStrict as Conv
open Conv _≈_ _≤_

strictTotalOrder : StrictTotalOrder
strictTotalOrder = record
  { isStrictTotalOrder = record
      { isEquivalence = isEquivalence
      ; trans         = trans isPartialOrder
      ; compare       = trichotomous Eq.sym _≟_ antisym total
      ; <-resp-≈      = <-resp-≈ isEquivalence ≤-resp-≈
      }
  }

open StrictTotalOrder strictTotalOrder public


open import Common.Prelude

infixr 9 _∘_

_∘_ : {A B C : Set} → (B → C) → (A → B) → (A → C)
f ∘ g = λ x → f (g x)

test : Nat → Nat
test = _* 5 ∘ 6 +_ ∘ 2 ∸_


open import SOAS.Common
open import SOAS.Families.Core
import SOAS.Metatheory.MetaAlgebra

-- Shorthands for de Bruijn indices
module SOAS.Syntax.Shorthands {T : Set}
  {⅀F : Functor 𝔽amiliesₛ 𝔽amiliesₛ}
  (open SOAS.Metatheory.MetaAlgebra ⅀F)
  {𝒜 : Familyₛ → Familyₛ}(𝒜ᵃ : (𝔛 : Familyₛ) → MetaAlg 𝔛 (𝒜 𝔛))
  where

open import SOAS.Context
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive
open import SOAS.Variable
open import Data.Nat

open import Relation.Nullary.Decidable using (True; toWitness)

private
  variable
    α β γ δ υ : T
    Γ Δ : Ctx

module _ {𝔛 : Familyₛ} where
  open MetaAlg 𝔛 (𝒜ᵃ 𝔛)

  -- Refer to variables via de Bruijn numerals: e.g. ` 2 = 𝑣𝑎𝑟 (old (old new))
  len : Ctx {T} → ℕ
  len ∅        =  ℕ.zero
  len (α ∙ Γ)  =  suc (len Γ)

  ix : {Γ : Ctx} → {n : ℕ} → (p : n < len Γ) → T
  ix {(α ∙ _)} {zero}    (s≤s z≤n)  =  α
  ix {(_ ∙ Γ)} {(suc n)} (s≤s p)    =  ix p

  deBruijn : ∀ {Γ} → {n : ℕ} → (p : n < len Γ) → ℐ (ix p) Γ
  deBruijn {_ ∙ _} {zero}    (s≤s z≤n)  =  new
  deBruijn {_ ∙ Γ} {(suc n)} (s≤s p)    =  old (deBruijn p)

  ′ : {Γ : Ctx}(n : ℕ){n∈Γ : True (suc n ≤? len Γ)} → 𝒜 𝔛 (ix (toWitness n∈Γ)) Γ
  ′ n {n∈Γ} = 𝑣𝑎𝑟 (deBruijn (toWitness n∈Γ))

  -- Explicit abbreviations for de Bruijn indices 0-4
  x₀ : 𝒜 𝔛 α (α ∙ Γ)
  x₀ = 𝑣𝑎𝑟 new
  x₁ : 𝒜 𝔛 β (α ∙ β ∙ Γ)
  x₁ = 𝑣𝑎𝑟 (old new)
  x₂ : 𝒜 𝔛 γ (α ∙ β ∙ γ ∙ Γ)
  x₂ = 𝑣𝑎𝑟 (old (old new))
  x₃ : 𝒜 𝔛 δ (α ∙ β ∙ γ ∙ δ ∙ Γ)
  x₃ = 𝑣𝑎𝑟 (old (old (old new)))
  x₄ : 𝒜 𝔛 υ (α ∙ β ∙ γ ∙ δ ∙ υ ∙ Γ)
  x₄ = 𝑣𝑎𝑟 (old (old (old (old new))))


module STLC.Term where

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

open import Relation.Binary.Construct.Closure.ReflexiveTransitive
  using (Star; ε; _◅_)

open import Data.Vec using (Vec; []; _∷_; lookup)

open import Relation.Binary.PropositionalEquality
  using (refl; _≡_; cong₂)

-- --------------------------------------------------------------------
-- Untyped terms and values
-- --------------------------------------------------------------------

infix 7 _·_

data Term (n : ℕ) : Set where
  # : (x : Fin n) -> Term n
  ƛ : Term (1 + n) -> Term n
  _·_ : Term n -> Term n -> Term n

data Value {n : ℕ} : Term n -> Set where
  ƛ :
    ∀ { t }
    -- -----------
    -> Value (ƛ t)

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

module Substitution where

  -- This sub module defines application of the subtitution
  -- TODO: Rename for consistency
  module SubstApplication { T : ℕ -> Set } ( l : Lift T Term ) where
    open Lift l hiding  (var)

    -- Application of substitution to term
    infixl 8 _/_

    _/_ : ∀ { m n : ℕ } -> Term m -> Sub T m n -> Term n
    # x / ρ = lift (lookup ρ x)
    (ƛ t) / ρ = ƛ (t / ρ ↑)
    (t₁ · t₂) / ρ = (t₁ / ρ) · (t₂ / ρ)

    open Application (record { _/_ = _/_ }) using (_/✶_)

  open TermSubst (record { var = #; app = SubstApplication._/_ }) public hiding (var)

  infix 8 _[/_]

  -- Shorthand for single-variable term substitutions
  _[/_] : ∀ { n } → Term (1 + n) → Term n → Term n
  t₁ [/ t₂ ] = t₁ / sub t₂

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

-- TODO: Add additional operators
-- TODO: Add constants w/ delta-rules


{-# OPTIONS --safe #-}
module Cubical.Data.NatMinusOne where

open import Cubical.Data.NatMinusOne.Base public
open import Cubical.Data.NatMinusOne.Properties public


-- Properties of quicksort

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

open import Relation.Binary

module Algorithms.List.Sort.Quick.Properties
  {c l₁ l₂} (DTO : DecTotalOrder c l₁ l₂)
  where

-- agda-stdlib
open import Level
open import Data.List
import      Data.List.Properties as Listₚ
import Data.List.Relation.Binary.Equality.Setoid as EqualitySetoid
import Data.List.Relation.Binary.Permutation.Setoid as PermutationSetoid
open import Data.Product
import      Data.Nat as ℕ
open import Data.Nat.Induction as Ind
open import Relation.Binary as B
open import Relation.Unary as U
import      Relation.Unary.Properties as Uₚ
open import Relation.Binary.PropositionalEquality as P using (_≡_)
import Relation.Binary.Reasoning.Setoid as SetoidReasoning
open import Function.Base
open import Induction.WellFounded

-- agda-misc
open import Algorithms.List.Sort.Common DTO
open import Algorithms.List.Sort.Quick

open DecTotalOrder DTO renaming (Carrier to A)
open Quicksort _≤?_
open PermutationSetoid Eq.setoid
open EqualitySetoid Eq.setoid
{-
sort-acc-cong : ∀ {xs ys rs₁ rs₂} → xs ≋ ys → sort-acc xs rs₁ ≋ sort-acc ys rs₂
sort-acc-cong {[]}     {[]}     {rs₁}     {rs₂}     xs≋ys = ≋-refl
sort-acc-cong {x ∷ xs} {y ∷ ys} {acc rs₁} {acc rs₂} (x≈y EqualitySetoid.∷ xs≋ys) =
  ++⁺ (sort-acc-cong {!   !}) (++⁺ (x≈y ∷ []) {!   !})
-}

{-
sort-acc-filter : ∀ x xs rs lt₁ lt₂ →
  sort-acc (x ∷ xs) (acc rs) ≡
  sort-acc (filter (_≤? x) xs) (rs _ lt₁) ++ [ x ] ++
  sort-acc (filter (Uₚ.∁? (_≤? x)) xs) (rs _ lt₂)
sort-acc-filter x xs rs lt₁ lt₂ = begin
  sort-acc (proj₁ (split x xs)) (rs _ _) ++ [ x ] ++
    sort-acc (proj₂ (split x xs)) (rs _ _)
    ≡⟨ ? ⟩
  sort-acc (filter (_≤? x) xs) (rs _ lt₁) ++ [ x ] ++
    sort-acc (filter (Uₚ.∁? (_≤? x)) xs) (rs _ lt₂) ∎

sort-acc-permutation : ∀ xs ac → sort-acc xs ac ↭ xs
sort-acc-permutation []       ac       = ↭-refl
sort-acc-permutation (x ∷ xs) (acc rs) = begin
  sort-acc (x ∷ xs) (acc rs) ≈⟨ {!   !} ⟩
  x ∷ xs ∎
  where open SetoidReasoning ↭-setoid
-}


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

module Relation.Nullary.Decidable.Properties where

open import Relation.Nullary.Decidable
open import Level
open import Relation.Nullary.Stable
open import Data.Empty
open import HLevels
open import Data.Empty.Properties using (isProp¬)
open import Data.Unit
open import Data.Empty

Dec→Stable : ∀ {ℓ} (A : Type ℓ) → Dec A → Stable A
Dec→Stable A (yes x) = λ _ → x
Dec→Stable A (no x) = λ f → ⊥-elim (f x)

isPropDec : (Aprop : isProp A) → isProp (Dec A)
isPropDec Aprop (yes a) (yes a') i = yes (Aprop a a' i)
isPropDec Aprop (yes a) (no ¬a) = ⊥-elim (¬a a)
isPropDec Aprop (no ¬a) (yes a) = ⊥-elim (¬a a)
isPropDec {A = A} Aprop (no ¬a) (no ¬a') i = no (isProp¬ A ¬a ¬a' i)

True : Dec A → Type
True (yes _) = ⊤
True (no  _) = ⊥

toWitness : {x : Dec A} → True x → A
toWitness {x = yes p} _ = p

open import Path
open import Data.Bool.Base

from-reflects : ∀ b → (d : Dec A) → Reflects A b → does d ≡ b
from-reflects false (no  y) r = refl
from-reflects false (yes y) r = ⊥-elim (r y)
from-reflects true  (no  y) r = ⊥-elim (y r)
from-reflects true  (yes y) r = refl


module Relator.Congruence.Proofs where

import      Lvl
open import Functional
open import Logic.Propositional
open import Logic.Predicate
-- TODO: open import Structure.Function.Domain
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Relator.Congruence
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function.Names
open import Syntax.Transitivity
open import Type

module _ {ℓ₁ ℓ₂} {X : Type{ℓ₁}}{Y : Type{ℓ₂}} {f : X → Y} where
  instance
    [≅]-reflexivity : Reflexivity (_≅_of f)
    Reflexivity.proof([≅]-reflexivity) = [≅]-intro [≡]-intro

  instance
    [≅]-symmetry : Symmetry (_≅_of f)
    Symmetry.proof([≅]-symmetry) = ([≅]-intro ∘ symmetry(_≡_) ∘ [≅]-elim)

  instance
    [≅]-transitivity : Transitivity (_≅_of f)
    Transitivity.proof([≅]-transitivity) (eq1) (eq2) = [≅]-intro(([≅]-elim eq1) 🝖 ([≅]-elim eq2))

  instance
    [≅]-equivalence : Equivalence (_≅_of f)
    [≅]-equivalence = record {
        reflexivity  = [≅]-reflexivity ;
        symmetry     = [≅]-symmetry    ;
        transitivity = [≅]-transitivity
      }

  [≅]-to-[≡] : Injective(f) ↔ (∀{x₁ x₂ : X} → (x₁ ≅ x₂ of f) → (x₁ ≡ x₂))
  [≅]-to-[≡] = [↔]-intro (_∘ [≅]-intro) (_∘ [≅]-elim)

module _ {ℓ₁ ℓ₂ ℓ₃} {X₁ : Type{ℓ₁}}{X₂ : Type{ℓ₂}}{Y : Type{ℓ₃}} where
  [≅]-composition : ∀{x₁ x₂ : X₁}{g : X₁ → X₂} → (x₁ ≅ x₂ of g) → ∀{f : X₂ → Y} → (g(x₁) ≅ g(x₂) of f)
  [≅]-composition ([≅]-intro (fx₁≡fx₂)) {f} = [≅]-intro ([≡]-with(f) (fx₁≡fx₂))
    -- x₁ ≅ x₂
    -- ⇔ g(x₁) = g(x₂)
    -- ⇒ f(g(x₁)) = f(g(x₂))


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Terms that operate on changes (Fig. 3).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

open import Data.Product

-- Extension point 1: A term for ⊝ on base types.
DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔBase ι)

-- Extension point 2: A term for ⊕ on base types.
ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

-- Extension point 3: A term for 0 on base types.
NilStructure : Set
NilStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ ΔBase ι)

module Structure
    (apply-base : ApplyStructure)
    (diff-base  : DiffStructure)
    (nil-base   : NilStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  -- We provide: terms for ⊕ and ⊝ on arbitrary types.
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)
  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
  nil-term : ∀ {τ Γ} → Term Γ (τ ⇒ ΔType τ)

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    let
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
       nil-σ = λ {Γ} t → app (nil-term {σ} {Γ}) t
     in
       absV 3 (λ Δh h y → app h y ⊕τ app (app Δh y) (nil-σ y))

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       absV 4 (λ g f x Δx → app g (x ⊕σ Δx) ⊝τ app f x)

  nil-term {base ι} = nil-base
  nil-term {σ ⇒ τ} =
    -- What I'd usually write:
    --absV 1 (λ f → app₂ diff-term f f)
    -- What I wrote in fact:
    let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       absV 1 (λ ff → app (absV 3 (λ f x Δx → app f (x ⊕σ Δx) ⊝τ app f x)) ff)
    -- This simplified a lot proving meaning-onil by reusing meaning-⊝.
    --
    -- The reason is that the extra lambda-abstraction ensures that f is pushed
    -- twice in the environment.

  apply : ∀ τ {Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply _ = app₂ apply-term

  diff : ∀ τ {Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff _ = app₂ diff-term

  onil₍_₎ : ∀ τ {Γ} →
    Term Γ τ →
    Term Γ (ΔType τ)
  onil₍ _ ₎ = app nil-term

  infixl 6 apply diff

  syntax apply τ x Δx = Δx ⊕₍ τ ₎ x
  syntax diff τ x y = x ⊝₍ τ ₎ y

  infixl 6 _⊕_ _⊝_

  _⊕_ : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  _⊕_ {τ} = apply τ

  _⊝_ : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  _⊝_ {τ} = diff τ

  onil : ∀ {τ Γ} →
    Term Γ τ →
    Term Γ (ΔType τ)
  onil {τ} = onil₍ τ ₎


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

module FOT.PA.Inductive.CanonicalTerm where

-- We cannot extract a canonical term from a non-intuitionistic proof.

open import PA.Inductive.Base
open import PA.Inductive.PropertiesI

------------------------------------------------------------------------------
-- The existential projections

∃-proj₁ : ∀ {A} → ∃ A → ℕ
∃-proj₁ (x , _) = x

∃-proj₂ : ∀ {A} → (h : ∃ A) → A (∃-proj₁ h)
∃-proj₂ (_ , Ax) = Ax

------------------------------------------------------------------------------
-- Non-intuitionistic logic theorems

-- The principle of the excluded middle.
postulate pem : ∀ {A} → A ∨ ¬ A

-- The principle of indirect proof (proof by contradiction).
¬-elim : ∀ {A} → (¬ A → ⊥) → A
¬-elim h = case (λ a → a) (λ ¬a → ⊥-elim (h ¬a)) pem

-- ∃ in terms of ∀ and ¬.
¬∃¬→∀ : {A : ℕ → Set} → ¬ (∃[ x ] ¬ A x) → ∀ {x} → A x
¬∃¬→∀ h {x} = ¬-elim (λ h₁ → h (x , h₁))

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

-- Intuitionistic proof.
proof₁ : ∃[ x ] x ≢ succ x
proof₁ = succ zero , x≢Sx

-- Non-intuitionistic proof.
proof₂ : ∃[ x ] x ≢ succ x
proof₂ = ¬-elim (λ h → x≢Sx {succ zero} (¬∃¬→∀ h))

-- We can extract a canonical term from an intuitionistic proof.
canonicalTerm₁ : ∃-proj₁ proof₁ ≡ succ zero
canonicalTerm₁ = refl

-- We cannot extract a canonical term from a non-intuitionistic proof.
-- canonicalTerm₂ : ∃-proj₁ proof₂ ≡ succ zero
-- canonicalTerm₂ = {!refl!}

-- Agda error:
--
-- ∃-proj₁ ([ (λ a → a) , (λ ¬a → ⊥-elim (x≢Sx (¬∃¬→∀ ¬a))) ] pem) !=
-- succ zero of type M
-- when checking that the expression refl has type
-- ∃-proj₁ proof₂ ≡ succ zero


module Dave.Equality where
  data _≡_ {A : Set} (x : A) : A → Set where
    refl : x ≡ x

  infix 4 _≡_

  {-# BUILTIN EQUALITY _≡_ #-}

  sym : ∀ {A : Set} {x y : A} → x ≡ y → y ≡ x
  sym refl = refl

  trans : ∀ {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
  trans refl b = b

  cong : ∀ {A B : Set} (f : A → B) {x y : A} → x ≡ y → f x ≡ f y
  cong f refl = refl

  cong₂ : ∀ {A B C : Set} (f : A → B → C) {u x : A} {v y : B}
    → u ≡ x
    → v ≡ y
    → f u v ≡ f x y
  cong₂ f refl refl = refl

  cong-app : ∀ {A B : Set} {f g : A → B}
    → f ≡ g
    → ∀ (x : A) → f x ≡ g x
  cong-app refl x = refl

  subst : ∀ {A : Set} {x y : A} (P : A → Set)
    → x ≡ y
    → P x → P y
  subst P refl px = px

  infix  1 begin_
  infixr 2 _≡⟨⟩_ _≡⟨_⟩_
  infix  3 _∎

  begin_ : ∀ {A : Set} {x y : A}
    → x ≡ y
      -----
    → x ≡ y
  begin x≡y  =  x≡y

  _≡⟨⟩_ : ∀ {A : Set} (x : A) {y : A}
    → x ≡ y
      -----
    → x ≡ y
  x ≡⟨⟩ x≡y  =  x≡y

  _≡⟨_⟩_ : ∀ {A : Set} (x : A) {y z : A}
    → x ≡ y
    → y ≡ z
      -----
    → x ≡ z
  x ≡⟨ x≡y ⟩ y≡z  =  trans x≡y y≡z

  _∎ : ∀ {A : Set} (x : A)
     -----
     → x ≡ x
  x ∎  =  refl


------------------------------------------------------------------------
-- A coinductive definition of (strong) similarity
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Labelled-transition-system

module Similarity {ℓ} (lts : LTS ℓ) where

open import Equality.Propositional
open import Prelude
open import Prelude.Size

open import Bisimilarity lts as SB using ([_]_∼_; [_]_∼′_)
open import Indexed-container hiding (⟨_⟩)
open import Relation
import Similarity.General

open LTS lts

private
  module General = Similarity.General lts _[_]⟶_ id

open General public
  using (module StepC; ⟨_⟩; challenge; force;
         reflexive-≤; reflexive-≤′; ≡⇒≤; ≤:_; ≤′:_;
         [_]_≡_; [_]_≡′_; []≡↔; Extensionality; extensionality)

-- StepC is given in the following way, rather than via open public,
-- to make hyperlinks to it more informative.

StepC : Container (Proc × Proc) (Proc × Proc)
StepC = General.StepC

-- The following definitions are given explicitly, in order to make
-- the code easier to follow.

Similarity : Size → Rel₂ ℓ Proc
Similarity = ν StepC

Similarity′ : Size → Rel₂ ℓ Proc
Similarity′ = ν′ StepC

infix 4 [_]_≤_ [_]_≤′_ _≤_ _≤′_

[_]_≤_ : Size → Proc → Proc → Type ℓ
[ i ] p ≤ q = ν StepC i (p , q)

[_]_≤′_ : Size → Proc → Proc → Type ℓ
[ i ] p ≤′ q = ν′ StepC i (p , q)

_≤_ : Proc → Proc → Type ℓ
_≤_ = [ ∞ ]_≤_

_≤′_ : Proc → Proc → Type ℓ
_≤′_ = [ ∞ ]_≤′_

private

  -- However, these definitions are definitionally equivalent to
  -- corresponding definitions in General.

  indirect-Similarity : Similarity ≡ General.Similarity
  indirect-Similarity = refl

  indirect-Similarity′ : Similarity′ ≡ General.Similarity′
  indirect-Similarity′ = refl

  indirect-[]≤ : [_]_≤_ ≡ General.[_]_≤_
  indirect-[]≤ = refl

  indirect-[]≤′ : [_]_≤′_ ≡ General.[_]_≤′_
  indirect-[]≤′ = refl

  indirect-≤ : _≤_ ≡ General._≤_
  indirect-≤ = refl

  indirect-≤′ : _≤′_ ≡ General._≤′_
  indirect-≤′ = refl

mutual

  -- Bisimilarity is contained in similarity.

  ∼⇒≤ : ∀ {i p q} → [ i ] p ∼ q → [ i ] p ≤ q
  ∼⇒≤ = λ p∼q →
    ⟨ (λ q⟶q′ →
         let p′ , p⟶p′ , p′∼′q′ = SB.left-to-right p∼q q⟶q′
         in p′ , p⟶p′ , ∼⇒≤′ p′∼′q′)
    ⟩

  ∼⇒≤′ : ∀ {i p q} → [ i ] p ∼′ q → [ i ] p ≤′ q
  force (∼⇒≤′ p≳′q) = ∼⇒≤ (SB.force p≳′q)

mutual

  -- Similarity is transitive.

  transitive-≤ : ∀ {i p q r} → [ i ] p ≤ q → [ i ] q ≤ r → [ i ] p ≤ r
  transitive-≤ p≤q q≤r =
    ⟨ (λ p⟶p′ →
         let q′ , q⟶q′ , p′≤q′ = challenge p≤q p⟶p′
             r′ , r⟶r′ , q′≤r′ = challenge q≤r q⟶q′
         in r′ , r⟶r′ , transitive-≤′ p′≤q′ q′≤r′)
    ⟩

  transitive-≤′ :
    ∀ {i p q r} → [ i ] p ≤′ q → [ i ] q ≤′ r → [ i ] p ≤′ r
  force (transitive-≤′ p≤q q≤r) = transitive-≤ (force p≤q) (force q≤r)


{-# OPTIONS --without-K --safe #-}
module Cats.Category.Constructions.Exponential where

open import Level

open import Cats.Category.Base
open import Cats.Category.Constructions.Product as Product using
  (HasBinaryProducts)
open import Cats.Util.Conv

import Cats.Category.Constructions.Iso as Iso
import Cats.Category.Constructions.Unique as Unique

module Build {lo la l≈}
  (Cat : Category lo la l≈)
  {{hasBinaryProducts : HasBinaryProducts Cat}}
  where

  open Category Cat
  open ≈-Reasoning
  open Unique.Build Cat
  open Iso.Build Cat
  open HasBinaryProducts hasBinaryProducts
  open _≅_

  record Exp (B C : Obj) : Set (lo ⊔ la ⊔ l≈) where
    field
      Cᴮ : Obj
      eval : Cᴮ × B ⇒ C
      curry′ : ∀ {A} (f : A × B ⇒ C)
        → ∃![ f̃ ∈ A ⇒ Cᴮ ] (eval ∘ ⟨ f̃ × id ⟩ ≈ f)

    curry : ∀ {A} → A × B ⇒ C → A ⇒ Cᴮ
    curry f = curry′ f ⃗

    eval-curry : ∀ {A} {f : A × B ⇒ C}
      → eval ∘ ⟨ curry f × id ⟩ ≈ f
    eval-curry {f = f} = ∃!′.prop (curry′ f)

    curry-unique : ∀ {A} {f : A × B ⇒ C} {g}
      → eval ∘ ⟨ g × id ⟩ ≈ f
      → curry f ≈ g
    curry-unique {f = f} = ∃!′.unique (curry′ f)

    uncurry : ∀ {A} → A ⇒ Cᴮ → A × B ⇒ C
    uncurry f = eval ∘ ⟨ f × id ⟩

    curry∘uncurry : ∀ {A} {f : A ⇒ Cᴮ}
      → curry (uncurry f) ≈ f
    curry∘uncurry = curry-unique ≈.refl

    uncurry∘curry : ∀ {A} {f : A × B ⇒ C}
      → uncurry (curry f) ≈ f
    uncurry∘curry = eval-curry

  instance HasObj-Exp : ∀ {B C} → HasObj (Exp B C) lo la l≈
  HasObj-Exp = record { Cat = Cat ; _ᴼ = Exp.Cᴮ }

  open Exp public

  curry∘curry : ∀ {A B C Y Z} (Cᴮ : Exp B C) (Yᶻ : Exp Y Z)
    → {f : Cᴮ ᴼ × Y ⇒ Z} {g : A × B ⇒ C}
    → curry Yᶻ f ∘ curry Cᴮ g ≈ curry Yᶻ (f ∘ ⟨ curry Cᴮ g × id ⟩)
  curry∘curry Cᴮ Yᶻ {f} {g} = ≈.sym (curry-unique Yᶻ (
      begin
        eval Yᶻ ∘ ⟨ curry Yᶻ f ∘ curry Cᴮ g × id ⟩
      ≈⟨ ∘-resp-r (⟨×⟩-resp ≈.refl (≈.sym id-l)) ⟩
        eval Yᶻ ∘ ⟨ curry Yᶻ f ∘ curry Cᴮ g × id ∘ id ⟩
      ≈⟨ ∘-resp-r (≈.sym ⟨×⟩-∘) ⟩
        eval Yᶻ ∘ ⟨ curry Yᶻ f × id ⟩ ∘ ⟨ curry Cᴮ g × id ⟩
      ≈⟨ unassoc ⟩
        (eval Yᶻ ∘ ⟨ curry Yᶻ f × id ⟩) ∘ ⟨ curry Cᴮ g × id ⟩
      ≈⟨ ∘-resp-l (eval-curry Yᶻ) ⟩
        f ∘ ⟨ curry Cᴮ g × id ⟩
      ∎
    ))

  Exp-resp-≅ : ∀ {A A′ B B′}
    → A ≅ A′
    → B ≅ B′
    → (E : Exp A B) (E′ : Exp A′ B′)
    → E ᴼ ≅ E′ ᴼ
  Exp-resp-≅ A≅A′ B≅B′ E E′ = record
    { forth = curry E′ (B≅B′ .forth ∘ eval E ∘ ⟨ id × A≅A′ .back ⟩)
    ; back = curry E (B≅B′ .back ∘ eval E′ ∘ ⟨ id × A≅A′ .forth ⟩)
    -- Today in our series on 'trivial' properties (also copy-and-paste
    -- programming).
    ; back-forth = ≈.trans (curry∘curry E′ E)
        (curry-unique E (≈.trans (∘-resp-r ⟨×⟩-id) (≈.trans id-r
        (≈.sym (≈.trans assoc (≈.trans (∘-resp-r (≈.trans assoc (≈.trans
        (∘-resp-r (≈.trans ⟨×⟩-∘
        (≈.trans (⟨×⟩-resp (≈.trans id-l (≈.sym id-r)) (≈.trans id-r (≈.sym id-l)))
        (≈.sym ⟨×⟩-∘)))) (≈.trans unassoc (∘-resp-l (eval-curry E′))))))
        (≈.trans unassoc (≈.trans (∘-resp-l (≈.trans unassoc
        (≈.trans (∘-resp-l (B≅B′ .back-forth)) id-l)))
        (≈.trans assoc (≈.trans (∘-resp-r (≈.trans ⟨×⟩-∘
        (≈.trans (⟨×⟩-resp id-l (A≅A′ .back-forth)) ⟨×⟩-id))) id-r))))))))))
    ; forth-back = ≈.trans (curry∘curry E E′)
        (curry-unique E′ (≈.trans (∘-resp-r ⟨×⟩-id) (≈.trans id-r
        (≈.sym (≈.trans assoc (≈.trans (∘-resp-r (≈.trans assoc (≈.trans
        (∘-resp-r (≈.trans ⟨×⟩-∘
        (≈.trans (⟨×⟩-resp (≈.trans id-l (≈.sym id-r)) (≈.trans id-r (≈.sym id-l)))
        (≈.sym ⟨×⟩-∘)))) (≈.trans unassoc (∘-resp-l (eval-curry E))))))
        (≈.trans unassoc (≈.trans (∘-resp-l (≈.trans unassoc
        (≈.trans (∘-resp-l (B≅B′ .forth-back)) id-l)))
        (≈.trans assoc (≈.trans (∘-resp-r (≈.trans ⟨×⟩-∘
        (≈.trans (⟨×⟩-resp id-l (A≅A′ .forth-back)) ⟨×⟩-id))) id-r))))))))))
    }

record HasExponentials {lo la l≈}
  (Cat : Category lo la l≈)
  : Set (lo ⊔ la ⊔ l≈)
  where
  private open module Bld = Build Cat using (Exp)
  open Category Cat
  open Unique.Build Cat
  open Iso.Build Cat

  infixr 1 _↝′_ _↝_

  field
    {{hasBinaryProducts}} : HasBinaryProducts Cat
    _↝′_ : ∀ B C → Exp B C

  open HasBinaryProducts hasBinaryProducts

  _↝_ : Obj → Obj → Obj
  B ↝ C = (B ↝′ C) ᴼ

  eval : ∀ {B C} → (B ↝ C) × B ⇒ C
  eval {B} {C} = Bld.eval (B ↝′ C)

  curry : ∀ {A B C} → A × B ⇒ C → A ⇒ B ↝ C
  curry {B = B} {C} f = Bld.curry (B ↝′ C) f

  uncurry : ∀ {A B C} → A ⇒ B ↝ C → A × B ⇒ C
  uncurry {B = B} {C} = Bld.uncurry (B ↝′ C)

  eval-curry : ∀ {A B C} {f : A × B ⇒ C}
    → eval ∘ ⟨ curry f × id ⟩ ≈ f
  eval-curry {B = B} {C} = Bld.eval-curry (B ↝′ C)

  curry-unique : ∀ {A B C} {f : A × B ⇒ C} {g}
    → eval ∘ ⟨ g × id ⟩ ≈ f
    → curry f ≈ g
  curry-unique {B = B} {C} = Bld.curry-unique (B ↝′ C)

  curry∘uncurry : ∀ {A B C} {f : A ⇒ B ↝ C}
    → curry (uncurry f) ≈ f
  curry∘uncurry {B = B} {C} = Bld.curry∘uncurry (B ↝′ C)

  uncurry∘curry : ∀ {A B C} {f : A × B ⇒ C}
    → uncurry (curry f) ≈ f
  uncurry∘curry {B = B} {C} = Bld.uncurry∘curry (B ↝′ C)

  curry∘curry : ∀ {A B C Y Z}
    → {f : (B ↝ C) × Y ⇒ Z} {g : A × B ⇒ C}
    → curry f ∘ curry g ≈ curry (f ∘ ⟨ curry g × id ⟩)
  curry∘curry {B = B} {C} {Y} {Z} = Bld.curry∘curry (B ↝′ C) (Y ↝′ Z)

  ↝-resp-≅ : ∀ {A A′ B B′}
    → A ≅ A′
    → B ≅ B′
    → (A ↝ B) ≅ (A′ ↝ B′)
  ↝-resp-≅ {A} {A′} {B} {B′} A≅A′ B≅B′
    = Bld.Exp-resp-≅ A≅A′ B≅B′ (A ↝′ B) (A′ ↝′ B′)

open Build public


{-# OPTIONS --type-in-type #-}
-- {-# OPTIONS --guardedness-preserving-type-constructors #-}

module PatternSynonymsErrorLocation where

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

infixr 2 _,_

record Unit : Set where

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

-- Prod does not communicate guardedness
Prod : (A B : Set) -> Set
Prod A B = Sigma A \ _ -> B

data Empty : Set where

data ListTag : Set where nil cons : ListTag

{-# TERMINATING #-}
List : (A : Set) -> Set
List A = Sigma ListTag T where
  T : ListTag -> Set
  T nil  = Unit
  T cons = Sigma A \ _ -> List A

infix 5 _∷_

pattern []       = nil , _
pattern _∷_ x xs = cons , x , xs
-- FAILS: pattern x ∷ xs = cons , x , xs

data TyTag : Set where base arr : TyTag

{-# TERMINATING #-}
Ty : Set
Ty = Sigma TyTag T where
  T : TyTag -> Set
  T base = Unit
  T arr  = Sigma Ty \ _ -> Ty  -- Prod Ty Ty

infix 10 _⇒_

pattern ★       = base , _
pattern _⇒_ A B = arr , A , B

Context = List Ty

data NatTag : Set where zero succ : NatTag

Var : (Gamma : Context)(C : Ty) -> Set
Var []           C = Empty
Var (cons , A , Gamma) C =  Sigma NatTag T
  where T : NatTag -> Set
        T zero = A ≡ C
        T succ = Var Gamma C

pattern vz   = zero , refl
pattern vs x = succ , x

idVar : (Gamma : Context)(C : Ty)(x : Var Gamma C) -> Var Gamma C
idVar [] _ ()
-- CORRECT: idVar (A ∷ Gamma) C (zero , proof) = zero , proof
idVar (A ∷ Gamma) C vz         = vz
idVar (A ∷ Gamma) C (vs x)     = vs (idVar Gamma C x)


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

module Data.Binary.Increment where

open import Data.Binary.Definition
open import Strict

inc : 𝔹 → 𝔹
inc 0ᵇ      = 1ᵇ 0ᵇ
inc (1ᵇ xs) = 2ᵇ xs
inc (2ᵇ xs) = 1ᵇ inc xs


module Nat where

open import Eq

data ℕ : Set where
  Z : ℕ
  S : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

infixl 6 _+_
infixl 7 _×_

_+_ : ℕ → ℕ → ℕ
Z + n     = n
(S k) + n = S(k + n)

{-# BUILTIN NATPLUS _+_ #-}

_×_ : ℕ → ℕ → ℕ
Z  × n = Z
S m × n = n + m × n

{-# BUILTIN NATTIMES _×_ #-}

*-right-zero : ∀ (n : ℕ) → n × Z ≡ Z
*-right-zero Z = Refl
*-right-zero (S n) = *-right-zero n

testEq : (x : ℕ) → (y : ℕ) → (p : x ≡ y) → ℕ
testEq x _ Refl = x


module eq-reasoning {A : Set} where

  open import eq

  infix  1 begin_
  infixr 2 _≡⟨⟩_ _≡⟨_⟩_
  infix  3 _∎

  begin_ : ∀ {x y : A}
    → x ≡ y
      -----
    → x ≡ y
  begin x≡y  =  x≡y

  _≡⟨⟩_ : ∀ (x : A) {y : A}
    → x ≡ y
      -----
    → x ≡ y
  x ≡⟨⟩ x≡y  =  x≡y

  _≡⟨_⟩_ : ∀ (x : A) {y z : A}
    → x ≡ y
    → y ≡ z
      -----
    → x ≡ z
  x ≡⟨ x≡y ⟩ y≡z  =  trans x≡y y≡z

  _∎ : ∀ (x : A)
      -----
    → x ≡ x
  x ∎  =  refl


{-# OPTIONS --without-K #-}
module hott.univalence where

open import level using (lsuc)
open import sum using (_,_ ; proj₁)
open import equality.core
open import equality.calculus
open import equality.reasoning
open import function.core
open import function.isomorphism.core using (_≅_ ; module _≅_)
open import hott.equivalence.core

-- mapping from equality to function
coerce : ∀ {i} {X Y : Set i} → X ≡ Y → X → Y
coerce refl = id

coerce-equiv : ∀ {i} {X Y : Set i} → (p : X ≡ Y) → weak-equiv (coerce p)
coerce-equiv refl x = (x , refl) , λ { (.x , refl) → refl }

coerce-hom : ∀ {i} {X Y Z : Set i}
           → (p : X ≡ Y)(q : Y ≡ Z)
           → coerce (p · q) ≡ coerce q ∘ coerce p
coerce-hom refl q = refl

-- mapping from propositional equality to weak equivalence
≡⇒≈ : ∀ {i} {X Y : Set i} → X ≡ Y → X ≈ Y
≡⇒≈ p = coerce p , coerce-equiv p

Univalence : ∀ i → Set (lsuc i)
Univalence i = {X Y : Set i} → weak-equiv $ ≡⇒≈ {X = X} {Y = Y}

postulate univalence : ∀ {i} → Univalence i

private
  module Properties {i} {X Y : Set i} where
    uni-equiv : (X ≡ Y) ≈ (X ≈ Y)
    uni-equiv = ≡⇒≈ , univalence

    uni-iso : (X ≡ Y) ≅ (X ≈ Y)
    uni-iso = ≈⇒≅ uni-equiv
    open _≅_ uni-iso public using ()
      renaming (from to ≈⇒≡)

    uni-coherence : (f : X ≈ Y) → coerce (≈⇒≡ f) ≡ proj₁ f
    uni-coherence f = begin
        coerce (≈⇒≡ f)
      ≡⟨ refl ⟩
        proj₁ (≡⇒≈ (≈⇒≡ f))
      ≡⟨ ap proj₁ (iso₂ f) ⟩
        proj₁ f
      ∎
      where
        open ≡-Reasoning
        open _≅_ uni-iso using (iso₂)

open Properties public


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

{-# OPTIONS --sized-types #-}

open import Codata.Colist
open import Codata.Thunk
open import Size
open import Data.Empty
open import Relation.Binary.PropositionalEquality

module Examples.Colists.Auxiliary.Colist_member {A : Set} where

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

  mem-abs : ∀{x xs} → x ∈ xs → xs ≡ [] → ⊥
  mem-abs {_} {.[]} () refl


-- The Berry majority function.

module Berry where

  data Bool : Set where
    F : Bool
    T : Bool

  maj : Bool -> Bool -> Bool -> Bool
  maj T T T = T
  maj T F x = x
  maj F x T = x
  maj x T F = x   -- doesn't hold definitionally
  maj F F F = F

  postulate
    z : Bool


-- {-# OPTIONS --show-implicit --show-irrelevant #-}
module Data.QuadTree.LensProofs.Valid-LensAtLocation where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Data.QuadTree.InternalAgda
open import Agda.Primitive
open import Data.Lens.Proofs.LensLaws
open import Data.Lens.Proofs.LensPostulates
open import Data.Lens.Proofs.LensComposition
open import Data.QuadTree.LensProofs.Valid-LensLeaf
open import Data.QuadTree.LensProofs.Valid-LensWrappedTree
open import Data.QuadTree.LensProofs.Valid-LensA
open import Data.QuadTree.LensProofs.Valid-LensBCD
open import Data.QuadTree.LensProofs.Valid-LensGo
open import Data.QuadTree.Implementation.QuadrantLenses
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.SafeFunctions
open import Data.QuadTree.Implementation.PublicFunctions
open import Data.QuadTree.Implementation.DataLenses

---- Lens laws for go

ValidLens-AtLocation-ViewSet :
    {t : Set} {{eqT : Eq t}}
    -> (loc : Nat × Nat) -> (dep : Nat)
    -> {ins : IsTrue (isInsidePow loc dep)}
    -> ViewSet (atLocation {t} loc dep {ins})
ValidLens-AtLocation-ViewSet (x , y) dep {ins} v s = trans refl (prop-Composition-ViewSet (ValidLens-WrappedTree) (ValidLens-go (x , y) dep {ins}) v s)

ValidLens-AtLocation-SetView :
    {t : Set} {{eqT : Eq t}}
    -> (loc : Nat × Nat) -> (dep : Nat)
    -> {ins : IsTrue (isInsidePow loc dep)}
    -> SetView (atLocation {t} loc dep {ins})
ValidLens-AtLocation-SetView (x , y) dep {ins} s = trans refl (prop-Composition-SetView (ValidLens-WrappedTree) (ValidLens-go (x , y) dep {ins}) s)

ValidLens-AtLocation-SetSet :
    {t : Set} {{eqT : Eq t}}
    -> (loc : Nat × Nat) -> (dep : Nat)
    -> {ins : IsTrue (isInsidePow loc dep)}
    -> SetSet (atLocation {t} loc dep {ins})
ValidLens-AtLocation-SetSet (x , y) dep {ins} v1 v2 s = trans refl (prop-Composition-SetSet (ValidLens-WrappedTree) (ValidLens-go (x , y) dep {ins}) v1 v2 s)

ValidLens-AtLocation : {t : Set} {{eqT : Eq t}}
    -> (loc : Nat × Nat) -> (dep : Nat)
    -> {ins : IsTrue (isInsidePow loc dep)}
    -> ValidLens (VQuadTree t {dep}) t
ValidLens-AtLocation {t} {{eqT}} (x , y) dep {ins} = CValidLens (atLocation (x , y) dep {ins}) (ValidLens-AtLocation-ViewSet (x , y) dep {ins}) (ValidLens-AtLocation-SetView (x , y) dep {ins}) (ValidLens-AtLocation-SetSet (x , y) dep {ins})


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

module Cubical.Categories.Equivalence.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Sigma
open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.NaturalTransformation
open import Cubical.Categories.Morphism
open import Cubical.Categories.Equivalence.Base
open import Cubical.HITs.PropositionalTruncation.Base

open Precategory
open Functor
open NatIso
open CatIso
open NatTrans
open isEquivalence

private
  variable
    ℓC ℓC' ℓD ℓD' : Level

-- Equivalence implies Full, Faithul, and Essentially Surjective

module _ {C : Precategory ℓC ℓC'} {D : Precategory ℓD ℓD'} where
  symEquiv : ∀ {F : Functor C D} → (e : isEquivalence F) → isEquivalence (e .invFunc)
  symEquiv {F} record { invFunc = G ; η = η ; ε = ε } = record { invFunc = F ; η = symNatIso ε ; ε = symNatIso η }

  isEquiv→Faithful : ∀ {F : Functor C D} → isEquivalence F → isFaithful F
  isEquiv→Faithful {F} record { invFunc = G
                              ; η = η
                              ; ε = _ }
                   c c' f g p = f
                              ≡⟨ sqRL η ⟩
                                cIso .mor ⋆⟨ C ⟩ G ⟪ F ⟪ f ⟫ ⟫ ⋆⟨ C ⟩ c'Iso .inv
                              ≡⟨ cong (λ v → cIso .mor ⋆⟨ C ⟩ (G ⟪ v ⟫) ⋆⟨ C ⟩ c'Iso .inv) p ⟩
                                cIso .mor ⋆⟨ C ⟩ G ⟪ F ⟪ g ⟫ ⟫ ⋆⟨ C ⟩ c'Iso .inv
                              ≡⟨ sym (sqRL η) ⟩
                                g
                              ∎
    where

      -- isomorphism between c and GFc
      cIso = isIso→CatIso (η .nIso c)
      -- isomorphism between c' and GFc'
      c'Iso = isIso→CatIso (η .nIso c')

module _ {C : Precategory ℓC ℓC'} {D : Precategory ℓD ℓD'} where
  isEquiv→Full : ∀ {F : Functor C D} → isEquivalence F → isFull F
  isEquiv→Full {F} eq@record { invFunc = G
                             ; η = η
                             ; ε = _ }
               c c' g = ∣ h , isEquiv→Faithful (symEquiv eq) _ _ _ _ GFh≡Gg ∣ -- apply faithfulness of G
    where
      -- isomorphism between c and GFc
      cIso = isIso→CatIso (η .nIso c)
      -- isomorphism between c' and GFc'
      c'Iso = isIso→CatIso (η .nIso c')

      -- reverses
      cIso⁻ = symCatIso cIso
      c'Iso⁻ = symCatIso c'Iso

      h = cIso .mor ⋆⟨ C ⟩ G ⟪ g ⟫ ⋆⟨ C ⟩ c'Iso .inv

      -- we show that both `G ⟪ g ⟫` and `G ⟪ F ⟪ h ⟫ ⟫`
      -- are equal to the same thing
      -- namely : cIso .inv ⋆⟨ C ⟩ h ⋆⟨ C ⟩ c'Iso .mor
      Gg≡ηhη : G ⟪ g ⟫ ≡ cIso .inv ⋆⟨ C ⟩ h ⋆⟨ C ⟩ c'Iso .mor
      Gg≡ηhη = invMoveL cAreInv move-c' ∙ sym (C .⋆Assoc _ _ _)
        where
          cAreInv : areInv (cIso .mor) (cIso .inv)
          cAreInv = CatIso→areInv cIso

          c'AreInv : areInv (c'Iso .mor) (c'Iso .inv)
          c'AreInv = CatIso→areInv c'Iso

          move-c' : cIso .mor ⋆⟨ C ⟩ G ⟪ g ⟫ ≡ h ⋆⟨ C ⟩ c'Iso .mor
          move-c' = invMoveR (symAreInv c'AreInv) refl

      GFh≡Gg : G ⟪ F ⟪ h ⟫ ⟫ ≡ G ⟪ g ⟫
      GFh≡Gg = G ⟪ F ⟪ h ⟫ ⟫
             ≡⟨ sqLR η ⟩
               cIso .inv ⋆⟨ C ⟩ h ⋆⟨ C ⟩ c'Iso .mor
             ≡⟨ sym Gg≡ηhη ⟩
               G ⟪ g ⟫
             ∎

  isEquiv→Surj : ∀ {F : Functor C D} → isEquivalence F → isEssentiallySurj F
  isEquiv→Surj isE d = (isE .invFunc ⟅ d ⟆) , isIso→CatIso ((isE .ε .nIso) d)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on characters
------------------------------------------------------------------------

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

module Data.Char.Properties where

open import Data.Bool.Base using (Bool)
open import Data.Char.Base

import Data.Nat.Base as ℕ
import Data.Nat.Properties as ℕₚ

open import Function
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (map′; isYes)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.Core
import Relation.Binary.Construct.On as On
import Relation.Binary.PropositionalEquality as PropEq

------------------------------------------------------------------------
-- Primitive properties

open import Agda.Builtin.Char.Properties
  renaming ( primCharToNatInjective to toℕ-injective)
  public

------------------------------------------------------------------------
-- Properties of _≈_

≈⇒≡ : _≈_ ⇒ _≡_
≈⇒≡ = toℕ-injective _ _

≈-reflexive : _≡_ ⇒ _≈_
≈-reflexive = cong toℕ

≈-refl : Reflexive _≈_
≈-refl = refl

≈-sym : Symmetric _≈_
≈-sym = sym

≈-trans : Transitive _≈_
≈-trans = trans

≈-subst : ∀ {ℓ} → Substitutive _≈_ ℓ
≈-subst P x≈y p = subst P (≈⇒≡ x≈y) p

infix 4 _≈?_
_≈?_ : Decidable _≈_
x ≈? y = toℕ x ℕₚ.≟ toℕ y

≈-isEquivalence : IsEquivalence _≈_
≈-isEquivalence = record
  { refl  = λ {i} → ≈-refl {i}
  ; sym   = λ {i j} → ≈-sym {i} {j}
  ; trans = λ {i j k} → ≈-trans {i} {j} {k}
  }

≈-setoid : Setoid _ _
≈-setoid = record
  { isEquivalence = ≈-isEquivalence
  }

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

≈-decSetoid : DecSetoid _ _
≈-decSetoid = record
  { isDecEquivalence = ≈-isDecEquivalence
  }

------------------------------------------------------------------------
-- Properties of _≡_

infix 4 _≟_
_≟_ : Decidable {A = Char} _≡_
x ≟ y = map′ ≈⇒≡ ≈-reflexive (x ≈? y)

≡-setoid : Setoid _ _
≡-setoid = PropEq.setoid Char

≡-decSetoid : DecSetoid _ _
≡-decSetoid = PropEq.decSetoid _≟_

------------------------------------------------------------------------
-- Boolean equality test.
--
-- Why is the definition _==_ = primCharEquality not used? One reason
-- is that the present definition can sometimes improve type
-- inference, at least with the version of Agda that is current at the
-- time of writing: see unit-test below.

infix 4 _==_
_==_ : Char → Char → Bool
c₁ == c₂ = isYes (c₁ ≟ c₂)

private

  -- The following unit test does not type-check (at the time of
  -- writing) if _==_ is replaced by primCharEquality.

  data P : (Char → Bool) → Set where
    p : (c : Char) → P (c ==_)

  unit-test : P ('x' ==_)
  unit-test = p _

------------------------------------------------------------------------
-- Properties of _<_

infix 4 _<?_
_<?_ : Decidable _<_
_<?_ = On.decidable toℕ ℕ._<_ ℕₚ._<?_

<-isStrictPartialOrder-≈ : IsStrictPartialOrder _≈_ _<_
<-isStrictPartialOrder-≈ = On.isStrictPartialOrder toℕ ℕₚ.<-isStrictPartialOrder

<-isStrictTotalOrder-≈ : IsStrictTotalOrder _≈_ _<_
<-isStrictTotalOrder-≈ = On.isStrictTotalOrder toℕ ℕₚ.<-isStrictTotalOrder

<-strictPartialOrder-≈ : StrictPartialOrder _ _ _
<-strictPartialOrder-≈ = On.strictPartialOrder ℕₚ.<-strictPartialOrder toℕ

<-strictTotalOrder-≈ : StrictTotalOrder _ _ _
<-strictTotalOrder-≈ = On.strictTotalOrder ℕₚ.<-strictTotalOrder toℕ

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

-- Version 1.1

toNat-injective = toℕ-injective
{-# WARNING_ON_USAGE toℕ-injective
"Warning: toNat-injective was deprecated in v1.1.
Please use toℕ-injective instead."
#-}

setoid = ≡-setoid
{-# WARNING_ON_USAGE setoid
"Warning: setoid was deprecated in v1.1.
Please use ≡-setoid instead."
#-}

decSetoid = ≡-decSetoid
{-# WARNING_ON_USAGE decSetoid
"Warning: decSetoid was deprecated in v1.1.
Please use ≡-decSetoid instead."
#-}

strictTotalOrder = <-strictTotalOrder-≈
{-# WARNING_ON_USAGE strictTotalOrder
"Warning: strictTotalOrder was deprecated in v1.1.
Please use <-strictTotalOrder-≈ instead."
#-}


module Category.Instance where

open import Level
open import Category.Core

𝟙 : Category _ _
𝟙 = record
    { Objects = record
        { Carrier = ⊤
        ; _≈_ = λ _ _ → ⊤
        ; isEquivalence = _
        }
    ; Morphisms = record
        { Carrier = λ x → ⊤
        ; _≈_ = λ _ _ → ⊤
        ; isEquivalence = _
        ; _∘_ = λ _ _ → tt
        ; id = λ a → tt
        ; isMorphism = _
        }
    }
    where
        open import Data.Unit

-- "pointing" an element with a functor from 𝟙
point : ∀ {𝒸 ℓ} → {C : Category 𝒸 ℓ} → Category.Object C → Functor 𝟙 C
point {_} {_} {C} c = record
    { mapObject = λ _ → c
    ; mapMorphism = λ _ → id c
    ; isFunctor = record
        { preserve-id = λ a → MorphEq.refl
        ; preserve-∘ = λ _ _ → MorphEq.sym (left-identity (id c))
        }
    }
    where
        open Category C
        open import Relation.Binary.Indexed
        module MorphEq = IsEquivalence (MorphismStructure.isEquivalence Morphisms)

        open IsMorphism isMorphism

-- the identity functo
identity : ∀ {𝒸 ℓ} → (C : Category 𝒸 ℓ) → Functor C C
identity C = record
    { mapObject = λ x → x
    ; mapMorphism = λ x → x
    ; isFunctor = record
        { preserve-id = λ a → MorphEq.refl
        ; preserve-∘ = λ f g → MorphEq.refl
        }
    }
    where
        open Category C
        open import Relation.Binary.Indexed
        module MorphEq = IsEquivalence (MorphismStructure.isEquivalence Morphisms)

        open IsMorphism isMorphism


{-# OPTIONS --type-in-type #-}

open import Data.Empty
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
open import Function.Base using (_∘_; id)
open import Relation.Nullary using (¬_)
open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl; subst; cong; sym)

record _◁_ {ℓ} (A B : Set ℓ) : Set ℓ where
  constructor _,_,_
  field
    ϕ : A → B
    ψ : B → A
    retract : ψ ∘ ϕ ≡ id
open _◁_

record _◁′_ {ℓ} (A B : Set ℓ) : Set ℓ where
  constructor _,_,_
  field
    ϕ : A → B
    ψ : B → A
    retract : A ◁ B → ψ ∘ ϕ ≡ id
open _◁′_

postulate
  EM : ∀ {ℓ} (A : Set ℓ) → A ⊎ (¬ A)

℘ : ∀ {ℓ} → Set ℓ → Set _
℘ X = X → Set

t : ∀ {ℓ} (A B : Set ℓ) → ℘ A ◁′ ℘ B
t A B with EM (℘ A ◁ ℘ B)
... | inj₁  ℘A◁℘B =
      let ϕ , ψ , retract = ℘A◁℘B
      in ϕ , ψ , λ _ → retract
... | inj₂ ¬℘A◁℘B =
      (λ _ _ → ⊥) , (λ _ _ → ⊥) , λ ℘A◁℘B → ⊥-elim (¬℘A◁℘B ℘A◁℘B)

-- type-in-type allows U to be put into Set...
U : Set
U = ∀ X → ℘ X

-- ...so that u: U can be applied to U itself
projᵤ : U → ℘ U
projᵤ u = u U

injᵤ : ℘ U → U
injᵤ f X =
  let _ , ψ , _ = t X U
      ϕ , _ , _ = t U U
  in ψ (ϕ f)

projᵤ∘injᵤ : projᵤ ∘ injᵤ ≡ id
projᵤ∘injᵤ = retract (t U U) (id , id , refl)

_∈_ : U → U → Set
u ∈ v = projᵤ u v

Russell : ℘ U
Russell u = ¬ u ∈ u

r : U
r = injᵤ Russell

-- up to here EM + impredicativity is enough,
-- as long as _≡_ itself is in the impredicative universe,
-- but to go further, large elimination (via subst) is required
r∈r≡r∉r : r ∈ r ≡ (¬ r ∈ r)
r∈r≡r∉r = cong (λ f → f Russell r) projᵤ∘injᵤ

r∉r : ¬ r ∈ r
r∉r r∈r =
  let r∈r→r∉r = subst id r∈r≡r∉r
  in r∈r→r∉r r∈r r∈r

false : ⊥
false =
  let r∉r→r∈r = subst id (sym r∈r≡r∉r)
  in r∉r (r∉r→r∈r r∉r)


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

module Categories.Minus2-Category.Properties where

-- All -2-Categories are equivalent to One

open import Level
open import Data.Product using (Σ; _,_; proj₁; proj₂)
open import Data.Unit using (⊤; tt)

open import Categories.Minus2-Category
open import Categories.Category
import Categories.Morphism as M
open import Categories.Category.Monoidal
open import Categories.Category.Instance.One
open import Categories.Category.Equivalence hiding (refl)
open import Categories.NaturalTransformation using (ntHelper)

private
  variable
    o ℓ e : Level

shrink-them-all : (X : -2-Category {o} {ℓ} {e}) → StrongEquivalence (-2-Category.cat X) (One {o} {ℓ} {e})
shrink-them-all X = record
  { F = record
    { F₀ = λ _ → lift tt
    ; F₁ = λ _ → lift tt
    }
  ; G = record
    { F₀ = λ _ → proj₁ Obj-Contr
    ; F₁ = λ _ → M._≅_.from (proj₂ Obj-Contr (proj₁ Obj-Contr))
    ; identity = Hom-Conn
    ; homomorphism = Hom-Conn
    ; F-resp-≈ = λ _ → Hom-Conn
    }
  ; weak-inverse = record
    { F∘G≈id = _
    ; G∘F≈id = record
      { F⇒G = ntHelper (record
        { η = λ y → M._≅_.from (proj₂ Obj-Contr y)
        ; commute = λ _ → Hom-Conn
        })
      ; F⇐G = ntHelper (record
        { η = λ y → M._≅_.to (proj₂ Obj-Contr y)
        ; commute = λ _ → Hom-Conn
        })
      ; iso = λ Z → record
        { isoˡ = M._≅_.isoˡ (proj₂ Obj-Contr Z)
        ; isoʳ = M._≅_.isoʳ (proj₂ Obj-Contr Z)
        }
      }
    }
  }
  where
    open -2-Category X
    open Category cat


open import SOAS.Common

-- Free construction with respect to a forgetful functor between categories
module SOAS.Construction.Free {ℂ 𝕊 : Category 1ℓ 0ℓ 0ℓ}
                               (U : Functor 𝕊 ℂ) where

open import Categories.Adjoint
import Categories.Morphism.Reasoning as MR
open import Categories.Category.Equivalence using (WeakInverse; StrongEquivalence)
open import Categories.Adjoint.Properties
open import Categories.Monad

private module ℂ = Category ℂ
private module 𝕊 = Category 𝕊
private module U = Functor U

-- Mapping from an object of the carrier category to the carrier of an object
-- from the structure category
_↪_ : ℂ.Obj → 𝕊.Obj → Set
C ↪ S = ℂ [ C , U.₀ S ]

-- Definition of F being a free structure over a carrier C:
-- any carrier map c : C → S into the carrier of a structure S factorises
-- through a unique extension of c to a structure homomorphism ĉ : F C → S:
--
--           ⌊-⌋
--   C ────────────── FC
--  ╰─────── S ───────╯
--      c         ĉ

record FreeConstruction (F : ℂ.Obj → 𝕊.Obj)
                        (C : ℂ.Obj)
                        (embed : C ↪ F C)
                        (S : 𝕊.Obj)
                        (c : C ↪ S)
                        : Set₁ where

  field
    -- Given another structure S, any mapping from C to the carrier of S can be
    -- extended into a structure homomorphism from F C to S.
    extend : 𝕊 [ F C , S ]

    -- Any map from C to the carrier of a structure S factors through the
    -- embedding and extension
    factor : U.₁ extend ℂ.∘ embed ℂ.≈ c

    -- Extension is the unique factorising morphism
    unique : (e : 𝕊 [ F C , S ])
           → (p : (U.₁ e ℂ.∘ embed) ℂ.≈ c)
           → 𝕊 [ e ≈ extend ]

record FreeMapping (F : ℂ.Obj → 𝕊.Obj) : Set₁ where

  field
    embed : {C : ℂ.Obj} → C ↪ F C
    univ  : (C : ℂ.Obj) (S : 𝕊.Obj)(c : C ↪ S)
          → FreeConstruction F C embed S c

  module Universal C S c = FreeConstruction (univ C S c)

  module _ {C : ℂ.Obj} {S : 𝕊.Obj}(c : C ↪ S) where
    open Universal C S c public

  open MR ℂ
  open ℂ.HomReasoning
  private module 𝕊R = 𝕊.HomReasoning
  open NT

  -- The uniqueness of the factors means that any two morphisms
  -- that factorise the same arrow must be equal
  equate : {C : ℂ.Obj}{S : 𝕊.Obj}
        → (f g : 𝕊 [ F C , S ])
        → (p : U.₁ f ℂ.∘ embed ℂ.≈ U.₁ g ℂ.∘ embed)
        → 𝕊 [ f ≈ g ]
  equate f g p = unique _ f p 𝕊R.○ 𝕊R.⟺ (unique _ g ℂ.Equiv.refl)

  -- Infix shorthand
  [_≋_]! : {C : ℂ.Obj}{S : 𝕊.Obj}
        → (f g : 𝕊 [ F C , S ])
        → (p : U.₁ f ℂ.∘ embed ℂ.≈ U.₁ g ℂ.∘ embed)
        → 𝕊 [ f ≈ g ]
  [ f ≋ g ]! p = equate f g p

  -- Extensions of equal embeddings are equal
  extend-cong : {C : ℂ.Obj}{S : 𝕊.Obj}(c₁ c₂ : C ↪ S)
             → ℂ [ c₁ ≈ c₂ ] → 𝕊 [ extend c₁ ≈ extend c₂ ]
  extend-cong {C}{S} c₁ c₂ p = unique _ (extend c₁) (factor c₁ ○ p)

  -- | Freeness makes F into a functor

  map : {C D : ℂ.Obj} → C ℂ.⇒ D → F C 𝕊.⇒ F D
  map {C}{D} f = extend (embed ℂ.∘ f)

  embed-commute : {C D : ℂ.Obj}(f : C ℂ.⇒ D)
               → embed ℂ.∘ f ℂ.≈ (U.₁ (map f) ℂ.∘ embed)
  embed-commute {C}{D} f = ⟺ (factor (embed ℂ.∘ f))

  identity : {C : ℂ.Obj} → map (ℂ.id {C}) 𝕊.≈ 𝕊.id
  identity {C} = 𝕊R.⟺ $ᶠ unique _ 𝕊.id (begin
         U.₁ 𝕊.id ℂ.∘ embed  ≈⟨ U.identity ⟩∘⟨refl ⟩
         ℂ.id ℂ.∘ embed      ≈⟨ id-comm-sym ⟩
         embed ℂ.∘ ℂ.id      ∎)

  homomorphism : {C D E : ℂ.Obj} {f : ℂ [ C , D ]} {g : ℂ [ D , E ]}
              → 𝕊 [ map (ℂ [ g ∘ f ])
               ≈ 𝕊 [ map g ∘ map f ] ]
  homomorphism {C}{D}{E}{f}{g} = 𝕊R.⟺ $ᶠ unique _ (𝕊 [ map g ∘ map f ]) (begin
         U.₁ (map g 𝕊.∘ map f) ℂ.∘ embed           ≈⟨ pushˡ U.homomorphism ⟩
         U.₁ (map g)  ℂ.∘  U.₁ (map f)  ℂ.∘ embed  ≈⟨ pushʳ (⟺ (embed-commute f)) ⟩
         (U.₁ (map g)  ℂ.∘  embed) ℂ.∘ f           ≈⟨ pushˡ (⟺ (embed-commute g)) ⟩
         embed ℂ.∘ g ℂ.∘ f                          ∎)

  -- Free functor from ℂ to 𝕊
  Free : Functor ℂ 𝕊
  Free = record
    { F₀ = F
    ; F₁ = map
    ; identity = identity
    ; homomorphism = homomorphism
    ; F-resp-≈ = λ {C}{D}{f}{g} p →
          extend-cong (embed ℂ.∘ f) (embed ℂ.∘ g) (ℂ.∘-resp-≈ʳ p)
    }

  module F = Functor Free

  -- | Freeness also induces a free-forgetful adjunction

  -- Embedding is a natural transformation
  embed-NT : NT idF (U ∘F Free)
  embed-NT = ntHelper record
    { η = λ C → embed
    ; commute = embed-commute
    }

  -- Extension of the identity on US is a natural transformation
  extract : (S : 𝕊.Obj) → F (U.₀ S) 𝕊.⇒ S
  extract S = extend ℂ.id

  -- Extraction is a natural transformation
  extract-NT : NT (Free ∘F U) idF
  extract-NT = ntHelper record
    { η = extract
    ; commute = λ {S}{T} f → [ extract T 𝕊.∘ F.₁ (U.₁ f) ≋ f 𝕊.∘ extract S ]!
        (begin
             U.₁ (extract T 𝕊.∘ F.₁ (U.₁ f)) ℂ.∘ embed
        ≈⟨ pushˡ U.homomorphism ⟩
             U.₁ (extract T) ℂ.∘ U.₁ (F.₁ (U.₁ f)) ℂ.∘ embed
        ≈⟨ refl⟩∘⟨ sym-commute embed-NT (U.₁ f) ⟩
             U.₁ (extract T) ℂ.∘ embed ℂ.∘ U.₁ f
        ≈⟨ pullˡ (factor ℂ.id) ○ ℂ.identityˡ ⟩
             U.₁ f
        ≈˘⟨ (refl⟩∘⟨ factor ℂ.id) ○ ℂ.identityʳ ⟩
             U.₁ f ℂ.∘ U.₁ (extract S) ℂ.∘ embed
        ≈˘⟨ pushˡ U.homomorphism ⟩
             U.₁ (f 𝕊.∘ extract S) ℂ.∘ embed
        ∎)
    }

  -- The free-forgetful adjunction arising from the universal morphisms
  Free⊣Forgetful : Free ⊣ U
  Free⊣Forgetful = record
    { unit = embed-NT
    ; counit = extract-NT
    ; zig = λ {C} → [ extract (F.₀ C) 𝕊.∘ F.₁ embed ≋ 𝕊.id ]!
        (begin
             U.₁ (extract (F.₀ C) 𝕊.∘ F.₁ embed) ℂ.∘ embed
         ≈⟨ pushˡ U.homomorphism ⟩
             U.₁ (extract (F.₀ C)) ℂ.∘ U.₁ (F.₁ embed) ℂ.∘ embed
         ≈⟨ refl⟩∘⟨ (sym-commute embed-NT embed) ⟩
             U.₁ (extract (F.₀ C)) ℂ.∘ (embed ℂ.∘ embed)
         ≈⟨ pullˡ (factor (ℂ.id)) ⟩
             ℂ.id ℂ.∘ embed
         ≈˘⟨ U.identity ⟩∘⟨refl ⟩
             U.₁ 𝕊.id ℂ.∘ embed
         ∎)
    ; zag = factor ℂ.id
    }

  FreeMonad : Monad ℂ
  FreeMonad = adjoint⇒monad Free⊣Forgetful


module Modal where

open import Prelude
open import Star

data Progress (A : Set) : Set where
  cont : A -> Progress A
  stop : Progress A

record Some {A : Set}(R : Rel A) : Set where
  field
    a    : A
    b    : A
    edge : R a b

some : {A : Set}{R : Rel A}{a b : A} -> R a b -> Some R
some x = record {a = _; b = _; edge = x}

EdgePred : {A : Set} -> Rel A -> Set1
EdgePred R = forall {a b} -> R a b -> Set

data PStep {A : Set}{R : Rel A}(P : EdgePred R) :
           Rel (Progress (Some (Star R))) where
  step : {a b c : A}{x : R a b}{xs : Star R b c} ->
         PStep P (cont (some (x • xs))) (cont (some xs))
  done : {a b c : A}{x : R a b}{xs : Star R b c} ->
         P x -> PStep P (cont (some (x • xs))) stop

Any : {A : Set}{R : Rel A}(P : EdgePred R) -> EdgePred (Star R)
Any P xs = Star (PStep P) (cont (some xs)) stop

mapAny : {A₁ A₂ : Set}{R₁ : Rel A₁}{R₂ : Rel A₂}
         {P₁ : EdgePred R₁}{P₂ : EdgePred R₂}{a b : A₁}{xs : Star R₁ a b}
         {i : A₁ -> A₂}{f : R₁ =[ i ]=> R₂} ->
         ({a b : A₁}{x : R₁ a b} -> P₁ x -> P₂ (f x)) ->
         Any P₁ xs -> Any (\{a b} -> P₂{a}{b}) (map i f xs)
mapAny h (step   • i) = step • mapAny h i
mapAny h (done p • ε) = done (h p) • ε
mapAny h (done p • (() • _))

data Check {A : Set}{R : Rel A}(P : EdgePred R) :
           Rel (Some (Star R)) where
  check : {a b c : A}{x : R a b}{xs : Star R b c} ->
          P x -> Check P (some (x • xs)) (some xs)

checkedEdge : {A : Set}{R : Rel A}{P : EdgePred R}{xs ys : Some (Star R)} ->
              Check P xs ys -> Some R
checkedEdge (check {x = x} _) = some x

uncheck : {X : Set}{R : Rel X}{P : EdgePred R}{xs ys : Some (Star R)}
          (chk : Check P xs ys) -> P (Some.edge (checkedEdge chk))
uncheck (check p) = p

All : {A : Set}{R : Rel A}(P : EdgePred R) -> EdgePred (Star R)
All P {a}{b} xs = Star (Check P) (some xs) (some {a = b} ε)

data Lookup {A : Set}{R : Rel A}(P Q : EdgePred R) : Set where
  result : {a b : A} -> (x : R a b) -> P x -> Q x -> Lookup P Q

lookup : {A : Set}{R : Rel A}{P Q : EdgePred R}{a b : A}{xs : Star R a b} ->
         Any P xs -> All Q xs -> Lookup (\{a b} -> P{a}{b}) Q
lookup (step   • i) (check _ • xs) = lookup i xs
lookup (done p • ε) (check q • _ ) = result _ p q
lookup (done p • (() • _)) (check q • _ )


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Transitivity
open import Oscar.Class.Reflexivity
open import Oscar.Class.Transleftidentity
open import Oscar.Class.Transrightidentity
open import Oscar.Class.Symmetry
open import Oscar.Class.Hmap
open import Oscar.Class.Leftunit

module Oscar.Class.Hmap.Transleftidentity where

instance
  Relprop'idFromTransleftidentity : ∀
    {𝔵} {𝔛 : Ø 𝔵}
    {𝔞} {𝔄 : 𝔛 → Ø 𝔞}
    {𝔟} {𝔅 : 𝔛 → Ø 𝔟}
    (let _∼_ = Arrow 𝔄 𝔅)
    {ℓ̇} {_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ̇}
    {transitivity : Transitivity.type _∼_}
    {reflexivity : Reflexivity.type _∼_}
    {ℓ}
    ⦃ _ : Transleftidentity.class _∼_ _∼̇_ reflexivity transitivity ⦄
    ⦃ _ : ∀ {x y} → Symmetry.class (_∼̇_ {x} {y}) ⦄
    → ∀ {m n}
    → Hmap.class (λ (f : m ∼ n) (P : LeftExtensionṖroperty ℓ _∼_ _∼̇_ m) → π₀ (π₀ P) f)
                 (λ f P → π₀ (π₀ P) (transitivity f reflexivity))
  Relprop'idFromTransleftidentity .⋆ _ (_ , P₁) = P₁ $ symmetry transleftidentity


------------------------------------------------------------------------
-- The Agda standard library
--
-- Conversion of < to ≤, along with a number of properties
------------------------------------------------------------------------

-- Possible TODO: Prove that a conversion ≤ → < → ≤ returns a
-- relation equivalent to the original one (and similarly for
-- < → ≤ → <).

open import Relation.Binary

module Relation.Binary.StrictToNonStrict
         {a ℓ₁ ℓ₂} {A : Set a}
         (_≈_ : Rel A ℓ₁) (_<_ : Rel A ℓ₂)
         where

open import Relation.Nullary
open import Relation.Binary.Consequences
open import Function
open import Data.Product
open import Data.Sum
open import Data.Empty

------------------------------------------------------------------------
-- Conversion

-- _<_ can be turned into _≤_ as follows:

_≤_ : Rel A _
x ≤ y = (x < y) ⊎ (x ≈ y)

------------------------------------------------------------------------
-- The converted relations have certain properties
-- (if the original relations have certain other properties)

reflexive : _≈_ ⇒ _≤_
reflexive = inj₂

antisym : IsEquivalence _≈_ →
          Transitive _<_ →
          Irreflexive _≈_ _<_ →
          Antisymmetric _≈_ _≤_
antisym eq trans irrefl = as
  where
  module Eq = IsEquivalence eq

  as : Antisymmetric _≈_ _≤_
  as (inj₂ x≈y) _          = x≈y
  as (inj₁ _)   (inj₂ y≈x) = Eq.sym y≈x
  as (inj₁ x<y) (inj₁ y<x) =
    ⊥-elim (trans∧irr⟶asym {_≈_ = _≈_} Eq.refl trans irrefl x<y y<x)

trans : IsEquivalence _≈_ → _<_ Respects₂ _≈_ →
        Transitive _<_ → Transitive _≤_
trans eq <-resp-≈ <-trans = tr
  where
  module Eq = IsEquivalence eq

  tr : Transitive _≤_
  tr (inj₁ x<y) (inj₁ y<z) = inj₁ $ <-trans x<y y<z
  tr (inj₁ x<y) (inj₂ y≈z) = inj₁ $ proj₁ <-resp-≈ y≈z x<y
  tr (inj₂ x≈y) (inj₁ y<z) = inj₁ $ proj₂ <-resp-≈ (Eq.sym x≈y) y<z
  tr (inj₂ x≈y) (inj₂ y≈z) = inj₂ $ Eq.trans x≈y y≈z

≤-resp-≈ : IsEquivalence _≈_ → _<_ Respects₂ _≈_ → _≤_ Respects₂ _≈_
≤-resp-≈ eq <-resp-≈ = ((λ {_ _ _} → resp₁) , (λ {_ _ _} → resp₂))
  where
  module Eq = IsEquivalence eq

  resp₁ : ∀ {x y' y} → y' ≈ y → x  ≤ y' → x ≤ y
  resp₁ y'≈y (inj₁ x<y') = inj₁ (proj₁ <-resp-≈ y'≈y x<y')
  resp₁ y'≈y (inj₂ x≈y') = inj₂ (Eq.trans x≈y' y'≈y)

  resp₂ : ∀ {y x' x} → x' ≈ x → x' ≤ y  → x ≤ y
  resp₂ x'≈x (inj₁ x'<y) = inj₁ (proj₂ <-resp-≈ x'≈x x'<y)
  resp₂ x'≈x (inj₂ x'≈y) = inj₂ (Eq.trans (Eq.sym x'≈x) x'≈y)

total : Trichotomous _≈_ _<_ → Total _≤_
total <-tri x y with <-tri x y
... | tri< x<y x≉y x≯y = inj₁ (inj₁ x<y)
... | tri≈ x≮y x≈y x≯y = inj₁ (inj₂ x≈y)
... | tri> x≮y x≉y x>y = inj₂ (inj₁ x>y)

decidable : Decidable _≈_ → Decidable _<_ → Decidable _≤_
decidable ≈-dec <-dec x y with ≈-dec x y | <-dec x y
... | yes x≈y | _       = yes (inj₂ x≈y)
... | no  x≉y | yes x<y = yes (inj₁ x<y)
... | no  x≉y | no  x≮y = no helper
  where
  helper : x ≤ y → ⊥
  helper (inj₁ x<y) = x≮y x<y
  helper (inj₂ x≈y) = x≉y x≈y

decidable' : Trichotomous _≈_ _<_ → Decidable _≤_
decidable' compare x y with compare x y
... | tri< x<y _   _ = yes (inj₁ x<y)
... | tri≈ _   x≈y _ = yes (inj₂ x≈y)
... | tri> x≮y x≉y _ = no helper
  where
  helper : x ≤ y → ⊥
  helper (inj₁ x<y) = x≮y x<y
  helper (inj₂ x≈y) = x≉y x≈y


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

module Cubical.Data.Group.Base where

import Cubical.Core.Glue as G

open import Cubical.Foundations.Prelude hiding ( comp )

import Cubical.Foundations.Isomorphism as I
import Cubical.Foundations.Equiv as E
import Cubical.Foundations.HAEquiv as HAE

record isGroup {ℓ} (A : Type ℓ) : Type ℓ where
  constructor group-struct
  field
    id  : A
    inv  : A → A
    comp  : A → A → A
    lUnit : ∀ a → comp id a ≡ a
    rUnit : ∀ a → comp a id ≡ a
    assoc  : ∀ a b c → comp (comp a b) c ≡ comp a (comp b c)
    lCancel  : ∀ a → comp (inv a) a ≡ id
    rCalcel : ∀ a → comp a (inv a) ≡ id

record Group {ℓ} : Type (ℓ-suc ℓ) where
  constructor group
  field
    type : Type ℓ
    setStruc : isSet type
    groupStruc : isGroup type

isMorph : ∀ {ℓ ℓ'} (G : Group {ℓ}) (H : Group {ℓ'}) → (f : (Group.type G → Group.type H)) → Type (ℓ-max ℓ ℓ')
isMorph (group G Gset (group-struct _ _ _⊙_ _ _ _ _ _))
        (group H Hset (group-struct _ _ _∘_ _ _ _ _ _)) f
        = (g0 g1 : G) → f (g0 ⊙ g1) ≡ (f g0) ∘ (f g1)

morph : ∀ {ℓ ℓ'} (G : Group {ℓ}) (H : Group {ℓ'}) → Type (ℓ-max ℓ ℓ')
morph G H = Σ (Group.type G →  Group.type H) (isMorph G H)

record Iso {ℓ ℓ'} (G : Group {ℓ}) (H : Group {ℓ'}) : Type (ℓ-max ℓ ℓ') where
  constructor iso
  field
    fun : morph G H
    inv : morph H G
    rightInv : I.section (fun .fst) (inv .fst)
    leftInv : I.retract (fun .fst) (inv .fst)

record Iso' {ℓ ℓ'} (G : Group {ℓ}) (H : Group {ℓ'}) : Type (ℓ-max ℓ ℓ') where
  constructor iso'
  field
    isoSet : I.Iso (Group.type G) (Group.type H)
    isoSetMorph : isMorph G H (I.Iso.fun isoSet)

_≃_ : ∀ {ℓ ℓ'} (A : Group {ℓ}) (B : Group {ℓ'}) → Type (ℓ-max ℓ ℓ')
A ≃ B = Σ (morph A B) \ f → (G.isEquiv (f .fst))

Iso'→Iso : ∀ {ℓ ℓ'} {G : Group {ℓ}} {H : Group {ℓ'}} → Iso' G  H → Iso G H
Iso'→Iso {G = group G Gset Ggroup} {H = group H Hset Hgroup} i = iso (fun , funMorph) (inv , invMorph) rightInv leftInv
  where
    G_ : Group
    G_ = (group G Gset Ggroup)

    H_ : Group
    H_ = (group H Hset Hgroup)

    open Iso'

    fun : G → H
    fun = I.Iso.fun (isoSet i)

    inv : H → G
    inv = I.Iso.inv (isoSet i)

    rightInv : I.section fun inv
    rightInv = I.Iso.rightInv (isoSet i)

    leftInv : I.retract fun inv
    leftInv = I.Iso.leftInv (isoSet i)

    e' : G G.≃ H
    e' = E.isoToEquiv (I.iso fun inv rightInv leftInv)

    funMorph : isMorph G_ H_ fun
    funMorph = isoSetMorph i

    _∘_ : H → H → H
    _∘_ = isGroup.comp Hgroup

    _⊙_ : G → G → G
    _⊙_ = isGroup.comp Ggroup

    invMorph : isMorph H_ G_ inv
    invMorph h0 h1 = E.invEq (HAE.congEquiv e')
          (fun (inv (h0 ∘ h1)) ≡⟨ rightInv (h0 ∘ h1) ⟩
           h0 ∘ h1 ≡⟨ cong (λ x → x ∘ h1) (sym (rightInv h0)) ⟩
           (fun (inv h0)) ∘ h1 ≡⟨ cong (λ x → fun (inv h0) ∘ x) (sym (rightInv h1)) ⟩
           (fun (inv h0)) ∘ (fun (inv h1)) ≡⟨ sym (funMorph (inv h0) (inv h1)) ⟩
           fun ((inv h0) ⊙ (inv h1)) ∎ )

Equiv→Iso' : ∀ {ℓ ℓ'} {G : Group {ℓ}} {H : Group {ℓ'}} → G ≃ H → Iso' G H
Equiv→Iso' {G = group G Gset Ggroup}
           {H = group H Hset Hgroup}
           e = iso' i' (e .fst .snd)
  where
    e' : G G.≃ H
    e' = (e .fst .fst) , (e .snd)

    i' : I.Iso G H
    i' = E.equivToIso e'

compMorph : ∀ {ℓ} {F G H : Group {ℓ}} (I : morph F G) (J : morph G H) → morph F H
compMorph {ℓ} {group F Fset (group-struct _ _ _⊙_ _ _ _ _ _)}
              {group G Gset (group-struct _ _ _∙_ _ _ _ _ _)}
              {group H Hset (group-struct _ _ _∘_ _ _ _ _ _)}
              (i , ic) (j , jc) = k , kc
  where
    k : F → H
    k f = j (i f)

    kc : (g0 g1 : F) → k (g0 ⊙ g1) ≡ (k g0) ∘ (k g1)
    kc g0 g1 = j (i (g0 ⊙ g1)) ≡⟨ cong j (ic _ _) ⟩
                j (i g0 ∙ i g1) ≡⟨ jc _ _ ⟩
                j (i g0) ∘ j (i g1) ∎

compIso : ∀ {ℓ} {F G H : Group {ℓ}} (I : Iso F G) (J : Iso G H) → Iso F H
compIso {ℓ} {F} {G} {H}
        (iso F→G G→F fg gf) (iso G→H H→G gh hg ) = iso F→H H→F sec ret
  where
    F→H : morph F H
    F→H = compMorph {ℓ} {F} {G} {H} F→G G→H

    H→F : morph H F
    H→F = compMorph {ℓ} {H} {G} {F} H→G G→F

    open Group

    f→h : F .type → H .type
    f→h = F→H .fst

    f→g : F .type → G .type
    f→g = F→G .fst

    g→h : G .type → H .type
    g→h = G→H .fst

    h→f : H .type → F .type
    h→f = H→F .fst

    h→g : H .type → G .type
    h→g = H→G .fst

    g→f : G .type → F .type
    g→f = G→F .fst

    sec : I.section f→h h→f
    sec h = f→h (h→f h) ≡⟨ cong g→h (fg (h→g h)) ⟩
             g→h (h→g h) ≡⟨ gh _ ⟩
             h ∎

    ret : I.retract f→h h→f
    ret f = h→f (f→h f) ≡⟨ cong g→f (hg (f→g f)) ⟩
             g→f (f→g f) ≡⟨ gf _ ⟩
             f ∎


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

open import Cubical.Data.NatMinusOne
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.HITs.Sn

data  ∥_∥_ {ℓ} (A : Type ℓ) (n : ℕ₋₁) : Type ℓ where
  ∣_∣ : A  → ∥ A ∥ n
  hub : (f : S (1+ n) → ∥ A ∥ n) → ∥ A ∥ n
  spoke : (f : S (1+ n) → ∥ A ∥ n) (x : S (1+ n)) → hub f ≡ f x


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

open import HoTT
import homotopy.HopfConstruction
open import homotopy.CircleHSpace
open import homotopy.SuspensionJoin using () renaming (e to suspension-join)
open import homotopy.S1SuspensionS0 using () renaming (e to S¹≃SuspensionS⁰)
import homotopy.JoinAssoc

module homotopy.Hopf where

-- To move
S⁰ = Bool
S² = Suspension S¹
S³ = Suspension S²

-- To move
S¹-connected : is-connected ⟨0⟩ S¹
S¹-connected =
  ([ base ] , Trunc-elim (λ x → =-preserves-level ⟨0⟩ Trunc-level)
             (S¹-elim idp (prop-has-all-paths-↓ ((Trunc-level :> is-set (Trunc ⟨0⟩ S¹)) _ _))))

module Hopf = homotopy.HopfConstruction S¹ S¹-connected S¹-hSpace

Hopf : S² → Type₀
Hopf = Hopf.H.f

Hopf-fiber : Hopf (north _) == S¹
Hopf-fiber = idp

Hopf-total : Σ _ Hopf == S³
Hopf-total =
  Σ _ Hopf               =⟨ Hopf.theorem ⟩
  S¹ * S¹                =⟨ ua S¹≃SuspensionS⁰ |in-ctx (λ u → u * S¹) ⟩
  (Suspension S⁰) * S¹   =⟨ ua (suspension-join S⁰) |in-ctx (λ u → u * S¹) ⟩
  (S⁰ * S⁰) * S¹         =⟨ ua (homotopy.JoinAssoc.*-assoc S⁰ S⁰ S¹) ⟩
  S⁰ * (S⁰ * S¹)         =⟨ ! (ua (suspension-join S¹)) |in-ctx (λ u → S⁰ * u) ⟩
  S⁰ * S²                =⟨ ! (ua (suspension-join S²)) ⟩
  S³ ∎


-- ----------------------------------------------------------------------
-- The Agda Descriptor Library
--
-- Natural transformations on indexed families (predicates)
-- ----------------------------------------------------------------------

module Relation.Unary.Predicate.Transformation where

open import Data.Empty.Polymorphic using (⊥)
open import Data.Product using (_×_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Unit.Polymorphic using (⊤)
open import Function using (_∘_)
open import Level using (Level; _⊔_; 0ℓ)
open import Relation.Unary

private
  variable
    a b c d ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level
    A : Set a
    B : Set b
    C : Set c
    D : Set d

-- ----------------------------------------------------------------------
-- Definition

-- A predicate transformation is a morphism between 2 predicates
-- indexed by A and B (w/ levels ℓ₁ ℓ₂ for universe polymorphism)

infixr 0 _▷_ _►_

_▷_ : Set a → Set b → (ℓ₁ ℓ₂ : Level) → Set _
(A ▷ B) ℓ₁ ℓ₂ = Pred A ℓ₁ → Pred B ℓ₂

_►_ : Set a → Set b → Set _
(A ► B) = Pred A 0ℓ → Pred B 0ℓ

-- ----------------------------------------------------------------------
-- Composition and Identity

id : (A ▷ A) ℓ₁ ℓ₁
id = Function.id

_○_ : (B ▷ C) ℓ₂ ℓ₃ → (A ▷ B) ℓ₁ ℓ₂ → (A ▷ C) ℓ₁ _
X ○ Y = X ∘ Y

-- TODO: Cateogrical view

-- ----------------------------------------------------------------------
-- Special transformations

empty : (A ▷ B) ℓ₁ ℓ₂
empty = λ _ _ → ⊥

univ : (A ▷ B) ℓ₁ ℓ₂
univ = λ _ _ → ⊤

-- ----------------------------------------------------------------------
-- Operations on transformations

infixr 8 _⇉_
infixl 7 _⋏_
infixl 6 _⋎_

-- Negation
∼ : (A ▷ B) ℓ₁ ℓ₂ → (A ▷ B) ℓ₁ ℓ₂
∼ X = ∁ ∘ X

-- Implication
_⇉_ : (A ▷ B) ℓ₁ ℓ₂ → (A ▷ B) ℓ₁ ℓ₂ → (A ▷ B) ℓ₁ ℓ₂
X ⇉ Y = λ P → X P ⇒ Y P

-- Intersection
_⋏_ : (A ▷ B) ℓ₁ ℓ₂ → (A ▷ B) ℓ₁ ℓ₂ → (A ▷ B) ℓ₁ ℓ₂
X ⋏ Y = λ P → X P ∩ Y P

-- Union
_⋎_ : (A ▷ B) ℓ₁ ℓ₂ → (A ▷ B) ℓ₁ ℓ₂ → (A ▷ B) ℓ₁ ℓ₂
X ⋎ Y = λ P → X P ∪ Y P

-- TODO: Infinitary union + intersection

-- ----------------------------------------------------------------------
-- Combinators on transformations

-- Disjoint sum
_∣∣_ : (A ▷ C) ℓ₁ ℓ₂ → (B ▷ D) ℓ₁ ℓ₂ → (A ⊎ B ▷ C ⊎ D) ℓ₁ ℓ₂
(X ∣∣ Y) P (inj₁ x) = X (P ∘ inj₁) x
(X ∣∣ Y) P (inj₂ y) = Y (P ∘ inj₂) y

-- TODO: Product, etc


{-# OPTIONS --without-K #-}
module hott.loop.level where

open import sets.nat.core
open import hott.loop.core
open import hott.level.core

Ω-level : ∀ {i n}{X : Set i}(m : ℕ){x : X}
        → h (m + n) X → h n (Ω m x)
Ω-level zero hX = hX
Ω-level (suc m) hX = Ω-level m (hX _ _)


module Preduploid where

open import Relation.Unary using (Pred)
open import Relation.Binary using (REL)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)

open import Level

data Polarity : Set where
  + : Polarity
  ⊝ : Polarity

private
  variable p q r s : Polarity

record Preduploid o ℓ : Set (suc (o ⊔ ℓ)) where
  infix 4 _⇒_
  infix 9 _∙_ _∘_ _⊙_

  field
    Ob : Polarity -> Set o
    _⇒_ : REL (Ob p) (Ob q) ℓ

    id : forall {A : Ob p} -> A ⇒ A
    _∙_ : forall {A : Ob p} {B : Ob +} {C : Ob q} -> B ⇒ C -> A ⇒ B -> A ⇒ C
    _∘_ : forall {A : Ob p} {B : Ob ⊝} {C : Ob q} -> B ⇒ C -> A ⇒ B -> A ⇒ C

    identity∙ˡ : forall {A : Ob p} {B : Ob +} {f : A ⇒ B} -> id ∙ f ≡ f
    identity∙ʳ : forall {A : Ob +} {B : Ob p} {f : A ⇒ B} -> f ∙ id ≡ f

    identity∘ˡ : forall {A : Ob p} {B : Ob ⊝} {f : A ⇒ B} -> id ∘ f ≡ f
    identity∘ʳ : forall {A : Ob ⊝} {B : Ob p} {f : A ⇒ B} -> f ∘ id ≡ f

    assoc∙∙ : forall {A : Ob p} {B : Ob +} {C : Ob +} {D : Ob q}
      {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D} -> (h ∙ g) ∙ f ≡ h ∙ (g ∙ f)
    assoc∘∘ : forall {A : Ob p} {B : Ob ⊝} {C : Ob ⊝} {D : Ob q}
      {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D} -> (h ∘ g) ∘ f ≡ h ∘ (g ∘ f)
    assoc∙∘ : forall {A : Ob p} {B : Ob ⊝} {C : Ob +} {D : Ob q}
      {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D} -> (h ∙ g) ∘ f ≡ h ∙ (g ∘ f)

  π : Ob p -> Polarity
  π {p = p} _ = p

  _⊙_ : forall {A : Ob p} {B : Ob q} {C : Ob r} -> B ⇒ C -> A ⇒ B -> A ⇒ C
  _⊙_ {q = +} = _∙_
  _⊙_ {q = ⊝} = _∘_

  identityˡ : forall {A : Ob p} {B : Ob q} {f : A ⇒ B} -> id ⊙ f ≡ f
  identityˡ {q = +} = identity∙ˡ
  identityˡ {q = ⊝} = identity∘ˡ

  identityʳ : forall {A : Ob p} {B : Ob q} {f : A ⇒ B} -> f ⊙ id ≡ f
  identityʳ {p = +} = identity∙ʳ
  identityʳ {p = ⊝} = identity∘ʳ

  Linear : forall {C : Ob r} {D : Ob s} -> Pred (C ⇒ D) (o ⊔ ℓ)
  Linear {C = C} {D = D} f = forall {p q} {A : Ob p} {B : Ob q} {g : B ⇒ C} {h : A ⇒ B} -> f ⊙ (g ⊙ h) ≡ (f ⊙ g) ⊙ h

  Thunkable : forall {A : Ob p} {B : Ob q} -> Pred (A ⇒ B) (o ⊔ ℓ)
  Thunkable {A = A} {B = B} f = forall {r s} {C : Ob r} {D : Ob s} {g : B ⇒ C} {h : C ⇒ D} -> h ⊙ (g ⊙ f) ≡ (h ⊙ g) ⊙ f

  P-Linear : forall {P : Ob +} {A : Ob p} -> (f : P ⇒ A) -> Linear f
  P-Linear f {q = +} = sym assoc∙∙
  P-Linear f {q = ⊝} = sym assoc∙∘

  N-Thunkable : forall {A : Ob p} {N : Ob ⊝} -> (f : A ⇒ N) -> Thunkable f
  N-Thunkable f {r = +} = sym assoc∙∘
  N-Thunkable f {r = ⊝} = sym assoc∘∘


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

open import HoTT
open import homotopy.HSpace

module homotopy.EM1HSpace where

module EM₁HSpace {i} (A : Group i) (A-abelian : is-abelian A) where

  module A = Group A
  open EM₁ A

  mult-loop : (g : A.El) (x : EM₁) → x == x
  mult-loop g = EM₁-elim
    {P = λ x → x == x}
    (λ _ → =-preserves-level _ emlevel)
    (emloop g)
    loop'
    (set-↓-has-all-paths-↓ (emlevel embase embase))
    (λ _ _ → set-↓-has-all-paths-↓ (emlevel embase embase))
    where
    abstract
      loop' : (g' : A.El) → emloop g == emloop g [ (λ x → x == x) ↓ emloop g' ]
      loop' g' = ↓-idf=idf-in $
        emloop g ∙ emloop g'     =⟨ ! (emloop-comp g g') ⟩
        emloop (A.comp g g')      =⟨ ap emloop (A-abelian g g') ⟩
        emloop (A.comp g' g)      =⟨ emloop-comp g' g ⟩
        emloop g' ∙ emloop g     =⟨ ∙=∙' (emloop g') (emloop g) ⟩
        emloop g' ∙' emloop g    ∎

  mult-hom : GroupHom A
    (Ω^S-group 0 ((EM₁ → EM₁) , (λ x → x)) (Π-level (λ _ → emlevel)))
  mult-hom = record {f = f; pres-comp = pres-comp}
    where
    f = λ g → λ= (mult-loop g)

    pres-comp = λ g₁ g₂ →
      ap λ= (λ= (EM₁-elim
        {P = λ x → mult-loop (A.comp g₁ g₂) x
                == mult-loop g₁ x ∙ mult-loop g₂ x}
        (λ _ →  =-preserves-level _ (=-preserves-level _ emlevel))
        (emloop-comp g₁ g₂)
        (λ _ → prop-has-all-paths-↓ (emlevel _ _ _ _))
        (set-↓-has-all-paths-↓ (=-preserves-level _ (emlevel _ _)))
        (λ _ _ → set-↓-has-all-paths-↓ (=-preserves-level _ (emlevel _ _)))))
      ∙ ! (∙-λ= _ _)

  mult : EM₁ → EM₁ → EM₁
  mult = EM₁-rec {C = EM₁ → EM₁} (Π-level (λ _ → emlevel)) (λ x → x) mult-hom

  H-EM₁ : HSpaceStructure EM₁
  H-EM₁ = record { e = embase; μ = mult; μ-e-l = μ-e-l; μ-e-r = μ-e-r; μ-coh = μ-coh }
    where
    μ-e-l : (x : EM₁) → mult embase x == x
    μ-e-l = EM₁-elim
      {P = λ x → mult embase x == x}
      (λ _ → =-preserves-level 1 emlevel)
      idp
      (λ g → ↓-app=idf-in $ ∙'-unit-l (emloop g) ∙ (! (ap-idf (emloop g)))
                            ∙ ! (∙-unit-r (ap (mult embase) (emloop g))))
      (set-↓-has-all-paths-↓ (emlevel _ _))
      (λ _ _ → set-↓-has-all-paths-↓ (emlevel _ _))

    μ-e-r : (x : EM₁) → mult x embase == x
    μ-e-r = EM₁-elim
      {P = λ x → mult x embase == x}
      (λ _ → =-preserves-level 1 emlevel)
      idp
      (λ g → ↓-app=idf-in $
         idp ∙' emloop g
           =⟨ ∙'-unit-l (emloop g) ⟩
         emloop g
           =⟨ ! (app=-β (mult-loop g) embase) ⟩
         app= (λ= (mult-loop g)) embase
           =⟨ ! (EM₁Rec.emloop-β {C = EM₁ → EM₁}
                   (Π-level (λ _ → emlevel)) (λ x → x) mult-hom g)
              |in-ctx (λ w → app= w embase) ⟩
         app= (ap mult (emloop g)) embase
           =⟨ ∘-ap (λ f → f embase) mult (emloop g) ⟩
         ap (λ z → mult z embase) (emloop g)
           =⟨ ! (∙-unit-r (ap (λ z → mult z embase) (emloop g))) ⟩
         ap (λ z → mult z embase) (emloop g) ∙ idp ∎)
      (set-↓-has-all-paths-↓ (emlevel _ _))
      (λ _ _ → set-↓-has-all-paths-↓ (emlevel _ _))

    μ-coh : μ-e-l embase == μ-e-r embase
    μ-coh = idp

  open HSpaceStructure H-EM₁


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

open import M-types.Base.Core
open import M-types.Base.Sum
open import M-types.Base.Prod
open import M-types.Base.Eq

module M-types.Base.Contr where
    IsContr : ∏[ X ∈ Ty ℓ ] Ty ℓ
    IsContr X = ∑[ x ∈ X ] ∏[ x′ ∈ X ] x′ ≡ x

    Contr : Ty (ℓ-suc ℓ)
    Contr {ℓ} = ∑[ X ∈ Ty ℓ ] IsContr X


import      Lvl
open import Structure.Operator.Vector
open import Structure.Setoid
open import Type

module Structure.Operator.Vector.LinearCombination.Proofs
  {ℓᵥ ℓₛ ℓᵥₑ ℓₛₑ}
  {V : Type{ℓᵥ}} ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  {S : Type{ℓₛ}} ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  {_+ᵥ_ : V → V → V}
  {_⋅ₛᵥ_ : S → V → V}
  {_+ₛ_ _⋅ₛ_ : S → S → S}
  ⦃ vectorSpace : VectorSpace(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) ⦄
  where

open VectorSpace(vectorSpace)

import      Lvl
open import Function.Equals
open import Logic.Predicate
open import Numeral.CoordinateVector as Vec using () renaming (Vector to Vec)
open import Numeral.Finite
open import Numeral.Natural
open import Structure.Function.Multi
import      Structure.Function.Names as Names
open import Structure.Operator.Proofs.Util
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Operator.Vector.LinearCombination ⦃ vectorSpace = vectorSpace ⦄
open import Structure.Operator.Vector.Proofs
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Number
open import Syntax.Transitivity
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₗ : Lvl.Level
private variable n n₁ n₂ : ℕ
private variable i j k : 𝕟(n)
private variable vf vf₁ vf₂ : Vec(n)(V)
private variable sf sf₁ sf₂ : Vec(n)(S)

instance
  linearCombination-binaryOperator : BinaryOperator(linearCombination{n})
  linearCombination-binaryOperator = intro p where
    p : Names.Congruence₂(linearCombination{n})
    p {𝟎}       {vf₁} {vf₂} (intro vfeq) {sf₁} {sf₂} (intro sfeq) = reflexivity(_≡_)
    p {𝐒(𝟎)}    {vf₁} {vf₂} (intro vfeq) {sf₁} {sf₂} (intro sfeq) = congruence₂(_⋅ₛᵥ_) sfeq vfeq
    p {𝐒(𝐒(n))} {vf₁} {vf₂} (intro vfeq) {sf₁} {sf₂} (intro sfeq) =
      (sf₁(𝟎) ⋅ₛᵥ vf₁(𝟎)) +ᵥ linearCombination(Vec.tail vf₁) (Vec.tail sf₁) 🝖[ _≡_ ]-[ congruence₂(_+ᵥ_) (congruence₂(_⋅ₛᵥ_) sfeq vfeq) (p {𝐒(n)} (intro vfeq) (intro sfeq)) ]
      (sf₂(𝟎) ⋅ₛᵥ vf₂(𝟎)) +ᵥ linearCombination(Vec.tail vf₂) (Vec.tail sf₂) 🝖-end

instance
  linearCombination-scalar-preserves-[+] : Preserving₂(linearCombination vf) (Vec.map₂(_+ₛ_)) (_+ᵥ_)
  linearCombination-scalar-preserves-[+] {vf = vf} = intro(p{vf = vf}) where
    p : ∀{n}{vf : Vec(n)(V)} → Names.Preserving₂(linearCombination vf) (Vec.map₂(_+ₛ_)) (_+ᵥ_)
    p {𝟎}{vf} {sf₁} {sf₂} =
      𝟎ᵥ       🝖[ _≡_ ]-[ identityₗ(_+ᵥ_)(𝟎ᵥ) ]-sym
      𝟎ᵥ +ᵥ 𝟎ᵥ 🝖-end
    p {𝐒(𝟎)}{vf} {sf₁} {sf₂} =
      (Vec.map₂(_+ₛ_) sf₁ sf₂ 𝟎) ⋅ₛᵥ vf(𝟎)     🝖[ _≡_ ]-[]
      (sf₁(𝟎) +ₛ sf₂(𝟎)) ⋅ₛᵥ vf(𝟎)             🝖[ _≡_ ]-[ [⋅ₛᵥ][+ₛ][+ᵥ]-distributivityᵣ ]
      (sf₁(𝟎) ⋅ₛᵥ vf(𝟎)) +ᵥ (sf₂(𝟎) ⋅ₛᵥ vf(𝟎)) 🝖-end
    p {𝐒(𝐒(n))}{vf} {sf₁} {sf₂} =
      ((Vec.map₂(_+ₛ_) sf₁ sf₂ 𝟎) ⋅ₛᵥ vf(𝟎)) +ᵥ (linearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail(Vec.map₂(_+ₛ_) sf₁ sf₂)))                                                🝖[ _≡_ ]-[]
      ((sf₁(𝟎) +ₛ sf₂(𝟎)) ⋅ₛᵥ vf(𝟎)) +ᵥ (linearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail(Vec.map₂(_+ₛ_) sf₁ sf₂)))                                                        🝖[ _≡_ ]-[ congruence₂(_+ᵥ_) [⋅ₛᵥ][+ₛ][+ᵥ]-distributivityᵣ (p {𝐒(n)}{Vec.tail vf} {Vec.tail sf₁} {Vec.tail sf₂}) ]
      ((sf₁(𝟎) ⋅ₛᵥ vf(𝟎)) +ᵥ (sf₂(𝟎) ⋅ₛᵥ vf(𝟎))) +ᵥ ((linearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail sf₁)) +ᵥ (linearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail sf₂)))   🝖[ _≡_ ]-[ One.associate-commute4 (commutativity(_+ᵥ_)) ]
      (((sf₁(𝟎) ⋅ₛᵥ vf(𝟎)) +ᵥ (linearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail sf₁))) +ᵥ ((sf₂(𝟎) ⋅ₛᵥ vf(𝟎)) +ᵥ (linearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail sf₂)))) 🝖-end

instance
  linearCombination-scalar-preserves-[⋅] : ∀{s} → Preserving₁(linearCombination vf) (Vec.map(s ⋅ₛ_)) (s ⋅ₛᵥ_)
  linearCombination-scalar-preserves-[⋅] {vf = vf} {s = s} = intro(p{vf = vf}) where
    p : ∀{n}{vf : Vec(n)(V)} → Names.Preserving₁(linearCombination vf) (Vec.map(s ⋅ₛ_)) (s ⋅ₛᵥ_)
    p {𝟎} {vf} {sf} =
      𝟎ᵥ       🝖[ _≡_ ]-[ [⋅ₛᵥ]-absorberᵣ ]-sym
      s ⋅ₛᵥ 𝟎ᵥ 🝖-end
    p {𝐒(𝟎)} {vf} {sf} =
      (s ⋅ₛ sf(𝟎)) ⋅ₛᵥ vf(𝟎)  🝖[ _≡_ ]-[ [⋅ₛ][⋅ₛᵥ]-compatibility ]
      s ⋅ₛᵥ (sf(𝟎) ⋅ₛᵥ vf(𝟎)) 🝖-end
    p {𝐒(𝐒(n))} {vf} {sf} =
      linearCombination vf (Vec.map (s ⋅ₛ_) sf)                                                     🝖[ _≡_ ]-[]
      ((s ⋅ₛ sf(𝟎)) ⋅ₛᵥ vf(𝟎)) +ᵥ (linearCombination (Vec.tail vf) (Vec.map (s ⋅ₛ_) (Vec.tail sf))) 🝖[ _≡_ ]-[ congruence₂(_+ᵥ_) ⦃ [+ᵥ]-binary-operator ⦄ [⋅ₛ][⋅ₛᵥ]-compatibility (p {𝐒(n)} {Vec.tail vf} {Vec.tail sf}) ]
      (s ⋅ₛᵥ (sf(𝟎) ⋅ₛᵥ vf(𝟎))) +ᵥ (s ⋅ₛᵥ (linearCombination (Vec.tail vf) (Vec.tail sf)))          🝖[ _≡_ ]-[ distributivityₗ(_⋅ₛᵥ_)(_+ᵥ_) ]-sym
      s ⋅ₛᵥ ((sf(𝟎) ⋅ₛᵥ vf(𝟎)) +ᵥ (linearCombination (Vec.tail vf) (Vec.tail sf)))                  🝖[ _≡_ ]-[]
      s ⋅ₛᵥ (linearCombination vf sf)                                                               🝖-end

-- linearCombination-of-unit : linearCombination vf (Vec.fill 𝟏ₛ) ≡ (foldᵣ(_+_) 𝟎ᵥ vf)
postulate linearCombination-of-indexProject : (linearCombination vf (Vec.indexProject i 𝟏ₛ 𝟎ₛ) ≡ vf(i))


{-# OPTIONS --safe --sized-types #-}

module Generic.Semantics.Elaboration.LetBinder where

open import Size
open import Data.Product
open import Agda.Builtin.List
open import Function
open import Relation.Unary

open import Data.Environment
open import Generic.Syntax
open import Generic.Syntax.LetBinder
open import Generic.Semantics
open import Generic.Semantics.Syntactic

private
  variable
    I : Set
    d : Desc I
    σ : I
    Γ Δ : List I
    s : Size

-- Elaborating away a single let-binder. The algebra is defined by case analysis
-- over the constructors:

-- * let-binders are inlined thanks to the substitution _[_/0] which takes two
-- arguments t and e and instatiates the first free variable of t with e.

-- * the other constructors are left as is by reusing Substitution's algebra

UnLet : Semantics (d `+ Let) (Tm d ∞) (Tm d ∞)
Semantics.th^𝓥  UnLet = th^Tm
Semantics.var   UnLet = id
Semantics.alg   UnLet = case (Semantics.alg Sub) $ λ where
 (`IN' e t) →  extract t (ε ∙ e)

unLet : (Γ ─Env) (Tm d ∞) Δ → Tm (d `+ Let) s σ Γ → Tm d ∞ σ Δ
unLet ρ t = Semantics.semantics UnLet ρ t

unlet : ∀[ Tm (d `+ Let) ∞ σ ⇒ Tm d ∞ σ ]
unlet = Semantics.semantics UnLet (pack `var)


{-# OPTIONS --rewriting #-}

open import Common.Prelude
open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

postulate
  f g    : Nat → Nat
  f-zero : f zero ≡ g zero
  f-suc  : ∀ n → f n ≡ g n → f (suc n) ≡ g (suc n)

r : (n : Nat) → f n ≡ g n
r zero = f-zero
r (suc n) = f-suc n refl
  where
    rn : f n ≡ g n
    rn = r n
    {-# REWRITE rn #-}


------------------------------------------------------------------------
-- Pointwise products of binary relations
------------------------------------------------------------------------

module Relation.Binary.Product.Pointwise where

open import Data.Function
open import Data.Product
open import Data.Sum
open import Relation.Nullary.Product
open import Relation.Binary

private
 module Dummy {a₁ a₂ : Set} where

  infixr 2 _×-Rel_

  _×-Rel_ : Rel a₁ → Rel a₂ → Rel (a₁ × a₂)
  ∼₁ ×-Rel ∼₂ = (∼₁ on₁ proj₁) -×- (∼₂ on₁ proj₂)

  -- Some properties which are preserved by ×-Rel (under certain
  -- assumptions).

  _×-reflexive_ : ∀ {≈₁ ∼₁ ≈₂ ∼₂} →
                  ≈₁ ⇒ ∼₁ → ≈₂ ⇒ ∼₂ → (≈₁ ×-Rel ≈₂) ⇒ (∼₁ ×-Rel ∼₂)
  refl₁ ×-reflexive refl₂ = λ x≈y →
    (refl₁ (proj₁ x≈y) , refl₂ (proj₂ x≈y))

  _×-refl_ : ∀ {∼₁ ∼₂} →
             Reflexive ∼₁ → Reflexive ∼₂ → Reflexive (∼₁ ×-Rel ∼₂)
  refl₁ ×-refl refl₂ = (refl₁ , refl₂)

  ×-irreflexive₁ :
    ∀ {≈₁ <₁ ≈₂ <₂} →
    Irreflexive ≈₁ <₁ → Irreflexive (≈₁ ×-Rel ≈₂) (<₁ ×-Rel <₂)
  ×-irreflexive₁ ir = λ x≈y x<y → ir (proj₁ x≈y) (proj₁ x<y)

  ×-irreflexive₂ :
    ∀ {≈₁ <₁ ≈₂ <₂} →
    Irreflexive ≈₂ <₂ → Irreflexive (≈₁ ×-Rel ≈₂) (<₁ ×-Rel <₂)
  ×-irreflexive₂ ir = λ x≈y x<y → ir (proj₂ x≈y) (proj₂ x<y)

  _×-symmetric_ : ∀ {∼₁ ∼₂} →
                  Symmetric ∼₁ → Symmetric ∼₂ → Symmetric (∼₁ ×-Rel ∼₂)
  sym₁ ×-symmetric sym₂ = λ x∼y → sym₁ (proj₁ x∼y) , sym₂ (proj₂ x∼y)

  _×-transitive_ : ∀ {∼₁ ∼₂} →
                   Transitive ∼₁ → Transitive ∼₂ →
                   Transitive (∼₁ ×-Rel ∼₂)
  trans₁ ×-transitive trans₂ = λ x∼y y∼z →
    trans₁ (proj₁ x∼y) (proj₁ y∼z) ,
    trans₂ (proj₂ x∼y) (proj₂ y∼z)

  _×-antisymmetric_ : ∀ {≈₁ ≤₁ ≈₂ ≤₂} →
                      Antisymmetric ≈₁ ≤₁ → Antisymmetric ≈₂ ≤₂ →
                      Antisymmetric (≈₁ ×-Rel ≈₂) (≤₁ ×-Rel ≤₂)
  antisym₁ ×-antisymmetric antisym₂ = λ x≤y y≤x →
    ( antisym₁ (proj₁ x≤y) (proj₁ y≤x)
    , antisym₂ (proj₂ x≤y) (proj₂ y≤x) )

  ×-asymmetric₁ : ∀ {<₁ ∼₂} → Asymmetric <₁ → Asymmetric (<₁ ×-Rel ∼₂)
  ×-asymmetric₁ asym₁ = λ x<y y<x → asym₁ (proj₁ x<y) (proj₁ y<x)

  ×-asymmetric₂ : ∀ {∼₁ <₂} → Asymmetric <₂ → Asymmetric (∼₁ ×-Rel <₂)
  ×-asymmetric₂ asym₂ = λ x<y y<x → asym₂ (proj₂ x<y) (proj₂ y<x)

  _×-≈-respects₂_ : ∀ {≈₁ ∼₁ ≈₂ ∼₂} →
                    ∼₁ Respects₂ ≈₁ → ∼₂ Respects₂ ≈₂ →
                    (∼₁ ×-Rel ∼₂) Respects₂ (≈₁ ×-Rel ≈₂)
  _×-≈-respects₂_ {≈₁ = ≈₁} {∼₁ = ∼₁} {≈₂ = ≈₂} {∼₂ = ∼₂}
                  resp₁ resp₂ =
    (λ {x y z} → resp¹ {x} {y} {z}) ,
    (λ {x y z} → resp² {x} {y} {z})
    where
    ∼ = ∼₁ ×-Rel ∼₂

    resp¹ : ∀ {x} → (∼ x) Respects (≈₁ ×-Rel ≈₂)
    resp¹ y≈y' x∼y = proj₁ resp₁ (proj₁ y≈y') (proj₁ x∼y) ,
                     proj₁ resp₂ (proj₂ y≈y') (proj₂ x∼y)

    resp² : ∀ {y} → (flip₁ ∼ y) Respects (≈₁ ×-Rel ≈₂)
    resp² x≈x' x∼y = proj₂ resp₁ (proj₁ x≈x') (proj₁ x∼y) ,
                     proj₂ resp₂ (proj₂ x≈x') (proj₂ x∼y)

  ×-total : ∀ {∼₁ ∼₂} →
            Symmetric ∼₁ → Total ∼₁ → Total ∼₂ → Total (∼₁ ×-Rel ∼₂)
  ×-total {∼₁ = ∼₁} {∼₂ = ∼₂} sym₁ total₁ total₂ = total
    where
    total : Total (∼₁ ×-Rel ∼₂)
    total x y with total₁ (proj₁ x) (proj₁ y)
                 | total₂ (proj₂ x) (proj₂ y)
    ... | inj₁ x₁∼y₁ | inj₁ x₂∼y₂ = inj₁ (     x₁∼y₁ , x₂∼y₂)
    ... | inj₁ x₁∼y₁ | inj₂ y₂∼x₂ = inj₂ (sym₁ x₁∼y₁ , y₂∼x₂)
    ... | inj₂ y₁∼x₁ | inj₂ y₂∼x₂ = inj₂ (     y₁∼x₁ , y₂∼x₂)
    ... | inj₂ y₁∼x₁ | inj₁ x₂∼y₂ = inj₁ (sym₁ y₁∼x₁ , x₂∼y₂)

  _×-decidable_ : ∀ {∼₁ ∼₂} →
                  Decidable ∼₁ → Decidable ∼₂ → Decidable (∼₁ ×-Rel ∼₂)
  dec₁ ×-decidable dec₂ = λ x y →
    dec₁ (proj₁ x) (proj₁ y)
      ×-dec
    dec₂ (proj₂ x) (proj₂ y)

  -- Some collections of properties which are preserved by ×-Rel.

  _×-isEquivalence_ : ∀ {≈₁ ≈₂} →
                      IsEquivalence ≈₁ → IsEquivalence ≈₂ →
                      IsEquivalence (≈₁ ×-Rel ≈₂)
  _×-isEquivalence_ {≈₁ = ≈₁} {≈₂ = ≈₂} eq₁ eq₂ = record
    { refl  = λ {x} →
              _×-refl_        {∼₁ = ≈₁} {∼₂ = ≈₂}
                              (refl  eq₁) (refl  eq₂) {x}
    ; sym   = λ {x y} →
              _×-symmetric_   {∼₁ = ≈₁} {∼₂ = ≈₂}
                              (sym   eq₁) (sym   eq₂) {x} {y}
    ; trans = λ {x y z} →
              _×-transitive_  {∼₁ = ≈₁} {∼₂ = ≈₂}
                              (trans eq₁) (trans eq₂) {x} {y} {z}
    }
    where open IsEquivalence

  _×-isPreorder_ : ∀ {≈₁ ∼₁ ≈₂ ∼₂} →
                   IsPreorder ≈₁ ∼₁ → IsPreorder ≈₂ ∼₂ →
                   IsPreorder (≈₁ ×-Rel ≈₂) (∼₁ ×-Rel ∼₂)
  _×-isPreorder_ {∼₁ = ∼₁} {∼₂ = ∼₂} pre₁ pre₂ = record
    { isEquivalence = isEquivalence pre₁ ×-isEquivalence
                      isEquivalence pre₂
    ; reflexive     = λ {x y} →
                      _×-reflexive_  {∼₁ = ∼₁} {∼₂ = ∼₂}
                                     (reflexive pre₁) (reflexive pre₂)
                                     {x} {y}
    ; trans         = λ {x y z} →
                      _×-transitive_ {∼₁ = ∼₁} {∼₂ = ∼₂}
                                     (trans pre₁) (trans pre₂)
                                     {x} {y} {z}
    ; ∼-resp-≈      = ∼-resp-≈ pre₁ ×-≈-respects₂ ∼-resp-≈ pre₂
    }
    where open IsPreorder

  _×-isDecEquivalence_ : ∀ {≈₁ ≈₂} →
                         IsDecEquivalence ≈₁ → IsDecEquivalence ≈₂ →
                         IsDecEquivalence (≈₁ ×-Rel ≈₂)
  eq₁ ×-isDecEquivalence eq₂ = record
    { isEquivalence = isEquivalence eq₁ ×-isEquivalence
                      isEquivalence eq₂
    ; _≟_           = _≟_ eq₁ ×-decidable _≟_ eq₂
    }
    where open IsDecEquivalence

  _×-isPartialOrder_ : ∀ {≈₁ ≤₁ ≈₂ ≤₂} →
                       IsPartialOrder ≈₁ ≤₁ → IsPartialOrder ≈₂ ≤₂ →
                       IsPartialOrder (≈₁ ×-Rel ≈₂) (≤₁ ×-Rel ≤₂)
  _×-isPartialOrder_ {≤₁ = ≤₁} {≤₂ = ≤₂} po₁ po₂ = record
    { isPreorder = isPreorder po₁ ×-isPreorder isPreorder po₂
    ; antisym    = λ {x y} →
                   _×-antisymmetric_ {≤₁ = ≤₁} {≤₂ = ≤₂}
                                     (antisym po₁) (antisym po₂)
                                     {x} {y}
    }
    where open IsPartialOrder

  _×-isStrictPartialOrder_ :
    ∀ {≈₁ <₁ ≈₂ <₂} →
    IsStrictPartialOrder ≈₁ <₁ → IsStrictPartialOrder ≈₂ <₂ →
    IsStrictPartialOrder (≈₁ ×-Rel ≈₂) (<₁ ×-Rel <₂)
  _×-isStrictPartialOrder_ {<₁ = <₁} {≈₂ = ≈₂} {<₂ = <₂} spo₁ spo₂ =
    record
      { isEquivalence = isEquivalence spo₁ ×-isEquivalence
                        isEquivalence spo₂
      ; irrefl        = λ {x y} →
                        ×-irreflexive₁ {<₁ = <₁} {≈₂ = ≈₂} {<₂ = <₂}
                                       (irrefl spo₁) {x} {y}
      ; trans         = λ {x y z} →
                        _×-transitive_ {∼₁ = <₁} {∼₂ = <₂}
                                       (trans spo₁) (trans spo₂)
                                       {x} {y} {z}
      ; <-resp-≈      = <-resp-≈ spo₁ ×-≈-respects₂ <-resp-≈ spo₂
      }
    where open IsStrictPartialOrder

open Dummy public

-- "Packages" (e.g. setoids) can also be combined.

_×-preorder_ : Preorder → Preorder → Preorder
p₁ ×-preorder p₂ = record
  { isPreorder = isPreorder p₁ ×-isPreorder isPreorder p₂
  } where open Preorder

_×-setoid_ : Setoid → Setoid → Setoid
s₁ ×-setoid s₂ = record
  { isEquivalence = isEquivalence s₁ ×-isEquivalence isEquivalence s₂
  } where open Setoid

_×-decSetoid_ : DecSetoid → DecSetoid → DecSetoid
s₁ ×-decSetoid s₂ = record
  { isDecEquivalence = isDecEquivalence s₁ ×-isDecEquivalence
                       isDecEquivalence s₂
  } where open DecSetoid

_×-poset_ : Poset → Poset → Poset
s₁ ×-poset s₂ = record
  { isPartialOrder = isPartialOrder s₁ ×-isPartialOrder
                     isPartialOrder s₂
  } where open Poset

_×-strictPartialOrder_ :
  StrictPartialOrder → StrictPartialOrder → StrictPartialOrder
s₁ ×-strictPartialOrder s₂ = record
  { isStrictPartialOrder = isStrictPartialOrder s₁
                             ×-isStrictPartialOrder
                           isStrictPartialOrder s₂
  } where open StrictPartialOrder


open import Agda.Builtin.Equality
open import Agda.Builtin.Nat

foo : Nat → (Nat → Nat) → Nat
foo zero    f = f zero
foo (suc n) f = foo n λ n → f (suc n)

fsuc : (Nat → Nat) → Nat → Nat
fsuc f n = f (suc n)

foo' : Nat → (Nat → Nat) → Nat
foo' zero    f = f zero
foo' (suc n) f = foo' n (fsuc f)

foo'' : Nat → (Nat → Nat) → Nat
foo'' zero    f = f zero
foo'' (suc n) f = foo'' n λ { n → f (suc n) }

test : foo 50000 (λ n → n) ≡ 50000
test = refl

test' : foo' 50000 (λ n → n) ≡ 50000
test' = refl

test'' : foo'' 50000 (λ n → n) ≡ 50000
test'' = refl


-- 2011-09-15 posted by Nisse, variant of Issue292e
-- {-# OPTIONS --show-implicit -v tc.lhs.unify:15 #-}
module Issue292-16b where

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

postulate
  A : Set
  f : A → A

data C (A : Set)(f : A → A) : A → Set where
  c : ∀ x → C A f (f x)

record Box : Set where
  constructor box
  field
    a : A
    b : C A f a

test : ∀ {x₁ x₂} → box (f x₁) (c x₁) ≡ box (f x₂) (c x₂) → x₁ ≡ x₂
test refl = refl

-- We recover from the heteogenerous
--
--   c x₁ : C A f (f x₁) =?= c₂ x₂ : C A f (f x₂)
--
-- to the homogeneous
--
--   x₁ =?= x₂ : A
--
-- since the parameters to C are syntactically equal on lhs and rhs


module _ where

module Batch4 where
  data D1 (open Star) (A : ★) : ★ where
    c : (x : A) → D1 A

  data D2 (open Star) : ★ where

  data D3 (open Star) : ★₁ where
    c : (A : ★) → D3

  data D4 : (open Star) → ★ where

  data D0 (A : Set) (let B = A → A) : B → Set where
    c : (f : B) → D0 A f

  module _ where

    data D5 (open Star) (A : ★) (open MEndo A) : ★

    data D5 A (open MEndo A) where
      c : (f : Endo) → D5 A

  data D6 (open Star) (A : ★) (open MEndo A) : Endo → ★ where
    c : (f : Endo) → D6 A f

module Batch5 where
  data D1 (open Star) (A : ★) : ★

  data D1 A where
    c : (x : A) → D1 A

  data D2 (open Star) : ★
  data D2 where

  data D3 (open Star) : ★₁
  data D3 where
    c : (A : ★) → D3

  data D4 : (open Star) → ★
  data D4 where

open import Common.Equality

module Batch6 where

  BinOp : (A : Set) → Set
  BinOp A = A → A → A

  record IsAssoc {A : Set} (_∘_ : BinOp A) : Set where
    field
      assoc : ∀ {a b c} →
        ((a ∘ b) ∘ c) ≡ (a ∘ (b ∘ c))

  record RawSemiGroup : Set₁ where
    field
      Carrier : Set
      _∘_     : Carrier → Carrier → Carrier

  record SemiGroupLaws1 (G : RawSemiGroup) : Set where
    open RawSemiGroup G
    field
      isAssoc : IsAssoc _∘_

  module _ where
   record SemiGroupBLA
      (G : RawSemiGroup)
      (open RawSemiGroup G)
      (ass : IsAssoc _∘_) : Set
    where

  record SemiGroupLaws (G : RawSemiGroup) (open RawSemiGroup G) : Set where
    field
      isAssoc : IsAssoc {A = Carrier} _∘_

  record SemiGroup : Set₁ where
    field
      rawSemiGroup  : RawSemiGroup
      semiGroupLaws : SemiGroupLaws rawSemiGroup