module Function.Multi.Functions where

open import Data
import      Data.Option.Functions as Option
open import Data.Tuple renaming (curry to curry₁ ; uncurry to uncurry₁) using (_⨯_ ; _,_)
open import Data.Tuple.Raise
import      Data.Tuple.Raiseᵣ.Functions as Raise
open import Data.Tuple.RaiseTypeᵣ
open import Data.Tuple.RaiseTypeᵣ.Functions
open import Function.Multi
open import Functional using (_→ᶠ_ ; id ; _∘_ ; _∘ᵢₙₛₜ_ ; _⦗_⦘_) renaming (const to const₁ ; apply to apply₁ ; swap to swap₁ ; _$_ to _$₁_)
open import Logic
import      Lvl
import      Lvl.MultiFunctions as Lvl
open import Numeral.Finite
open import Numeral.Finite.Bound
open import Numeral.Natural
open import Syntax.Function
open import Syntax.Number
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓ₃ : Lvl.Level
private variable n n₁ n₂ : ℕ
private variable ℓ𝓈 ℓ𝓈₁ ℓ𝓈₂ : Lvl.Level ^ n
private variable A B C : Type{ℓ}
private variable As Bs Cs : Types{n}(ℓ𝓈)

-- TODO: Make all n, n₁, n₂ explicit. Find a way to do this while having generalized variables
-- TODO: Some of these functions can be generalised to arbitrary categories instead of using the function type (_→_). This makes it possible to skip the specialized variants for different parameter types (e.g. compose and composeᵢₙₛₜ)

-- A constant function of many variables.
-- Lifts a value to being a number of nested functions.
-- Examples:
--   const(x) _ _ _ ... = x
--   const(x)
--   = (const₁ ∘ const₁ ∘ const₁ ∘ ...)(x)
--   = (_ ↦ (_ ↦ (_ ↦ x)))
--   = (_ ↦ _ ↦ _ ↦ x)
const : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → B → (As ⇉ B)
const(0)       = id
const(1)       = const₁
const(𝐒(𝐒(n))) = const₁ ∘ const(𝐒(n))

-- A projection function of many variables.
-- Returns one of the specified arguments.
-- Examples:
--   proj(2)(0) x y = x
--   proj(2)(1) x y = y
--   proj(3)(0) x y z = x
--   proj(3)(1) x y z = y
--   proj(3)(2) x y z = z
--   proj(4)(0) x y z w = x
--   proj(4)(1) x y z w = y
--   proj(4)(2) x y z w = z
--   proj(4)(3) x y z w = w
proj : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (i : 𝕟(n)) → (As ⇉ index i As)
proj(1)       𝟎      x = x
proj(𝐒(𝐒(n))) 𝟎      x = const(𝐒(n)) x
proj(𝐒(𝐒(n))) (𝐒(i)) _ = proj(𝐒(n)) i

-- Applies a function on the return value of a multivariate function.
-- Composes the first argument and the last function of the second argument.
-- Can also be seen as lifting the function type to the structure of (As ⇉_).
-- Examples:
--   f ∘ᵣ g = (((f ∘_) ∘_) ∘_) ..
--   ((((f ∘ᵣ g) x₁) x₂) x₃) .. = f((((g x₁) x₂) x₃) ..)
--   (f ∘ᵣ g) x₁ x₂ x₃ .. = f(g x₁ x₂ x₃ ..)
-- Note: This can be used to specify the `map` function of a functor (As ⇉_).
compose : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ₁}{B : Type{ℓ₁}}{ℓ₂}{C : Type{ℓ₂}} → (B → C) → (As ⇉ B) → (As ⇉ C)
compose(0)         = id
compose(1)         = _∘_
compose(𝐒(𝐒(n))) f = compose(𝐒(n)) f ∘_
_∘ᵣ_ : ∀{As : Types{n}(ℓ𝓈)}{B : Type{ℓ₁}}{C : Type{ℓ₂}} → (B → C) → (As ⇉ B) → (As ⇉ C)
_∘ᵣ_ {n = n} = compose(n)

composeᵢₙₛₜ : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ₁}{B : Type{ℓ₁}}{ℓ₂}{C : Type{ℓ₂}} → (B → C) → (As ⇉ᵢₙₛₜ B) → (As ⇉ᵢₙₛₜ C)
composeᵢₙₛₜ(0)           = id
composeᵢₙₛₜ(1)       f g = f(g)
composeᵢₙₛₜ(𝐒(𝐒(n))) f g = composeᵢₙₛₜ(𝐒(n)) f g

-- Puts the second function on every argument of the first function.
-- Example:
--   (f on g) x₁ x₂ x₃ .. = f (g x₁) (g x₂) (g x₃) ..
composeOnEvery : (n : ℕ) → ∀{ℓ₁}{A : Type{ℓ₁}}{ℓ₂}{B : Type{ℓ₂}}{ℓ₃}{C : Type{ℓ₃}} → (repeat n B ⇉ C) → (A → B) → (repeat n A ⇉ C)
composeOnEvery 0               = const₁
composeOnEvery 1               = _∘_
composeOnEvery (𝐒(𝐒(n))) f g x = composeOnEvery(𝐒(n)) (f(g(x))) g
_on_ : ∀{A : Type{ℓ₁}}{B : Type{ℓ₂}}{C : Type{ℓ₃}} → (repeat n B ⇉ C) → (A → B) → (repeat n A ⇉ C)
_on_ {n = n} = composeOnEvery(n)

applyTwice : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (As ⇉ As ⇉ B) → (As ⇉ B)
applyTwice(0)            = id
applyTwice(1)       f(x) = f(x)(x)
applyTwice(𝐒(𝐒(n))) f(x) = applyTwice(𝐒(n)) ((_$₁ x) ∘ᵣ (f(x)))

swap : (n₁ n₂ : ℕ) → ∀{ℓ𝓈₁}{As : Types{n₁}(ℓ𝓈₁)}{ℓ𝓈₂}{Bs : Types{n₂}(ℓ𝓈₂)}{ℓ}{C : Type{ℓ}} → (As ⇉ Bs ⇉ C) → (Bs ⇉ As ⇉ C)
swap(n₁)(0)            = id
swap(n₁)(1)        f b = (_$₁ b) ∘ᵣ f
swap(n₁)(𝐒(𝐒(n₂))) f b = swap(n₁)(𝐒(n₂)) ((_$₁ b) ∘ᵣ f)

-- Lifts a function/operator pointwise.
-- A generalized variant of `(_∘ᵣ_)` that allows the left function to have multiple arguments.
-- Example:
--   (f ∘ₗ g₁ g₂ g₃ ...) x₁ x₂ x₃ ... = f (g₁ x₁ x₂ x₃ ...) (g₂ x₁ x₂ x₃ ...) (g₃ x₁ x₂ x₃ ...) ...
--   (f ∘ₗ g) x₁ x₂ x₃ ... = (f ∘ᵣ g) x₁ x₂ x₃ ...
--   pointwise(1)(2) (_+_) = (f ↦ g ↦ x ↦ f(x) + g(x))
pointwise : (n₁ n₂ : ℕ) → ∀{ℓ𝓈₁}{As : Types{n₁}(ℓ𝓈₁)}{ℓ𝓈₂}{Bs : Types{n₂}(ℓ𝓈₂)}{ℓ}{C : Type{ℓ}} → (Bs ⇉ C) → (map (As ⇉_) Bs) ⇉ (As ⇉ C)
pointwise(n₁)(0)            = const(n₁)
pointwise(n₁)(1)            = compose(n₁)
pointwise(n₁)(𝐒(𝐒(n₂))) {As = As}{Bs = B , Bs}{C = C} f g = p{n = 𝐒(n₂)} (pointwise(n₁)(𝐒(n₂))) (f ∘ᵣ g) where
  p : ∀{Ts : Types{n}(ℓ𝓈)} → ((Bs ⇉ C) → (Ts ⇉ As ⇉ C)) → ((As ⇉ Bs ⇉ C) → (Ts ⇉ As ⇉ C)) -- TODO: Is it possible to simplify this helper function?
  p{n = n}{Ts = Ts} f g = compose(n) (applyTwice(n₁)) (swap(n₁)(n) (compose(n₁) f g))
_∘ₗ : ∀{As : Types{n₁}(ℓ𝓈₁)}{Bs : Types{n₂}(ℓ𝓈₂)}{C : Type{ℓ}} → (Bs ⇉ C) → (map (As ⇉_) Bs) ⇉ (As ⇉ C)
_∘ₗ {n₁ = n₁}{n₂ = n₂} = pointwise(n₁)(n₂)

-- Converts a function using a tuple to represent its arguments to a curried function (nested function types).
-- Example:
--   curry((x,y,z,...) ↦ φ) = (x ↦ y ↦ z ↦ ... ↦ φ)
--   curry(0) = id                       : (A₁                  → B) → (A₁                → B)
--   curry(1) = curry₁                   : ((A₁ ⨯ A₂)           → B) → (A₁ → A₂           → B)
--   curry(2) = curry₁ ∘ curry₁          : ((A₁ ⨯ A₂ ⨯ A₃)      → B) → (A₁ → A₂ → A₃      → B)
--   curry(3) = curry₁ ∘ curry₁ ∘ curry₁ : ((A₁ ⨯ A₂ ⨯ A₃ ⨯ A₄) → B) → (A₁ → A₂ → A₃ → A₄ → B)
-- Note: If there is a nested uncurry and curry, one can often use (_∘ᵣ_) instead (I think?).
curry : (n : ℕ) → ∀{ℓ𝓈}{As : Types{𝐒(n)}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (reduceᵣ(_⨯_) As → B) → (As ⇉ B)
curry(𝟎)        = id
curry(𝐒(n)) f x = curry(n) (f ∘ (x ,_))

-- Converts a curried function (nested function types) to a function using a tuple to represent its arguments.
-- Example:
--   uncurry(x ↦ y ↦ z ↦ ... ↦ φ) = ((x,y,z,...) ↦ φ)
uncurry : (n : ℕ) → ∀{ℓ𝓈}{As : Types{𝐒(n)}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (As ⇉ B) → (reduceᵣ(_⨯_) As → B)
uncurry(𝟎)               = id
uncurry(𝐒(n)) f (x , xs) = uncurry(n) (f(x)) xs

-- Applies a tuple as arguments to a multivariate function.
-- Example:
--   apply(x,y,z,...) (x ↦ y ↦ z ↦ ... ↦ φ) = φ
applyTuple : (n : ℕ) → ∀{ℓ𝓈}{As : Types{𝐒(n)}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (reduceᵣ(_⨯_) As) → (As ⇉ B) → B
applyTuple(n) = swap₁(uncurry(n))

-- Applies an argument to a specific position in the arguments of an argument list of a multivariate function.
-- Examples:
--   applyAt 0 (x ↦ y ↦ ... ↦ f(x,y)) a = (y ↦ ... ↦ f(a,y))
--   applyAt 1 (x ↦ y ↦ ... ↦ f(x,y)) b = (x ↦ ... ↦ f(x,b))
--   applyAt 0 (x ↦ y ↦ z ↦ ... ↦ f(x,y,z)) a = (y ↦ z ↦ ... ↦ f(a,y,z))
--   applyAt 1 (x ↦ y ↦ z ↦ ... ↦ f(x,y,z)) b = (x ↦ z ↦ ... ↦ f(x,b,z))
--   applyAt 2 (x ↦ y ↦ z ↦ ... ↦ f(x,y,z)) c = (x ↦ y ↦ ... ↦ f(x,y,c))
applyAt : (n : ℕ) → ∀{ℓ𝓈}{As : Types{𝐒(n)}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (i : 𝕟(𝐒(n))) → (index i As) → (As ⇉ B) → (without i As ⇉ B)
applyAt(0)       𝟎      xi f    = f xi
applyAt(1)       𝟎      xi f x  = f xi x
applyAt(1)       (𝐒(𝟎)) xi f x  = f x xi
applyAt(𝐒(𝐒(n))) 𝟎      xi f xs = f xi xs
applyAt(𝐒(𝐒(n))) (𝐒(i)) xi f x  = applyAt(𝐒(n)) i xi (f(x))

-- Puts the second and each succeeding functions on the respective arguments of the first function.
-- Applies each argument `xₙ` on the inner function `gₙ`, and then apply the value of these as the arguments to an outer function `f`.
-- This is similiar to (_on_) but uses different functions for every argument and each argument is applied to its respective function instead.
-- Example:
--   (onMany(n) f g₁ g₂ g₃ ...) x₁ x₂ x₃ ... = f (g₁ x₁) (g₂ x₂) (g₃ x₃) ...
-- TODO: Try to get rid of the curry/uncurry by using (_∘ᵣ_)
onEach : (n : ℕ) → ∀{ℓ𝓈₁}{As : Types{n}(ℓ𝓈₁)}{ℓ𝓈₂}{Bs : Types{n}(ℓ𝓈₂)}{C : Type{ℓ}} → (Bs ⇉ C) → (As ⦗ map₂(_→ᶠ_) ⦘ Bs) ⇉ (As ⇉ C)
onEach(0)           = id
onEach(1)           = _∘_
onEach(𝐒(𝐒(n))) f g = curry(n) (gs ↦ x ↦ uncurry(n) (onEach(𝐒(n)) (f(g(x)))) gs)

-- Note: One of the parts of being an "applicative functor". The other being `const`
liftedApply : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ₁}{B : Type{ℓ₁}}{ℓ₂}{C : Type{ℓ₂}} → (As ⇉ (B → C)) → ((As ⇉ B) → (As ⇉ C))
liftedApply(0)             = id
liftedApply(1)       f g x = f x (g x)
liftedApply(𝐒(𝐒(n))) f g x = liftedApply(𝐒(n)) (f(x)) (g(x))

lifted-[,] : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ₁}{B : Type{ℓ₁}}{ℓ₂}{C : Type{ℓ₂}} → (As ⇉ B) → (As ⇉ C) → (As ⇉ (B ⨯ C))
lifted-[,](n) f g = liftedApply(n) ((swap₁ _,_) ∘ᵣ g) f

-- TODO: How to implement something like this
--(F(x) ▫ F(y)) ▫ F(x . y)
--_aryᵣFromBinaryOperator_ : (n : ℕ) → ∀{X : Type{ℓ₁}}{Y : Type{ℓ₂}} → (_▫_ : X → Y → X) →
-- _aryᵣFromBinaryOperator_ : (n : ℕ) → ∀{F}{_○_} → (_▫_ : ∀{x y} → F(x) → F(y) → F(x ○ y)) →
-- _aryᵣFromBinaryOperator_ : (n : ℕ) → ∀{F} → (_▫_ : ∀{x y z} → F(x)(y) → F(y)(z) → F(x)(z)) →
-- CategoricalOperator₊ : ℕ → {Obj : Type{ℓ₁}} → (Obj → Obj → Type{ℓ₂}) → Type
-- CategoricalOperator₊(0)       F = ∀{x₁ x₂} → F(x₁)(x₂) → F(x₁)(x₂)
-- CategoricalOperator₊(1)       F = ∀{x₁ x₂ x₃} → F(x₂)(x₃) → F(x₁)(x₂) → F(x₁)(x₃)
-- CategoricalOperator₊(𝐒(𝐒(n))) F = {!!}

-- Nested binary type relations that associate to the right.
-- Used to define n-ary binary relations that accepts any types.
-- Example:
--   binaryTypeRelator₊(4)(_▫_) A B C D = A ▫ (B ▫ (C ▫ D))
-- TODO: It is possible to generalize the levels
binaryTypeRelator₊ : (n : ℕ) → (∀{ℓ₁ ℓ₂} → Type{ℓ₁} → Type{ℓ₂} → Type{ℓ₁ Lvl.⊔ ℓ₂}) → (∀{ℓ} → Type{ℓ}) → ∀{ℓ𝓈} → TypesOfTypes{n}(ℓ𝓈) ⇉ Type{Lvl.⨆(ℓ𝓈)}
binaryTypeRelator₊(0)       (_▫_) id   = id
binaryTypeRelator₊(1)       (_▫_) _  A = A
binaryTypeRelator₊(𝐒(𝐒(n))) (_▫_) id A = compose(𝐒(n)) (A ▫_) (binaryTypeRelator₊(𝐒(n)) (_▫_) id)

-- Nested quantifiers over multiple values.
-- Used to define nested universal and existential quantifications.
-- Example:
--   quantifier₊(3) □(P) = □(x ↦ □(y ↦ □(z ↦ P(x)(y)(z))))
quantifier₊ : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (∀{ℓ₁ ℓ₂}{T : Type{ℓ₁}} → (T → Stmt{ℓ₂}) → Stmt{ℓ₁ Lvl.⊔ ℓ₂}) → (As ⇉ Stmt{ℓ}) → Stmt{ℓ Lvl.⊔ (Lvl.⨆(ℓ𝓈))}
quantifier₊(0)       □(P) = P
quantifier₊(1)       □(P) = □(P)
quantifier₊(𝐒(𝐒(n))) □(P) = □(x ↦ quantifier₊(𝐒(n)) □(P(x)))

quantifier₊ᵢₘₚₗ : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (∀{ℓ₁ ℓ₂}{T : Type{ℓ₁}} → (T → Stmt{ℓ₂}) → Stmt{ℓ₁ Lvl.⊔ ℓ₂}) → (As ⇉ᵢₘₚₗ Stmt{ℓ}) → Stmt{ℓ Lvl.⊔ (Lvl.⨆(ℓ𝓈))}
quantifier₊ᵢₘₚₗ(0)       □(P) = P
quantifier₊ᵢₘₚₗ(1)       □(P) = □(x ↦ P{x})
quantifier₊ᵢₘₚₗ(𝐒(𝐒(n))) □(P) = □(x ↦ quantifier₊ᵢₘₚₗ(𝐒(n)) □(P{x}))

quantifier₊ᵢₙₛₜ : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (∀{ℓ₁ ℓ₂}{T : Type{ℓ₁}} → (T → Stmt{ℓ₂}) → Stmt{ℓ₁ Lvl.⊔ ℓ₂}) → (As ⇉ᵢₙₛₜ Stmt{ℓ}) → Stmt{ℓ Lvl.⊔ (Lvl.⨆(ℓ𝓈))}
quantifier₊ᵢₙₛₜ(0)       □(P) = P
quantifier₊ᵢₙₛₜ(1)       □(P) = □(x ↦ P ⦃ x ⦄)
quantifier₊ᵢₙₛₜ(𝐒(𝐒(n))) □(P) = □(x ↦ quantifier₊ᵢₙₛₜ(𝐒(n)) □(P ⦃ x ⦄))

quantify : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (As ⇉ Stmt{ℓ}) → Stmt{ℓ Lvl.⊔ (Lvl.⨆(ℓ𝓈))}
quantify(n) P = quantifier₊(n) (Pred ↦ (∀(x) → Pred(x))) P

quantifyᵢₘₚₗ : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (As ⇉ᵢₘₚₗ Stmt{ℓ}) → Stmt{ℓ Lvl.⊔ (Lvl.⨆(ℓ𝓈))}
quantifyᵢₘₚₗ(n) P = quantifier₊ᵢₘₚₗ(n) (Pred ↦ (∀{x} → Pred(x))) P

quantifyᵢₙₛₜ : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (As ⇉ᵢₙₛₜ Stmt{ℓ}) → Stmt{ℓ Lvl.⊔ (Lvl.⨆(ℓ𝓈))}
quantifyᵢₙₛₜ(n) P = quantifier₊ᵢₙₛₜ(n) (Pred ↦ (∀ ⦃ x ⦄ → Pred(x))) P

quantifierSpecific : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (∀{i} → (index i As → Stmt{ℓ}) → Stmt{ℓ}) → (As ⇉ Stmt{ℓ}) → Stmt{ℓ}
quantifierSpecific(0)       □(P) = P
quantifierSpecific(1)       □(P) = □{𝟎}(P)
quantifierSpecific(𝐒(𝐒(n))) □(P) = □{𝟎}(x ↦ quantifierSpecific(𝐒(n)) (\{i} → □{𝐒(i)})(P(x)))

{- TODO: MOre general levels
quantifierSpecific : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (∀{i} → (index i As → Stmt{Raise.index i ℓ𝓈}) → Stmt{ℓ}) → (As ⇉ Stmt{Lvl.⨆(ℓ𝓈)}) → Stmt{(Raise.head₀ ℓ𝓈) Option.or ℓ}
quantifierSpecific(0)       □(P) = {!!}
quantifierSpecific(1)       □(P) = □{𝟎}(P)
quantifierSpecific(𝐒(𝐒(n))) □(P) = □{𝟎}(x ↦ {!quantifierSpecific(𝐒(n)) (\{i} → □{𝐒(i)})(P(x))!})
-}

expl-to-impl : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (As ⇉ B) → (As ⇉ᵢₘₚₗ B)
expl-to-impl 0         f = f
expl-to-impl 1         f{x} = f(x)
expl-to-impl (𝐒(𝐒(n))) f{x} = expl-to-impl(𝐒(n)) (f(x))

expl-to-inst : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (As ⇉ B) → (As ⇉ᵢₙₛₜ B)
expl-to-inst 0         f = f
expl-to-inst 1         f ⦃ x ⦄ = f(x)
expl-to-inst (𝐒(𝐒(n))) f ⦃ x ⦄ = expl-to-inst(𝐒(n)) (f(x))

impl-to-expl : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (As ⇉ᵢₘₚₗ B) → (As ⇉ B)
impl-to-expl 0         f = f
impl-to-expl 1         f(x) = f{x}
impl-to-expl (𝐒(𝐒(n))) f(x) = impl-to-expl(𝐒(n)) (f{x})

inst-to-expl : (n : ℕ) → ∀{ℓ𝓈}{As : Types{n}(ℓ𝓈)}{ℓ}{B : Type{ℓ}} → (As ⇉ᵢₙₛₜ B) → (As ⇉ B)
inst-to-expl 0         f = f
inst-to-expl 1         f(x) = f ⦃ x ⦄
inst-to-expl (𝐒(𝐒(n))) f(x) = inst-to-expl(𝐒(n)) (f ⦃ x ⦄)


------------------------------------------------------------------------
-- The Agda standard library
--
-- W-types
------------------------------------------------------------------------

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

module Data.W where

open import Level
open import Function
open import Data.Product hiding (map)
open import Data.Container.Core hiding (map)
open import Data.Container.Relation.Unary.All using (□; all)
open import Relation.Nullary
open import Agda.Builtin.Equality

-- The family of W-types.

data W {s p} (C : Container s p) : Set (s ⊔ p) where
  sup : ⟦ C ⟧ (W C) → W C

module _ {s p} {C : Container s p} {s : Shape C} {f : Position C s → W C} where

 sup-injective₁ : ∀ {t g} → sup (s , f) ≡ sup (t , g) → s ≡ t
 sup-injective₁ refl = refl

 -- See also Data.W.WithK.sup-injective₂.

-- Projections.

module _ {s p} {C : Container s p} where

  head : W C → Shape C
  head (sup (x , f)) = x

  tail : (x : W C) → Position C (head x) → W C
  tail (sup (x , f)) = f

-- map

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂}
         (m : C₁ ⇒ C₂) where

  map : W C₁ → W C₂
  map (sup (x , f)) = sup (⟪ m ⟫ (x , λ p → map (f p)))

-- induction

module _ {s p ℓ} {C : Container s p} (P : W C → Set ℓ)
         (alg : ∀ {t} → □ C P t → P (sup t)) where

 induction : (w : W C) → P w
 induction (sup (s , f)) = alg $ all (induction ∘ f)

module _ {s p ℓ} {C : Container s p} (open Container C)
         {P : Set ℓ} (alg : ⟦ C ⟧ P → P) where

 foldr : W C → P
 foldr = induction (const P) (alg ∘ -,_ ∘ □.proof)

-- If Position is always inhabited, then W_C is empty.

module _ {s p} {C : Container s p} where

  inhabited⇒empty : (∀ s → Position C s) → ¬ W C
  inhabited⇒empty b = foldr ((_$ b _) ∘ proj₂)


----------------------------------------------------------------------
-- Copyright: 2013, Jan Stolarek, Lodz University of Technology     --
--                                                                  --
-- License: See LICENSE file in root of the repo                    --
-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps   --
--                                                                  --
-- Weight biased leftist tree that proves both priority and rank    --
-- invariants. Uses a two-pass merging algorithm.                   --
----------------------------------------------------------------------

{-# OPTIONS --sized-types #-}
module TwoPassMerge.CombinedProofs where

open import Basics
open import Sized
open import TwoPassMerge.RankProof using ( makeT-lemma; proof-1; proof-2 )

-- Now that we have separate proofs of priority and rank invariants we
-- can combine them into one proof. We index Heap with two indices:
-- one for Priority and one for Rank.
data Heap : {i : Size} → Priority → Rank → Set where
  empty : {i : Size} {b : Priority} → Heap {↑ i} b zero
  node  : {i : Size} {b : Priority} → (p : Priority) → p ≥ b → {l r : Rank} →
          l ≥ r → Heap {i} p l → Heap {i} p r → Heap {↑ i} b (suc (l + r))

-- Now we will combine functions that prove priority invariant and
-- functions that prove rank invariant into functions that prove both
-- invariants.

-- Let's begin with singleton. Note the type of created Heap. We set
-- first index to zero, because it proves the priority invariant and
-- second index to one because it proves rank invariant. The node now
-- needs two ge0 evidence.
singleton : Priority → Heap zero one
singleton p = node p ge0 ge0 empty empty

-- makeT function requires that we supply evidence that priority
-- invariant holds (value of type p ≥ b), guarantees that resulting
-- heap has correct size and maintains rank invariant by using Order
-- type to supply evidence of rank correctness to node constructor.
makeT : {b : Priority} {l r : Rank} → (p : Priority) → p ≥ b →
      Heap p l → Heap p r → Heap b (suc (l + r))
makeT {b} {l-rank} {r-rank} p p≥n l r with order l-rank r-rank
makeT {b} {l-rank} {r-rank} p p≥n l r | ge l≥r
  = node p p≥n l≥r l r
makeT {b} {l-rank} {r-rank} p p≥n l r | le r≥l
  = subst (Heap b) (makeT-lemma r-rank l-rank) (node p p≥n r≥l r l)

-- merge combines previous proofs:
--
--  1) it enforces priority invariant by comparing priorities using
--     order function. Recall that this function returns value of
--     Order datatype that not only gives a result of comparison but
--     also supplies evidence that result is true. That evidence is
--     given to makeT which uses it to construct a new node.
--
--  2) it proves size invariant of merge by reusing proofs from
--     TwoPassMerge.RankProof
--
--  3) it delegates the proof of rank invariant to makeT
merge : {i j : Size} {b : Priority} {l r : Rank} → Heap {i} b l → Heap {j} b r
      → Heap b (l + r)
merge empty h2 = h2 -- See [merge, proof 0a]
merge {_} .{_} {b} {suc l} {zero} h1 empty
  = subst (Heap b)
          (sym (+0 (suc l)))  -- See [merge, proof 0b]
          h1
merge .{↑ i} .{↑ j} .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {i} .{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {j}  {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  with order p1 p2
merge .{↑ i} .{↑ j} .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {i} .{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {j}  {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  | le p1≤p2
  = subst (Heap b)
          (proof-1 l1-rank r1-rank l2-rank r2-rank) -- See [merge, proof 1]
          (makeT p1 p1≥b l1 (merge {i} {↑ j} r1 (node p2 p1≤p2 l2≥r2 l2 r2)))
merge .{↑ i} .{↑ j} .{b} {suc .(l1-rank + r1-rank)} {suc .(l2-rank + r2-rank)}
  (node {i} .{b} p1 p1≥b {l1-rank} {r1-rank} l1≥r1 l1 r1)
  (node {j}  {b} p2 p2≥b {l2-rank} {r2-rank} l2≥r2 l2 r2)
  | ge p1≥p2
  = subst (Heap b)
          (proof-2 l1-rank r1-rank l2-rank r2-rank) -- See [merge, proof 2]
          (makeT p2 p2≥b l2 (merge {j} {↑ i} r2 (node p1 p1≥p2 l1≥r1 l1 r1)))

-- Implementations of insert and findMin are the same as
-- previously. We only need to update the type signature accordingly.
insert : {b : Priority} {r : Rank} → Priority → Heap zero r → Heap zero (suc r)
insert p h = merge (singleton p) h

findMin : {b : Priority} {r : Rank} → Heap b (suc r) → Priority
findMin (node p _ _ _ _) = p

-- To define deleteMin we will need to update definition of
-- liftBound. We need to redefine ≥trans because Agda won't let us
-- import it from a module that has unfinished implementation (recall
-- that we left definitions of findMin and deleteMin incomplete in
-- TwoPassMerge.PriorityProof).
≥trans : {a b c : Nat} → a ≥ b → b ≥ c → a ≥ c
≥trans a≥b        ge0      = ge0
≥trans (geS a≥b) (geS b≥c) = geS (≥trans a≥b b≥c)

liftBound : {p b : Priority} → b ≥ p → {r : Rank} → Heap b r → Heap p r
liftBound b≥n empty                = empty
liftBound b≥n (node p p≥b l≥r l r) = node p (≥trans p≥b b≥n) l≥r l r

-- With the new definition of liftBound we can now define deleteMin.
-- Implementation is identical to the one in TwoPassMerge.RankProof -
-- we only had to update type signature.
deleteMin : {b : Priority} {r : Rank} → Heap b (suc r) → Heap b r
deleteMin (node _ p≥b _ l r) = merge (liftBound p≥b l) (liftBound p≥b r)


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category
open import Categories.Support.Equivalence

module Categories.Morphism.Indexed {o ℓ e c q} (C : Category o ℓ e) (B : Setoid c q) where

open import Level using (_⊔_)
open import Data.Product as P using (_,_; _×_)
open import Function as F using () renaming (_∘_ to _⋆_; _∘′_ to _⋆′_)
open import Relation.Binary as B using ()
open import Relation.Binary.HeterogeneousEquality as HE using (_≅_)

open import Categories.Support.PropositionalEquality
open import Categories.Support.SetoidFunctions as SF using (_⟶_; ⟪_,_⟫′)
open import Categories.Support.SetoidPi as SΠ public using (Π; IndexedSetoid) renaming (_⟨$⟩_ to _‼_; cong to cong₁)

import Categories.Object.Indexed as IxOb
open IxOb C B
open Category C
open Heterogeneous C

open Setoid B using () renaming (Carrier to Bc; _≈_ to _≈B_)

open Setoid using () renaming (_≈_ to _[_≈_])

ihom-setoid : {S : Set o} → (S → (Obj × Obj)) → (B ⟶ (set→setoid S)) → IndexedSetoid Bc _≈B_ _ _
ihom-setoid {S} F Xs = record
      -- ok, this is massively ugly, but it gets around some weird problems introduced in 2.5.1.1 (JC)
  { Carrier = λ i → (P.proj₁ (F (_⟶_._⟨$⟩_ Xs i)) ⇒ P.proj₂ (F (_⟶_._⟨$⟩_ Xs i)))
  ; _≈_ = λ f g → f ∼ g
  ; isEquivalence = record
    { refl = refl
    ; sym = sym
    ; trans = trans
    }
  ; resp = λ {i} {j} i≈j → SΠ.resp-per′ (at′ i) (at′ j) (resp₁ i≈j) (resp₂ i≈j)
  }
  where

  -- fake 'at' for resp
  at′ : Bc → Setoid _ _
  at′ i = record
    { Carrier = (P.proj₁ (F (_⟶_._⟨$⟩_ Xs i)) ⇒ P.proj₂ (F (_⟶_._⟨$⟩_ Xs i)))
    ; _≈_ = λ f g → f ∼ g
    ; isEquivalence = record { refl = refl; sym = sym; trans = trans }
    }

  at-≈ : (X : S) → B.Rel ((P.uncurry _⇒_ ⋆′ F) X) (ℓ ⊔ e)
  at-≈ X = λ f g → f ∼ g

  .resp₁ : ∀ {i j} → (i ≈B j) → (P.proj₁ (F (_⟶_._⟨$⟩_ Xs i)) ⇒ P.proj₂ (F (_⟶_._⟨$⟩_ Xs i))) ≣ (P.proj₁ (F (_⟶_._⟨$⟩_ Xs j)) ⇒ P.proj₂ (F (_⟶_._⟨$⟩_ Xs j)))
  resp₁ i≈j = ≣-cong (P.uncurry _⇒_ ⋆′ F) (cong₀ Xs i≈j)

  .resp₂ : ∀ {i j} → (i ≈B j) → Setoid._≈_ (at′ i) ≅ Setoid._≈_ (at′ j)
  resp₂ i≈j = HE.cong at-≈ (HE.≡-to-≅ (cong₀ Xs i≈j))

Fan : Obj → Dust → Set _
Fan X Ys = Π B (ihom-setoid (λ Y → X , Y) Ys)

fan-setoid : Obj → Dust → Setoid _ _
fan-setoid X Ys = SΠ.setoid B (ihom-setoid (λ Y → X , Y) Ys)

_⇒∗_ = Fan
_⇨∗_ = fan-setoid

Plume : Dust → Obj → Set _
Plume Xs Y = Π B (ihom-setoid (λ X → X , Y) Xs)

plume-setoid : Dust → Obj → Setoid _ _
plume-setoid Xs Y = SΠ.setoid B (ihom-setoid (λ X → X , Y) Xs)

_∗⇒_ = Plume
_∗⇨_ = plume-setoid

Dance : Dust → Dust → Set _
Dance Xs Ys = Π B (ihom-setoid F.id ⟪ Xs , Ys ⟫′)

dance-setoid : Dust → Dust → Setoid _ _
dance-setoid Xs Ys = SΠ.setoid B (ihom-setoid F.id ⟪ Xs , Ys ⟫′)

_∗⇒∗_ = Dance
_∗⇨∗_ = dance-setoid

_◃_ : ∀ {Xs Y Z} (f : Y ⇒ Z) (g : Xs ∗⇒ Y) → Xs ∗⇒ Z
f ◃ g = record { _⟨$⟩_ = λ x → f ∘ (g ‼ x)
               ; cong = λ x≈y → ∘-resp-∼ʳ (cong₁ g x≈y) }

_▹_ : ∀ {X Y Zs} (f : Y ⇒∗ Zs) (g : X ⇒ Y) → X ⇒∗ Zs
f ▹ g = record { _⟨$⟩_ = λ x → (f ‼ x) ∘ g
               ; cong = λ x≈y → ∘-resp-∼ˡ (cong₁ f x≈y) }

_⋊_ : ∀ {Xs Ys Z} (f : Ys ∗⇒ Z) (g : Xs ∗⇒∗ Ys) → Xs ∗⇒ Z
f ⋊ g = record { _⟨$⟩_ = λ x → (f ‼ x) ∘ (g ‼ x)
               ; cong = λ x≈y → ∘-resp-∼ (cong₁ f x≈y) (cong₁ g x≈y) }

_⋉_ : ∀ {X Ys Zs} (f : Ys ∗⇒∗ Zs) (g : X ⇒∗ Ys) → X ⇒∗ Zs
f ⋉ g = record { _⟨$⟩_ = λ x → (f ‼ x) ∘ (g ‼ x)
               ; cong = λ x≈y → ∘-resp-∼ (cong₁ f x≈y) (cong₁ g x≈y) }

_⋈_ : ∀ {Xs Y Zs} (f : Y ⇒∗ Zs) (g : Xs ∗⇒ Y) → Xs ∗⇒∗ Zs
f ⋈ g = record { _⟨$⟩_ = λ x → (f ‼ x) ∘ (g ‼ x)
               ; cong = λ x≈y → ∘-resp-∼ (cong₁ f x≈y) (cong₁ g x≈y) }

_◽_ : ∀ {Xs Ys Zs} (f : Ys ∗⇒∗ Zs) (g : Xs ∗⇒∗ Ys) → Xs ∗⇒∗ Zs
f ◽ g = record { _⟨$⟩_ = λ x → (f ‼ x) ∘ (g ‼ x)
               ; cong = λ x≈y → ∘-resp-∼ (cong₁ f x≈y) (cong₁ g x≈y) }

.assoc-◽⋉ : ∀ {X Ys Zs Ws} {f : Zs ∗⇒∗ Ws} {g : Ys ∗⇒∗ Zs} {h : X ⇒∗ Ys}
          → (X ⇨∗ Ws) [ _⋉_ {Ys = Ys} {Ws} (_◽_ {Ys} {Zs} {Ws} f g) h ≈ _⋉_ {Ys = Zs} {Ws} f (_⋉_ {Ys = Ys} {Zs} g h) ]
assoc-◽⋉ {Ys = Ys} {Zs} {Ws} {f = f} {g} {h} {i} {j} i≈j with Ys _⟶_.⟨$⟩ j | cong₀ Ys i≈j | Zs _⟶_.⟨$⟩ j | cong₀ Zs i≈j | Ws _⟶_.⟨$⟩ j | cong₀ Ws i≈j | f ‼ j | cong₁ f i≈j | g ‼ j | cong₁ g i≈j | h ‼ j | cong₁ h i≈j
assoc-◽⋉ {f = f} {g} {h} {i} i≈j | ._ | ≣-refl | ._ | ≣-refl | ._ | ≣-refl | fj | ≡⇒∼ fi≡fj | gj | ≡⇒∼ gi≡gj | hj | ≡⇒∼ hi≡hj =
  ≡⇒∼ (begin
    ((f ‼ i) ∘ (g ‼ i)) ∘ (h ‼ i)
  ↓⟨ ∘-resp-≡ (∘-resp-≡ fi≡fj gi≡gj) hi≡hj ⟩
    (fj ∘ gj) ∘ hj
  ↓⟨ assoc ⟩
    fj ∘ (gj ∘ hj)
  ∎)
  where
  open Heterogeneous C hiding (≡⇒∼)
  open HomReasoning


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

module _ where

Set' : ∀ i → Set _
Set' i = Set i

postulate
  A : Set
  a : A
  T : Set → Set
  comp : (P : A → Set) (g : (a : A) → P a) → P a
  foo : ∀ i (Q : A → Set' i) → T (comp _ Q)
  -- (no issue if Set' is replaced by Set)

bar : T {!_!} -- Try to give _
bar = foo _ _

-- WAS:
-- A !=< Agda.Primitive.Level of type Set
-- when checking that the expression _ has type Set
-- SHOULD: succeed (with unsolved meta)


------------------------------------------------------------------------
-- Equivalences with erased "proofs", defined in terms of partly
-- erased contractible fibres
------------------------------------------------------------------------

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

open import Equality

module Equivalence.Erased.Contractible-preimages
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open Derived-definitions-and-properties eq
open import Prelude

open import Bijection eq using (_↔_)
open import Equivalence eq as Eq using (_≃_; Is-equivalence)
import Equivalence.Contractible-preimages eq as CP
open import Erased.Level-1 eq as Erased
  hiding (module []-cong; module []-cong₁; module []-cong₂)
open import Function-universe eq hiding (id; _∘_)
open import H-level eq as H-level
open import H-level.Closure eq
open import Preimage eq as Preimage using (_⁻¹_)
open import Surjection eq using (_↠_; Split-surjective)

private
  variable
    a b ℓ ℓ₁ ℓ₂      : Level
    A B              : Type a
    c ext k k′ p x y : A
    P                : A → Type p
    f                : (x : A) → P x

------------------------------------------------------------------------
-- Some basic types

-- "Preimages" with erased proofs.

infix 5 _⁻¹ᴱ_

_⁻¹ᴱ_ : {A : Type a} {@0 B : Type b} → @0 (A → B) → @0 B → Type (a ⊔ b)
f ⁻¹ᴱ y = ∃ λ x → Erased (f x ≡ y)

-- Contractibility with an erased proof.

Contractibleᴱ : Type ℓ → Type ℓ
Contractibleᴱ A = ∃ λ (x : A) → Erased (∀ y → x ≡ y)

-- The property of being an equivalence (with erased proofs).

Is-equivalenceᴱ : {A : Type a} {B : Type b} → @0 (A → B) → Type (a ⊔ b)
Is-equivalenceᴱ f = ∀ y → Contractibleᴱ (f ⁻¹ᴱ y)

-- Equivalences with erased proofs.

_≃ᴱ_ : Type a → Type b → Type (a ⊔ b)
A ≃ᴱ B = ∃ λ (f : A → B) → Is-equivalenceᴱ f

------------------------------------------------------------------------
-- Some conversion lemmas

-- Conversions between _⁻¹_ and _⁻¹ᴱ_.

⁻¹→⁻¹ᴱ :
  {@0 A : Type a} {@0 B : Type b} {@0 f : A → B} {@0 y : B} →
  f ⁻¹ y → f ⁻¹ᴱ y
⁻¹→⁻¹ᴱ = Σ-map id [_]→

@0 ⁻¹ᴱ→⁻¹ : f ⁻¹ᴱ x → f ⁻¹ x
⁻¹ᴱ→⁻¹ = Σ-map id erased

@0 ⁻¹≃⁻¹ᴱ : f ⁻¹ y ≃ f ⁻¹ᴱ y
⁻¹≃⁻¹ᴱ {f = f} {y = y} =
  (∃ λ x → f x ≡ y)           ↝⟨ (∃-cong λ _ → Eq.inverse $ Eq.↔⇒≃ $ erased Erased↔) ⟩□
  (∃ λ x → Erased (f x ≡ y))  □

_ : _≃_.to ⁻¹≃⁻¹ᴱ p ≡ ⁻¹→⁻¹ᴱ p
_ = refl _

@0 _ : _≃_.from ⁻¹≃⁻¹ᴱ p ≡ ⁻¹ᴱ→⁻¹ p
_ = refl _

-- Conversions between Contractible and Contractibleᴱ.

Contractible→Contractibleᴱ :
  {@0 A : Type a} →
  Contractible A → Contractibleᴱ A
Contractible→Contractibleᴱ = Σ-map id [_]→

@0 Contractibleᴱ→Contractible : Contractibleᴱ A → Contractible A
Contractibleᴱ→Contractible = Σ-map id erased

@0 Contractible≃Contractibleᴱ :
  Contractible A ≃ Contractibleᴱ A
Contractible≃Contractibleᴱ =
  (∃ λ x → ∀ y → x ≡ y)           ↝⟨ (∃-cong λ _ → Eq.inverse $ Eq.↔⇒≃ $ erased Erased↔) ⟩□
  (∃ λ x → Erased (∀ y → x ≡ y))  □

_ :
  _≃_.to Contractible≃Contractibleᴱ c ≡ Contractible→Contractibleᴱ c
_ = refl _

@0 _ :
  _≃_.from Contractible≃Contractibleᴱ c ≡ Contractibleᴱ→Contractible c
_ = refl _

-- Conversions between CP.Is-equivalence and Is-equivalenceᴱ.

Is-equivalence→Is-equivalenceᴱ :
  {@0 A : Type a} {@0 B : Type b} {@0 f : A → B} →
  CP.Is-equivalence f → Is-equivalenceᴱ f
Is-equivalence→Is-equivalenceᴱ eq y =
    ⁻¹→⁻¹ᴱ (proj₁₀ (eq y))
  , [ cong ⁻¹→⁻¹ᴱ ∘ proj₂ (eq y) ∘ ⁻¹ᴱ→⁻¹ ]

@0 Is-equivalenceᴱ→Is-equivalence :
  Is-equivalenceᴱ f → CP.Is-equivalence f
Is-equivalenceᴱ→Is-equivalence eq y =
    ⁻¹ᴱ→⁻¹ (proj₁ (eq y))
  , cong ⁻¹ᴱ→⁻¹ ∘ erased (proj₂ (eq y)) ∘ ⁻¹→⁻¹ᴱ

private

  -- In an erased context CP.Is-equivalence and Is-equivalenceᴱ are
  -- pointwise equivalent (assuming extensionality).
  --
  -- This lemma is not exported. See Is-equivalence≃Is-equivalenceᴱ
  -- below, which computes in a different way.

  @0 Is-equivalence≃Is-equivalenceᴱ′ :
    {A : Type a} {B : Type b} {f : A → B} →
    CP.Is-equivalence f ↝[ a ⊔ b ∣ a ⊔ b ] Is-equivalenceᴱ f
  Is-equivalence≃Is-equivalenceᴱ′ {a = a} {f = f} {k = k} ext =
    (∀ y → Contractible (f ⁻¹ y))    ↝⟨ (∀-cong ext′ λ _ → H-level-cong ext 0 ⁻¹≃⁻¹ᴱ) ⟩
    (∀ y → Contractible (f ⁻¹ᴱ y))   ↝⟨ (∀-cong ext′ λ _ → from-isomorphism Contractible≃Contractibleᴱ) ⟩□
    (∀ y → Contractibleᴱ (f ⁻¹ᴱ y))  □
    where
    ext′ = lower-extensionality? k a lzero ext

------------------------------------------------------------------------
-- Some type formers are propositional in erased contexts

-- In an erased context Contractibleᴱ is propositional (assuming
-- extensionality).

@0 Contractibleᴱ-propositional :
  {A : Type a} →
  Extensionality a a →
  Is-proposition (Contractibleᴱ A)
Contractibleᴱ-propositional ext =
  H-level.respects-surjection
    (_≃_.surjection Contractible≃Contractibleᴱ)
    1
    (Contractible-propositional ext)

-- In an erased context Is-equivalenceᴱ f is a proposition (assuming
-- extensionality).
--
-- See also Is-equivalenceᴱ-propositional-for-Erased below.

@0 Is-equivalenceᴱ-propositional :
  {A : Type a} {B : Type b} →
  Extensionality (a ⊔ b) (a ⊔ b) →
  (f : A → B) → Is-proposition (Is-equivalenceᴱ f)
Is-equivalenceᴱ-propositional ext f =
  H-level.respects-surjection
    (_≃_.surjection $ Is-equivalence≃Is-equivalenceᴱ′ ext)
    1
    (CP.propositional ext f)

------------------------------------------------------------------------
-- More conversion lemmas

-- In an erased context CP.Is-equivalence and Is-equivalenceᴱ are
-- pointwise equivalent (assuming extensionality).

@0 Is-equivalence≃Is-equivalenceᴱ :
  {A : Type a} {B : Type b} {f : A → B} →
  CP.Is-equivalence f ↝[ a ⊔ b ∣ a ⊔ b ] Is-equivalenceᴱ f
Is-equivalence≃Is-equivalenceᴱ {k = equivalence} ext =
  Eq.with-other-function
    (Eq.with-other-inverse
       (Is-equivalence≃Is-equivalenceᴱ′ ext)
       Is-equivalenceᴱ→Is-equivalence
       (λ _ → CP.propositional ext _ _ _))
    Is-equivalence→Is-equivalenceᴱ
    (λ _ → Is-equivalenceᴱ-propositional ext _ _ _)
Is-equivalence≃Is-equivalenceᴱ = Is-equivalence≃Is-equivalenceᴱ′

_ :
  _≃_.to (Is-equivalence≃Is-equivalenceᴱ ext) p ≡
  Is-equivalence→Is-equivalenceᴱ p
_ = refl _

@0 _ :
  _≃_.from (Is-equivalence≃Is-equivalenceᴱ ext) p ≡
  Is-equivalenceᴱ→Is-equivalence p
_ = refl _

-- Conversions between CP._≃_ and _≃ᴱ_.

≃→≃ᴱ :
  {@0 A : Type a} {@0 B : Type b} →
  A CP.≃ B → A ≃ᴱ B
≃→≃ᴱ = Σ-map id Is-equivalence→Is-equivalenceᴱ

@0 ≃ᴱ→≃ : A ≃ᴱ B → A CP.≃ B
≃ᴱ→≃ = Σ-map id Is-equivalenceᴱ→Is-equivalence

-- In an erased context CP._≃_ and _≃ᴱ_ are pointwise equivalent
-- (assuming extensionality).

@0 ≃≃≃ᴱ :
  {A : Type a} {B : Type b} →
  (A CP.≃ B) ↝[ a ⊔ b ∣ a ⊔ b ] (A ≃ᴱ B)
≃≃≃ᴱ {A = A} {B = B} ext =
  A CP.≃ B                       ↔⟨⟩
  (∃ λ f → CP.Is-equivalence f)  ↝⟨ (∃-cong λ _ → Is-equivalence≃Is-equivalenceᴱ ext) ⟩
  (∃ λ f → Is-equivalenceᴱ f)    ↔⟨⟩
  A ≃ᴱ B                         □

_ : _≃_.to (≃≃≃ᴱ ext) p ≡ ≃→≃ᴱ p
_ = refl _

@0 _ : _≃_.from (≃≃≃ᴱ ext) p ≡ ≃ᴱ→≃ p
_ = refl _

-- An isomorphism relating _⁻¹ᴱ_ to _⁻¹_.

Erased-⁻¹ᴱ↔Erased-⁻¹ :
  {@0 A : Type a} {@0 B : Type b} {@0 f : A → B} {@0 y : B} →
  Erased (f ⁻¹ᴱ y) ↔ Erased (f ⁻¹ y)
Erased-⁻¹ᴱ↔Erased-⁻¹ {f = f} {y = y} =
  Erased (∃ λ x → Erased (f x ≡ y))             ↝⟨ Erased-Σ↔Σ ⟩
  (∃ λ x → Erased (Erased (f (erased x) ≡ y)))  ↝⟨ (∃-cong λ _ → Erased-Erased↔Erased) ⟩
  (∃ λ x → Erased (f (erased x) ≡ y))           ↝⟨ inverse Erased-Σ↔Σ ⟩□
  Erased (∃ λ x → f x ≡ y)                      □

-- An isomorphism relating Contractibleᴱ to Contractible.

Erased-Contractibleᴱ↔Erased-Contractible :
  {@0 A : Type a} →
  Erased (Contractibleᴱ A) ↔ Erased (Contractible A)
Erased-Contractibleᴱ↔Erased-Contractible =
  Erased (∃ λ x → Erased (∀ y → x ≡ y))           ↝⟨ Erased-Σ↔Σ ⟩
  (∃ λ x → Erased (Erased (∀ y → erased x ≡ y)))  ↝⟨ (∃-cong λ _ → Erased-Erased↔Erased) ⟩
  (∃ λ x → Erased (∀ y → erased x ≡ y))           ↝⟨ inverse Erased-Σ↔Σ ⟩□
  Erased (∃ λ x → ∀ y → x ≡ y)                    □

------------------------------------------------------------------------
-- Some results related to Contractibleᴱ

-- Contractibleᴱ respects split surjections with erased proofs.

Contractibleᴱ-respects-surjection :
  {@0 A : Type a} {@0 B : Type b}
  (f : A → B) → @0 Split-surjective f →
  Contractibleᴱ A → Contractibleᴱ B
Contractibleᴱ-respects-surjection {A = A} {B = B} f s h@(x , _) =
    f x
  , [ proj₂ (H-level.respects-surjection surj 0
               (Contractibleᴱ→Contractible h))
    ]
  where
  @0 surj : A ↠ B
  surj = record
    { logical-equivalence = record
      { to   = f
      ; from = proj₁ ∘ s
      }
    ; right-inverse-of = proj₂ ∘ s
    }

-- "Preimages" (with erased proofs) of an erased function with a
-- quasi-inverse with erased proofs are contractible.

Contractibleᴱ-⁻¹ᴱ :
  {@0 A : Type a} {@0 B : Type b}
  (@0 f : A → B)
  (g : B → A)
  (@0 f∘g : ∀ x → f (g x) ≡ x)
  (@0 g∘f : ∀ x → g (f x) ≡ x) →
  ∀ y → Contractibleᴱ (f ⁻¹ᴱ y)
Contractibleᴱ-⁻¹ᴱ {A = A} {B = B} f g f∘g g∘f y =
    (g y , [ proj₂ (proj₁ c′) ])
  , [ cong ⁻¹→⁻¹ᴱ ∘ proj₂ c′ ∘ ⁻¹ᴱ→⁻¹ ]
  where
  @0 A↔B : A ↔ B
  A↔B = record
    { surjection = record
      { logical-equivalence = record
        { to   = f
        ; from = g
        }
      ; right-inverse-of = f∘g
      }
    ; left-inverse-of = g∘f
    }

  @0 c′ : Contractible (f ⁻¹ y)
  c′ = Preimage.bijection⁻¹-contractible A↔B y

-- If an inhabited type comes with an erased proof of
-- propositionality, then it is contractible (with erased proofs).

inhabited→Is-proposition→Contractibleᴱ :
  {@0 A : Type a} →
  A → @0 Is-proposition A → Contractibleᴱ A
inhabited→Is-proposition→Contractibleᴱ x prop = (x , [ prop x ])

-- Some closure properties.

Contractibleᴱ-Σ :
  {@0 A : Type a} {@0 P : A → Type p} →
  Contractibleᴱ A → (∀ x → Contractibleᴱ (P x)) → Contractibleᴱ (Σ A P)
Contractibleᴱ-Σ cA@(a , _) cP =
    (a , proj₁₀ (cP a))
  , [ proj₂ $ Σ-closure 0 (Contractibleᴱ→Contractible cA)
                          (Contractibleᴱ→Contractible ∘ cP)
    ]

Contractibleᴱ-× :
  {@0 A : Type a} {@0 B : Type b} →
  Contractibleᴱ A → Contractibleᴱ B → Contractibleᴱ (A × B)
Contractibleᴱ-× cA cB = Contractibleᴱ-Σ cA (λ _ → cB)

Contractibleᴱ-Π :
  {@0 A : Type a} {@0 P : A → Type p} →
  @0 Extensionality a p →
  (∀ x → Contractibleᴱ (P x)) → Contractibleᴱ ((x : A) → P x)
Contractibleᴱ-Π ext c =
    proj₁₀ ∘ c
  , [ proj₂ $ Π-closure ext 0 (Contractibleᴱ→Contractible ∘ c)
    ]

Contractibleᴱ-↑ :
  {@0 A : Type a} →
  Contractibleᴱ A → Contractibleᴱ (↑ ℓ A)
Contractibleᴱ-↑ c@(a , _) =
    lift a
  , [ proj₂ $ ↑-closure 0 (Contractibleᴱ→Contractible c)
    ]

------------------------------------------------------------------------
-- Results that follow if the []-cong axioms hold for one universe
-- level

module []-cong₁ (ax : []-cong-axiomatisation ℓ) where

  open Erased-cong ax ax
  open Erased.[]-cong₁ ax

  ----------------------------------------------------------------------
  -- Some results related to _⁻¹ᴱ_

  -- The function _⁻¹ᴱ y respects erased extensional equality.

  ⁻¹ᴱ-respects-extensional-equality :
    {@0 B : Type ℓ} {@0 f g : A → B} {@0 y : B} →
    @0 (∀ x → f x ≡ g x) → f ⁻¹ᴱ y ≃ g ⁻¹ᴱ y
  ⁻¹ᴱ-respects-extensional-equality {f = f} {g = g} {y = y} f≡g =
    (∃ λ x → Erased (f x ≡ y))  ↝⟨ (∃-cong λ _ → Erased-cong-≃ (≡⇒↝ _ (cong (_≡ _) $ f≡g _))) ⟩□
    (∃ λ x → Erased (g x ≡ y))  □

  -- An isomorphism relating _⁻¹ᴱ_ to _⁻¹_.

  ⁻¹ᴱ[]↔⁻¹[] :
    {@0 B : Type ℓ} {f : A → Erased B} {@0 y : B} →
    f ⁻¹ᴱ [ y ] ↔ f ⁻¹ [ y ]
  ⁻¹ᴱ[]↔⁻¹[] {f = f} {y = y} =
    (∃ λ x → Erased (f x ≡ [ y ]))       ↔⟨ (∃-cong λ _ → Erased-cong-≃ (Eq.≃-≡ $ Eq.↔⇒≃ $ inverse $ erased Erased↔)) ⟩
    (∃ λ x → Erased (erased (f x) ≡ y))  ↝⟨ (∃-cong λ _ → Erased-≡↔[]≡[]) ⟩□
    (∃ λ x → f x ≡ [ y ])                □

  -- Erased "commutes" with _⁻¹ᴱ_.

  Erased-⁻¹ᴱ :
    {@0 A : Type a} {@0 B : Type ℓ} {@0 f : A → B} {@0 y : B} →
    Erased (f ⁻¹ᴱ y) ↔ map f ⁻¹ᴱ [ y ]
  Erased-⁻¹ᴱ {f = f} {y = y} =
    Erased (f ⁻¹ᴱ y)  ↝⟨ Erased-⁻¹ᴱ↔Erased-⁻¹ ⟩
    Erased (f ⁻¹ y)   ↝⟨ Erased-⁻¹ ⟩
    map f ⁻¹ [ y ]    ↝⟨ inverse ⁻¹ᴱ[]↔⁻¹[] ⟩□
    map f ⁻¹ᴱ [ y ]   □

  ----------------------------------------------------------------------
  -- Some results related to Contractibleᴱ

  -- Erased commutes with Contractibleᴱ.

  Erased-Contractibleᴱ↔Contractibleᴱ-Erased :
    {@0 A : Type ℓ} →
    Erased (Contractibleᴱ A) ↝[ ℓ ∣ ℓ ]ᴱ Contractibleᴱ (Erased A)
  Erased-Contractibleᴱ↔Contractibleᴱ-Erased {A = A} ext =
    Erased (∃ λ x → Erased ((y : A) → x ≡ y))           ↔⟨ Erased-cong-↔ (∃-cong λ _ → erased Erased↔) ⟩
    Erased (∃ λ x → (y : A) → x ≡ y)                    ↔⟨ Erased-Σ↔Σ ⟩
    (∃ λ x → Erased ((y : A) → erased x ≡ y))           ↝⟨ (∃-cong λ _ →
                                                            Erased-cong?
                                                              (λ ext → ∀-cong ext λ _ →
                                                                         from-isomorphism (inverse $ erased Erased↔))
                                                              ext) ⟩
    (∃ λ x → Erased ((y : A) → Erased (erased x ≡ y)))  ↝⟨ (∃-cong λ _ →
                                                            Erased-cong?
                                                              (λ ext → Π-cong ext (inverse $ erased Erased↔) λ _ →
                                                                         from-isomorphism Erased-≡↔[]≡[])
                                                              ext) ⟩□
    (∃ λ x → Erased ((y : Erased A) → x ≡ y))           □

  -- An isomorphism relating Contractibleᴱ to Contractible.

  Contractibleᴱ-Erased↔Contractible-Erased :
    {@0 A : Type ℓ} →
    Contractibleᴱ (Erased A) ↝[ ℓ ∣ ℓ ] Contractible (Erased A)
  Contractibleᴱ-Erased↔Contractible-Erased {A = A} ext =
    Contractibleᴱ (Erased A)  ↝⟨ inverse-erased-ext? Erased-Contractibleᴱ↔Contractibleᴱ-Erased ext ⟩
    Erased (Contractibleᴱ A)  ↔⟨ Erased-Contractibleᴱ↔Erased-Contractible ⟩
    Erased (Contractible A)   ↝⟨ Erased-H-level↔H-level 0 ext ⟩□
    Contractible (Erased A)   □

------------------------------------------------------------------------
-- Results that follow if the []-cong axioms hold for two universe
-- levels

module []-cong₂
  (ax₁ : []-cong-axiomatisation ℓ₁)
  (ax₂ : []-cong-axiomatisation ℓ₂)
  where

  open Erased-cong ax₁ ax₂

  ----------------------------------------------------------------------
  -- A result related to Contractibleᴱ

  -- Contractibleᴱ preserves isomorphisms (assuming extensionality).

  Contractibleᴱ-cong :
    {A : Type ℓ₁} {B : Type ℓ₂} →
    @0 Extensionality? k′ (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂) →
    A ↔[ k ] B → Contractibleᴱ A ↝[ k′ ] Contractibleᴱ B
  Contractibleᴱ-cong {A = A} {B = B} ext A↔B =
    (∃ λ (x : A) → Erased ((y : A) → x ≡ y))  ↝⟨ (Σ-cong A≃B′ λ _ →
                                                  Erased-cong?
                                                    (λ ext → Π-cong ext A≃B′ λ _ →
                                                             from-isomorphism $ inverse $ Eq.≃-≡ A≃B′)
                                                    ext) ⟩□
    (∃ λ (x : B) → Erased ((y : B) → x ≡ y))  □
    where
    A≃B′ = from-isomorphism A↔B

------------------------------------------------------------------------
-- Results that follow if the []-cong axioms hold for all universe
-- levels

module []-cong (ax : ∀ {ℓ} → []-cong-axiomatisation ℓ) where

  private
    open module BC₁ {ℓ} =
      []-cong₁ (ax {ℓ = ℓ})
      public
    open module BC₂ {ℓ₁ ℓ₂} =
      []-cong₂ (ax {ℓ = ℓ₁}) (ax {ℓ = ℓ₂})
      public


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

module Experiment.TTG where

{-
data Phase : Set where
  parse : Phase
  scopecheck : Phase
  typecheck : Phase

xVar : Phase → Set
xVar p = ?

idP : Phase → Set
idP p = ?

xNew : Phase → Set

data Exp (p : Phase) : Set where
  var : xVar p → idP p → Exp p
  new : xNew p → Exp p
-}


{-# OPTIONS --without-K --safe #-}
module Experiment.EvenOdd where

open import Data.List
open import Data.List.Relation.Unary.All
open import Data.Product hiding (map)
open import Data.Sum as Sum hiding (map)
open import Data.Nat
open import Data.Nat.GeneralisedArithmetic
import Data.Nat.Properties as ℕₚ
open import Function.Base
open import Relation.Binary.PropositionalEquality

data RoseTree {a} (A : Set a) : Set a where
  node : A → List (RoseTree A) → RoseTree A

unnode : ∀ {a} {A : Set a} → RoseTree A → A × List (RoseTree A)
unnode (node x rs) = x , rs

foldRoseTree : ∀ {a b} {A : Set a} {B : Set b} →
               (A → List B → B) → RoseTree A → B
foldRoseTrees : ∀ {a b} {A : Set a} {B : Set b} →
                (A → List B → B) → List (RoseTree A) → List B
foldRoseTree f (node x rs) = f x (foldRoseTrees f rs)
foldRoseTrees f []       = []
foldRoseTrees f (x ∷ rs) = foldRoseTree f x ∷ foldRoseTrees f rs

mapRoseTree : ∀ {a b} {A : Set a} {B : Set b} →
              (A → B) → RoseTree A → RoseTree B
mapRoseTree f r = foldRoseTree (λ x rs → node (f x) rs) r

data Parity : Set where
  even odd : Parity

data Pos : Set where
  one  : Pos
  node : Parity → Pos → List Pos → Pos

op : Parity → Parity
op even = odd
op odd  = even

induction : ∀ {p} {P : Pos → Set p} →
            P one →
            (∀ pa x xs → P x → All P xs → P (node pa x xs)) →
            ∀ n → P n
induction-node : ∀ {p} {P : Pos → Set p} →
                 P one →
                 (∀ pa x xs → P x → All P xs → P (node pa x xs)) →
                 ∀ ns → All P ns
induction P1 Pn one            = P1
induction P1 Pn (node pa n ns) = Pn pa n ns (induction P1 Pn n) (induction-node P1 Pn ns)
induction-node P1 Pn []       = []
induction-node P1 Pn (x ∷ ns) = induction P1 Pn x ∷ induction-node P1 Pn ns

recursion : ∀ {a} {A : Set a} → A → (Parity → A → List A → A) → Pos → A
recursion o n p = induction o (λ pa _ _ x AllAxs → n pa x (reduce id AllAxs)) p

ℕ⁺ : Set
ℕ⁺ = Σ ℕ (λ n → n ≢ 0)

1ℕ⁺ : ℕ⁺
1ℕ⁺ = 1 , (λ ())

2ℕ⁺ : ℕ⁺
2ℕ⁺ = 2 , (λ ())

sucℕ⁺ : ℕ⁺ → ℕ⁺
sucℕ⁺ (n , _) = suc n , λ ()

_+ℕ⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
(m , m≢0) +ℕ⁺ (n , n≢0) = (m + n) , (λ m+n≡0 → m≢0 (ℕₚ.m+n≡0⇒m≡0 m m+n≡0) )

private
  m*n≡0⇒m≡0∨n≡0 : ∀ m {n} → m * n ≡ 0 → m ≡ 0 ⊎ n ≡ 0
  m*n≡0⇒m≡0∨n≡0 zero    {zero}  m+n≡0 = inj₁ refl
  m*n≡0⇒m≡0∨n≡0 zero    {suc n} m+n≡0 = inj₁ refl
  m*n≡0⇒m≡0∨n≡0 (suc m) {zero}  m+n≡0 = inj₂ refl

_*ℕ⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
(m , m≢0) *ℕ⁺ (n , n≢0) =
  (m * n) , λ m*n≡0 → Sum.[ m≢0 , n≢0 ] (m*n≡0⇒m≡0∨n≡0 m m*n≡0)

private
  m^n≡0⇒m≡0 : ∀ m n → m ^ n ≡ 0 → m ≡ 0
  m^n≡0⇒m≡0 zero    (suc n) m^n≡0 = refl
  m^n≡0⇒m≡0 (suc m) (suc n) m^n≡0 with m*n≡0⇒m≡0∨n≡0 (suc m) m^n≡0
  ... | inj₂ sm^n≡0 = m^n≡0⇒m≡0 (suc m) n sm^n≡0

_^ℕ⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
(m , m≢0) ^ℕ⁺ (n , n≢0) = (m ^ n) , λ m^n≡0 → m≢0 (m^n≡0⇒m≡0 m n m^n≡0)

_⊓ℕ⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
(m , m≢0) ⊓ℕ⁺ (n , n≢0) = (m ⊓ n) , {!   !}

oℕ : ℕ → ℕ
oℕ n = 2 * n

iℕ : ℕ → ℕ
iℕ n = 1 + 2 * n

oℕ⁺ : ℕ⁺ → ℕ⁺
oℕ⁺ n = 2ℕ⁺ *ℕ⁺ n

iℕ⁺ : ℕ⁺ → ℕ⁺
iℕ⁺ n = sucℕ⁺ (2ℕ⁺ *ℕ⁺ n)

o^ℕ⁺ : ℕ⁺ → ℕ⁺ → ℕ⁺
o^ℕ⁺ (m , _) x = fold x oℕ⁺ m

i^ℕ⁺ : ℕ⁺ → ℕ⁺ → ℕ⁺
i^ℕ⁺ (m , _) x = fold x iℕ⁺ m

toℕ⁺ : Pos → ℕ⁺
toℕ⁺ = recursion 1ℕ⁺ f
  where
  f : Parity → ℕ⁺ → List ℕ⁺ → ℕ⁺
  f even x []       = o^ℕ⁺ x 1ℕ⁺
  f even x (y ∷ xs) = o^ℕ⁺ x (f odd y xs)
  f odd  x []       = i^ℕ⁺ x 1ℕ⁺
  f odd  x (y ∷ xs) = i^ℕ⁺ x (f even y xs)