module Data.Iterator where

import      Lvl
open import Data hiding (empty)
open import Data.Boolean
open import Functional
open import Numeral.Natural
open import Type

private variable ℓ : Lvl.Level
private variable T A B : Type{ℓ}
private variable a x init : T
private variable f : A → B
private variable n : ℕ

-- TODO: Is this useful when not lazy? It cannot store data and I am not sure if the whole list is evaluated in listIterator or not (strictness)
record Iterator (T : Type{ℓ}) : Type{ℓ} where
  coinductive
  field
    isEmpty : Bool
    current : if isEmpty then Unit else T -- TODO: These are essentially `Option`s but instead of storing its state, they depend on a boolean defined somewhere else
    step    : if isEmpty then Unit else Iterator(T)

open Iterator

{- TODO: This is a generalization of an iterator. It could be used to define iterators for any number of dimensions or to define double-ended iterators.
-- TODO: decidable-all-step may also be ∃{Obj = (Step → Bool) → Bool}(dec ↦ ∀{P} → (IsTrue(dec(P)) ↔ ∀ₗ(IsTrue ∘ P))). Not sure if it captures that (∀{s} → atEnd s) always is decidable by the smallest amount of assumptions. An example of this is when Step is finitely enumerable.
record Stepper (Step : Type{ℓₛ}) ⦃ decidable-all-step : ∀{P : Step → Bool} → Decidable(∀ₗ(IsTrue ∘ P)) ⦄ (T : Type{ℓ}) : Type{ℓ} where
  coinductive
  field
    atEnd : Step → Bool
    current : if decide(∀ₗ(IsTrue ∘ atEnd)) then Unit else T
    step    : (step : Step) → if(atEnd step) then Unit else Stepper(Step)(T)
-}

open import Data.Option
open import Data.Boolean.Operators
open        Data.Boolean.Operators.Programming

skip : ℕ → Iterator(T) → Iterator(T)
skip 𝟎 iter = iter
skip (𝐒 n) iter with isEmpty iter | step iter
... | 𝑇 | <>    = iter
... | 𝐹 | sIter = skip n sIter

skipExact : ℕ → Iterator(T) → Option(Iterator(T))
skipExact 𝟎 iter = Some iter
skipExact (𝐒 n) iter with isEmpty iter | step iter
... | 𝑇 | <>    = None
... | 𝐹 | sIter = skipExact n sIter

{- TODO: Not sure if I did not get the semantics of how codata works or whether the termination checker is wrong
{-# TERMINATING #-}
_++_ : Iterator(T) → Iterator(T) → Iterator(T)
isEmpty (a ++ b) with isEmpty a
... | 𝑇 = isEmpty b
... | 𝐹 = 𝐹
current (a ++ b) with isEmpty a | current a
... | 𝐹 | ca = ca
... | 𝑇 | <> with isEmpty b | current b
...     | 𝐹 | cb = cb
...     | 𝑇 | <> = <>
step (a ++ b) with isEmpty a | step a
... | 𝐹 | sa = sa ++ b
... | 𝑇 | <> with isEmpty b | step b
...     | 𝐹 | sb = sb
...     | 𝑇 | <> = <>

{-# TERMINATING #-}
map : (A → B) → (Iterator(A) → Iterator(B))
isEmpty (map f iter) = isEmpty iter
current (map f iter) with isEmpty iter | current iter
... | 𝑇 | <> = <>
... | 𝐹 | a = f(a)
step    (map f iter) with isEmpty iter | step iter
... | 𝑇 | <>    = <>
... | 𝐹 | sIter = map f sIter
-}

empty : Iterator(T)
isEmpty empty = 𝑇
current empty = <>
step    empty = <>

prepend : T → Iterator(T) → Iterator(T)
isEmpty (prepend x l) = 𝐹
current (prepend x l) = x
step    (prepend x l) = l

open import Data.List

listIterator : List(T) → Iterator(T)
listIterator ∅ = empty
listIterator (x ⊰ l) = prepend x (listIterator l)


------------------------------------------------------------------------
-- Some definitions related to Dec
------------------------------------------------------------------------

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

module Dec where

open import Logical-equivalence hiding (_∘_)
open import Prelude

private
  variable
    a   : Level
    A B : Type a

-- A map function for Dec.

Dec-map : A ⇔ B → Dec A → Dec B
Dec-map A⇔B = ⊎-map to (_∘ from)
  where
  open _⇔_ A⇔B

-- Dec preserves logical equivalences.

Dec-preserves : A ⇔ B → Dec A ⇔ Dec B
Dec-preserves A⇔B = record
  { to   = Dec-map A⇔B
  ; from = Dec-map (inverse A⇔B)
  }

-- If A and B are decided, then A × B is.

Dec-× : Dec A → Dec B → Dec (A × B)
Dec-× =
  [ (λ a → [ (λ b → yes (a , b))
           , (λ ¬b → no (¬b ∘ proj₂))
           ])
  , (λ ¬a _ → no (¬a ∘ proj₁))
  ]

-- If A and B are decided, then A ⊎ B is.

Dec-⊎ : Dec A → Dec B → Dec (A ⊎ B)
Dec-⊎ =
  [ (λ a _ → yes (inj₁ a))
  , (λ ¬a →
       [ (λ b → yes (inj₂ b))
       , (λ ¬b → no [ ¬a , ¬b ])
       ])
  ]


-- Andreas, 2019-04-10, re #3687, better test case for #1926

-- {-# OPTIONS -v interaction.contents.record:20 #-}

module _ (Foo : Set) where

open import Agda.Builtin.Sigma

test : {A : Set} {B : A → Set} (r : Σ A B) → Set
test r = {!r!}  -- C-c C-o


{-# OPTIONS --rewriting --prop --exact-split #-}

open import common

{-
An arity is something of the form (((n_1, k_1), …, (n_l, k_l)) , k), where the n_i are natural
numbers and the k_i and k are sorts. We will use two different types of sorts, so we parametrize
arities by the type of sorts.
The type [ArityArgs Sort] represents the first components of arities (the list), and [Arity Sort]
represents arities.
-}

data ArityArgs (Sort : Set) : Set where
  [] : ArityArgs Sort
  _,_ : ArityArgs Sort → (ℕ × Sort) → ArityArgs Sort

record Arity (Sort : Set) : Set where
  constructor _,_
  field
    args : ArityArgs Sort
    sort : Sort
open Arity public

SyntaxArityArgs = ArityArgs SyntaxSort
SyntaxArity = Arity SyntaxSort

{-
A signature consists of symbols, which are indexed by their arities. To have instead a set of
symbols and an arity function is very inconvenient.
-}

record Signature : Set₁ where
  field
    Symbols : SyntaxArity → Set
open Signature public

{-
Expressions are indexed by their syntactic class and their scope. An expression is either a variable
or a symbol applied to the appropriate number of arguments.
The type [Expr Σ n] is defined simultaneously with the type [Args Σ n args] which represents the
type of the arguments of a symbol with arity (args, _).
-}

data Args (Σ : Signature) (n : ℕ) : SyntaxArityArgs → Set

data Expr (Σ : Signature) (n : ℕ) : SyntaxSort → Set where
  var : VarPos n → Expr Σ n Tm
  sym : {ar : SyntaxArity} (s : Symbols Σ ar) → Args Σ n (args ar) → Expr Σ n (sort ar)

data Args Σ n where
  [] : Args Σ n []
  _,_ : {m : ℕ} {k : SyntaxSort} {args : SyntaxArityArgs}
      → Args Σ n args
      → Expr Σ (n + m) k
      → Args Σ n (args , (m , k))

{- Abbreviations for type-/term-expressions -}

TyExpr : (Σ : Signature) → ℕ → Set
TyExpr Σ n = Expr Σ n Ty

TmExpr : (Σ : Signature) → ℕ → Set
TmExpr Σ n = Expr Σ n Tm

{-
weakenV : {n m : ℕ} {{_ : n ≤ m}} (p : WeakPos n) → VarPos n → VarPos m
weakenV ⦃ ≤r ⦄ p x = x
weakenV ⦃ ≤S r ⦄ last x = prev (weakenV {{r}} last x)
weakenV ⦃ ≤S r ⦄ (prev p) last = last
weakenV ⦃ ≤S r ⦄ (prev p) (prev x) = prev (weakenV {{≤P (≤S r)}} p x)
-}

-- weakenVL : {n m : ℕ} {{_ : n ≤ m}} → VarPos n → VarPos m
-- weakenVL {{ ≤r }} x = x
-- weakenVL {{ ≤S p }} x = prev (weakenVL {{p}} x)

-- postulate
--   weakenV : {n m : ℕ} {{_ : n ≤ m}} (p : WeakPos n) → VarPos n → VarPos m
-- weakenV {m = _} ⦃ ≤r ⦄ last last = last
-- weakenV {m = _} ⦃ ≤S r ⦄ last last = prev (weakenV {{r}} last last)
-- weakenV {m = suc m} ⦃ r ⦄ (prev p) last = last
-- weakenV {m = suc m} ⦃ ≤r ⦄ last (prev x) = prev x
-- weakenV {m = suc m} ⦃ ≤S r ⦄ last (prev x) = prev (weakenV {m = m} {{≤P (≤S r)}} last x)
-- weakenV {m = suc m} ⦃ r ⦄ (prev p) (prev x) = prev (weakenV {m = m} {{≤P r}} p x)

-- weakenV {m = suc m}       (prev wp) last = last
-- weakenV {m = suc m} {{p}} (prev wp) (prev x) = prev (weakenV {{≤P p}} wp x)
-- weakenV {m = suc m} ⦃ ≤r ⦄ last x = x
-- weakenV {m = suc m} ⦃ ≤S r ⦄ last x = prev (weakenV {{r}} last x)

-- weakenV {m = suc m} ⦃ p ⦄ (prev wp) last = last
-- weakenV {m = suc m} ⦃ p ⦄ (prev wp) (prev x) = prev (weakenV {{≤P p}} wp x)
-- weakenV {m = suc m} ⦃ ≤r ⦄ last x = x
-- weakenV {m = suc m} ⦃ ≤S p ⦄ last x = prev (weakenV {{p}} last x)

postulate
  TODO : {A : Set} → A

weaken : {Σ : Signature} {k : _} {n m : ℕ} {{_ : n ≤ m}} (p : WeakPos n) → Expr Σ n k → Expr Σ m k
weakenA : {Σ : Signature} {ar : _} {n m : ℕ} {{_ : n ≤ m}} (p : WeakPos n) → Args Σ n ar → Args Σ m ar

weaken p (var x) = var (weakenV p x)
weaken p (sym s es) = sym s (weakenA p es)

weakenA p [] = []
weakenA {{q}} p (_,_ {m = m} es e) = (weakenA p es , weaken {{≤+ m {{q}}}} (weakenPos (≤-+ {m = m}) p) e)

weaken' : {Σ : Signature} {k : _} {n m : ℕ} {{_ : n ≤ m}} (p : WeakPos n) → Expr Σ n k → Expr Σ m k
weaken' ⦃ ≤r ⦄ p e = e
weaken' ⦃ ≤S q ⦄ p e = weaken {{≤S q}} p e

weakenL : {Σ : Signature} {k : _} {m n : ℕ} → Expr Σ m k → Expr Σ (m + n) k
weakenL {n = zero} e = e
weakenL {n = suc n} e = weaken last e

weaken0 : {Σ : Signature} {k : _} {n : ℕ} → Expr Σ 0 k → Expr Σ n k
weaken0 e = weaken {{0≤}} last e

weaken0' : {Σ : Signature} {k : _} {n : ℕ} → Expr Σ 0 k → Expr Σ n k
weaken0' {n = zero} e = e
weaken0' {n = suc n} e = weaken last e

weakenAL : {Σ : Signature} {ar : _} {m n : ℕ} → Args Σ m ar → Args Σ (m + n) ar
weakenAL {n = zero} es = es
weakenAL {n = suc n} es = weakenA last es

prev^last : (n l : ℕ) → WeakPos (n + l)
prev^last n zero = last
prev^last n (suc l) = prev (prev^last n l)

-- weaken≤ : {Σ : Signature} {k : _} {n m l : ℕ} {{_ : n ≤ m}} → Expr Σ (n + l) k → Expr Σ (m + l) k
-- weaken≤ ⦃ ≤r ⦄ e = e
-- weaken≤ {n = n} {l = l} ⦃ ≤S p ⦄ e = weaken {{TODO}} (prev^last n l) e

-- weaken^V' : {l m n : ℕ} → VarPos (l + m) → VarPos (l + n + m)
-- weaken^' : {Σ : Signature} {k : _} {l m n : ℕ} → Expr Σ (l + m) k → Expr Σ (l + n + m) k
-- weaken^A' : {Σ : Signature} {ar : _} {l m n : ℕ} → Args Σ (l + m) ar → Args Σ (l + n + m) ar

-- weaken^V' {zero} {m} {zero} k = k
-- weaken^V' {zero} {m} {suc n} k = prev (weaken^V' {zero} {m} {n} k)
-- weaken^V' {suc l} {m} {n} last = last
-- weaken^V' {suc l} {m} {n} (prev k) = prev (weaken^V' {l} {m} {n} k)

-- weaken^' {l = l} {m} {n} (var k) = var (weaken^V' {l = _} {m} {n} k)
-- weaken^' {l = l} {m} {n} (sym s x) = sym s (weaken^A' {l = _} {m} {n} x)

-- weaken^A' [] = []
-- weaken^A' {l = l} {m} {n} (_,_ {m = _} a x) = (weaken^A' {l = _} {m} {n} a , weaken^' {l = _} {m} {n} x)

-- -- this should not be defined as iterated weakening, it should reduce on expressions
-- weaken^ : {Σ : Signature} {k : _} {l n m : ℕ} {{p : n ≤ m}} → Expr Σ (l + n) k → Expr Σ (l + m) k
-- weaken^ {l = l} {n} {m} {{p}} k = weaken^' {l = l} {{!n!}} {{!!}} k

-- weaken^A : {Σ : Signature} {ar : _} {l n m : ℕ} {{p : n ≤ m}} → Args Σ (l + n) ar → Args Σ (l + m) ar
-- weaken^A {{p}} = weaken^A' {{p}}

-- weakenV≤r : {n : ℕ} {p : WeakPos n} (v : VarPos n) → weakenV {{≤r}} p v ≡ v
-- weakenV≤r {p = last} last = refl
-- weakenV≤r {p = prev p} last = refl
-- weakenV≤r {p = last} (prev v) = refl
-- weakenV≤r {p = prev p} (prev v) = ap prev (weakenV≤r {p = p} v)

-- weaken≤r : {Σ : Signature} {k : _} {n : ℕ} {p : WeakPos n} (e : Expr Σ n k) → weaken p e ≡ e
-- weakenA≤r : {Σ : Signature} {k : _} {n : ℕ} {p : WeakPos n} (as : Args Σ n k) → weakenA p as ≡ as

-- weaken≤r {p = p} (var x) = ap var (weakenV≤r {p = p} x)
-- weaken≤r (sym s x) = ap (sym s) (weakenA≤r x)

-- weakenA≤r [] = refl
-- weakenA≤r (es , e) = ap2 _,_ (weakenA≤r es) (weaken≤r e)

-- -- {-# REWRITE weaken^'≤r #-}

{- Contexts, [Ctx Σ n] represents contexts in signature [Σ] and of length [n] -}

data Ctx (Σ : Signature) : ℕ → Set where
  ◇ : Ctx Σ 0
  _,_ : {n : ℕ} (Γ : Ctx Σ n) (A : TyExpr Σ n) → Ctx Σ (suc n)

{- TODO
Dependent contexts, [DepCtx Σ n m] represents contexts in signature [Σ], in scope [n], and of
length [m]. They are built in the other direction compared to [Ctx], we add types to the left
instead of adding them to the right. The reason is that the "purpose" of dependent contexts is to
move the types one by one to the context on the left.
-}

data DepCtx (Σ : Signature) (n : ℕ) : ℕ → Set where
  ◇ : DepCtx Σ n 0
  _,_ : {m : ℕ} → DepCtx Σ n m → TyExpr Σ (n + m) → DepCtx Σ n (suc m)

{-
Extraction of types from contexts.
We need this partial version instead of the total well-typed one (below, not used).
-}

get : {Σ : Signature} {n : ℕ} (k : ℕ) → Ctx Σ n → Partial (VarPos n × TyExpr Σ n)
get k ◇ = fail
get zero (Γ , A) = return (last , weaken last A)
get (suc k) (Γ , X) = do
  (k' , A) ← get k Γ
  return (prev k' , weaken last A)

getTotal : {Σ : Signature} {n : ℕ} (k : VarPos n) → Ctx Σ n → TyExpr Σ n
getTotal last (Γ , A) = weaken last A
getTotal (prev k) (Γ , X) = weaken last (getTotal k Γ)

{-
In order to deal with extensions of signatures, we need a notion of map between signatures. There
are a few possible options:
- Mapping symbols to symbols: not strong enough, as later we need to map a symbol s(-) to the
  expression s(a, -)
- Mapping expressions to expressions: too strong, makes it impossible to look inside expressions
- Mapping symbols to expression-building function: this is the approach we take. A symbol will be
  mapped to a function of the corresponding arity between expressions of the codomain signature.

We need sometimes to restrict them to expressions in a certain scope (bounded below). This happens
for instance when turning typing rules to partial functions on the syntax, we replace something by a
specific term which lives in a scope, so the map between signatures does not work for a lower scope.
We need to have it bounded below (as opposed to having a fixed scope) otherwise we cannot map
expressions to expressions (as they may bind new variables).

Therefore we define [(Σ →Sig Σ') n] which represents maps from symbols of [Σ] to expression-building
functions for signature [Σ'], and which works for any scope above (and including) [n].
-}

record _→Sig_ (Σ Σ' : Signature) (n : ℕ) : Set where
  constructor sub
  field
    _$_ : {m : ℕ} {{p : n ≤ m}} {ar : SyntaxArity} (s : Symbols Σ ar) → Args Σ' m (args ar) → Expr Σ' m (sort ar)
open _→Sig_ public

{- Identity map -}

idSig : {n : ℕ} {Σ : Signature} → (Σ →Sig Σ) n
idSig $ s = sym s

{- Lifting at a higher scope -}

liftSig : {m n : ℕ} {Σ Σ' : Signature} → (Σ →Sig Σ') m → (Σ →Sig Σ') (m + n)
(liftSig {n = n} ↑ $ s) x = _$_ ↑ {{≤tr {{≤-+ {m = n}}}}} s x

{- Lifting of a map between signatures to expressions -}

↑Expr : {Σ Σ' : Signature} {n : ℕ} {k : SyntaxSort} → (Σ →Sig Σ') n → Expr Σ n k → Expr Σ' n k
↑Args : {Σ Σ' : Signature} {n : ℕ} {args : SyntaxArityArgs} → (Σ →Sig Σ') n → Args Σ n args → Args Σ' n args

↑Expr ↑ (var x) = var x
↑Expr ↑ (sym s x) = (↑ $ s) (↑Args ↑ x)

↑Args ↑ [] = []
↑Args ↑ (_,_ {m = m} es e) = ↑Args ↑ es , ↑Expr (liftSig ↑) e

{-
[ExtSig Σ ar] extends the signature [Σ] by an arity [ar].
In order to add a symbol only at the correct arity, we use an inductive family (another possibility
would be to use decidable equality of arities but that would be very ugly).
-}

data ExtSigSymbols (S : SyntaxArity → Set) (ar : SyntaxArity) : SyntaxArity → Set where
  prev : {ar' : SyntaxArity} → S ar' → (ExtSigSymbols S ar) ar'
  new : (ExtSigSymbols S ar) ar

ExtSig : Signature → SyntaxArity → Signature
Symbols (ExtSig Σ ar) = ExtSigSymbols (Symbols Σ) ar

{- If an extended signature maps to [Σ'], then the original signature too. -}
Ext→ : {Σ Σ' : Signature} {ar : SyntaxArity} {n : ℕ} → (ExtSig Σ ar →Sig Σ') n → (Σ →Sig Σ') n
Ext→ ↑ $ s = ↑ $ (prev s)

{- Arities of metavariables -}

MArityArgs : ℕ → SyntaxArityArgs
MArityArgs zero = []
MArityArgs (suc n) = MArityArgs n , (0 , Tm)

MArity : ℕ → SyntaxSort → SyntaxArity
args (MArity n k) = MArityArgs n
sort (MArity n k) = k

{- [ExtSig^ Σ args] extends the signature [Σ] by symbols for metavariables with arities given by [args] -}

ExtSig^ : Signature → SyntaxArityArgs → Signature
ExtSig^ Σ [] = Σ
ExtSig^ Σ (args , (n , k)) = ExtSig (ExtSig^ Σ args) (MArity n k)

{- Example
ExtSig^ Σ ((0, Ty), (1, Ty)) = extend Σ with one symbol of arity (() , Ty) and
                                             one symbol of arity ((0 , Tm), Ty)
-}

{-
Given two signatures [Σ] and [Σ'], we can map from a signature extended over [Σ] to [Σ'] as long as
we can map from [Σ] to [Σ'] and that we have terms [as] in [Σ'] to replace the new symbols.
[SubstM ↑ as] represents that map.
-}

-- trExpr : {Σ : Signature} {n n' : ℕ} (p : n === n') {k : SyntaxSort} → Expr Σ n k → Expr Σ n' k
-- trExpr refl u = u

-- trExpr! : {Σ : Signature} {n n' : ℕ} (p : n === n') {k : SyntaxSort} → Expr Σ n' k → Expr Σ n k
-- trExpr! refl u = u

pred : ℕ → ℕ
pred zero = zero
pred (suc n) = n

trV  : {n m : ℕ} → n ≡ m → VarPos n → VarPos m
trV {m = suc m} p last = last
trV {m = suc m} p (prev x) = prev (trV (ap pred p) x)

tr  : {Σ : Signature} {k : SyntaxSort} {n m : ℕ} → n ≡ m → Expr Σ n k → Expr Σ m k
trA : {Σ : Signature} {ar : SyntaxArityArgs} {n m : ℕ} → n ≡ m → Args Σ n ar → Args Σ m ar

tr p (var x) = var (trV p x)
tr p (sym s es) = sym s (trA p es)

trA p [] = []
trA p (es , x) = (trA p es , tr (ap (_+ _) p) x)

tr! : {Σ : Signature} {k : SyntaxSort} {n m : ℕ} → m ≡ n → Expr Σ n k → Expr Σ m k
tr! p e = tr (! p) e

data Mor (Σ : Signature) (n : ℕ) : ℕ → Set where
 ◇ : Mor Σ n 0
 _,_ : {m : ℕ} (δ : Mor Σ n m) (u : TmExpr Σ n) → Mor Σ n (suc m)

weakenMor : {Σ : Signature} {n m : ℕ} → Mor Σ m n → Mor Σ (suc m) n
weakenMor ◇ = ◇
weakenMor (δ , u) = (weakenMor δ , weaken last u)

idMor : {Σ : Signature} {n : ℕ} → Mor Σ n n
idMor {n = zero} = ◇
idMor {n = suc n} = (weakenMor idMor , var last)

weakenMor+ : {Σ : Signature} (k : ℕ) {n m : ℕ} → Mor Σ m n → Mor Σ (m + k) (n + k)
weakenMor+ zero δ = δ
weakenMor+ (suc k) δ = (weakenMor (weakenMor+ k δ) , var last)

SubstMor  : {Σ : Signature} {n m : ℕ} {k : SyntaxSort} → Expr Σ n k → Mor Σ m n → Expr Σ m k
SubstAMor : {Σ : Signature} {n m : ℕ} {args : SyntaxArityArgs} → Args Σ n args → Mor Σ m n → Args Σ m args

SubstMor (var last) (δ , u) = u
SubstMor (var (prev x)) (δ , u) = SubstMor (var x) δ
SubstMor (sym s es) δ = sym s (SubstAMor es δ)

SubstAMor [] δ = []
SubstAMor (_,_ {m = m} es x) δ = (SubstAMor es δ , SubstMor x (weakenMor+ m δ))

-- Subst1  : {Σ : Signature} {n : ℕ} (m : ℕ) {k : SyntaxSort} → Expr Σ (suc n + m) k → TmExpr Σ n → Expr Σ (n + m) k
-- Subst1A : {Σ : Signature} {n : ℕ} (m : ℕ) {args : SyntaxArityArgs} → Args Σ (suc n + m) args → TmExpr Σ n → Args Σ (n + m) args

-- Subst1 n (sym s x) a = sym s (Subst1A n x a)
-- Subst1 zero (var last) a = a
-- Subst1 zero (var (prev x)) a = var x
-- Subst1 (suc m) (var last) a = var last
-- Subst1 (suc m) (var (prev x)) a = weaken last (Subst1 m (var x) a)

-- Subst1A m [] a = []
-- Subst1A {n = n} m (_,_ {m = k} es e) a = (Subst1A m es a , tr! (assoc {n} {m} {k}) (Subst1 (m + k) (tr (assoc {suc n} {m} {k}) e) a))

Subst  : {Σ : Signature} {l m : ℕ} {k : SyntaxSort} → Expr Σ (m + l) k → Args Σ m (MArityArgs l) → Expr Σ m k
Subst {l = zero} e [] = e
Subst {l = suc l} {m} e (as , a) = Subst (SubstMor e (idMor , weakenL a)) as

SubstM : {Σ Σ' : Signature} {m : ℕ} {args : SyntaxArityArgs}
      → (Σ →Sig Σ') m
      → Args Σ' m args
      → ((ExtSig^ Σ args) →Sig Σ') m
SubstM ↑ [] = ↑
SubstM ↑ (as , a) $ prev s = SubstM ↑ as $ s
(SubstM ↑ (_,_ {m = l} as a)) $ new = Subst (weaken' {{≤+ l}} (prev^last _ l) a)

subst : {n m : ℕ} {k : SyntaxSort} {Σ Σ' : Signature} (↑ : (Σ →Sig Σ') n) {args : SyntaxArityArgs} (as : Args Σ' (n + m) args)
      → Expr (ExtSig^ Σ args) (n + m) k
      → Expr Σ' (n + m) k
subst {m = m} ↑ as e = ↑Expr (SubstM (liftSig ↑) as) e

-- {-
-- Example:

-- args = ((0, Ty), (1, Ty), (1, Tm))
-- ExtSig^ Σ args = Σ + {A} + {B} + {u} where A has arity ((), Ty), B has arity ((0, Tm), Ty), u has arity ((0, Tm), Tm)
-- To get a map from it to Σ', we need
-- - a map from Σ to Σ'
-- - a type expression in Σ' (for A)
-- - a type expression in Σ' in scope (m + 1)  (for B)
-- - a term expression in Σ' in scope (m + 1)  (for u)
-- -}


{-# OPTIONS --cubical --no-import-sorts --safe  #-}
module Cubical.HITs.SetQuotients where

open import Cubical.HITs.SetQuotients.Base public
open import Cubical.HITs.SetQuotients.Properties public


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

-- This is more a pair of constructions that a property...
-- but show that one can build a Cone for the Twisted Arrow functor from a Wedge
-- and vice-versa.

open import Categories.Category
open import Categories.Functor.Bifunctor

module Categories.Diagram.Wedge.Properties {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where

private
  module C = Category C
  module D = Category D
  open D
  open HomReasoning
  variable
    A : Obj

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

open import Categories.Category.Construction.TwistedArrow
open import Categories.Category.Equivalence using (StrongEquivalence)
open import Categories.Category.Construction.Cones using (Cones)
open import Categories.Category.Construction.Wedges
open import Categories.Diagram.Cone
open import Categories.Diagram.Wedge F
open import Categories.Functor hiding (id)
open import Categories.Functor.Bifunctor.Properties
open import Categories.Functor.Construction.Constant
open import Categories.Functor.Instance.Twisted C D
import Categories.Morphism as M
open import Categories.Morphism.Reasoning D
open import Categories.NaturalTransformation.Dinatural
open import Categories.NaturalTransformation.NaturalIsomorphism using (niHelper)

open Functor F

-- There is a construction that builds a Cone (Twist F) from a Wedge
module _ (w : Wedge)  where
  open Wedge w
  open DinaturalTransformation
  open Morphism
  open Morphism⇒

  private
    Wedge-to-Cone′ : {C C′ : C.Obj} (f : C C.⇒ C′) → Wedge.E w ⇒ F₀ (C , C′)
    Wedge-to-Cone′ {C} {C′} f = F₁ (C.id , f) ∘ α dinatural C

  Wedge-to-Cone : Cone (Twist F)
  Wedge-to-Cone = record
    { N = E
    ; apex = record
      { ψ = λ Tw → Wedge-to-Cone′ (arr Tw)
      ; commute = λ { {record { dom = dom₁ ; cod = cod₁ ; arr = arr₁ }}
                      {record { dom = dom ; cod = cod ;  arr = arr }}
                      (record { dom⇐ = dom⇐₁ ; cod⇒ = cod⇒₁; square = square₁}) → begin
        F₁ (dom⇐₁ , cod⇒₁) ∘ F₁ (C.id , arr₁) ∘ dinatural.α dom₁                      ≈⟨ pullˡ (Equiv.sym homomorphism) ⟩
        F₁ (C.id C.∘ dom⇐₁ , cod⇒₁ C.∘ arr₁) ∘ dinatural.α dom₁                       ≈⟨ ([ F ]-decompose₁ ⟩∘⟨refl) ⟩
        (F₁ (C.id C.∘ dom⇐₁ , C.id) ∘ F₁ (C.id , cod⇒₁ C.∘ arr₁)) ∘ dinatural.α dom₁  ≈⟨ (F-resp-≈ (C.identityˡ , C.Equiv.refl) ⟩∘⟨refl ⟩∘⟨refl) ⟩
        (F₁ (dom⇐₁ , C.id) ∘ F₁ (C.id , cod⇒₁ C.∘ arr₁)) ∘ dinatural.α dom₁           ≈⟨ pullʳ (extranatural-commʳ dinatural) ⟩
        F₁ (dom⇐₁ , C.id) ∘ (F₁ (cod⇒₁ C.∘ arr₁ , C.id) ∘ dinatural.α cod)            ≈⟨ pullˡ (Equiv.sym homomorphism) ⟩
        F₁ ((cod⇒₁ C.∘ arr₁) C.∘ dom⇐₁ , C.id C.∘ C.id) ∘ dinatural.α cod             ≈⟨ (F-resp-≈ (C.assoc , C.identity²) ⟩∘⟨refl) ⟩
        F₁ (cod⇒₁ C.∘ arr₁ C.∘ dom⇐₁ , C.id) ∘ dinatural.α cod                        ≈⟨ (F-resp-≈ (square₁ , C.Equiv.refl) ⟩∘⟨refl) ⟩
        F₁ (arr , C.id) ∘ dinatural.α cod                                              ≈˘⟨ extranatural-commʳ dinatural ⟩
        F₁ (C.id , arr) ∘ dinatural.α dom   ∎             }
      }
    }

-- And a construction that builds a Wedge from a Cone (Twist F)
module _ (c : Cone (Twist F)) where
  open Cone c
  open DinaturalTransformation

  private
    fam : {A B : C.Obj} (f : A C.⇒ B) → N ⇒ F₀ (A , B)
    fam f = ψ record { arr = f }
    id² : {A B : C.Obj} (f : A C.⇒ B) → f C.∘ C.id C.∘ C.id C.≈ f
    id² f = C.∘-resp-≈ʳ C.identity² HR.○ C.identityʳ
      where
      module HR = C.HomReasoning

  Cone-to-Wedge : Wedge
  Cone-to-Wedge = record
    { E = N
    ; dinatural = dtHelper record
      { α = λ _ → fam C.id
      ; commute = λ f → begin
        F₁ (C.id , f) ∘ fam C.id ∘ id ≈⟨ pullˡ (Cone.commute c (mor⇒ (id² f))) ⟩
        ψ (record { arr = f }) ∘ id   ≈⟨ pushˡ (Equiv.sym (Cone.commute c (mor⇒ (C.identityˡ C.HomReasoning.○ C.identityˡ)))) ⟩
        F₁ (f , C.id) ∘ fam C.id ∘ id ∎
      }
    }

ConeTwist⇒WedgeF : Functor (Cones (Twist F)) (Wedges F)
ConeTwist⇒WedgeF = record
  { F₀ = Cone-to-Wedge
  ; F₁ = λ c⇒ → record
    { u = Cone⇒.arr c⇒
    ; commute = Cone⇒.commute c⇒
    }
  ; identity = Equiv.refl
  ; homomorphism = Equiv.refl
  ; F-resp-≈ = λ f≈g → f≈g
  }
Wedge⇒ConeTwistF : Functor (Wedges F) (Cones (Twist F))
Wedge⇒ConeTwistF = record
  { F₀ = Wedge-to-Cone
  ; F₁ = λ {A} {B} f → record
    { arr = u f
    ; commute = pullʳ (commute f)
    }
  ; identity = Equiv.refl
  ; homomorphism = Equiv.refl
  ; F-resp-≈ = λ f≈g → f≈g
  }
  where
  open Wedge-Morphism

ConesTwist≅Wedges : StrongEquivalence (Cones (Twist F)) (Wedges F)
ConesTwist≅Wedges = record
  { F = ConeTwist⇒WedgeF
  ; G = Wedge⇒ConeTwistF
  ; weak-inverse = record
    { F∘G≈id = niHelper record
      { η = λ _ → record { u = id ; commute = id-comm ○ (Equiv.sym identity ⟩∘⟨refl) }
      ; η⁻¹ = λ _ → record { u = id ; commute = assoc ○ identity ⟩∘⟨refl ○ (identityˡ ○ identityʳ) }
      ; commute = λ _ → id-comm-sym
      ; iso = λ X → record { isoˡ = identity² ; isoʳ = identity² }
      }
    ; G∘F≈id = niHelper record
      { η = λ Co → record
        { arr = id
        ; commute = λ {X} →
          let m = record { dom⇐ = C.id; cod⇒ = Morphism.arr X; square = (C.∘-resp-≈ʳ C.identity²) C.HomReasoning.○ C.identityʳ}
              a = record { arr = C.id } in begin
          ψ (apex Co) X ∘ id                ≈⟨ identityʳ ⟩
          ψ (apex Co) X                     ≈˘⟨ commute Co m ⟩
          F₁ (C.id , arr X) ∘ ψ (apex Co) a ∎ --
        }
      ; η⁻¹ = λ Co → record
        { arr = id
        ; commute = λ {X} →
        let m = record { dom⇐ = C.id; cod⇒ = Morphism.arr X; square = (C.∘-resp-≈ʳ C.identity²) C.HomReasoning.○ C.identityʳ}
            a = record { arr = C.id } in begin
        (F₁ (C.id , arr X) ∘ ψ (apex Co) a) ∘ id ≈⟨ identityʳ ⟩
        F₁ (C.id , arr X) ∘ ψ (apex Co) a        ≈⟨ commute Co m ⟩
        ψ (apex Co) X ∎
        }
      ; commute = λ f → id-comm-sym
      ; iso = λ X → record { isoˡ = identity² ; isoʳ = identity² }
      }
    }
  }
  where
  open Cone
  open Apex
  open Morphism


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

open import lib.Basics
open import lib.types.Group
open import lib.types.Pi
open import lib.NType2
open import lib.types.EilenbergMacLane1.Core

module lib.types.EilenbergMacLane1.DoubleElim where

private

  emloop-emloop-helper : ∀ {i j k} {A : Type i} {B : Type j} {C : A → B → Type k}
    {a : A} (p : a == a)
    {b₀ b₁ : B} (q : b₀ == b₁)
    (f : (b : B) → C a b)
    (g : (b : B) → C a b)
    (r₀ : f b₀ == g b₀ [ (λ a → C a b₀) ↓ p ])
    (r₁ : f b₁ == g b₁ [ (λ a → C a b₁) ↓ p ])
    → ↓-ap-in (λ Z → Z) (λ a → C a b₀) r₀ ∙'ᵈ ↓-ap-in (λ Z → Z) (C a) (apd g q) ==
      ↓-ap-in (λ Z → Z) (C a) (apd f q) ∙ᵈ ↓-ap-in (λ Z → Z) (λ a → C a b₁) r₁
        [ (λ p → f b₀ == g b₁ [ (λ Z → Z) ↓ p ]) ↓ ap-comm' C p q ]
    → r₀ == r₁ [ (λ b → f b == g b [ (λ a → C a b) ↓ p ]) ↓ q ]
  emloop-emloop-helper {C = C} p {b₀} idp f g r₀ r₁ s =
    –>-is-inj (↓-ap-equiv (λ Z → Z) (λ a → C a b₀)) r₀ r₁ $
    (! (▹idp (↓-ap-in (λ Z → Z) (λ a → C a b₀) r₀)) ∙
    s ∙
    idp◃ (↓-ap-in (λ Z → Z) (λ a → C a b₀) r₁))

module _ {i j} (G : Group i) (H : Group j) where

  private
    module G = Group G
    module H = Group H

  module EM₁Level₁DoubleElim {k} {P : EM₁ G → EM₁ H → Type k}
    {{P-level : ∀ x y → has-level 1 (P x y)}}
    (embase-embase* : P embase embase)
    (embase-emloop* : ∀ h → embase-embase* == embase-embase* [ P embase ↓ emloop h ])
    (emloop-embase* : ∀ g → embase-embase* == embase-embase* [ (λ x → P x embase) ↓ emloop g ])
    (embase-emloop-comp* : ∀ h₁ h₂ →
      embase-emloop* (H.comp h₁ h₂) == embase-emloop* h₁ ∙ᵈ embase-emloop* h₂
        [ (λ p → embase-embase* == embase-embase* [ P embase ↓ p ]) ↓ emloop-comp h₁ h₂ ])
    (emloop-comp-embase* : ∀ g₁ g₂ →
      emloop-embase* (G.comp g₁ g₂) == emloop-embase* g₁ ∙ᵈ emloop-embase* g₂
        [ (λ p → embase-embase* == embase-embase* [ (λ x → P x embase) ↓ p ]) ↓ emloop-comp g₁ g₂ ])
    (emloop-emloop* : ∀ g h →
      ↓-ap-in (λ Z → Z) (λ a → P a embase) (emloop-embase* g) ∙'ᵈ
      ↓-ap-in (λ Z → Z) (P embase) (embase-emloop* h)
      ==
      ↓-ap-in (λ Z → Z) (P embase) (embase-emloop* h) ∙ᵈ
      ↓-ap-in (λ Z → Z) (λ a → P a embase) (emloop-embase* g)
        [ (λ p → embase-embase* == embase-embase* [ (λ Z → Z) ↓ p ]) ↓ ap-comm' P (emloop g) (emloop h) ])
    where

    private
      module Embase =
        EM₁Level₁Elim {P = P embase}
                      {{P-level embase}}
                      embase-embase*
                      embase-emloop*
                      embase-emloop-comp*

      P' : embase' G == embase → EM₁ H → Type k
      P' p y = Embase.f y == Embase.f y [ (λ x → P x y) ↓ p ]

      P'-level : ∀ p y → has-level 0 (P' p y)
      P'-level _ y = ↓-level (P-level embase y)

      emloop-emloop** : ∀ g h → emloop-embase* g == emloop-embase* g [ P' (emloop g) ↓ emloop h ]
      emloop-emloop** g h =
        emloop-emloop-helper
          {C = P}
          (emloop g) (emloop h)
          Embase.f Embase.f
          (emloop-embase* g) (emloop-embase* g)
          (transport!
            (λ u →
              ↓-ap-in (λ Z → Z) (λ a → P a embase) (emloop-embase* g) ∙'ᵈ
              ↓-ap-in (λ Z → Z) (P embase) u
              ==
              ↓-ap-in (λ Z → Z) (P embase) u ∙ᵈ
              ↓-ap-in (λ Z → Z) (λ a → P a embase) (emloop-embase* g)
                [ (λ p → embase-embase* == embase-embase* [ (λ Z → Z) ↓ p ]) ↓ ap-comm' P (emloop g) (emloop h) ])
            (Embase.emloop-β h)
            (emloop-emloop* g h))

      module Emloop (g : G.El) =
        EM₁SetElim {P = P' (emloop g)}
                   {{P'-level (emloop g)}}
                   (emloop-embase* g)
                   (emloop-emloop** g)

      module EmloopComp (g₁ g₂ : G.El) =
        EM₁PropElim {P = λ y → Emloop.f (G.comp g₁ g₂) y ==
                               Emloop.f g₁ y ∙ᵈ Emloop.f g₂ y
                                 [ (λ x → P' x y) ↓ emloop-comp g₁ g₂ ]}
                    {{λ y → ↓-level (P'-level _ y)}}
                    (emloop-comp-embase* g₁ g₂)

      module DoubleElim (y : EM₁ H) =
        EM₁Level₁Elim {P = λ x → P x y}
                      {{λ x → P-level x y}}
                      (Embase.f y)
                      (λ g → Emloop.f g y)
                      (λ g₁ g₂ → EmloopComp.f g₁ g₂ y)

    abstract
      f : ∀ x y → P x y
      f x y = DoubleElim.f y x

      embase-embase-β : f embase embase ↦ embase-embase*
      embase-embase-β = Embase.embase-β
      {-# REWRITE embase-embase-β #-}

      embase-emloop-β : ∀ (h : H.El) → apd (λ y → f embase y) (emloop h) == embase-emloop* h
      embase-emloop-β h = Embase.emloop-β h

      emloop-embase-β : ∀ (g : G.El) → apd (λ x → f x embase) (emloop g) == emloop-embase* g
      emloop-embase-β g = DoubleElim.emloop-β embase g


------------------------------------------------------------------------
-- The Agda standard library
--
-- A larger example for sublists (propositional case):
-- Simply-typed lambda terms with globally unique variables
-- (both bound and free ones).
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Sublist.Propositional.Example.UniqueBoundVariables (Base : Set) where

open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong; subst; module ≡-Reasoning)
open ≡-Reasoning

open import Data.List.Base using (List; []; _∷_; [_])
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Relation.Unary.All using (Null; [])
open import Data.List.Relation.Binary.Sublist.Propositional using
  ( _⊆_; []; _∷_; _∷ʳ_
  ; ⊆-refl; ⊆-trans; minimum
  ; from∈; to∈; lookup
  ; ⊆-pushoutˡ; RawPushout
  ; Disjoint; DisjointUnion
  ; separateˡ; Separation
  )
open import Data.List.Relation.Binary.Sublist.Propositional.Properties using
  ( ∷ˡ⁻
  ; ⊆-trans-assoc
  ; from∈∘to∈; from∈∘lookup; lookup-⊆-trans
  ; ⊆-pushoutˡ-is-wpo
  ; Disjoint→DisjointUnion; DisjointUnion→Disjoint
  ; Disjoint-sym; DisjointUnion-inj₁; DisjointUnion-inj₂; DisjointUnion-[]ʳ
  ; weakenDisjoint; weakenDisjointUnion; shrinkDisjointˡ
  ; disjoint⇒disjoint-to-union; DisjointUnion-fromAny∘toAny-∷ˡ⁻
  ; equalize-separators
  )

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

-- Simple types over a set Base of base types.

data Ty : Set where
  base : (o : Base) → Ty
  _⇒_ : (a b : Ty) → Ty

-- Typing contexts are lists of types.

Cxt = List Ty

variable
  a b : Ty
  Γ Δ : Cxt
  x y : a ∈ Γ

-- The familiar intrinsically well-typed formulation of STLC
-- where a de Bruijn index x is a pointer into the context.

module DeBruijn where

  data Tm (Δ : Cxt) : (a : Ty) → Set where
    var : (x : a ∈ Δ) → Tm Δ a
    abs : (t : Tm (a ∷ Δ) b) → Tm Δ (a ⇒ b)
    app : (t : Tm Δ (a ⇒ b)) (u : Tm Δ a) → Tm Δ b

-- We formalize now intrinsically well-typed STLC with
-- named variables that are globally unique, i.e.,
-- each variable can be bound at most once.

-- List of bound variables of a term.

BVars = List Ty

variable
  B    : BVars
  noBV : Null B

-- There is a single global context Γ of all variables used in the terms.
-- Each list of bound variables B is a sublist of Γ.

variable
  β βₜ βᵤ yβ β\y : B ⊆ Γ

-- Named terms are parameterized by a sublist β : B ⊆ Γ of bound variables.
-- Variables outside B can occur as free variables in a term.
--
--   * Variables x do not contain any bound variables (Null B).
--
--   * The bound variables of an application (t u) is the disjoint union
--     of the bound variables βₜ of t and βᵤ of u.
--
--   * The bound variables β of an abstraction λyt is the disjoint union
--     of the single variable y and the bound variables β\y of t.

module UniquelyNamed where

  data Tm (β : B ⊆ Γ) : (a : Ty) → Set where

    var : (noBV : Null B)
          (x : a ∈ Γ)
        → Tm β a

    abs : (y : a ∈ Γ)
          (y# : DisjointUnion (from∈ y) β\y β)
          (t : Tm β\y b)
        → Tm β (a ⇒ b)

    app : (t : Tm βₜ (a ⇒ b))
          (u : Tm βᵤ a)
          (t#u : DisjointUnion βₜ βᵤ β)
        → Tm β b

  pattern var! x = var [] x

  -- Bound variables β : B ⊆ Γ can be considered in a larger context Γ′
  -- obtained by γ : Γ ⊆ Γ′.  The embedding β′ : B ⊆ Γ′ is simply the
  -- composition of β and γ, and terms can be coerced recursively:

  weakenBV : ∀ {Γ B Γ′} {β : B ⊆ Γ} (γ : Γ ⊆ Γ′)  →
          Tm β a → Tm (⊆-trans β γ) a

  weakenBV γ (var noBV x)  = var noBV (lookup γ x)
  weakenBV γ (app t u t#u) = app (weakenBV γ t) (weakenBV γ u) (weakenDisjointUnion γ t#u)
  weakenBV γ (abs y y# t)  = abs y′ y′# (weakenBV γ t)
    where
    y′  = lookup γ y
    -- Typing:  y′# : DisjointUnion (from∈ y′) (⊆-trans β\y γ) (⊆-trans β γ)
    y′# = subst (λ □ → DisjointUnion □ _ _) (sym (from∈∘lookup _ _)) (weakenDisjointUnion γ y#)

-- We bring de Bruijn terms into scope as Exp.

open DeBruijn renaming (Tm to Exp)
open UniquelyNamed

variable
  t u  : Tm β a
  f e  : Exp Δ a

-- Relating de Bruijn terms and uniquely named terms.
--
-- The judgement δ ⊢ e ~ β ▷ t relates a de Bruijn term e with potentially free variables δ : Δ ⊆ Γ
-- to a named term t with exact bound variables β : B ⊆ Γ.  The intention is to relate exactly
-- the terms with the same meaning.
--
-- The judgement will imply the disjointness of Δ and B.

variable
  δ yδ : Δ ⊆ Γ

data _⊢_~_▷_ {Γ Δ : Cxt} (δ : Δ ⊆ Γ) : ∀{a} (e : Exp Δ a) {B} (β : B ⊆ Γ) (t : Tm β a) → Set where

  -- Free de Bruijn index x : a ∈ Δ is related to free variable y : a ∈ Γ
  -- if δ : Δ ⊆ Γ maps x to y.

  var : ∀{y} (δx≡y : lookup δ x ≡ y) (δ#β : Disjoint δ β)
      → δ ⊢ var x ~ β ▷ var! y

  -- Unnamed lambda δ ⊢ λ.e is related to named lambda y,β ▷ λy.t
  -- if body y,δ ⊢ e is related to body β ▷ t.

  abs : (y#δ : DisjointUnion (from∈ y) δ yδ)
      → (y#β : DisjointUnion (from∈ y) β yβ)
      → yδ ⊢ e ~ β ▷ t
      → δ ⊢ abs e ~ yβ ▷ abs y y#β t

  -- Application δ ⊢ f e is related to application βₜ,βᵤ ▷ t u
  -- if function δ ⊢ f is related to βₜ ▷ t
  -- and argument δ ⊢ e is related to βᵤ ▷ u.

  app : δ ⊢ f ~ βₜ ▷ t
      → δ ⊢ e ~ βᵤ ▷ u
      → (t#u : DisjointUnion βₜ βᵤ β)
      → δ ⊢ app f e ~ β ▷ app t u t#u

-- A dependent substitution lemma for ~.
-- Trivial, but needed because term equality t : Tm β a ≡ t′ : Tm β′ a is heterogeneous,
-- or, more precisely, indexed by a sublist equality β ≡ β′.

subst~ : ∀ {a Δ Γ B} {δ δ′ : Δ ⊆ Γ} {β β′ : B ⊆ Γ}
         {e : Exp Δ a} {t : Tm β a} {t′ : Tm β′ a}
         (δ≡δ′ : δ ≡ δ′)
         (β≡β′ : β ≡ β′)
         (t≡t′ : subst (λ □ → Tm □ a) β≡β′ t ≡ t′) →
         δ ⊢ e ~ β ▷ t →
         δ′ ⊢ e ~ β′ ▷ t′
subst~ refl refl refl d = d

-- The judgement δ ⊢ e ~ β ▷ t relative to Γ
-- can be transported to a bigger context γ : Γ ⊆ Γ′.

weaken~ : ∀{a Δ B Γ Γ′} {δ : Δ ⊆ Γ} {β : B ⊆ Γ} {e : Exp Δ a} {t : Tm β a}  (γ : Γ ⊆ Γ′)
  (let δ′ = ⊆-trans δ γ)
  (let β′ = ⊆-trans β γ)
  (let t′ = weakenBV γ t) →
  δ ⊢ e ~ β ▷ t →
  δ′ ⊢ e ~ β′ ▷ t′
weaken~ γ (var refl δ#β)  = var (lookup-⊆-trans γ _) (weakenDisjoint γ δ#β)
weaken~ γ (abs y#δ y#β d) = abs y′#δ′ y′#β′ (weaken~ γ d)
  where
  y′#δ′ = subst (λ □ → DisjointUnion □ _ _) (sym (from∈∘lookup _ _)) (weakenDisjointUnion γ y#δ)
  y′#β′ = subst (λ □ → DisjointUnion □ _ _) (sym (from∈∘lookup _ _)) (weakenDisjointUnion γ y#β)
weaken~ γ (app dₜ dᵤ t#u) = app (weaken~ γ dₜ) (weaken~ γ dᵤ) (weakenDisjointUnion γ t#u)

-- Lemma:  If δ ⊢ e ~ β ▷ t, then
-- the (potentially) free variables δ of the de Bruijn term e
-- are disjoint from the bound variables β of the named term t.

disjoint-fv-bv : δ ⊢ e ~ β ▷ t → Disjoint δ β
disjoint-fv-bv (var _ δ#β) = δ#β

disjoint-fv-bv {β = yβ} (abs y⊎δ y⊎β d) = δ#yβ
  where
  δ#y     = Disjoint-sym (DisjointUnion→Disjoint y⊎δ)
  yδ#β    = disjoint-fv-bv d
  δ⊆yδ,eq = DisjointUnion-inj₂ y⊎δ
  δ⊆yδ    = proj₁ δ⊆yδ,eq
  eq      = proj₂ δ⊆yδ,eq
  δ#β     = subst (λ □ → Disjoint □ _) eq (shrinkDisjointˡ δ⊆yδ yδ#β)
  δ#yβ    = disjoint⇒disjoint-to-union δ#y δ#β y⊎β

disjoint-fv-bv (app dₜ dᵤ βₜ⊎βᵤ) = disjoint⇒disjoint-to-union δ#βₜ δ#βᵤ βₜ⊎βᵤ
  where
  δ#βₜ = disjoint-fv-bv dₜ
  δ#βᵤ = disjoint-fv-bv dᵤ

-- Translating de Bruijn terms to uniquely named terms.
--
-- Given a de Bruijn term Δ ⊢ e : a, we seek to produce a named term β ▷ t : a
-- that is related to the de Bruijn term.  On the way, we have to compute the
-- global context Γ that hosts all free and bound variables of t.

-- Record (NamedOf e) collects all the outputs of the translation of e.

record NamedOf (e : Exp Δ a) : Set where
  constructor mkNamedOf
  field
    {glob} : Cxt                    -- Γ
    emb    : Δ ⊆ glob               -- δ : Δ ⊆ Γ
    {bv}   : BVars                  -- B
    bound  : bv ⊆ glob              -- β : B ⊆ Γ
    {tm}   : Tm bound a             -- t : Tm β a
    relate : emb ⊢ e ~ bound ▷ tm   -- δ ⊢ e ~ β ▷ t

-- The translation.

dB→Named : (e : Exp Δ a) → NamedOf e

-- For the translation of a variable x : a ∈ Δ, we can pick Γ := Δ and B := [].
-- Δ and B are obviously disjoint subsets of Γ.

dB→Named (var x) = record
    { emb    = ⊆-refl     -- Γ := Δ
    ; bound  = minimum _  -- no bound variables
    ; relate = var refl (DisjointUnion→Disjoint DisjointUnion-[]ʳ)
    }

-- For the translation of an abstraction
--
--   abs (t : Exp (a ∷ Δ) b) : Exp Δ (a ⇒ b)
--
-- we recursively have Γ, B and β : B ⊆ Γ with z,δ : (a ∷ Δ) ⊆ Γ
-- and know that B # a∷Δ.
--
-- We keep Γ and produce embedding δ : Δ ⊆ Γ and bound variables z ⊎ β.

dB→Named {Δ = Δ} {a = a ⇒ b} (abs e) with dB→Named e
... | record{ glob = Γ; emb = zδ; bound = β; relate = d } =
  record
    { glob   = Γ
    ; emb    = δ̇
    ; bound  = proj₁ (proj₂ z⊎β)
    ; relate = abs [a]⊆Γ⊎δ (proj₂ (proj₂ z⊎β)) d
    }
  where
  -- Typings:
  -- zδ   : a ∷ Δ ⊆ Γ
  -- β    : bv ⊆ Γ
  zδ#β    = disjoint-fv-bv d
  z       : a ∈ Γ
  z       = to∈ zδ
  [a]⊆Γ   = from∈ z
  δ̇       = ∷ˡ⁻ zδ
  [a]⊆Γ⊎δ = DisjointUnion-fromAny∘toAny-∷ˡ⁻ zδ
  [a]⊆aΔ  : [ a ] ⊆ (a ∷ Δ)
  [a]⊆aΔ  = refl ∷ minimum _
  eq      : ⊆-trans [a]⊆aΔ zδ ≡ [a]⊆Γ
  eq      = sym (from∈∘to∈ _)
  z#β     : Disjoint [a]⊆Γ β
  z#β     = subst (λ □ → Disjoint □ β) eq (shrinkDisjointˡ [a]⊆aΔ zδ#β)
  z⊎β     = Disjoint→DisjointUnion z#β

-- For the translation of an application (f e) we have by induction hypothesis
-- two independent extensions δ₁ : Δ ⊆ Γ₁ and δ₂ : Δ ⊆ Γ₂
-- and two bound variable lists β₁ : B₁ ⊆ Γ₁ and β₂ : B₂ ⊆ Γ₂.
-- We need to find a common global context Γ such that
--
--   (a) δ : Δ ⊆ Γ and
--   (b) the bound variables embed disjointly as β₁″ : B₁ ⊆ Γ and β₂″ : B₂ ⊆ Γ.
--
-- (a) δ is (eventually) found via a weak pushout of δ₁ and δ₂, giving
-- ϕ₁ : Γ₁ ⊆ Γ₁₂  and  ϕ₂ : Γ₂ ⊆ Γ₁₂.
--
-- (b) The bound variable embeddings
--
--   β₁′ = β₁ϕ₁ : B₁ ⊆ Γ₁₂ and
--   β₂′ = β₂ϕ₂ : B₂ ⊆ Γ₁₂ and
--
-- may be overlapping, but we can separate them by enlarging the global context
-- to Γ with two embeddings
--
--   γ₁ : Γ₁₂ ⊆ Γ
--   γ₂ : Γ₁₂ ⊆ Γ
--
-- such that
--
--   β₁″ = β₁′γ₁ : B₁ ⊆ Γ
--   β₂″ = β₂′γ₂ : B₂ ⊆ Γ
--
-- are disjoint.  Since Δ is disjoint to both B₁ and B₂ we have equality of
--
--   δ₁ϕ₁γ₁ : Δ ⊆ Γ
--   δ₂ϕ₂γ₂ : Δ ⊆ Γ
--
-- Thus, we can return either of them as δ.

dB→Named (app f e) with dB→Named f | dB→Named e
... | mkNamedOf {Γ₁} δ₁ β₁ {t} d₁ | mkNamedOf {Γ₂} δ₂ β₂ {u} d₂ =
  mkNamedOf δ̇ β̇ (app d₁″ d₂″ β₁″⊎β₂″)
  where
  -- Disjointness of δᵢ and βᵢ from induction hypotheses.
  δ₁#β₁   = disjoint-fv-bv d₁
  δ₂#β₂   = disjoint-fv-bv d₂

  -- join δ₁ and δ₂ via weak pushout
  po      = ⊆-pushoutˡ δ₁ δ₂
  Γ₁₂     = RawPushout.upperBound po
  ϕ₁      = RawPushout.leg₁ po
  ϕ₂      = RawPushout.leg₂ po
  δ₁′     = ⊆-trans δ₁ ϕ₁
  δ₂′     = ⊆-trans δ₂ ϕ₂
  β₁′     = ⊆-trans β₁ ϕ₁
  β₂′     = ⊆-trans β₂ ϕ₂
  δ₁′#β₁′ : Disjoint δ₁′ β₁′
  δ₁′#β₁′ = weakenDisjoint ϕ₁ δ₁#β₁
  δ₂′#β₂′ : Disjoint δ₂′ β₂′
  δ₂′#β₂′ = weakenDisjoint ϕ₂ δ₂#β₂
  δ₁′≡δ₂′ : δ₁′ ≡ δ₂′
  δ₁′≡δ₂′ = ⊆-pushoutˡ-is-wpo δ₁ δ₂
  δ₂′#β₁′ : Disjoint δ₂′ β₁′
  δ₂′#β₁′ = subst (λ □ → Disjoint □ β₁′) δ₁′≡δ₂′ δ₁′#β₁′

  -- separate β₁ and β₂
  sep     : Separation β₁′ β₂′
  sep     = separateˡ β₁′ β₂′
  γ₁      = Separation.separator₁ sep
  γ₂      = Separation.separator₂ sep
  β₁″     = Separation.separated₁ sep
  β₂″     = Separation.separated₂ sep

  -- produce their disjoint union
  uni     = Disjoint→DisjointUnion (Separation.disjoint sep)
  β̇       = proj₁ (proj₂ uni)
  β₁″⊎β₂″ : DisjointUnion β₁″ β₂″ β̇
  β₁″⊎β₂″ = proj₂ (proj₂ uni)
  ι₁      = DisjointUnion-inj₁ β₁″⊎β₂″
  ι₂      = DisjointUnion-inj₂ β₁″⊎β₂″

  -- after separation, the FVs are still disjoint from the BVs.
  δ₁″     = ⊆-trans δ₂′ γ₁
  δ₂″     = ⊆-trans δ₂′ γ₂
  δ₁″≡δ₂″ : δ₁″ ≡ δ₂″
  δ₁″≡δ₂″ = equalize-separators δ₂′#β₁′ δ₂′#β₂′
  δ₁″#β₁″ : Disjoint δ₁″ β₁″
  δ₁″#β₁″ = weakenDisjoint γ₁ δ₂′#β₁′
  δ₂″#β₂″ : Disjoint δ₂″ β₂″
  δ₂″#β₂″ = weakenDisjoint γ₂ δ₂′#β₂′
  δ̇       = δ₂″
  δ₂″#β₁″ : Disjoint δ₂″ β₁″
  δ₂″#β₁″ = subst (λ □ → Disjoint □ β₁″) δ₁″≡δ₂″ δ₁″#β₁″
  δ̇#β̇     : Disjoint δ̇ β̇
  δ̇#β̇     = disjoint⇒disjoint-to-union δ₂″#β₁″ δ₂″#β₂″ β₁″⊎β₂″

  -- Combined weakening from Γᵢ to Γ
  γ₁′     = ⊆-trans ϕ₁ γ₁
  γ₂′     = ⊆-trans ϕ₂ γ₂

  -- Weakening and converting the first derivation.
  d₁′     : ⊆-trans δ₁ γ₁′ ⊢ f ~ ⊆-trans β₁ γ₁′ ▷ weakenBV γ₁′ t
  d₁′     = weaken~ γ₁′ d₁
  δ₁≤δ̇    : ⊆-trans δ₁ γ₁′ ≡ ⊆-trans δ₂′ γ₂
  δ₁≤δ̇    = begin
            ⊆-trans δ₁ γ₁′ ≡⟨ ⊆-trans-assoc ⟩
            ⊆-trans δ₁′ γ₁ ≡⟨ cong (λ □ → ⊆-trans □ γ₁) δ₁′≡δ₂′ ⟩
            ⊆-trans δ₂′ γ₁ ≡⟨⟩
            δ₁″            ≡⟨ δ₁″≡δ₂″ ⟩
            δ₂″            ≡⟨⟩
            δ̇              ∎
  β₁≤β₁″  : ⊆-trans β₁ γ₁′ ≡ β₁″
  β₁≤β₁″  = ⊆-trans-assoc
  d₁″     : δ̇ ⊢ f ~ β₁″ ▷ subst (λ □ → Tm □ _) β₁≤β₁″ (weakenBV γ₁′ t)
  d₁″     =  subst~ δ₁≤δ̇ β₁≤β₁″ refl d₁′

  -- Weakening and converting the second derivation.
  d₂′     : ⊆-trans δ₂ γ₂′ ⊢ e ~ ⊆-trans β₂ γ₂′ ▷ weakenBV γ₂′ u
  d₂′     = weaken~ γ₂′ d₂
  β₂≤β₂″  : ⊆-trans β₂ γ₂′ ≡ β₂″
  β₂≤β₂″  = ⊆-trans-assoc
  δ₂≤δ̇    : ⊆-trans δ₂ γ₂′ ≡ δ̇
  δ₂≤δ̇    = ⊆-trans-assoc
  d₂″     : δ̇ ⊢ e ~ β₂″ ▷ subst (λ □ → Tm □ _) β₂≤β₂″ (weakenBV γ₂′ u)
  d₂″     = subst~ δ₂≤δ̇ β₂≤β₂″ refl d₂′


{-# OPTIONS --without-K --safe #-}
module Cats.Category.Setoids.Facts where

open import Cats.Category.Setoids.Facts.Exponential public using
  (hasExponentials)
open import Cats.Category.Setoids.Facts.Initial public using
  (hasInitial)
open import Cats.Category.Setoids.Facts.Limit public using
  (complete)
open import Cats.Category.Setoids.Facts.Product public using
  (hasProducts ; hasBinaryProducts ; hasFiniteProducts)
open import Cats.Category.Setoids.Facts.Terminal public using
  (hasTerminal)

open import Cats.Category
open import Cats.Category.Setoids using (Setoids)

instance
  isCCC : ∀ {l} → IsCCC (Setoids l l)
  isCCC = record {}


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

module Categories.Functor.Monoidal.Properties where

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

open import Categories.Category
open import Categories.Category.Monoidal
open import Categories.Category.Cartesian.Structure
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Properties
open import Categories.Functor.Cartesian
open import Categories.Functor.Monoidal
open import Categories.Functor.Monoidal.Braided as Braided
open import Categories.Functor.Monoidal.Symmetric as Symmetric
open import Categories.NaturalTransformation

import Categories.Object.Terminal as ⊤
import Categories.Object.Product as P
import Categories.Morphism as M
import Categories.Morphism.Reasoning as MR

private
  variable
    o o′ o″ ℓ ℓ′ ℓ″ e e′ e″ : Level

-- The identity functor is monoidal

module _ (C : MonoidalCategory o ℓ e) where
  private
    module C = MonoidalCategory C
    open C.HomReasoning
    open M C.U
    open MR C.U

  idF-IsStrongMonoidal : IsStrongMonoidalFunctor C C idF
  idF-IsStrongMonoidal = record
    { ε             = ≅.refl
    ; ⊗-homo        = record
      { F⇒G = record
        { η           = λ _ → C.id
        ; commute     = λ _ → id-comm-sym
        ; sym-commute = λ _ → id-comm
        }
      ; F⇐G = record
        { η           = λ _ → C.id
        ; commute     = λ _ → id-comm-sym
        ; sym-commute = λ _ → id-comm
        }
      ; iso = λ _ → record
        { isoˡ = C.identity²
        ; isoʳ = C.identity²
        }
      }
    ; associativity = begin
      C.associator.from C.∘ C.id C.∘ Functor.F₁ C.⊗ (C.id , C.id) ≈⟨ refl⟩∘⟨ elimʳ C.⊗.identity ⟩
      C.associator.from C.∘ C.id                                  ≈⟨ id-comm ⟩
      C.id C.∘ C.associator.from                                  ≈⟨ refl⟩∘⟨ introˡ C.⊗.identity ⟩
      C.id C.∘ Functor.F₁ C.⊗ (C.id , C.id) C.∘ C.associator.from ∎
    ; unitaryˡ      = elimʳ (elimʳ C.⊗.identity)
    ; unitaryʳ      = elimʳ (elimʳ C.⊗.identity)
    }

  idF-IsMonoidal : IsMonoidalFunctor C C idF
  idF-IsMonoidal = IsStrongMonoidalFunctor.isMonoidal idF-IsStrongMonoidal

  idF-StrongMonoidal : StrongMonoidalFunctor C C
  idF-StrongMonoidal = record { isStrongMonoidal = idF-IsStrongMonoidal }

  idF-Monoidal : MonoidalFunctor C C
  idF-Monoidal = record { isMonoidal = idF-IsMonoidal }

-- The identity functor is braided monoidal

module _ (C : BraidedMonoidalCategory o ℓ e) where
  open Braided

  idF-IsStrongBraidedMonoidal : Strong.IsBraidedMonoidalFunctor C C idF
  idF-IsStrongBraidedMonoidal = record
    { isStrongMonoidal = idF-IsStrongMonoidal monoidalCategory
    ; braiding-compat  = MR.id-comm U
    }
    where open BraidedMonoidalCategory C

  idF-IsBraidedMonoidal : Lax.IsBraidedMonoidalFunctor C C idF
  idF-IsBraidedMonoidal =
    Strong.IsBraidedMonoidalFunctor.isLaxBraidedMonoidal idF-IsStrongBraidedMonoidal

  idF-StrongBraidedMonoidal : Strong.BraidedMonoidalFunctor C C
  idF-StrongBraidedMonoidal = record { isBraidedMonoidal = idF-IsStrongBraidedMonoidal }

  idF-BraidedMonoidal : Lax.BraidedMonoidalFunctor C C
  idF-BraidedMonoidal = record { isBraidedMonoidal = idF-IsBraidedMonoidal }

-- The identity functor is symmetric monoidal

module _ (C : SymmetricMonoidalCategory o ℓ e) where
  open Symmetric
  open SymmetricMonoidalCategory C using (braidedMonoidalCategory)

  idF-StrongSymmetricMonoidal : Strong.SymmetricMonoidalFunctor C C
  idF-StrongSymmetricMonoidal = record
    { isBraidedMonoidal = idF-IsStrongBraidedMonoidal braidedMonoidalCategory }

  idF-SymmetricMonoidal : Lax.SymmetricMonoidalFunctor C C
  idF-SymmetricMonoidal = record
    { isBraidedMonoidal = idF-IsBraidedMonoidal braidedMonoidalCategory }

-- Functor composition preserves monoidality

module _ (A : MonoidalCategory o ℓ e) (B : MonoidalCategory o′ ℓ′ e′) (C : MonoidalCategory o″ ℓ″ e″) where
  private
    module A = MonoidalCategory A
    module B = MonoidalCategory B
    module C = MonoidalCategory C
    open P C.U
    open M C.U
    open C.HomReasoning
    open MR C.U

  ∘-IsMonoidal : ∀ {F : Functor A.U B.U} {G : Functor B.U C.U} →
                    IsMonoidalFunctor B C G → IsMonoidalFunctor A B F →
                    IsMonoidalFunctor A C (G ∘F F)
  ∘-IsMonoidal {F} {G} CG CF = record
    { ε             = G.₁ CF.ε C.∘ CG.ε
    ; ⊗-homo        = ntHelper record
      { η       = λ { (X , Y) → G.₁ (CF.⊗-homo.η (X , Y)) C.∘ CG.⊗-homo.η (F.F₀ X , F.F₀ Y) }
      ; commute = λ { (f , g) → begin
        (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ (G.₁ (F.₁ f) C.⊗₁ G.₁ (F.₁ g)) ≈⟨ C.assoc ⟩
        G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _ C.∘ (G.₁ (F.₁ f) C.⊗₁ G.₁ (F.₁ g))   ≈⟨ pushʳ (CG.⊗-homo.commute _) ⟩
        (G.₁ (CF.⊗-homo.η _) C.∘ G.₁ (F.₁ f B.⊗₁ F.₁ g)) C.∘ CG.⊗-homo.η _         ≈⟨ pushˡ ([ G ]-resp-square (CF.⊗-homo.commute _)) ⟩
        G.₁ (F.₁ (f A.⊗₁ g)) C.∘ G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _             ∎ }
      }
    ; associativity = begin
      G.₁ (F.₁ A.associator.from) C.∘ (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ ((G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.⊗₁ C.id)
        ≈⟨ refl⟩∘⟨ refl⟩∘⟨ (Functor.homomorphism (C.-⊗ _) ○ C.∘-resp-≈ˡ (C.⊗.F-resp-≈ (C.Equiv.refl , ⟺ G.identity))) ⟩
      G.₁ (F.₁ A.associator.from) C.∘ (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ (G.₁ (CF.⊗-homo.η _) C.⊗₁ G.₁ B.id) C.∘ (CG.⊗-homo.η _ C.⊗₁ C.id)
        ≈⟨ refl⟩∘⟨ center (CG.⊗-homo.commute _) ⟩
      G.₁ (F.₁ A.associator.from) C.∘ G.₁ (CF.⊗-homo.η _) C.∘ (G.₁ (CF.⊗-homo.η _ B.⊗₁ B.id) C.∘ CG.⊗-homo.η _) C.∘ (CG.⊗-homo.η _ C.⊗₁ C.id)
        ≈⟨ C.∘-resp-≈ʳ (center⁻¹ C.Equiv.refl C.Equiv.refl) ○ C.sym-assoc ⟩
      (G.₁ (F.₁ A.associator.from) C.∘ G.₁ (CF.⊗-homo.η _) C.∘ G.₁ (CF.⊗-homo.η _ B.⊗₁ B.id)) C.∘ CG.⊗-homo.η _ C.∘ (CG.⊗-homo.η _ C.⊗₁ C.id)
        ≈⟨ C.∘-resp-≈ʳ (⟺ G.homomorphism) ⟩∘⟨refl ⟩
      (G.₁ (F.₁ A.associator.from) C.∘ G.₁ (CF.⊗-homo.η _ B.∘ CF.⊗-homo.η _ B.⊗₁ B.id)) C.∘ CG.⊗-homo.η _ C.∘ (CG.⊗-homo.η _ C.⊗₁ C.id)
        ≈⟨ [ G ]-resp-square CF.associativity ⟩∘⟨refl ⟩
      (G.₁ (CF.⊗-homo.η _) C.∘ G.₁ ((B.id B.⊗₁ CF.⊗-homo.η _) B.∘ B.associator.from)) C.∘ CG.⊗-homo.η _ C.∘ (CG.⊗-homo.η _ C.⊗₁ C.id)
        ≈⟨ C.∘-resp-≈ʳ G.homomorphism ⟩∘⟨refl ⟩
      (G.₁ (CF.⊗-homo.η _) C.∘ G.₁ (B.id B.⊗₁ CF.⊗-homo.η _) C.∘ G.₁ B.associator.from) C.∘ CG.⊗-homo.η _ C.∘ (CG.⊗-homo.η _ C.⊗₁ C.id)
        ≈⟨ C.∘-resp-≈ˡ C.sym-assoc ○ C.assoc ⟩
      (G.₁ (CF.⊗-homo.η _) C.∘ G.₁ (B.id B.⊗₁ CF.⊗-homo.η _)) C.∘ G.₁ B.associator.from C.∘ CG.⊗-homo.η _ C.∘ (CG.⊗-homo.η _ C.⊗₁ C.id)
        ≈⟨ refl⟩∘⟨ CG.associativity ⟩
      (G.₁ (CF.⊗-homo.η _) C.∘ G.₁ (B.id B.⊗₁ CF.⊗-homo.η _)) C.∘ CG.⊗-homo.η _ C.∘ (C.id C.⊗₁ CG.⊗-homo.η _) C.∘ C.associator.from
        ≈⟨ center (CG.⊗-homo.sym-commute _) ⟩
      G.₁ (CF.⊗-homo.η _) C.∘ (CG.⊗-homo.η _ C.∘ (G.₁ B.id C.⊗₁ G.₁ (CF.⊗-homo.η _))) C.∘ (C.id C.⊗₁ CG.⊗-homo.η _) C.∘ C.associator.from
        ≈⟨ pull-first C.Equiv.refl ○ C.∘-resp-≈ʳ (C.∘-resp-≈ˡ (C.⊗.F-resp-≈ (G.identity , C.Equiv.refl))) ⟩
      (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ (C.id C.⊗₁ G.₁ (CF.⊗-homo.η _)) C.∘ (C.id C.⊗₁ CG.⊗-homo.η _) C.∘ C.associator.from
        ≈˘⟨ refl⟩∘⟨ pushˡ (Functor.homomorphism (_ C.⊗-)) ⟩
      (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ (C.id C.⊗₁ (G.F₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _)) C.∘ C.associator.from
        ∎
    ; unitaryˡ      = begin
      G.₁ (F.₁ A.unitorˡ.from) C.∘ (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ ((G.₁ CF.ε C.∘ CG.ε) C.⊗₁ C.id)
        ≈⟨ refl⟩∘⟨ refl⟩∘⟨ (Functor.homomorphism (C.-⊗ _) ○ C.∘-resp-≈ˡ (C.⊗.F-resp-≈ (C.Equiv.refl , ⟺ G.identity))) ⟩
      G.₁ (F.₁ A.unitorˡ.from) C.∘ (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ (G.₁ CF.ε C.⊗₁ G.₁ B.id) C.∘ (CG.ε C.⊗₁ C.id)
        ≈⟨ refl⟩∘⟨ center (CG.⊗-homo.commute _) ⟩
      G.₁ (F.₁ A.unitorˡ.from) C.∘ G.₁ (CF.⊗-homo.η _) C.∘ (G.₁ (CF.ε B.⊗₁ B.id) C.∘ CG.⊗-homo.η _) C.∘ (CG.ε C.⊗₁ C.id)
        ≈⟨ C.∘-resp-≈ʳ (center⁻¹ C.Equiv.refl C.Equiv.refl) ○ C.sym-assoc ⟩
      (G.₁ (F.₁ A.unitorˡ.from) C.∘ G.₁ (CF.⊗-homo.η _) C.∘ G.₁ (CF.ε B.⊗₁ B.id)) C.∘ CG.⊗-homo.η _ C.∘ (CG.ε C.⊗₁ C.id)
        ≈⟨ C.∘-resp-≈ʳ (⟺ G.homomorphism) ⟩∘⟨refl ⟩
      (G.₁ (F.₁ A.unitorˡ.from) C.∘ G.₁ (CF.⊗-homo.η _ B.∘ CF.ε B.⊗₁ B.id)) C.∘ CG.⊗-homo.η _ C.∘ (CG.ε C.⊗₁ C.id)
        ≈⟨ [ G ]-resp-∘ CF.unitaryˡ ⟩∘⟨refl ⟩
      G.₁ B.unitorˡ.from C.∘ CG.⊗-homo.η _ C.∘ (CG.ε C.⊗₁ C.id)
        ≈⟨ CG.unitaryˡ ⟩
      C.unitorˡ.from
        ∎
    ; unitaryʳ      = begin
      G.₁ (F.₁ A.unitorʳ.from) C.∘ (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ (C.id C.⊗₁ (G.₁ CF.ε C.∘ CG.ε))
        ≈⟨ (refl⟩∘⟨ refl⟩∘⟨ (Functor.homomorphism (_ C.⊗-) ○ C.∘-resp-≈ˡ (C.⊗.F-resp-≈ (⟺ G.identity , C.Equiv.refl)))) ⟩
      G.₁ (F.₁ A.unitorʳ.from) C.∘ (G.₁ (CF.⊗-homo.η _) C.∘ CG.⊗-homo.η _) C.∘ (G.₁ B.id C.⊗₁ G.₁ CF.ε) C.∘ (C.id C.⊗₁ CG.ε)
        ≈⟨ refl⟩∘⟨ center (CG.⊗-homo.commute _) ⟩
      G.₁ (F.₁ A.unitorʳ.from) C.∘ G.₁ (CF.⊗-homo.η _) C.∘ (G.₁ (B.id B.⊗₁ CF.ε) C.∘ CG.⊗-homo.η _) C.∘ (C.id C.⊗₁ CG.ε)
        ≈⟨ C.∘-resp-≈ʳ (center⁻¹ C.Equiv.refl C.Equiv.refl) ○ C.sym-assoc ⟩
      (G.₁ (F.₁ A.unitorʳ.from) C.∘ G.₁ (CF.⊗-homo.η _) C.∘ G.₁ (B.id B.⊗₁ CF.ε)) C.∘ CG.⊗-homo.η _ C.∘ (C.id C.⊗₁ CG.ε)
        ≈⟨ C.∘-resp-≈ʳ (⟺ G.homomorphism) ⟩∘⟨refl ⟩
      (G.₁ (F.₁ A.unitorʳ.from) C.∘ G.F₁ (CF.⊗-homo.η _ B.∘ (B.id B.⊗₁ CF.ε))) C.∘ CG.⊗-homo.η _ C.∘ (C.id C.⊗₁ CG.ε)
        ≈⟨ [ G ]-resp-∘ CF.unitaryʳ ⟩∘⟨refl ⟩
      G.F₁ B.unitorʳ.from C.∘ CG.⊗-homo.η _ C.∘ C.id C.⊗₁ CG.ε
        ≈⟨ CG.unitaryʳ ⟩
      C.unitorʳ.from
        ∎
    }
    where module F  = Functor F
          module G  = Functor G
          module CF = IsMonoidalFunctor CF
          module CG = IsMonoidalFunctor CG

  ∘-IsStrongMonoidal : ∀ {F : Functor A.U B.U} {G : Functor B.U C.U} →
                    IsStrongMonoidalFunctor B C G → IsStrongMonoidalFunctor A B F →
                    IsStrongMonoidalFunctor A C (G ∘F F)
  ∘-IsStrongMonoidal {F} {G} CG CF = record
    { ε             = ≅.trans CG.ε ([ G ]-resp-≅ CF.ε)
    ; ⊗-homo        = record
      { F⇒G = ∘.⊗-homo
      ; F⇐G = ntHelper record
        { η       = λ { (X , Y) → CG.⊗-homo.⇐.η (F.F₀ X , F.F₀ Y) C.∘ G.₁ (CF.⊗-homo.⇐.η (X , Y)) }
        ; commute = λ _ → pullʳ ([ G ]-resp-square (CF.⊗-homo.⇐.commute _)) ○ pullˡ (CG.⊗-homo.⇐.commute _) ○ C.assoc
        }
      ; iso = λ _ → record
        { isoˡ = cancelInner ([ G ]-resp-∘ (CF.⊗-homo.iso.isoˡ _) ○ G.identity) ○ CG.⊗-homo.iso.isoˡ _
        ; isoʳ = cancelInner (CG.⊗-homo.iso.isoʳ _) ○ [ G ]-resp-∘ (CF.⊗-homo.iso.isoʳ _) ○ G.identity
        }
      }
    ; associativity = ∘.associativity
    ; unitaryˡ      = ∘.unitaryˡ
    ; unitaryʳ      = ∘.unitaryʳ
    }
    where module F  = Functor F
          module G  = Functor G
          module CF = IsStrongMonoidalFunctor CF
          module CG = IsStrongMonoidalFunctor CG
          module ∘  = IsMonoidalFunctor (∘-IsMonoidal CG.isMonoidal CF.isMonoidal)

module _ {A : MonoidalCategory o ℓ e} {B : MonoidalCategory o′ ℓ′ e′} {C : MonoidalCategory o″ ℓ″ e″} where

    ∘-StrongMonoidal : StrongMonoidalFunctor B C → StrongMonoidalFunctor A B → StrongMonoidalFunctor A C
    ∘-StrongMonoidal G F = record { isStrongMonoidal = ∘-IsStrongMonoidal _ _ _ (StrongMonoidalFunctor.isStrongMonoidal G) (StrongMonoidalFunctor.isStrongMonoidal F) }

    ∘-Monoidal : MonoidalFunctor B C → MonoidalFunctor A B → MonoidalFunctor A C
    ∘-Monoidal G F = record { isMonoidal = ∘-IsMonoidal _ _ _ (MonoidalFunctor.isMonoidal G) (MonoidalFunctor.isMonoidal F) }

-- Functor composition preserves braided monoidality

module _ {A : BraidedMonoidalCategory o ℓ e}
         {B : BraidedMonoidalCategory o′ ℓ′ e′}
         {C : BraidedMonoidalCategory o″ ℓ″ e″} where

  private
    module A = BraidedMonoidalCategory A
    module B = BraidedMonoidalCategory B
    module C = BraidedMonoidalCategory C
  open Braided

  ∘-IsBraidedMonoidal : ∀ {G : Functor B.U C.U} {F : Functor A.U B.U} →
                        Lax.IsBraidedMonoidalFunctor B C G →
                        Lax.IsBraidedMonoidalFunctor A B F →
                        Lax.IsBraidedMonoidalFunctor A C (G ∘F F)
  ∘-IsBraidedMonoidal {G} {F} GB FB = record
    { isMonoidal      = ∘-IsMonoidal _ _ _ (isMonoidal GB) (isMonoidal FB)
    ; braiding-compat = begin
        G₁ (F₁ AB) ∘ G₁ FH ∘ GH   ≈˘⟨ pushˡ (homomorphism G) ⟩
        G₁ (F₁ AB B.∘ FH) ∘ GH    ≈⟨ F-resp-≈ G (braiding-compat FB) ⟩∘⟨refl ⟩
        G₁ (FH B.∘ BB) ∘ GH       ≈⟨ pushˡ (homomorphism G) ⟩
        G₁ FH ∘ G₁ BB ∘ GH        ≈⟨ pushʳ (braiding-compat GB) ⟩
        (G₁ FH ∘ GH) ∘ CB         ∎
    }
    where
      open C
      open HomReasoning
      open MR C.U
      open Functor hiding (F₁)
      open Functor F using (F₁)
      open Functor G using () renaming (F₁ to G₁)
      open Lax.IsBraidedMonoidalFunctor

      FH  = λ {X Y} → ⊗-homo.η FB (X , Y)
      GH  = λ {X Y} → ⊗-homo.η GB (X , Y)
      AB = λ {X Y} → A.braiding.⇒.η (X , Y)
      BB = λ {X Y} → B.braiding.⇒.η (X , Y)
      CB = λ {X Y} → C.braiding.⇒.η (X , Y)

  ∘-IsStrongBraidedMonoidal : ∀ {G : Functor B.U C.U} {F : Functor A.U B.U} →
                              Strong.IsBraidedMonoidalFunctor B C G →
                              Strong.IsBraidedMonoidalFunctor A B F →
                              Strong.IsBraidedMonoidalFunctor A C (G ∘F F)
  ∘-IsStrongBraidedMonoidal {G} {F} GB FB = record
    { isStrongMonoidal =
      ∘-IsStrongMonoidal _ _ _ (isStrongMonoidal GB) (isStrongMonoidal FB)
    ; braiding-compat =
      Lax.IsBraidedMonoidalFunctor.braiding-compat
        (∘-IsBraidedMonoidal (isLaxBraidedMonoidal GB) (isLaxBraidedMonoidal FB))
    }
    where open Strong.IsBraidedMonoidalFunctor

  ∘-BraidedMonoidal : Lax.BraidedMonoidalFunctor B C →
                      Lax.BraidedMonoidalFunctor A B →
                      Lax.BraidedMonoidalFunctor A C
  ∘-BraidedMonoidal G F = record
    { isBraidedMonoidal =
      ∘-IsBraidedMonoidal (isBraidedMonoidal G) (isBraidedMonoidal F)
    }
    where open Lax.BraidedMonoidalFunctor hiding (F)

  ∘-StrongBraidedMonoidal : Strong.BraidedMonoidalFunctor B C →
                            Strong.BraidedMonoidalFunctor A B →
                            Strong.BraidedMonoidalFunctor A C
  ∘-StrongBraidedMonoidal G F = record
    { isBraidedMonoidal =
      ∘-IsStrongBraidedMonoidal (isBraidedMonoidal G) (isBraidedMonoidal F)
    }
    where open Strong.BraidedMonoidalFunctor hiding (F)

-- Functor composition preserves symmetric monoidality

module _ {A : SymmetricMonoidalCategory o ℓ e}
         {B : SymmetricMonoidalCategory o′ ℓ′ e′}
         {C : SymmetricMonoidalCategory o″ ℓ″ e″} where
  open Symmetric

  ∘-SymmetricMonoidal : Lax.SymmetricMonoidalFunctor B C →
                        Lax.SymmetricMonoidalFunctor A B →
                        Lax.SymmetricMonoidalFunctor A C
  ∘-SymmetricMonoidal G F = record
    { isBraidedMonoidal =
      ∘-IsBraidedMonoidal (isBraidedMonoidal G) (isBraidedMonoidal F)
    }
    where open Lax.SymmetricMonoidalFunctor hiding (F)

  ∘-StrongSymmetricMonoidal : Strong.SymmetricMonoidalFunctor B C →
                              Strong.SymmetricMonoidalFunctor A B →
                              Strong.SymmetricMonoidalFunctor A C
  ∘-StrongSymmetricMonoidal G F = record
    { isBraidedMonoidal =
      ∘-IsStrongBraidedMonoidal (isBraidedMonoidal G) (isBraidedMonoidal F)
    }
    where open Strong.SymmetricMonoidalFunctor hiding (F)

module _ (C : CartesianCategory o ℓ e) (D : CartesianCategory o′ ℓ′ e′) where
  private
    module C = CartesianCategory C
    module D = CartesianCategory D
    open D.HomReasoning
    open MR D.U

  module _ (F : StrongMonoidalFunctor C.monoidalCategory D.monoidalCategory) where
    private
      module F = StrongMonoidalFunctor F

      F-resp-⊤ : ⊤.IsTerminal D.U (F.F₀ C.⊤)
      F-resp-⊤ = ⊤.Terminal.⊤-is-terminal (⊤.transport-by-iso D.U D.terminal F.ε)
      module F-resp-⊤ = ⊤.IsTerminal F-resp-⊤

      lemma₁ : ∀ {X} → F.ε.from D.∘ D.! {F.₀ X} D.≈ F.₁ (C.! {X})
      lemma₁ = F-resp-⊤.!-unique _

      π₁-comm : ∀ {X Y} → F.F₁ C.π₁ D.∘ F.⊗-homo.⇒.η (X , Y) D.≈ D.π₁
      π₁-comm {X} {Y} = begin
        F.F₁ C.π₁ D.∘ F.⊗-homo.⇒.η (X , Y)                                                ≈˘⟨ [ F.F ]-resp-∘ (C.Equiv.trans C.project₁ C.identityˡ) ⟩∘⟨refl ⟩
        (F.F₁ C.π₁ D.∘ F.F₁ (C.id C.⁂ C.!)) D.∘ F.⊗-homo.⇒.η (X , Y)                      ≈⟨ pullʳ (F.⊗-homo.⇒.sym-commute _) ⟩
        F.F₁ C.π₁ D.∘ F.⊗-homo.⇒.η (X , C.⊤) D.∘ (F.F₁ C.id D.⁂ F.F₁ C.!)                 ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ ([ F.₀ X D.×- ]-resp-∘ lemma₁ ○ Functor.F-resp-≈ D.-×- (⟺ F.identity , D.Equiv.refl)) ⟩
        F.F₁ C.π₁ D.∘ F.⊗-homo.⇒.η (X , C.⊤) D.∘ (D.id D.⁂ F.ε.from) D.∘ (D.id D.⁂ D.!)   ≈⟨ D.∘-resp-≈ʳ D.sym-assoc ○ D.sym-assoc ⟩
        (F.F₁ C.π₁ D.∘ F.⊗-homo.⇒.η (X , C.⊤) D.∘ (D.id D.⁂ F.ε.from)) D.∘ (D.id D.⁂ D.!) ≈⟨ F.unitaryʳ ⟩∘⟨refl ⟩
        D.π₁ D.∘ (D.id D.⁂ D.!)                                                           ≈⟨ D.project₁ ○ D.identityˡ ⟩
        D.π₁                                                                              ∎

      π₂-comm : ∀ {X Y} → F.F₁ C.π₂ D.∘ F.⊗-homo.⇒.η (X , Y) D.≈ D.π₂
      π₂-comm {X} {Y} = begin
        F.F₁ C.π₂ D.∘ F.⊗-homo.⇒.η (X , Y)                                                ≈˘⟨ [ F.F ]-resp-∘ (C.Equiv.trans C.project₂ C.identityˡ) ⟩∘⟨refl ⟩
        (F.F₁ C.π₂ D.∘ F.F₁ (C.! C.⁂ C.id)) D.∘ F.⊗-homo.⇒.η (X , Y)                      ≈⟨ pullʳ (F.⊗-homo.⇒.sym-commute _) ⟩
        F.F₁ C.π₂ D.∘ F.⊗-homo.⇒.η (C.⊤ , Y) D.∘ (F.F₁ C.! D.⁂ F.F₁ C.id)                 ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ ([ D.-× F.₀ Y ]-resp-∘ lemma₁ ○ Functor.F-resp-≈ D.-×- (D.Equiv.refl , ⟺ F.identity)) ⟩
        F.F₁ C.π₂ D.∘ F.⊗-homo.⇒.η (C.⊤ , Y) D.∘ (F.ε.from D.⁂ D.id) D.∘ (D.! D.⁂ D.id)   ≈⟨ D.∘-resp-≈ʳ D.sym-assoc ○ D.sym-assoc ⟩
        (F.F₁ C.π₂ D.∘ F.⊗-homo.⇒.η (C.⊤ , Y) D.∘ (F.ε.from D.⁂ D.id)) D.∘ (D.! D.⁂ D.id) ≈⟨ F.unitaryˡ ⟩∘⟨refl ⟩
        D.π₂ D.∘ (D.! D.⁂ D.id)                                                           ≈⟨ D.project₂ ○ D.identityˡ ⟩
        D.π₂                                                                              ∎

      unique : ∀ {X A B} {h : X D.⇒ F.₀ (A C.× B)} {i : X D.⇒ F.₀ A} {j : X D.⇒ F.₀ B} →
                 F.₁ C.π₁ D.∘ h D.≈ i →
                 F.₁ C.π₂ D.∘ h D.≈ j →
                 F.⊗-homo.⇒.η (A , B) D.∘ D.product.⟨ i , j ⟩ D.≈ h
      unique  eq₁ eq₂ = ⟺ (switch-tofromˡ F.⊗-homo.FX≅GX (⟺ (D.unique (pullˡ (⟺ (switch-fromtoʳ F.⊗-homo.FX≅GX π₁-comm)) ○ eq₁)
                                                                      (pullˡ (⟺ (switch-fromtoʳ F.⊗-homo.FX≅GX π₂-comm)) ○ eq₂))))

    StrongMonoidal⇒Cartesian : CartesianF C D
    StrongMonoidal⇒Cartesian = record
      { F           = F.F
      ; isCartesian = record
        { F-resp-⊤ = F-resp-⊤
        ; F-resp-× = λ {A B} → record
          { ⟨_,_⟩    = λ f g → F.⊗-homo.⇒.η _ D.∘ D.⟨ f , g ⟩
          ; project₁ = λ {_ h i} → begin
            F.₁ C.π₁ D.∘ F.⊗-homo.⇒.η _ D.∘ D.⟨ h , i ⟩ ≈⟨ pullˡ π₁-comm ⟩
            D.π₁ D.∘ D.product.⟨ h , i ⟩                ≈⟨ D.project₁ ⟩
            h                                           ∎
          ; project₂ = λ {_ h i} → begin
            F.₁ C.π₂ D.∘ F.⊗-homo.⇒.η _ D.∘ D.⟨ h , i ⟩ ≈⟨ pullˡ π₂-comm ⟩
            D.π₂ D.∘ D.⟨ h , i ⟩                        ≈⟨ D.project₂ ⟩
            i                                           ∎
          ; unique   = unique
          }
        }
      }


module PatternSynonymImports where

open import PatternSynonyms renaming (z to zzz)

pattern myzero = zzz
two = ss zzz

list : List ℕ
list = 1 ∷ []


-- Define the integers as a HIT by identifying +0 and -0
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Ints.QuoInt.Base where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Relation.Nullary

open import Cubical.Data.Int as Int using (Int; sucInt; predInt; discreteInt; isSetInt)
open import Cubical.Data.Nat as ℕ using (ℕ; zero; suc)
open import Cubical.Data.Bool as Bool using (Bool; not; notnot)

variable
  l : Level

Sign : Type₀
Sign = Bool

pattern spos = Bool.false
pattern sneg = Bool.true

_·S_ : Sign → Sign → Sign
_·S_ = Bool._⊕_

data ℤ : Type₀ where
  signed : (s : Sign) (n : ℕ) → ℤ
  posneg : signed spos 0 ≡ signed sneg 0

pattern pos n = signed spos n
pattern neg n = signed sneg n

sign : ℤ → Sign
sign (signed _ zero) = spos
sign (signed s (suc _)) = s
sign (posneg i) = spos

sign-pos : ∀ n → sign (pos n) ≡ spos
sign-pos zero = refl
sign-pos (suc n) = refl

abs : ℤ → ℕ
abs (signed _ n) = n
abs (posneg i) = zero

signed-inv : ∀ n → signed (sign n) (abs n) ≡ n
signed-inv (pos zero) = refl
signed-inv (neg zero) = posneg
signed-inv (signed s (suc n)) = refl
signed-inv (posneg i) j = posneg (i ∧ j)

signed-zero : ∀ s₁ s₂ → signed s₁ zero ≡ signed s₂ zero
signed-zero spos spos = refl
signed-zero sneg sneg = refl
signed-zero spos sneg = posneg
signed-zero sneg spos = sym posneg

rec : ∀ {A : Type l} → (pos' neg' : ℕ → A) → pos' 0 ≡ neg' 0 → ℤ → A
rec pos' neg' eq (pos m)    = pos' m
rec pos' neg' eq (neg m)    = neg' m
rec pos' neg' eq (posneg i) = eq i

elim : ∀ (P : ℤ → Type l)
       → (pos' : ∀ n → P (pos n))
       → (neg' : ∀ n → P (neg n))
       → (λ i → P (posneg i)) [ pos' 0 ≡ neg' 0 ]
       → ∀ z → P z
elim P pos' neg' eq (pos n) = pos' n
elim P pos' neg' eq (neg n) = neg' n
elim P pos' neg' eq (posneg i) = eq i

Int→ℤ : Int → ℤ
Int→ℤ (Int.pos n) = pos n
Int→ℤ (Int.negsuc n) = neg (suc n)

ℤ→Int : ℤ → Int
ℤ→Int (pos n) = Int.pos n
ℤ→Int (neg zero) = Int.pos 0
ℤ→Int (neg (suc n)) = Int.negsuc n
ℤ→Int (posneg _) = Int.pos 0

ℤ→Int→ℤ : ∀ (n : ℤ) → Int→ℤ (ℤ→Int n) ≡ n
ℤ→Int→ℤ (pos n) _       = pos n
ℤ→Int→ℤ (neg zero) i    = posneg i
ℤ→Int→ℤ (neg (suc n)) _ = neg (suc n)
ℤ→Int→ℤ (posneg j) i    = posneg (j ∧ i)

Int→ℤ→Int : ∀ (n : Int) → ℤ→Int (Int→ℤ n) ≡ n
Int→ℤ→Int (Int.pos n) _ = Int.pos n
Int→ℤ→Int (Int.negsuc n) _ = Int.negsuc n

Int≡ℤ : Int ≡ ℤ
Int≡ℤ = isoToPath (iso Int→ℤ ℤ→Int ℤ→Int→ℤ Int→ℤ→Int)

discreteℤ : Discrete ℤ
discreteℤ = subst Discrete Int≡ℤ discreteInt

isSetℤ : isSet ℤ
isSetℤ = subst isSet Int≡ℤ isSetInt

-_ : ℤ → ℤ
- signed s n = signed (not s) n
- posneg i   = posneg (~ i)

negate-invol : ∀ n → - - n ≡ n
negate-invol (signed s n) i = signed (notnot s i) n
negate-invol (posneg i)   _ = posneg i

negateEquiv : ℤ ≃ ℤ
negateEquiv = isoToEquiv (iso -_ -_ negate-invol negate-invol)

negateEq : ℤ ≡ ℤ
negateEq = ua negateEquiv

infixl 6 _+_
infixl 7 _·_

sucℤ : ℤ → ℤ
sucℤ (pos n)       = pos (suc n)
sucℤ (neg zero)    = pos 1
sucℤ (neg (suc n)) = neg n
sucℤ (posneg _)    = pos 1

predℤ : ℤ → ℤ
predℤ = subst (λ Z → (Z → Z)) negateEq sucℤ
  -- definitionally equal to λ n → - (sucℤ (- n))
  -- strictly more useful than the direct pattern matching version,
  --  see negateSuc and negatePred

sucPredℤ : ∀ n → sucℤ (predℤ n) ≡ n
sucPredℤ (pos zero)    = sym posneg
sucPredℤ (pos (suc _)) = refl
sucPredℤ (neg _)       = refl
sucPredℤ (posneg i) j  = posneg (i ∨ ~ j)

predSucℤ : ∀ n → predℤ (sucℤ n) ≡ n
predSucℤ (pos _)       = refl
predSucℤ (neg zero)    = posneg
predSucℤ (neg (suc _)) = refl
predSucℤ (posneg i) j  = posneg (i ∧ j)

_+_ : ℤ → ℤ → ℤ
(signed _ zero) + n = n
(posneg _)      + n = n
(pos (suc m))   + n = sucℤ  (pos m + n)
(neg (suc m))   + n = predℤ (neg m + n)

sucPathℤ : ℤ ≡ ℤ
sucPathℤ  = isoToPath (iso sucℤ predℤ sucPredℤ predSucℤ)

-- We do the same trick as in Cubical.Data.Int to prove that addition
-- is an equivalence
addEqℤ : ℕ → ℤ ≡ ℤ
addEqℤ zero    = refl
addEqℤ (suc n) = addEqℤ n ∙ sucPathℤ

predPathℤ : ℤ ≡ ℤ
predPathℤ = isoToPath (iso predℤ sucℤ predSucℤ sucPredℤ)

subEqℤ : ℕ → ℤ ≡ ℤ
subEqℤ zero    = refl
subEqℤ (suc n) = subEqℤ n ∙ predPathℤ

addℤ : ℤ → ℤ → ℤ
addℤ (pos m) n    = transport (addEqℤ m) n
addℤ (neg m) n    = transport (subEqℤ m) n
addℤ (posneg _) n = n

isEquivAddℤ : (m : ℤ) → isEquiv (addℤ m)
isEquivAddℤ (pos n)    = isEquivTransport (addEqℤ n)
isEquivAddℤ (neg n)    = isEquivTransport (subEqℤ n)
isEquivAddℤ (posneg _) = isEquivTransport refl

addℤ≡+ℤ : addℤ ≡ _+_
addℤ≡+ℤ i  (pos (suc m)) n = sucℤ   (addℤ≡+ℤ i (pos m) n)
addℤ≡+ℤ i  (neg (suc m)) n = predℤ  (addℤ≡+ℤ i (neg m) n)
addℤ≡+ℤ i  (pos zero) n    = n
addℤ≡+ℤ i  (neg zero) n    = n
addℤ≡+ℤ _  (posneg _) n    = n

isEquiv+ℤ : (m : ℤ) → isEquiv (m +_)
isEquiv+ℤ = subst (λ _+_ → (m : ℤ) → isEquiv (m +_)) addℤ≡+ℤ isEquivAddℤ

_·_ : ℤ → ℤ → ℤ
m · n = signed (sign m ·S sign n) (abs m ℕ.· abs n)

private
  ·-abs : ∀ m n → abs (m · n) ≡ abs m ℕ.· abs n
  ·-abs m n = refl

-- Natural number and negative integer literals for ℤ

open import Cubical.Data.Nat.Literals public

instance
  fromNatℤ : HasFromNat ℤ
  fromNatℤ = record { Constraint = λ _ → Unit ; fromNat = λ n → pos n }

instance
  fromNegℤ : HasFromNeg ℤ
  fromNegℤ = record { Constraint = λ _ → Unit ; fromNeg = λ n → neg n }


-- Andreas, 2014-06-12  This feature has been addressed by issue 907

{-# OPTIONS --copatterns #-}

module CopatternsToRHS where

import Common.Level
open import Common.Equality
open import Common.Prelude using (Bool; true; false)

record R (A : Set) : Set where
  constructor mkR
  field
    fst : A → A
    snd : Bool
open R

someR : {A : Set} → R A
fst someR x = x
snd someR = true

-- This already behaves like:

someR' : {A : Set} → R A
fst someR' = λ x → x
snd someR' = true

-- We translate it to:

someR″ : {A : Set} → R A
someR″ = mkR (λ x → x) true

data C {A : Set} : R A → Set where
   c : ∀ f b → C (mkR f b)

works : {A : Set} → C {A} someR″ → Set₁
works (c .(λ x → x) .true) = Set

test : {A : Set} → C {A} someR → Set₁
test (c .(λ x → x) .true) = Set


module Class.Monad.Except where

open import Class.Monad
open import Class.Monoid
open import Data.Maybe
open import Level

private
  variable
    a : Level
    A : Set a

record MonadExcept (M : Set a → Set a) {{_ : Monad M}} (E : Set a) : Set (suc a) where
  field
    throwError : E → M A
    catchError : M A → (E → M A) → M A

  appendIfError : {{_ : Monoid E}} → M A → E → M A
  appendIfError x s = catchError x λ e → throwError (e + s)

  maybeToError : Maybe A → E → M A
  maybeToError (just x) e = return x
  maybeToError nothing e = throwError e

  tryElse : M A → M A → M A
  tryElse x y = catchError x λ _ → y

open MonadExcept {{...}} public


-- Andreas, 2017-03-08
-- Impredicative data types are incompatible with structural recursion
-- (Coquand, Pattern Matching with Dependent Types, 1992)

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

data ⊥ : Set where

-- An impredicative data type

data D : Set where
  c : (f : (A : Set) → A → A) → D

-- Structural recursion with  f args < c f  is no longer valid.
-- We should not be able to demonstrated that D is empty.

empty : D → ⊥
empty (c f) = empty (f D (c f))

-- This gets us to absurdity quickly:

inhabited : D
inhabited = c λ A x → x

absurd : ⊥
absurd = empty inhabited


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

open import HoTT

module groups.Pointed where

infix 60 ⊙[_,_]ᴳˢ ⊙[_,_]ᴳ

record ⊙GroupStructure {i : ULevel} (GEl : Type i) : Type (lsucc i) where
  constructor ⊙[_,_]ᴳˢ
  field
    de⊙ᴳˢ : GroupStructure GEl
    ptᴳˢ : GEl
  open GroupStructure de⊙ᴳˢ public
open ⊙GroupStructure using (de⊙ᴳˢ; ptᴳˢ) public

record ⊙Group (i : ULevel) : Type (lsucc i) where
  constructor ⊙[_,_]ᴳ
  field
    de⊙ᴳ : Group i
    ptᴳ : Group.El de⊙ᴳ
  open Group de⊙ᴳ public
  ⊙exp = Group.exp de⊙ᴳ ptᴳ
open ⊙Group using (de⊙ᴳ; ptᴳ) public

⊙Group₀ = ⊙Group lzero

infix 0 _⊙→ᴳ_
_⊙→ᴳ_ : ∀ {i j} → ⊙Group i → ⊙Group j → Type (lmax i j)
⊙G ⊙→ᴳ ⊙H = Σ (de⊙ᴳ ⊙G →ᴳ de⊙ᴳ ⊙H) (λ φ → GroupHom.f φ (ptᴳ ⊙G) == ptᴳ ⊙H)

infix 30 _⊙≃ᴳ_
_⊙≃ᴳ_ : ∀ {i j} → ⊙Group i → ⊙Group j → Type (lmax i j)
⊙G ⊙≃ᴳ ⊙H = Σ (de⊙ᴳ ⊙G ≃ᴳ de⊙ᴳ ⊙H) (λ φ → GroupIso.f φ (ptᴳ ⊙G) == ptᴳ ⊙H)

infixl 120 _⊙⁻¹ᴳ
_⊙⁻¹ᴳ : ∀ {i j} {⊙G : ⊙Group i} {⊙H : ⊙Group j} → ⊙G ⊙≃ᴳ ⊙H → ⊙H ⊙≃ᴳ ⊙G
_⊙⁻¹ᴳ (iso , iic) = iso ⁻¹ᴳ , ! (equiv-adj (GroupIso.f-equiv iso) iic)

⊙exp-hom : ∀ {i} (⊙G : ⊙Group i)
  → ⊙[ ℤ-group , 1 ]ᴳ ⊙→ᴳ ⊙G
⊙exp-hom ⊙[ G , pt ]ᴳ = exp-hom G pt , idp

is-struct-infinite-cyclic : ∀ {i} {El : Type i} → ⊙GroupStructure El → Type i
is-struct-infinite-cyclic ⊙[ G , g ]ᴳˢ = is-equiv (GroupStructure.exp G g)

is-infinite-cyclic : ∀ {i} → ⊙Group i → Type i
is-infinite-cyclic ⊙[ G , g ]ᴳ =
  is-struct-infinite-cyclic ⊙[ Group.group-struct G , g ]ᴳˢ

isomorphism-preserves-infinite-cyclic : ∀ {i j}
  → {⊙G : ⊙Group i} {⊙H : ⊙Group j} → ⊙G ⊙≃ᴳ ⊙H
  → is-infinite-cyclic ⊙G
  → is-infinite-cyclic ⊙H
isomorphism-preserves-infinite-cyclic
  {⊙G = ⊙[ G , g ]ᴳ} {⊙H = ⊙[ H , h ]ᴳ} (iso , pres-pt) ⊙G-iic =
  is-eq _ (is-equiv.g ⊙G-iic ∘ GroupIso.g iso) to-from from-to
  where
    abstract
      lemma : Group.exp H h ∼ GroupIso.f iso ∘ Group.exp G g
      lemma i = ! $
        GroupIso.f iso (Group.exp G g i)
          =⟨ GroupIso.pres-exp iso g i ⟩
        Group.exp H (GroupIso.f iso g) i
          =⟨ ap (λ x → Group.exp H x i) pres-pt ⟩
        Group.exp H h i
          =∎

      to-from : ∀ x → Group.exp H h (is-equiv.g ⊙G-iic (GroupIso.g iso x)) == x
      to-from x =
        Group.exp H h (is-equiv.g ⊙G-iic (GroupIso.g iso x))
          =⟨ lemma (is-equiv.g ⊙G-iic (GroupIso.g iso x)) ⟩
        GroupIso.f iso (Group.exp G g (is-equiv.g ⊙G-iic (GroupIso.g iso x)))
          =⟨ ap (GroupIso.f iso) (is-equiv.f-g ⊙G-iic (GroupIso.g iso x)) ⟩
        GroupIso.f iso (GroupIso.g iso x)
          =⟨ GroupIso.f-g iso x ⟩
        x
          =∎

      from-to : ∀ i → is-equiv.g ⊙G-iic (GroupIso.g iso (Group.exp H h i)) == i
      from-to i =
        is-equiv.g ⊙G-iic (GroupIso.g iso (Group.exp H h i))
          =⟨ ap (is-equiv.g ⊙G-iic ∘ GroupIso.g iso) (lemma i) ⟩
        is-equiv.g ⊙G-iic (GroupIso.g iso (GroupIso.f iso (Group.exp G g i)))
          =⟨ ap (is-equiv.g ⊙G-iic) (GroupIso.g-f iso (Group.exp G g i)) ⟩
        is-equiv.g ⊙G-iic (Group.exp G g i)
          =⟨ is-equiv.g-f ⊙G-iic i ⟩
        i
          =∎

isomorphism-preserves'-infinite-cyclic : ∀ {i j}
  → {⊙G : ⊙Group i} {⊙H : ⊙Group j} → ⊙G ⊙≃ᴳ ⊙H
  → is-infinite-cyclic ⊙H
  → is-infinite-cyclic ⊙G
isomorphism-preserves'-infinite-cyclic iso iic =
  isomorphism-preserves-infinite-cyclic (iso ⊙⁻¹ᴳ) iic


------------------------------------------------------------------------
-- Code related to the paper "Logical properties of a modality for
-- erasure"
--
-- Nils Anders Danielsson
------------------------------------------------------------------------

-- Note that the code does not follow the paper exactly. For instance,
-- some definitions use bijections (functions with quasi-inverses)
-- instead of equivalences. Some other differences are mentioned
-- below.

-- This file is not checked using --safe, because some parts use
-- --cubical, and some parts use --with-K. However, all files
-- imported below use --safe.

{-# OPTIONS --cubical --with-K #-}

module README.Erased where

import Agda.Builtin.Equality
import Agda.Builtin.Cubical.Id
import Agda.Builtin.Cubical.Path

import Embedding
import Equality
import Equality.Id
import Equality.Instances-related
import Equality.Path
import Equality.Propositional
import Equivalence
import Erased
import Erased.Cubical
import Erased.With-K
import Function-universe
import H-level
import Nat.Wrapper
import Nat.Wrapper.Cubical
import Prelude
import Queue.Truncated
import Quotient

------------------------------------------------------------------------
-- 3: Erased

-- Erased.

Erased = Erased.Erased

------------------------------------------------------------------------
-- 3.1: Erased is a monad

-- Bind.

bind = Erased._>>=′_

-- Erased is a monad.

erased-monad = Erased.monad

-- Lemma 3.

Lemma-3 = Erased.Erased-Erased↔Erased

------------------------------------------------------------------------
-- 3.2: The relationship between @0 and Erased

-- Lemma 4 and Lemma 5.

Lemmas-4-and-5 = Erased.Π-Erased≃Π0[]

-- The equality type family, defined as an inductive family.

Equality-defined-as-an-inductive-family = Agda.Builtin.Equality._≡_

-- Cubical Agda paths.

Path = Agda.Builtin.Cubical.Path._≡_

-- The Cubical Agda identity type family.

Id = Agda.Builtin.Cubical.Id.Id

-- The code uses an axiomatisation of "equality with J". The
-- axiomatisation is a little convoluted in order to support using
-- equality at all universe levels. Furthermore the axiomatisation
-- supports choosing specific definitions for other functions, like
-- cong, to make the code more usable when it is instantiated with
-- Cubical Agda paths (for which the canonical definition of cong
-- computes in a different way than typical definitions obtained
-- using J).

-- Equality and reflexivity.

≡-refl = Equality.Reflexive-relation

-- The J rule and its computation rule.

J-J-refl = Equality.Equality-with-J₀

-- Extended variants of the two definitions above.

Equivalence-relation⁺ = Equality.Equivalence-relation⁺
Equality-with-J       = Equality.Equality-with-J

-- To see how the code is axiomatised, see the module header of, say,
-- Erased.

module See-the-module-header-of = Erased

-- The equality type family defined as an inductive family, Cubical
-- Agda paths and the Cubical Agda identity type family can all be
-- used to instantiate the axioms.

Equality-with-J-for-equality-defined-as-an-inductive-family =
  Equality.Propositional.equality-with-J
Equality-with-J-for-Path = Equality.Path.equality-with-J
Equality-with-J-for-Id   = Equality.Id.equality-with-J

-- Lemma 7 in Cubical Agda.

Lemma-7-cubical = Erased.Cubical.Π-Erased≃Π0[]

-- Lemma 7 in traditional Agda.

Lemma-7-traditional = Erased.With-K.Π-Erased≃Π0[]

------------------------------------------------------------------------
-- 3.3: Erased commutes

-- Some lemmas.

Lemma-8  = Erased.Erased-⊤↔⊤
Lemma-9  = Erased.Erased-⊥↔⊥
Lemma-10 = Erased.Erased-Π↔Π
Lemma-11 = Erased.Erased-Π↔Π-Erased
Lemma-12 = Erased.Erased-Σ↔Σ

-- W-types.

W = Prelude.W

-- Lemma 14 (Erased commutes with W-types up to logical equivalence).

Lemma-14 = Erased.Erased-W⇔W

-- Erased commutes with W-types, assuming extensionality for functions
-- and []-cong.
--
-- The code uses a universe of "function formers" which makes it
-- possible to prove a single statement that can be instantiated both
-- as a logical equivalence that does not rely on extensionality, as
-- well as an equivalence that does rely on extensionality (and in
-- other ways). This lemma, and several others, are stated in that
-- way.

Lemma-14′ = Erased.Erased-W↔W

------------------------------------------------------------------------
-- 3.4: The []-cong property

-- []-cong, proved in traditional Agda.

[]-cong-traditional = Erased.With-K.[]-cong

-- []-cong, proved in Cubical Agda for paths.

[]-cong-cubical-paths = Erased.Cubical.[]-cong-Path

-- Every family of equality types satisfying the axiomatisation
-- discussed above is in pointwise bijective correspondence with every
-- other, with the bijections mapping reflexivity to reflexivity.

Families-equivalent =
  Equality.Instances-related.all-equality-types-isomorphic

-- []-cong, proved in Cubical Agda for an arbitrary equality type
-- family satisfying the axiomatisation discussed above.

[]-cong-cubical = Erased.Cubical.[]-cong

-- Lemmas 17 and 18 in traditional Agda.

Lemma-17-traditional = Erased.With-K.[]-cong-equivalence
Lemma-18-traditional = Erased.With-K.[]-cong-[refl]

-- Lemmas 17 and 18 in Cubical Agda, with paths.

Lemma-17-cubical-paths = Erased.Cubical.[]-cong-Path-equivalence
Lemma-18-cubical-paths = Erased.Cubical.[]-cong-Path-[refl]

-- Lemmas 17 and 18 in Cubical Agda, with an arbitrary family of
-- equality types satisfying the axiomatisation discussed above.

Lemma-17-cubical = Erased.Cubical.[]-cong-equivalence
Lemma-18-cubical = Erased.Cubical.[]-cong-[refl]

------------------------------------------------------------------------
-- 3.5: H-levels

-- H-level, For-iterated-equality and Contractible.

H-level               = H-level.H-level′
For-iterated-equality = H-level.For-iterated-equality
Contractible          = Equality.Reflexive-relation′.Contractible

-- Sometimes the code uses the following definition of h-levels
-- instead of the one used in the paper.

Other-definition-of-h-levels = H-level.H-level

-- The two definitions are pointwise logically equivalent, and
-- pointwise equivalent if equality is extensional for functions.

H-level≃H-level′ = Function-universe.H-level↔H-level′

-- There is a single statement for Lemmas 22 and 23.

Lemmas-22-and-23 = Erased.Erased-H-level′↔H-level′

------------------------------------------------------------------------
-- 3.6: Erased is a modality

-- Some lemmas.

Lemma-24 = Erased.uniquely-eliminating-modality
Lemma-25 = Erased.lex-modality

-- The map function.

map = Erased.map

-- Erased is a Σ-closed reflective subuniverse.

Σ-closed-reflective-subuniverse =
  Erased.Erased-Σ-closed-reflective-subuniverse

-- Another lemma.

Lemma-27 = Erased.Erased-connected↔Erased-Is-equivalence

------------------------------------------------------------------------
-- 3.7: Is [_] an embedding?

-- The function cong is unique up to pointwise equality if it is
-- required to map the canonical proof of reflexivity to the canonical
-- proof of reflexivity.

cong-canonical =
  Equality.Derived-definitions-and-properties.cong-canonical

-- Is-embedding.

Is-embedding = Embedding.Is-embedding

-- Embeddings are injective.

embeddings-are-injective = Embedding.injective

-- Some lemmas.

Lemma-29 = Erased.Is-proposition→Is-embedding-[]
Lemma-30 = Erased.With-K.Injective-[]
Lemma-31 = Erased.With-K.Is-embedding-[]
Lemma-32 = Erased.With-K.Is-proposition-Erased→Is-proposition

------------------------------------------------------------------------
-- 3.8: More commutation properties

-- There is a single statement for Lemmas 33–38 (and more).

Lemmas-33-to-38 = Erased.Erased-↝↔↝

-- There is also a single statement for the variants of Lemmas 33–38,
-- stated as logical equivalences instead of equivalences, that can be
-- proved without using extensionality.

Lemmas-33-to-38-with-⇔ = Erased.Erased-↝↝↝

-- Some lemmas.

Lemma-39 = Erased.Erased-cong-≃
Lemma-40 = Erased.Erased-Is-equivalence↔Is-equivalence

-- A generalisation of Lemma 41.

Lemma-41 = Function-universe.Σ-cong

-- More lemmas.

Lemma-42 = Erased.Erased-Split-surjective↔Split-surjective
Lemma-43 = Erased.Erased-Has-quasi-inverse↔Has-quasi-inverse
Lemma-44 = Erased.Erased-Injective↔Injective
Lemma-45 = Erased.Erased-Is-embedding↔Is-embedding
Lemma-46 = Erased.map-cong≡cong-map

-- There is a single statement for Lemmas 47–52 (and more).

Lemmas-47-to-52 = Erased.Erased-cong

-- The map function is functorial.

map-id = Erased.map-id
map-∘  = Erased.map-∘

-- All preservation lemmas (47–52) map identity to identity (assuming
-- extensionality, except for logical equivalences).

Erased-cong-id = Erased.Erased-cong-id

-- All preservation lemmas (47–52) commute with composition (assuming
-- extensionality, except for logical equivalences).

Erased-cong-∘ = Erased.Erased-cong-∘

------------------------------------------------------------------------
-- 4.1: Stable types

-- Stable.

Stable = Erased.Stable

-- Some lemmas.

Lemma-54 = Erased.¬¬-stable→Stable
Lemma-55 = Erased.Erased→¬¬
Lemma-56 = Erased.Dec→Stable

------------------------------------------------------------------------
-- 4.2: Very stable types

-- Very-stable.

Very-stable = Erased.Very-stable

-- A generalisation of Very-stable′.

Very-stable′ = Erased.Stable-[_]

-- Very stable types are stable (and Very-stable A implies
-- Very-stable′ A, and more).

Very-stable→Stable = Erased.Very-stable→Stable

-- [_] is an embedding for very stable types.

Very-stable→Is-embedding-[] = Erased.Very-stable→Is-embedding-[]

-- Some lemmas.

Lemma-59 = Erased.Stable→Left-inverse→Very-stable
Lemma-60 = Erased.Stable-proposition→Very-stable
Lemma-61 = Erased.Very-stable-Erased

-- It is not the case that every very stable type is a proposition.

¬-Very-stable→Is-proposition = Erased.¬-Very-stable→Is-proposition

-- More lemmas.

Lemma-62 = Erased.Very-stable-∃-Very-stable
Lemma-63 = Erased.Stable-∃-Very-stable

------------------------------------------------------------------------
-- 4.3: Stability for equality types

-- Stable-≡ and Very-stable-≡.

Stable-≡      = Erased.Stable-≡
Very-stable-≡ = Erased.Very-stable-≡

-- Some lemmas.

Lemma-66 = Erased.Stable→H-level-suc→Very-stable
Lemma-67 = Erased.Decidable-equality→Very-stable-≡
Lemma-68 = Erased.H-level→Very-stable

-- Lemmas 69 and 70, stated both as logical equivalences, and as
-- equivalences depending on extensionality.

Lemma-69 = Erased.Stable-≡↔Injective-[]
Lemma-70 = Erased.Very-stable-≡↔Is-embedding-[]

-- Equality is always very stable in traditional Agda.

Very-stable-≡-trivial = Erased.With-K.Very-stable-≡-trivial

------------------------------------------------------------------------
-- 4.4: Map-like functions

-- Lemma 71.

Lemma-71 = Erased.Stable-map-⇔

-- There is a single statement for Lemmas 72 and 73.

Lemmas-72-and-73 = Erased.Very-stable-cong

-- Lemma 74.

Lemma-74 = Erased.Very-stable-Erased↝Erased

-- Lemma 74, with Stable instead of Very-stable, and no assumption of
-- extensionality.

Lemma-74-Stable = Erased.Stable-Erased↝Erased

------------------------------------------------------------------------
-- 4.5: Closure properties

-- Lots of lemmas.

Lemmas-75-and-76 = Erased.Very-stable→Very-stable-≡
Lemma-77         = Erased.Very-stable-⊤
Lemma-78         = Erased.Very-stable-⊥
Lemma-79         = Erased.Stable-Π
Lemma-80         = Erased.Very-stable-Π
Lemma-81         = Erased.Very-stable-Stable-Σ
Lemma-82         = Erased.Very-stable-Σ
Lemma-83         = Erased.Stable-×
Lemma-84         = Erased.Very-stable-×
Lemma-85         = Erased.Very-stable-W
Lemmas-86-and-87 = Erased.Stable-H-level′
Lemmas-88-and-89 = Erased.Very-stable-H-level′
Lemma-90         = Erased.Stable-≡-⊎
Lemma-91         = Erased.Very-stable-≡-⊎
Lemma-92         = Erased.Stable-≡-List
Lemma-93         = Erased.Very-stable-≡-List
Lemma-94         = Quotient.Very-stable-≡-/

------------------------------------------------------------------------
-- 4.6: []‐cong can be proved using extensionality

-- The proof has been changed. Lemmas 95 and 97 have been removed.

-- A lemma.

Lemma-96 = Equivalence.≃-≡

-- []-cong, proved using extensionality, along with proofs showing
-- that it is an equivalence and that it satisfies the computation
-- rule of []-cong.

Extensionality→[]-cong = Erased.Extensionality→[]-cong-axiomatisation

------------------------------------------------------------------------
-- 5.1: Singleton types with erased equality proofs

-- Some lemmas.

Lemma-99  = Erased.erased-singleton-contractible
Lemma-100 = Erased.erased-singleton-with-erased-center-propositional

-- The generalisation of Lemma 82 used in the proof of Lemma 100.

Lemma-82-generalised = Erased.Very-stable-Σⁿ

-- Another lemma.

Lemma-101 = Erased.Σ-Erased-Erased-singleton↔

------------------------------------------------------------------------
-- 5.2: Efficient natural numbers

-- An implementation of natural numbers as lists of bits with the
-- least significant bit first and an erased invariant that ensures
-- that there are no trailing zeros.

import Nat.Binary

-- Nat-[_].

Nat-[_] = Nat.Wrapper.Nat-[_]

-- A lemma.

Lemma-103 = Nat.Wrapper.[]-cong.Nat-[]-propositional

-- Nat.

Nat = Nat.Wrapper.Nat

-- ⌊_⌋.

@0 ⌊_⌋ : _
⌊_⌋ = Nat.Wrapper.⌊_⌋

-- Another lemma.

Lemma-106 = Nat.Wrapper.[]-cong.≡-for-indices↔≡

------------------------------------------------------------------------
-- 5.2.1: Arithmetic

-- The functions unary-[] and unary.

unary-[] = Nat.Wrapper.unary-[]
unary    = Nat.Wrapper.unary

-- Similar functions for arbitrary arities.

n-ary-[] = Nat.Wrapper.n-ary-[]
n-ary    = Nat.Wrapper.n-ary

------------------------------------------------------------------------
-- 5.2.2: Converting Nat to ℕ

-- Some lemmas.

Lemma-109 = Nat.Wrapper.Nat-[]↔Σℕ
Lemma-110 = Nat.Wrapper.[]-cong.Nat↔ℕ

-- The function Nat→ℕ.

Nat→ℕ = Nat.Wrapper.Nat→ℕ

-- Some lemmas.

@0 Lemma-111 : _
Lemma-111 = Nat.Wrapper.≡⌊⌋
Lemma-112 = Nat.Wrapper.unary-correct

-- A variant of Lemma 112 for n-ary.

Lemma-112-for-n-ary = Nat.Wrapper.n-ary-correct

------------------------------------------------------------------------
-- 5.2.3: Decidable equality

-- Some lemmas.

Lemma-113 = Nat.Wrapper.Operations-for-Nat._≟_
Lemma-114 = Nat.Wrapper.Operations-for-Nat-[]._≟_

------------------------------------------------------------------------
-- 5.3: Queues

-- The implementation of queues (parametrised by an underlying queue
-- implementation).

module Queue = Queue.Truncated

-- The functions enqueue and dequeue.

enqueue = Queue.Truncated.Non-indexed.enqueue
dequeue = Queue.Truncated.Non-indexed.dequeue

------------------------------------------------------------------------
-- 6: Discussion and related work

-- Nat-[_]′.

Nat-[_]′ = Nat.Wrapper.Cubical.Nat-[_]′

-- An alternative implementation of Nat.

Alternative-Nat = Nat.Wrapper.Cubical.Nat-with-∥∥

-- The alternative implementation of Nat is isomorphic to the unit
-- type.

Alternative-Nat-isomorphic-to-⊤ = Nat.Wrapper.Cubical.Nat-with-∥∥↔⊤

-- The alternative implementation of Nat is not isomorphic to the
-- natural numbers.

Alternative-Nat-not-isomorphic-to-ℕ =
  Nat.Wrapper.Cubical.¬-Nat-with-∥∥↔ℕ


-- Andreas, 2018-10-17, re issue #2757
--
-- Matching on runtime-irrelevant arguments is fine
-- as long as it produces only one branch.

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

-- Matching on empty types can be erased.

data ⊥ : Set where

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

-- Accessibility.

data Acc {A : Set} (R : A → A → Set) (x : A) : Set where
  acc : (∀{y} (y<x : R y x) → Acc R y) → Acc R x

-- Accessibility proofs can be erased.

wfrec : {A : Set} (R : A → A → Set) {P : A → Set}
  → (∀{x} → (∀{y} (@0 y<x : R y x) → P y) → P x)
  → ∀{x} (@0 ax : Acc R x) → P x
wfrec R f (acc h) = f λ y<x → wfrec R f (h y<x)

-- Non-branching matches can be erased.

diag : ∀(@0 x) (y : Bool) (@0 eq : x ≡ y) → Bool
diag false false refl = false
diag true  y     refl = y

diag' : ∀ x (@0 y : Bool) (@0 eq : x ≡ y) → Bool
diag' false false refl = false
diag' true  y     refl = y

-- Also for literals.

nonBranchLit : ∀ (@0 x) (eq : x ≡ 0) → Set
nonBranchLit 0 refl = Nat

-- The attribute syntax collides lexically with the as-pattern syntax.

userConfusingClashOfAttributesAndAsPatterns : ∀ (@0 x) (eq : x ≡ 0) → Set
userConfusingClashOfAttributesAndAsPatterns (x @0) refl = Nat


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

-- Borrowed from OldUnivalence/Equivalences.agda, without HoTT
-- and then upgraded to work on Setoid rather than just on ≡

module SetoidEquiv where

open import Level using (Level; zero; _⊔_)

open import Data.Empty using (⊥)
open import Data.Sum using (_⊎_; inj₁; inj₂)

import Function as Fun using (id)
open import Function.Equality using (id; _∘_; _⟶_; _⟨$⟩_; _⇨_; cong)
open import Relation.Binary using (Setoid; module Setoid)
open import Relation.Binary.PropositionalEquality as P using (setoid; →-to-⟶)

open Setoid

-- Equivalence of setoids

infix 4 _≃S_

------------------------------------------------------------------------------
-- A setoid gives us a set and an equivalence relation on that set.
-- The setoids constructed in PropositionalEquality (P) use ≡ as the
-- equivalence relation

-- the empty set with ≡

{--
0S : Setoid zero zero
0S = P.setoid ⊥
--}

-- sum of setoids
-- we take the disjoint union of the carriers and construct a new
-- equivalence relation that uses the underlying relations on each
-- summand (and is undefined on elements that come from different
-- summands)

{--
_⊎S_ : (AS : Setoid zero zero) (BS : Setoid zero zero) → Setoid zero zero
_⊎S_ AS BS = record
  { Carrier = A ⊎ B
  ; _≈_ = _∼₁_
  ; isEquivalence = record
    { refl = λ { {inj₁ _} → refl AS ; {inj₂ _} → refl BS}
    ; sym = λ {x} {y} → sym∼₁ {x} {y}
    ; trans = λ {x} {y} {z} → trans∼₁ {x} {y} {z} }
  }
  where
    A = Carrier AS
    B = Carrier BS

    _∼₁_ : A ⊎ B → A ⊎ B → Set
    inj₁ x ∼₁ inj₁ x₁ = _≈_ AS x x₁
    inj₁ x ∼₁ inj₂ y = ⊥
    inj₂ y ∼₁ inj₁ x = ⊥
    inj₂ y ∼₁ inj₂ y₁ = _≈_ BS y y₁

    sym∼₁ : {x y : A ⊎ B} → x ∼₁ y → y ∼₁ x
    sym∼₁ {inj₁ _} {inj₁ _} x~y = sym AS x~y
    sym∼₁ {inj₁ _} {inj₂ _} ()
    sym∼₁ {inj₂ _} {inj₁ _} ()
    sym∼₁ {inj₂ _} {inj₂ _} x~y = sym BS x~y

    trans∼₁ : Relation.Binary.Transitive _∼₁_
    trans∼₁ {inj₁ x} {inj₁ x₁} {inj₁ x₂} i~j j~k = trans AS i~j j~k
    trans∼₁ {inj₁ x} {inj₁ x₁} {inj₂ y} i~j ()
    trans∼₁ {inj₁ x} {inj₂ y} {inj₁ x₁} i~j ()
    trans∼₁ {inj₁ x} {inj₂ y}  () j~k
    trans∼₁ {inj₂ y} {inj₁ x} () j~k
    trans∼₁ {inj₂ y} {inj₂ y₁} {inj₁ x} i~j ()
    trans∼₁ {inj₂ y} {inj₂ y₁} {inj₂ y₂} i~j j~k = trans BS i~j j~k
--}

------------------------------------------------------------------------------
-- Equivalence of setoids

-- Two setoids are equivalent if

record _≃S_ {ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level} (A : Setoid ℓ₁ ℓ₂) (B : Setoid ℓ₃ ℓ₄) :
  Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where
  constructor equiv

  field
    f : A ⟶ B
    g : B ⟶ A
    α : ∀ {x y} → _≈_ B x y → _≈_ B ((f ∘ g) ⟨$⟩ x) y
    β : ∀ {x y} → _≈_ A x y → _≈_ A ((g ∘ f) ⟨$⟩ x) y

{--
id≃S : ∀ {ℓ₁ ℓ₂} {A : Setoid ℓ₁ ℓ₂} → A ≃S A
id≃S {A = A} = equiv id id Fun.id Fun.id

sym≃S : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {A : Setoid ℓ₁ ℓ₂} {B : Setoid ℓ₃ ℓ₄} →
        (A ≃S B) → B ≃S A
sym≃S eq = equiv e.g e.f e.β e.α
  where module e = _≃S_ eq

trans≃S : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ ℓ₆}
          {A : Setoid ℓ₁ ℓ₂} {B : Setoid ℓ₃ ℓ₄} {C : Setoid ℓ₅ ℓ₆} →
          A ≃S B → B ≃S C → A ≃S C
trans≃S {A = A} {B} {C} A≃B B≃C = equiv f g α' β'
  where
    module fm = _≃S_ A≃B
    module gm = _≃S_ B≃C
    f : A ⟶ C
    f = gm.f ∘ fm.f
    g : C ⟶ A
    g = fm.g ∘ gm.g
    α' : _≈_ (C ⇨ C) (f ∘ g)  id
    α' = λ z → trans C (cong gm.f (fm.α (cong gm.g (refl C)))) (gm.α z)
    β' : _≈_ (A ⇨ A) (g ∘ f) id
    β' = λ z → trans A (cong fm.g (gm.β (cong fm.f (refl A)))) (fm.β z)

_✴_ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {A : Setoid ℓ₁ ℓ₂} {B : Setoid ℓ₃ ℓ₄} →
      (A ≃S B) → (x : Carrier A) → Carrier B
(equiv f _ _ _) ✴ x = f ⟨$⟩ x
--}

-- can't use id because it is not sufficiently dependently typed!

{--
0≃S : 0S ≃S 0S
0≃S = equiv id id (λ x → x) (λ x → x)
--}

-- just to make things prettier

_≃S≡_ : ∀ {ℓ₁} → (A B : Set ℓ₁) → Set ℓ₁
A ≃S≡ B = (P.setoid A) ≃S (P.setoid B)

-- Need to be able to take ⊎ of ≃S-Setoids
{--
_⊎≃S_ : {A B C D : Set} → A ≃S≡ B → C ≃S≡ D → (A ⊎ C) ≃S≡ (B ⊎ D)
_⊎≃S_ {A} {B} {C} {D} (equiv f g α β) (equiv f₁ g₁ α₁ β₁) =
  equiv (→-to-⟶ ff) (→-to-⟶ gg) αα ββ
  where
    ff : A ⊎ C → B ⊎ D
    ff (inj₁ x) = inj₁ (f ⟨$⟩ x)
    ff (inj₂ y) = inj₂ (f₁ ⟨$⟩ y)
    gg : B ⊎ D → A ⊎ C
    gg (inj₁ x) = inj₁ (g ⟨$⟩ x)
    gg (inj₂ y) = inj₂ (g₁ ⟨$⟩ y)
    αα : {x y : B ⊎ D} → x P.≡ y → ff (gg x) P.≡ y
    αα {inj₁ x} P.refl = P.cong inj₁ (α P.refl)
    αα {inj₂ y} P.refl = P.cong inj₂ (α₁ P.refl)
    ββ : {x y : A ⊎ C} → x P.≡ y → gg (ff x) P.≡ y
    ββ {inj₁ x} P.refl = P.cong inj₁ (β P.refl)
    ββ {inj₂ y} P.refl = P.cong inj₂ (β₁ P.refl)
--}
-- note that this appears to be redundant (especially when looking at
-- the proofs), but having both f and g is needed for inference of
-- other aspects to succeed.

record _≋_ {ℓ₁} {A B : Set ℓ₁} (eq₁ eq₂ : A ≃S≡ B) : Set ℓ₁ where
  constructor equivS
  field
    f≡ : ∀ (x : A) → P._≡_ (_≃S_.f eq₁ ⟨$⟩ x) (_≃S_.f eq₂ ⟨$⟩ x)
    g≡ : ∀ (x : B) → P._≡_ (_≃S_.g eq₁ ⟨$⟩ x) (_≃S_.g eq₂ ⟨$⟩ x)

id≋ : ∀ {ℓ} {A B : Set ℓ} {x : A ≃S≡ B} → x ≋ x
id≋ = record { f≡ = λ x → P.refl ; g≡ = λ x → P.refl }

sym≋ : ∀ {ℓ} {A B : Set ℓ} {x y : A ≃S≡ B} → x ≋ y → y ≋ x
sym≋ (equivS f≡ g≡) = equivS (λ a → P.sym (f≡ a)) (λ b → P.sym (g≡ b))

trans≋ : ∀ {ℓ} {A B : Set ℓ} {x y z : A ≃S≡ B} → x ≋ y → y ≋ z → x ≋ z
trans≋ (equivS f≡ g≡) (equivS h≡ i≡) =
   equivS (λ a → P.trans (f≡ a) (h≡ a)) (λ b → P.trans (g≡ b) (i≡ b))

-- WARNING: this is not generic, but specific to ≡-Setoids of functions.

≃S-Setoid : ∀ {ℓ₁} → (A B : Set ℓ₁) → Setoid ℓ₁ ℓ₁
≃S-Setoid {ℓ₁} A B = record
  { Carrier = AS ≃S BS
  ; _≈_ = _≋_
  ; isEquivalence = record
    { refl = id≋
    ; sym = sym≋
    ; trans = trans≋
    }
  }
  where
    open _≃S_
    AS = P.setoid A
    BS = P.setoid B

-- equivalences are injective

{--
inj≃ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {A : Setoid ℓ₁ ℓ₂} {B : Setoid ℓ₃ ℓ₄} →
       (eq : A ≃S B) → {x y : Carrier A} →
       _≈_ B (eq ✴ x)  (eq ✴ y) → _≈_ A x y
inj≃ {A = A'} (equiv f g _ β) p =
  A.trans (A.sym (β A.refl)) (A.trans (cong g p) (β A.refl))
  where
    module A = Setoid A'
--}

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