-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Gentzen-style formalisation of syntax with context pairs, after Pfenning-Davies.

module BasicIS4.Syntax.DyadicGentzen where

open import BasicIS4.Syntax.Common public

-- Derivations.

infix 3 _⊢_
data _⊢_ : Cx² Ty Ty → Ty → Set where
  var   : ∀ {A Γ Δ}   → A ∈ Γ → Γ ⁏ Δ ⊢ A
  lam   : ∀ {A B Γ Δ} → Γ , A ⁏ Δ ⊢ B → Γ ⁏ Δ ⊢ A ▻ B
  app   : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ▻ B → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ B
  mvar  : ∀ {A Γ Δ}   → A ∈ Δ → Γ ⁏ Δ ⊢ A
  box   : ∀ {A Γ Δ}   → ∅ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ □ A
  unbox : ∀ {A C Γ Δ} → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ , A ⊢ C → Γ ⁏ Δ ⊢ C
  pair  : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ B → Γ ⁏ Δ ⊢ A ∧ B
  fst   : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ∧ B → Γ ⁏ Δ ⊢ A
  snd   : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ∧ B → Γ ⁏ Δ ⊢ B
  unit  : ∀ {Γ Δ}     → Γ ⁏ Δ ⊢ ⊤

infix 3 _⊢⋆_
_⊢⋆_ : Cx² Ty Ty → Cx Ty → Set
Γ ⁏ Δ ⊢⋆ ∅     = 𝟙
Γ ⁏ Δ ⊢⋆ Ξ , A = Γ ⁏ Δ ⊢⋆ Ξ × Γ ⁏ Δ ⊢ A

-- Monotonicity with respect to context inclusion.

mono⊢ : ∀ {A Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢ A → Γ′ ⁏ Δ ⊢ A
mono⊢ η (var i)     = var (mono∈ η i)
mono⊢ η (lam t)     = lam (mono⊢ (keep η) t)
mono⊢ η (app t u)   = app (mono⊢ η t) (mono⊢ η u)
mono⊢ η (mvar i)    = mvar i
mono⊢ η (box t)     = box t
mono⊢ η (unbox t u) = unbox (mono⊢ η t) (mono⊢ η u)
mono⊢ η (pair t u)  = pair (mono⊢ η t) (mono⊢ η u)
mono⊢ η (fst t)     = fst (mono⊢ η t)
mono⊢ η (snd t)     = snd (mono⊢ η t)
mono⊢ η unit        = unit

mono⊢⋆ : ∀ {Ξ Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢⋆ Ξ → Γ′ ⁏ Δ ⊢⋆ Ξ
mono⊢⋆ {∅}     η ∙        = ∙
mono⊢⋆ {Ξ , A} η (ts , t) = mono⊢⋆ η ts , mono⊢ η t

-- Monotonicity with respect to modal context inclusion.

mmono⊢ : ∀ {A Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ′ ⊢ A
mmono⊢ θ (var i)     = var i
mmono⊢ θ (lam t)     = lam (mmono⊢ θ t)
mmono⊢ θ (app t u)   = app (mmono⊢ θ t) (mmono⊢ θ u)
mmono⊢ θ (mvar i)    = mvar (mono∈ θ i)
mmono⊢ θ (box t)     = box (mmono⊢ θ t)
mmono⊢ θ (unbox t u) = unbox (mmono⊢ θ t) (mmono⊢ (keep θ) u)
mmono⊢ θ (pair t u)  = pair (mmono⊢ θ t) (mmono⊢ θ u)
mmono⊢ θ (fst t)     = fst (mmono⊢ θ t)
mmono⊢ θ (snd t)     = snd (mmono⊢ θ t)
mmono⊢ θ unit        = unit

mmono⊢⋆ : ∀ {Ξ Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢⋆ Ξ → Γ ⁏ Δ′ ⊢⋆ Ξ
mmono⊢⋆ {∅}     θ ∙        = ∙
mmono⊢⋆ {Ξ , A} θ (ts , t) = mmono⊢⋆ θ ts , mmono⊢ θ t

-- Monotonicity using context pairs.

mono²⊢ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊢ A → Π′ ⊢ A
mono²⊢ (η , θ) = mono⊢ η ∘ mmono⊢ θ

-- Shorthand for variables.

v₀ : ∀ {A Γ Δ} → Γ , A ⁏ Δ ⊢ A
v₀ = var i₀

v₁ : ∀ {A B Γ Δ} → Γ , A , B ⁏ Δ ⊢ A
v₁ = var i₁

v₂ : ∀ {A B C Γ Δ} → Γ , A , B , C ⁏ Δ ⊢ A
v₂ = var i₂

mv₀ : ∀ {A Γ Δ} → Γ ⁏ Δ , A ⊢ A
mv₀ = mvar i₀

mv₁ : ∀ {A B Γ Δ} → Γ ⁏ Δ , A , B ⊢ A
mv₁ = mvar i₁

mv₂ : ∀ {A B C Γ Δ} → Γ ⁏ Δ , A , B , C ⊢ A
mv₂ = mvar i₂

-- Reflexivity.

refl⊢⋆ : ∀ {Γ Δ} → Γ ⁏ Δ ⊢⋆ Γ
refl⊢⋆ {∅}     = ∙
refl⊢⋆ {Γ , A} = mono⊢⋆ weak⊆ refl⊢⋆ , v₀

mrefl⊢⋆ : ∀ {Δ Γ} → Γ ⁏ Δ ⊢⋆ □⋆ Δ
mrefl⊢⋆ {∅}     = ∙
mrefl⊢⋆ {Δ , A} = mmono⊢⋆ weak⊆ mrefl⊢⋆ , box mv₀

mrefl⊢⋆′ : ∀ {Δ Δ′ Γ Γ′} → (∀ {A} → Γ ⁏ Δ ⊢ □ A → Γ′ ⁏ Δ′ ⊢ A) → Γ′ ⁏ Δ′ ⊢⋆ Δ
mrefl⊢⋆′ {∅}     f = ∙
mrefl⊢⋆′ {Δ , B} f = mrefl⊢⋆′ (f ∘ mmono⊢ weak⊆) , f (box mv₀)

-- Deduction theorem is built-in.

lam⋆ : ∀ {Ξ A Γ Δ} → Γ ⧺ Ξ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ Ξ ▻⋯▻ A
lam⋆ {∅}     = I
lam⋆ {Ξ , B} = lam⋆ {Ξ} ∘ lam

lam⋆₀ : ∀ {Γ A Δ} → Γ ⁏ Δ ⊢ A → ∅ ⁏ Δ ⊢ Γ ▻⋯▻ A
lam⋆₀ {∅}     = I
lam⋆₀ {Γ , B} = lam⋆₀ ∘ lam

-- Modal deduction theorem.

mlam : ∀ {A B Γ Δ} → Γ ⁏ Δ , A ⊢ B → Γ ⁏ Δ ⊢ □ A ▻ B
mlam t = lam (unbox v₀ (mono⊢ weak⊆ t))

mlam⋆ : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ ⧺ Ξ ⊢ A → Γ ⁏ Δ ⊢ □⋆ Ξ ▻⋯▻ A
mlam⋆ {∅}     = I
mlam⋆ {Ξ , B} = mlam⋆ {Ξ} ∘ mlam

mlam⋆₀ : ∀ {Δ A Γ} → Γ ⁏ Δ ⊢ A → Γ ⁏ ∅ ⊢ □⋆ Δ ▻⋯▻ A
mlam⋆₀ {∅}     = I
mlam⋆₀ {Δ , B} = mlam⋆₀ ∘ mlam

-- Detachment theorems.

det : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ▻ B → Γ , A ⁏ Δ ⊢ B
det t = app (mono⊢ weak⊆ t) v₀

det⋆ : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ ⊢ Ξ ▻⋯▻ A → Γ ⧺ Ξ ⁏ Δ ⊢ A
det⋆ {∅}     = I
det⋆ {Ξ , B} = det ∘ det⋆ {Ξ}

det⋆₀ : ∀ {Γ A Δ} → ∅ ⁏ Δ ⊢ Γ ▻⋯▻ A → Γ ⁏ Δ ⊢ A
det⋆₀ {∅}     = I
det⋆₀ {Γ , B} = det ∘ det⋆₀

mdet : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ A ▻ B → Γ ⁏ Δ , A ⊢ B
mdet t = app (mmono⊢ weak⊆ t) (box mv₀)

mdet⋆ : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ ⊢ □⋆ Ξ ▻⋯▻ A → Γ ⁏ Δ ⧺ Ξ ⊢ A
mdet⋆ {∅}     = I
mdet⋆ {Ξ , B} = mdet ∘ mdet⋆ {Ξ}

mdet⋆₀ : ∀ {Δ A Γ} → Γ ⁏ ∅ ⊢ □⋆ Δ ▻⋯▻ A → Γ ⁏ Δ ⊢ A
mdet⋆₀ {∅}     = I
mdet⋆₀ {Δ , B} = mdet ∘ mdet⋆₀

-- Context manipulation.

merge : ∀ {Δ A Γ} → Γ ⁏ Δ ⊢ A → Γ ⧺ (□⋆ Δ) ⁏ ∅ ⊢ A
merge {Δ} = det⋆ {□⋆ Δ} ∘ mlam⋆₀

mmerge : ∀ {Γ A Δ} → □⋆ Γ ⁏ Δ ⊢ A → ∅ ⁏ Δ ⧺ Γ ⊢ A
mmerge {Γ} = mdet⋆ {Γ} ∘ lam⋆₀

split : ∀ {Δ A Γ} → Γ ⧺ (□⋆ Δ) ⁏ ∅ ⊢ A → Γ ⁏ Δ ⊢ A
split {Δ} = mdet⋆₀ ∘ lam⋆ {□⋆ Δ}

msplit : ∀ {Γ A Δ} → ∅ ⁏ Δ ⧺ Γ ⊢ A → □⋆ Γ ⁏ Δ ⊢ A
msplit {Γ} = det⋆₀ ∘ mlam⋆ {Γ}

merge⋆ : ∀ {Ξ Δ Γ} → Γ ⁏ Δ ⊢⋆ Ξ → Γ ⧺ (□⋆ Δ) ⁏ ∅ ⊢⋆ Ξ
merge⋆ {∅}     ∙        = ∙
merge⋆ {Ξ , A} (ts , t) = merge⋆ ts , merge t

split⋆ : ∀ {Ξ Δ Γ} → Γ ⧺ (□⋆ Δ) ⁏ ∅ ⊢⋆ Ξ → Γ ⁏ Δ ⊢⋆ Ξ
split⋆ {∅}     ∙        = ∙
split⋆ {Ξ , A} (ts , t) = split⋆ ts , split t

-- Cut and multicut.

cut : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A → Γ , A ⁏ Δ ⊢ B → Γ ⁏ Δ ⊢ B
cut t u = app (lam u) t

mcut : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ , A ⊢ B → Γ ⁏ Δ ⊢ B
mcut t u = app (mlam u) t

multicut : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ ⊢⋆ Ξ → Ξ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ A
multicut {∅}     ∙        u = mono⊢ bot⊆ u
multicut {Ξ , B} (ts , t) u = app (multicut ts (lam u)) t

mmulticut : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ ⊢⋆ □⋆ Ξ → Γ ⁏ Ξ ⊢ A → Γ ⁏ Δ ⊢ A
mmulticut {∅}     ∙        u = mmono⊢ bot⊆ u
mmulticut {Ξ , B} (ts , t) u = app (mmulticut ts (mlam u)) t

multicut² : ∀ {Ξ Ξ′ A Γ Δ} → Γ ⁏ Δ ⊢⋆ Ξ → Γ ⁏ Δ ⊢⋆ □⋆ Ξ′ → Ξ ⁏ Ξ′ ⊢ A → Γ ⁏ Δ ⊢ A
multicut² {∅}     ∙        us v = mmulticut us (mono⊢ bot⊆ v)
multicut² {Ξ , B} (ts , t) us v = app (multicut² ts us (lam v)) t

-- Transitivity.

trans⊢⋆₀ : ∀ {Γ″ Γ′ Γ} → Γ ⁏ ∅ ⊢⋆ Γ′ → Γ′ ⁏ ∅ ⊢⋆ Γ″ → Γ ⁏ ∅ ⊢⋆ Γ″
trans⊢⋆₀ {∅}      ts ∙        = ∙
trans⊢⋆₀ {Γ″ , A} ts (us , u) = trans⊢⋆₀ ts us , multicut ts u

trans⊢⋆ : ∀ {Ξ Γ Γ′ Δ Δ′} → Γ ⁏ Δ ⊢⋆ Γ′ ⧺ (□⋆ Δ′) → Γ′ ⁏ Δ′ ⊢⋆ Ξ → Γ ⁏ Δ ⊢⋆ Ξ
trans⊢⋆ ts us = split⋆ (trans⊢⋆₀ (merge⋆ ts) (merge⋆ us))

-- Contraction.

ccont : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ (A ▻ A ▻ B) ▻ A ▻ B
ccont = lam (lam (app (app v₁ v₀) v₀))

cont : ∀ {A B Γ Δ} → Γ , A , A ⁏ Δ ⊢ B → Γ , A ⁏ Δ ⊢ B
cont t = det (app ccont (lam (lam t)))

mcont : ∀ {A B Γ Δ} → Γ ⁏ Δ , A , A ⊢ B → Γ ⁏ Δ , A ⊢ B
mcont t = mdet (app ccont (mlam (mlam t)))

-- Exchange, or Schönfinkel’s C combinator.

cexch : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ (A ▻ B ▻ C) ▻ B ▻ A ▻ C
cexch = lam (lam (lam (app (app v₂ v₀) v₁)))

exch : ∀ {A B C Γ Δ} → Γ , A , B ⁏ Δ ⊢ C → Γ , B , A ⁏ Δ ⊢ C
exch t = det (det (app cexch (lam (lam t))))

mexch : ∀ {A B C Γ Δ} → Γ ⁏ Δ , A , B ⊢ C → Γ ⁏ Δ , B , A ⊢ C
mexch t = mdet (mdet (app cexch (mlam (mlam t))))

-- Composition, or Schönfinkel’s B combinator.

ccomp : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ (B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
ccomp = lam (lam (lam (app v₂ (app v₁ v₀))))

comp : ∀ {A B C Γ Δ} → Γ , B ⁏ Δ ⊢ C → Γ , A ⁏ Δ ⊢ B → Γ , A ⁏ Δ ⊢ C
comp t u = det (app (app ccomp (lam t)) (lam u))

mcomp : ∀ {A B C Γ Δ} → Γ ⁏ Δ , B ⊢ □ C → Γ ⁏ Δ , A ⊢ □ B → Γ ⁏ Δ , A ⊢ □ C
mcomp t u = mdet (app (app ccomp (mlam t)) (mlam u))

-- Useful theorems in functional form.

dist : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ (A ▻ B) → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ ⊢ □ B
dist t u = unbox t (unbox (mmono⊢ weak⊆ u) (box (app mv₁ mv₀)))

up : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ ⊢ □ □ A
up t = unbox t (box (box mv₀))

down : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ ⊢ A
down t = unbox t mv₀

distup : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ (□ A ▻ B) → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ ⊢ □ B
distup t u = dist t (up u)

-- Useful theorems in combinatory form.

ci : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ A ▻ A
ci = lam v₀

ck : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ▻ B ▻ A
ck = lam (lam v₁)

cs : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
cs = lam (lam (lam (app (app v₂ v₀) (app v₁ v₀))))

cdist : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ (A ▻ B) ▻ □ A ▻ □ B
cdist = lam (lam (dist v₁ v₀))

cup : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ □ A ▻ □ □ A
cup = lam (up v₀)

cdown : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ □ A ▻ A
cdown = lam (down v₀)

cdistup : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ (□ A ▻ B) ▻ □ A ▻ □ B
cdistup = lam (lam (dist v₁ (up v₀)))

cunbox : ∀ {A C Γ Δ} → Γ ⁏ Δ ⊢ □ A ▻ (□ A ▻ C) ▻ C
cunbox = lam (lam (app v₀ v₁))

cpair : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ▻ B ▻ A ∧ B
cpair = lam (lam (pair v₁ v₀))

cfst : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ∧ B ▻ A
cfst = lam (fst v₀)

csnd : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ∧ B ▻ B
csnd = lam (snd v₀)

-- Internalisation, or lifting, and additional theorems.

lift : ∀ {Γ A Δ} → Γ ⁏ Δ ⊢ A → □⋆ Γ ⁏ Δ ⊢ □ A
lift {∅}     t = box t
lift {Γ , B} t = det (app cdist (lift (lam t)))

hypup : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ A ▻ B → Γ ⁏ Δ ⊢ □ A ▻ B
hypup t = lam (app (mono⊢ weak⊆ t) (down v₀))

hypdown : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ □ A ▻ B → Γ ⁏ Δ ⊢ □ A ▻ B
hypdown t = lam (app (mono⊢ weak⊆ t) (up v₀))

cxup : ∀ {Γ A Δ} → Γ ⁏ Δ ⊢ A → □⋆ Γ ⁏ Δ ⊢ A
cxup {∅}     t = t
cxup {Γ , B} t = det (hypup (cxup (lam t)))

cxdown : ∀ {Γ A Δ} → □⋆ □⋆ Γ ⁏ Δ ⊢ A → □⋆ Γ ⁏ Δ ⊢ A
cxdown {∅}     t = t
cxdown {Γ , B} t = det (hypdown (cxdown (lam t)))

box⋆ : ∀ {Ξ Γ Δ} → ∅ ⁏ Δ ⊢⋆ Ξ → Γ ⁏ Δ ⊢⋆ □⋆ Ξ
box⋆ {∅}     ∙        = ∙
box⋆ {Ξ , A} (ts , t) = box⋆ ts , box t

lift⋆ : ∀ {Ξ Γ Δ} → Γ ⁏ Δ ⊢⋆ Ξ → □⋆ Γ ⁏ Δ ⊢⋆ □⋆ Ξ
lift⋆ {∅}     ∙        = ∙
lift⋆ {Ξ , A} (ts , t) = lift⋆ ts , lift t

up⋆ : ∀ {Ξ Γ Δ} → Γ ⁏ Δ ⊢⋆ □⋆ Ξ → Γ ⁏ Δ ⊢⋆ □⋆ □⋆ Ξ
up⋆ {∅}     ∙        = ∙
up⋆ {Ξ , A} (ts , t) = up⋆ ts , up t

down⋆ : ∀ {Ξ Γ Δ} → Γ ⁏ Δ ⊢⋆ □⋆ Ξ → Γ ⁏ Δ ⊢⋆ Ξ
down⋆ {∅}     ∙        = ∙
down⋆ {Ξ , A} (ts , t) = down⋆ ts , down t

multibox : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ ⊢⋆ □⋆ Ξ → □⋆ Ξ ⁏ ∅ ⊢ A → Γ ⁏ Δ ⊢ □ A
multibox ts u = multicut (up⋆ ts) (mmono⊢ bot⊆ (lift u))

dist′ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ (A ▻ B) → Γ ⁏ Δ ⊢ □ A ▻ □ B
dist′ t = lam (dist (mono⊢ weak⊆ t) v₀)

mpair : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ ⊢ □ B → Γ ⁏ Δ ⊢ □ (A ∧ B)
mpair t u = unbox t (unbox (mmono⊢ weak⊆ u) (box (pair mv₁ mv₀)))

mfst : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ (A ∧ B) → Γ ⁏ Δ ⊢ □ A
mfst t = unbox t (box (fst mv₀))

msnd : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ □ (A ∧ B) → Γ ⁏ Δ ⊢ □ B
msnd t = unbox t (box (snd mv₀))

-- Closure under context concatenation.

concat : ∀ {A B Γ} Γ′ {Δ} → Γ , A ⁏ Δ ⊢ B → Γ′ ⁏ Δ ⊢ A → Γ ⧺ Γ′ ⁏ Δ ⊢ B
concat Γ′ t u = app (mono⊢ (weak⊆⧺₁ Γ′) (lam t)) (mono⊢ weak⊆⧺₂ u)

mconcat : ∀ {A B Γ Δ} Δ′ → Γ ⁏ Δ , A ⊢ B → Γ ⁏ Δ′ ⊢ □ A → Γ ⁏ Δ ⧺ Δ′ ⊢ B
mconcat Δ′ t u = app (mmono⊢ (weak⊆⧺₁ Δ′) (mlam t)) (mmono⊢ weak⊆⧺₂ u)

-- Substitution.

[_≔_]_ : ∀ {A B Γ Δ} → (i : A ∈ Γ) → Γ ∖ i ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ B → Γ ∖ i ⁏ Δ ⊢ B
[ i ≔ s ] var j     with i ≟∈ j
[ i ≔ s ] var .i    | same   = s
[ i ≔ s ] var ._    | diff j = var j
[ i ≔ s ] lam t     = lam ([ pop i ≔ mono⊢ weak⊆ s ] t)
[ i ≔ s ] app t u   = app ([ i ≔ s ] t) ([ i ≔ s ] u)
[ i ≔ s ] mvar j    = mvar j
[ i ≔ s ] box t     = box t
[ i ≔ s ] unbox t u = unbox ([ i ≔ s ] t) ([ i ≔ mmono⊢ weak⊆ s ] u)
[ i ≔ s ] pair t u  = pair ([ i ≔ s ] t) ([ i ≔ s ] u)
[ i ≔ s ] fst t     = fst ([ i ≔ s ] t)
[ i ≔ s ] snd t     = snd ([ i ≔ s ] t)
[ i ≔ s ] unit      = unit

[_≔_]⋆_ : ∀ {Ξ A Γ Δ} → (i : A ∈ Γ) → Γ ∖ i ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢⋆ Ξ → Γ ∖ i ⁏ Δ ⊢⋆ Ξ
[_≔_]⋆_ {∅}     i s ∙        = ∙
[_≔_]⋆_ {Ξ , B} i s (ts , t) = [ i ≔ s ]⋆ ts , [ i ≔ s ] t

-- Modal substitution.

m[_≔_]_ : ∀ {A B Γ Δ} → (i : A ∈ Δ) → ∅ ⁏ Δ ∖ i ⊢ A → Γ ⁏ Δ ⊢ B → Γ ⁏ Δ ∖ i ⊢ B
m[ i ≔ s ] var j     = var j
m[ i ≔ s ] lam t     = lam (m[ i ≔ s ] t)
m[ i ≔ s ] app t u   = app (m[ i ≔ s ] t) (m[ i ≔ s ] u)
m[ i ≔ s ] mvar j    with i ≟∈ j
m[ i ≔ s ] mvar .i   | same   = mono⊢ bot⊆ s
m[ i ≔ s ] mvar ._   | diff j = mvar j
m[ i ≔ s ] box t     = box (m[ i ≔ s ] t)
m[ i ≔ s ] unbox t u = unbox (m[ i ≔ s ] t) (m[ pop i ≔ mmono⊢ weak⊆ s ] u)
m[ i ≔ s ] pair t u  = pair (m[ i ≔ s ] t) (m[ i ≔ s ] u)
m[ i ≔ s ] fst t     = fst (m[ i ≔ s ] t)
m[ i ≔ s ] snd t     = snd (m[ i ≔ s ] t)
m[ i ≔ s ] unit      = unit

m[_≔_]⋆_ : ∀ {Ξ A Γ Δ} → (i : A ∈ Δ) → ∅ ⁏ Δ ∖ i ⊢ A → Γ ⁏ Δ ⊢⋆ Ξ → Γ ⁏ Δ ∖ i ⊢⋆ Ξ
m[_≔_]⋆_ {∅}     i s ∙        = ∙
m[_≔_]⋆_ {Ξ , B} i s (ts , t) = m[ i ≔ s ]⋆ ts , m[ i ≔ s ] t

-- Convertibility.

data _⋙_ {Γ Δ : Cx Ty} : ∀ {A} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ A → Set where
  refl⋙      : ∀ {A} → {t : Γ ⁏ Δ ⊢ A}
                      → t ⋙ t

  trans⋙     : ∀ {A} → {t t′ t″ : Γ ⁏ Δ ⊢ A}
                      → t ⋙ t′ → t′ ⋙ t″
                      → t ⋙ t″

  sym⋙       : ∀ {A} → {t t′ : Γ ⁏ Δ ⊢ A}
                      → t ⋙ t′
                      → t′ ⋙ t

  conglam⋙   : ∀ {A B} → {t t′ : Γ , A ⁏ Δ ⊢ B}
                        → t ⋙ t′
                        → lam t ⋙ lam t′

  congapp⋙   : ∀ {A B} → {t t′ : Γ ⁏ Δ ⊢ A ▻ B} → {u u′ : Γ ⁏ Δ ⊢ A}
                        → t ⋙ t′ → u ⋙ u′
                        → app t u ⋙ app t′ u′

  -- NOTE: Rejected by Pfenning and Davies.
  -- congbox⋙   : ∀ {A} → {t t′ : ∅ ⁏ Δ ⊢ A}
  --                     → t ⋙ t′
  --                     → box {Γ} t ⋙ box {Γ} t′

  congunbox⋙ : ∀ {A C} → {t t′ : Γ ⁏ Δ ⊢ □ A} → {u u′ : Γ ⁏ Δ , A ⊢ C}
                        → t ⋙ t′ → u ⋙ u′
                        → unbox t u ⋙ unbox t′ u′

  congpair⋙  : ∀ {A B} → {t t′ : Γ ⁏ Δ ⊢ A} → {u u′ : Γ ⁏ Δ ⊢ B}
                        → t ⋙ t′ → u ⋙ u′
                        → pair t u ⋙ pair t′ u′

  congfst⋙   : ∀ {A B} → {t t′ : Γ ⁏ Δ ⊢ A ∧ B}
                        → t ⋙ t′
                        → fst t ⋙ fst t′

  congsnd⋙   : ∀ {A B} → {t t′ : Γ ⁏ Δ ⊢ A ∧ B}
                        → t ⋙ t′
                        → snd t ⋙ snd t′

  beta▻⋙     : ∀ {A B} → {t : Γ , A ⁏ Δ ⊢ B} → {u : Γ ⁏ Δ ⊢ A}
                        → app (lam t) u ⋙ ([ top ≔ u ] t)

  eta▻⋙      : ∀ {A B} → {t : Γ ⁏ Δ ⊢ A ▻ B}
                        → t ⋙ lam (app (mono⊢ weak⊆ t) v₀)

  beta□⋙     : ∀ {A C} → {t : ∅ ⁏ Δ ⊢ A} → {u : Γ ⁏ Δ , A ⊢ C}
                        → unbox (box t) u ⋙ (m[ top ≔ t ] u)

  eta□⋙      : ∀ {A} → {t : Γ ⁏ Δ ⊢ □ A}
                      → t ⋙ unbox t (box mv₀)

  -- TODO: What about commuting conversions for □?

  beta∧₁⋙    : ∀ {A B} → {t : Γ ⁏ Δ ⊢ A} → {u : Γ ⁏ Δ ⊢ B}
                        → fst (pair t u) ⋙ t

  beta∧₂⋙    : ∀ {A B} → {t : Γ ⁏ Δ ⊢ A} → {u : Γ ⁏ Δ ⊢ B}
                        → snd (pair t u) ⋙ u

  eta∧⋙      : ∀ {A B} → {t : Γ ⁏ Δ ⊢ A ∧ B}
                        → t ⋙ pair (fst t) (snd t)

  eta⊤⋙     : ∀ {t : Γ ⁏ Δ ⊢ ⊤} → t ⋙ unit


-- Andreas, 2020-04-15, issue #4586
-- Better error for invalid let pattern.

import Agda.Builtin.Nat

test : Set₁
test = let 13 = Set
       in  Set

-- WAS:
-- Set != x of type Set₁
-- when checking that the given dot pattern Set matches the inferred
-- value x

-- EXPECTED:
-- Not a valid let pattern
-- when scope checking let .Set = Set in Set


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Gentzen-style formalisation of syntax with context pairs, after Pfenning-Davies.
-- Normal forms, neutrals, and spines.

module BasicIS4.Syntax.DyadicGentzenSpinalNormalForm where

open import BasicIS4.Syntax.DyadicGentzen public

-- Commuting propositions for neutrals.

data Tyⁿᵉ : Ty → Set where
  α_ : (P : Atom) → Tyⁿᵉ (α P)
  □_ : (A : Ty) → Tyⁿᵉ (□ A)

-- Derivations.

mutual
  -- Normal forms, or introductions.
  infix 3 _⊢ⁿᶠ_
  data _⊢ⁿᶠ_ : Cx² Ty Ty → Ty → Set where
    neⁿᶠ   : ∀ {A Γ Δ}   → Γ ⁏ Δ ⊢ⁿᵉ A → {{_ : Tyⁿᵉ A}} → Γ ⁏ Δ ⊢ⁿᶠ A
    lamⁿᶠ  : ∀ {A B Γ Δ} → Γ , A ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ⊢ⁿᶠ A ▻ B
    boxⁿᶠ  : ∀ {A Γ Δ}   → ∅ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ □ A
    pairⁿᶠ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ⊢ⁿᶠ A ∧ B
    unitⁿᶠ : ∀ {Γ Δ}     → Γ ⁏ Δ ⊢ⁿᶠ ⊤

  -- Neutrals, or eliminations.
  infix 3 _⊢ⁿᵉ_
  data _⊢ⁿᵉ_ : Cx² Ty Ty → Ty → Set where
    spⁿᵉ  : ∀ {A B C Γ Δ} → A ∈ Γ → Γ ⁏ Δ ⊢ˢᵖ A ⦙ B → Γ ⁏ Δ ⊢ᵗᵖ B ⦙ C → Γ ⁏ Δ ⊢ⁿᵉ C
    mspⁿᵉ : ∀ {A B C Γ Δ} → A ∈ Δ → Γ ⁏ Δ ⊢ˢᵖ A ⦙ B → Γ ⁏ Δ ⊢ᵗᵖ B ⦙ C → Γ ⁏ Δ ⊢ⁿᵉ C

  -- Spines.
  infix 3 _⊢ˢᵖ_⦙_
  data _⊢ˢᵖ_⦙_ : Cx² Ty Ty → Ty → Ty → Set where
    nilˢᵖ : ∀ {C Γ Δ} → Γ ⁏ Δ ⊢ˢᵖ C ⦙ C
    appˢᵖ : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ˢᵖ B ⦙ C → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ˢᵖ A ▻ B ⦙ C
    fstˢᵖ : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ˢᵖ A ⦙ C → Γ ⁏ Δ ⊢ˢᵖ A ∧ B ⦙ C
    sndˢᵖ : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ˢᵖ B ⦙ C → Γ ⁏ Δ ⊢ˢᵖ A ∧ B ⦙ C

  -- Spine tips.
  infix 3 _⊢ᵗᵖ_⦙_
  data _⊢ᵗᵖ_⦙_ : Cx² Ty Ty → Ty → Ty → Set where
    nilᵗᵖ   : ∀ {C Γ Δ} → Γ ⁏ Δ ⊢ᵗᵖ C ⦙ C
    unboxᵗᵖ : ∀ {A C Γ Δ} → Γ ⁏ Δ , A ⊢ⁿᶠ C → Γ ⁏ Δ ⊢ᵗᵖ □ A ⦙ C

-- Translation to simple terms.

mutual
  nf→tm : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ A
  nf→tm (neⁿᶠ t)     = ne→tm t
  nf→tm (lamⁿᶠ t)    = lam (nf→tm t)
  nf→tm (boxⁿᶠ t)    = box (nf→tm t)
  nf→tm (pairⁿᶠ t u) = pair (nf→tm t) (nf→tm u)
  nf→tm unitⁿᶠ       = unit

  ne→tm : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ ⊢ A
  ne→tm (spⁿᵉ i xs y)  = tp→tm (var i) xs y
  ne→tm (mspⁿᵉ i xs y) = tp→tm (mvar i) xs y

  sp→tm : ∀ {A C Γ Δ} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ˢᵖ A ⦙ C → Γ ⁏ Δ ⊢ C
  sp→tm t nilˢᵖ        = t
  sp→tm t (appˢᵖ xs u) = sp→tm (app t (nf→tm u)) xs
  sp→tm t (fstˢᵖ xs)   = sp→tm (fst t) xs
  sp→tm t (sndˢᵖ xs)   = sp→tm (snd t) xs

  tp→tm : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ˢᵖ A ⦙ B → Γ ⁏ Δ ⊢ᵗᵖ B ⦙ C → Γ ⁏ Δ ⊢ C
  tp→tm t xs nilᵗᵖ       = sp→tm t xs
  tp→tm t xs (unboxᵗᵖ u) = unbox (sp→tm t xs) (nf→tm u)

-- Monotonicity with respect to context inclusion.

mutual
  mono⊢ⁿᶠ : ∀ {A Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢ⁿᶠ A → Γ′ ⁏ Δ ⊢ⁿᶠ A
  mono⊢ⁿᶠ η (neⁿᶠ t)     = neⁿᶠ (mono⊢ⁿᵉ η t)
  mono⊢ⁿᶠ η (lamⁿᶠ t)    = lamⁿᶠ (mono⊢ⁿᶠ (keep η) t)
  mono⊢ⁿᶠ η (boxⁿᶠ t)    = boxⁿᶠ t
  mono⊢ⁿᶠ η (pairⁿᶠ t u) = pairⁿᶠ (mono⊢ⁿᶠ η t) (mono⊢ⁿᶠ η u)
  mono⊢ⁿᶠ η unitⁿᶠ       = unitⁿᶠ

  mono⊢ⁿᵉ : ∀ {A Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢ⁿᵉ A → Γ′ ⁏ Δ ⊢ⁿᵉ A
  mono⊢ⁿᵉ η (spⁿᵉ i xs y)  = spⁿᵉ (mono∈ η i) (mono⊢ˢᵖ η xs) (mono⊢ᵗᵖ η y)
  mono⊢ⁿᵉ η (mspⁿᵉ i xs y) = mspⁿᵉ i (mono⊢ˢᵖ η xs) (mono⊢ᵗᵖ η y)

  mono⊢ˢᵖ : ∀ {A C Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢ˢᵖ A ⦙ C → Γ′ ⁏ Δ ⊢ˢᵖ A ⦙ C
  mono⊢ˢᵖ η nilˢᵖ        = nilˢᵖ
  mono⊢ˢᵖ η (appˢᵖ xs u) = appˢᵖ (mono⊢ˢᵖ η xs) (mono⊢ⁿᶠ η u)
  mono⊢ˢᵖ η (fstˢᵖ xs)   = fstˢᵖ (mono⊢ˢᵖ η xs)
  mono⊢ˢᵖ η (sndˢᵖ xs)   = sndˢᵖ (mono⊢ˢᵖ η xs)

  mono⊢ᵗᵖ : ∀ {A C Γ Γ′ Δ} → Γ ⊆ Γ′ → Γ ⁏ Δ ⊢ᵗᵖ A ⦙ C → Γ′ ⁏ Δ ⊢ᵗᵖ A ⦙ C
  mono⊢ᵗᵖ η nilᵗᵖ       = nilᵗᵖ
  mono⊢ᵗᵖ η (unboxᵗᵖ u) = unboxᵗᵖ (mono⊢ⁿᶠ η u)

-- Monotonicity with respect to modal context inclusion.

mutual
  mmono⊢ⁿᶠ : ∀ {A Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ′ ⊢ⁿᶠ A
  mmono⊢ⁿᶠ θ (neⁿᶠ t)     = neⁿᶠ (mmono⊢ⁿᵉ θ t)
  mmono⊢ⁿᶠ θ (lamⁿᶠ t)    = lamⁿᶠ (mmono⊢ⁿᶠ θ t)
  mmono⊢ⁿᶠ θ (boxⁿᶠ t)    = boxⁿᶠ (mmono⊢ⁿᶠ θ t)
  mmono⊢ⁿᶠ θ (pairⁿᶠ t u) = pairⁿᶠ (mmono⊢ⁿᶠ θ t) (mmono⊢ⁿᶠ θ u)
  mmono⊢ⁿᶠ θ unitⁿᶠ       = unitⁿᶠ

  mmono⊢ⁿᵉ : ∀ {A Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ′ ⊢ⁿᵉ A
  mmono⊢ⁿᵉ θ (spⁿᵉ i xs y)  = spⁿᵉ i (mmono⊢ˢᵖ θ xs) (mmono⊢ᵗᵖ θ y)
  mmono⊢ⁿᵉ θ (mspⁿᵉ i xs y) = mspⁿᵉ (mono∈ θ i) (mmono⊢ˢᵖ θ xs) (mmono⊢ᵗᵖ θ y)

  mmono⊢ˢᵖ : ∀ {A C Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢ˢᵖ A ⦙ C → Γ ⁏ Δ′ ⊢ˢᵖ A ⦙ C
  mmono⊢ˢᵖ θ nilˢᵖ        = nilˢᵖ
  mmono⊢ˢᵖ θ (appˢᵖ xs u) = appˢᵖ (mmono⊢ˢᵖ θ xs) (mmono⊢ⁿᶠ θ u)
  mmono⊢ˢᵖ θ (fstˢᵖ xs)   = fstˢᵖ (mmono⊢ˢᵖ θ xs)
  mmono⊢ˢᵖ θ (sndˢᵖ xs)   = sndˢᵖ (mmono⊢ˢᵖ θ xs)

  mmono⊢ᵗᵖ : ∀ {A C Γ Δ Δ′} → Δ ⊆ Δ′ → Γ ⁏ Δ ⊢ᵗᵖ A ⦙ C → Γ ⁏ Δ′ ⊢ᵗᵖ A ⦙ C
  mmono⊢ᵗᵖ θ nilᵗᵖ       = nilᵗᵖ
  mmono⊢ᵗᵖ θ (unboxᵗᵖ u) = unboxᵗᵖ (mmono⊢ⁿᶠ (keep θ) u)

-- Monotonicity using context pairs.

mono²⊢ⁿᶠ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊢ⁿᶠ A → Π′ ⊢ⁿᶠ A
mono²⊢ⁿᶠ (η , θ) = mono⊢ⁿᶠ η ∘ mmono⊢ⁿᶠ θ

mono²⊢ⁿᵉ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊢ⁿᵉ A → Π′ ⊢ⁿᵉ A
mono²⊢ⁿᵉ (η , θ) = mono⊢ⁿᵉ η ∘ mmono⊢ⁿᵉ θ

mono²⊢ˢᵖ : ∀ {A C Π Π′} → Π ⊆² Π′ → Π ⊢ˢᵖ A ⦙ C → Π′ ⊢ˢᵖ A ⦙ C
mono²⊢ˢᵖ (η , θ) = mono⊢ˢᵖ η ∘ mmono⊢ˢᵖ θ

mono²⊢ᵗᵖ : ∀ {A C Π Π′} → Π ⊆² Π′ → Π ⊢ᵗᵖ A ⦙ C → Π′ ⊢ᵗᵖ A ⦙ C
mono²⊢ᵗᵖ (η , θ) = mono⊢ᵗᵖ η ∘ mmono⊢ᵗᵖ θ


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
module Optics.All where
  open import Optics.Functorial public
  open import Optics.Reflection public


-- Andreas, 2019-11-08, issue #4154 reported by Yashmine Sharoda.

-- Warn if a `renaming` clause clashes with an exported name
-- (that is not mentioned in a `using` clause).

module _ where

module M where
  postulate
    A B : Set

-- These produce warnings (#4154):

module N = M renaming (A to B)
open M renaming (A to B)

-- These produce errors (see also #3057)
-- as they produce ambiguous exports:

Test = B
TestN = N.B
module L = M using (B) renaming (A to B)


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Escape {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Reflexivity

open import Tools.Product
import Tools.PropositionalEquality as PE

import Data.Fin as Fin
import Data.Nat as Nat

-- Reducible types are well-formed.
escape : ∀ {l Γ A r} → Γ ⊩⟨ l ⟩ A ^ r → Γ ⊢ A ^ r
escape (Uᵣ′ _ _ _ _ _ PE.refl [[ ⊢A , ⊢B , D ]]) = ⊢A
escape (ℕᵣ [[ ⊢A , ⊢B , D ]]) = ⊢A
escape (Emptyᵣ [[ ⊢A , ⊢B , D ]]) = ⊢A
escape (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) = ⊢A
escape (Πᵣ′ rF lF lG _ _ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) = ⊢A
escape (∃ᵣ′ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) = ⊢A
escape {ι ¹} (emb X A) = escape A
escape {∞} (emb X A) = escape A

-- Reducible type equality respect the equality relation.
escapeEq : ∀ {l Γ A B r} → ([A] : Γ ⊩⟨ l ⟩ A ^ r)
            → Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A]
            → Γ ⊢ A ≅ B ^ r
escapeEq (Uᵣ′ _ _ _ ⁰ _ PE.refl [[ ⊢A , ⊢B , D ]]) D′ = ≅-red D D′ Uₙ Uₙ (≅-univ (≅-U⁰refl (wf ⊢A)))
escapeEq (Uᵣ′ _ _ _ ¹ _ PE.refl [[ ⊢A , ⊢B , D ]]) D′ = ≅-red D D′ Uₙ Uₙ (≅-U¹refl (wf ⊢A))
escapeEq (ℕᵣ [[ ⊢A , ⊢B , D ]]) D′ = ≅-red D D′ ℕₙ ℕₙ (≅-univ (≅ₜ-ℕrefl (wf ⊢A)))
escapeEq (Emptyᵣ [[ ⊢A , ⊢B , D ]]) D′ = ≅-red D D′ Emptyₙ Emptyₙ (≅-univ ((≅ₜ-Emptyrefl (wf ⊢A))))
escapeEq (ne′ K D neK K≡K) (ne₌ M D′ neM K≡M) =
  ≅-red (red D) (red D′) (ne neK) (ne neM) (~-to-≅ K≡M)
escapeEq (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
             (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ≅-red (red D) D′ Πₙ Πₙ A≡B
escapeEq (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
             (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ≅-red (red D) D′ ∃ₙ ∃ₙ A≡B
escapeEq {ι ¹} (emb X A) A≡B = escapeEq A A≡B
escapeEq {∞} (emb X A) A≡B = escapeEq A A≡B

-- Reducible terms are well-formed.
escapeTerm : ∀ {l Γ A t r} → ([A] : Γ ⊩⟨ l ⟩ A ^ r)
              → Γ ⊩⟨ l ⟩ t ∷ A ^ r / [A]
              → Γ ⊢ t ∷ A ^ r
escapeTerm (Uᵣ′ _ _ _ _ l< PE.refl D) (Uₜ A [[ ⊢t , ⊢u , d ]] typeA A≡A [A]) = conv ⊢t (sym (subset* (red D)))
escapeTerm (ℕᵣ D) (ℕₜ n [[ ⊢t , ⊢u , d ]] t≡t prop) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Emptyᵣ D) (Emptyₜ (ne ⊢t)) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm {r = [ ! , l ]} (ne′ K D neK K≡K) (neₜ k [[ ⊢t , ⊢u , d ]] nf) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm {r = [ % , l ]} (ne′ K D neK K≡K) (neₜ d) = d
escapeTerm {r = [ ! , l ] } (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
               (f , [[ ⊢t , ⊢u , d ]] , funcF , f≡f , [f] , [f]₁) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm {r = [ % , l ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ⊢t = conv ⊢t (sym (subset* (red D)))
escapeTerm (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ⊢t = conv ⊢t (sym (subset* (red D)))
escapeTerm {ι ¹} (emb X A) t = escapeTerm A t
escapeTerm {∞} (emb X A) t = escapeTerm A t

-- Reducible term equality respect the equality relation.
escapeTermEq : ∀ {l Γ A t u r} → ([A] : Γ ⊩⟨ l ⟩ A ^ r)
                → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ r / [A]
                → Γ ⊢ t ≅ u ∷ A ^ r
escapeTermEq (Uᵣ′ _ _ _ _ l< PE.refl D) (Uₜ₌ (Uₜ A d typeA A≡A [t]) (Uₜ B d′ typeB B≡B [u]) A≡B [A≡B]) = ≅ₜ-red (red D) (redₜ d) (redₜ d′) Uₙ (typeWhnf typeA) (typeWhnf typeB) A≡B
escapeTermEq (ℕᵣ D) (ℕₜ₌ k k′ d d′ k≡k′ prop) =
  let natK , natK′ = split prop
  in  ≅ₜ-red (red D) (redₜ d) (redₜ d′) ℕₙ
             (naturalWhnf natK) (naturalWhnf natK′) k≡k′
escapeTermEq (Emptyᵣ D) (Emptyₜ₌ (ne ⊢t ⊢u)) =
  ~-to-≅ₜ (~-irrelevance ((conv ⊢t (sym (subset* (red D)))))  ((conv ⊢u (sym (subset* (red D))))))
escapeTermEq {r = [ ! , l ]} (ne′ K D neK K≡K)
                 (neₜ₌ k m d d′ (neNfₜ₌ neT neU t≡u)) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) (ne neK) (ne neT) (ne neU)
         (~-to-≅ₜ t≡u)
escapeTermEq {r = [ % , l ]} (ne′ K D neK K≡K)
                 (neₜ₌ d d′) = ~-to-≅ₜ (~-irrelevance d d′)
escapeTermEq {r = [ ! , l ]} (Πᵣ′ rF lF lG _ _  F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                 (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) Πₙ (functionWhnf funcF) (functionWhnf funcG) f≡g
escapeTermEq {r = [ % , l ] } (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (⊢t , ⊢u) = ~-to-≅ₜ (~-irrelevance ((conv ⊢t (sym (subset* (red D))))) ((conv ⊢u (sym (subset* (red D))))))
escapeTermEq (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (⊢t , ⊢u) = ~-to-≅ₜ (~-irrelevance ((conv ⊢t (sym (subset* (red D))))) ((conv ⊢u (sym (subset* (red D))))))
escapeTermEq {ι ¹} (emb X A) t≡u = escapeTermEq A t≡u
escapeTermEq {∞} (emb X A) t≡u = escapeTermEq A t≡u

escapeEqRefl : ∀ {l Γ A r}
            → ([A] : Γ ⊩⟨ l ⟩ A ^ r)
            → Γ ⊢ A ≅ A ^ r
escapeEqRefl [A] = escapeEq [A] (reflEq [A])

escapeEqReflTerm : ∀ {l Γ A t r}
            → ([A] : Γ ⊩⟨ l ⟩ A ^ r)
            → ([t] : Γ ⊩⟨ l ⟩ t ∷ A ^ r / [A])
            → Γ ⊢ t ≅ t ∷ A ^ r
escapeEqReflTerm [A] [t] = escapeTermEq [A] (reflEqTerm [A] [t])


-- {-# OPTIONS -v interaction:50 #-}
module Issue841 where

postulate
  D : Set
  c : (A : Set) (B : Set1) → D
  e : (A : Set) (B : Set1) (C : Set2) (X : Set3) → D

-- When the following is refined the goals end up being the wrong way
-- around.
bad : D
bad = {!c ?!}

-- I.e. bad ?3 ?2 instead of bad ?2 ?3.

-- Andreas, 2013-05-01 should now be correct.

bad' : D
bad' = {!e ? ?!}

-- This works:
good : D
good = {!c!}

also-good : D
also-good = {!c ? ?!}


-- Andreas, 2021-10-08, first test case for unsupported generalization

variable
  X : Set

Y = X

-- Expected:
-- Generalizable variable GeneralizeRHS.X is not supported here
-- when scope checking X


-- {-# OPTIONS -v tc.term.let.pattern:20 #-}
-- Andreas, 2013-05-06 deep let-bound patterns were translated wrongly
module Issue843 {A B C : Set} (a : A) (b : B) (c : C) where

open import Common.Product
open import Common.Equality

T : Set
T = A × B × C

val : T
val = a , (b , c)

-- This was translated wrongly:
ap : {R : Set} (f : T → R) → R
ap f =
  let x , (y , z) = a , (b , c) -- val
  in f (x , (y , z))

works : {R : Set} (f : T → R) → R
works f =
  let x , yz = val
  in let y , z = yz
  in f (x , (y , z))

ap′ : {R : Set} (f : T → R) → R
ap′ f = f (proj₁ val , (proj₁ (proj₂ val) , proj₂ (proj₂ val)))

test : ∀ {R} (f : T → R) → ap f ≡ f (a , (b , c))
test f = refl

{- WAS:
The type of  test f  reduces to

Goal: f (a , proj₂ a , c) ≡ f (a , b , c)

even though it should reduce to

f (a , b , c) ≡ f (a , b , c)

And indeed, refl doesn't fit there. Typechecking the example where the hole has been replaced with refl produces:

D:\Agda\Strange.agda:21,10-14
proj₂ a != b of type B

when checking that the expression refl has type
ap f ≡ f (a , b , c)

With ap′, the goal reduces correctly and refl is accepted.

I'm using a development version of Agda, about one day old. 64bit Windows 7, if it matters.
-}


module Imports.A where

postulate A : Set


-- Andreas, 2020-01-28, issue #4399
-- Pattern @{{_ = p}}@ should not be parsed as cubical partial split.

postulate
  A : Set

data T : Set where
  tt : T

f : {x : A} {{_ : T}} → Set
f ⦃ _ = tt ⦄ = A

-- Expected: Parse error
-- Not a valid named argument: _ = tt


module Issue2575.M where

A : Set
A = Set


------------------------------------------------------------------------
-- Partiality algebra categories
------------------------------------------------------------------------

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

module Partiality-algebra.Category where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (T)

open import Bijection equality-with-J as Bijection using (_↔_)
open import Category equality-with-J as Category
open import Equality.Path.Isomorphisms.Univalence equality-with-paths
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import Structure-identity-principle equality-with-J
open import Univalence-axiom equality-with-J

open import Partiality-algebra as PA hiding (id; _∘_)

------------------------------------------------------------------------
-- Equality characterisation lemmas for Partiality-algebra-with

abstract

  -- An equality characterisation lemma for Partiality-algebra-with.

  equality-characterisation-Partiality-algebra-with₁ :
    ∀ {a p q} {A : Type a} {T : Type p}
      {P₁ P₂ : Partiality-algebra-with T q A} →
    let module P₁ = Partiality-algebra-with P₁
        module P₂ = Partiality-algebra-with P₂
    in
    (∃ λ (⊑≡⊑ : ∀ x y → (x P₁.⊑ y) ≡ (x P₂.⊑ y)) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡ P₂.⨆ (Σ-map id (≡⇒→ (⊑≡⊑ _ _) ∘_) s))
      ↔
    P₁ ≡ P₂
  equality-characterisation-Partiality-algebra-with₁
    {q = q} {A} {T} {P₁} {P₂} =

    (∃ λ (⊑≡⊑ : ∀ x y → (x P₁.⊑ y) ≡ (x P₂.⊑ y)) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡ P₂.⨆ (Σ-map id (≡⇒→ (⊑≡⊑ _ _) ∘_) s))              ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ s →
                                                                              ≡⇒↝ _ $ cong (λ (p : {f : ℕ → T} → _) →
                                                                                P₁.⨆ s ≡ P₂.⨆ (Σ-map id p s)) $
                                                                                (implicit-Π-closure ext 1 λ _ →
                                                                                Π-closure          ext 1 λ _ →
                                                                                Π-closure          ext 1 λ _ →
                                                                                P₂.⊑-propositional)
                                                                                (≡⇒→ (⊑≡⊑ _ _) ∘_)
                                                                                (λ {f} → ≡⇒→ (cong (λ _⊑_ → ∀ n → f n ⊑ f (suc n))
                                                                                (⟨ext⟩ (⟨ext⟩ ∘ ⊑≡⊑))))) ⟩
    (∃ λ (⊑≡⊑ : ∀ x y → (x P₁.⊑ y) ≡ (x P₂.⊑ y)) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ (Σ-map id
                         (λ {f} →
                            ≡⇒→ (cong (λ _⊑_ → ∀ n → f n ⊑ f (suc n))
                                      (⟨ext⟩ (⟨ext⟩ ∘ ⊑≡⊑))))
                         s))                                             ↝⟨ Σ-cong (∀-cong ext λ _ →
                                                                                Eq.extensionality-isomorphism bad-ext) (λ _ → F.id) ⟩
    (∃ λ (⊑≡⊑ : ∀ x → P₁._⊑_ x ≡ P₂._⊑_ x) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ (Σ-map id
                         (λ {f} →
                            ≡⇒→ (cong (λ _⊑_ → ∀ n → f n ⊑ f (suc n))
                                      (⟨ext⟩ ⊑≡⊑)))
                         s))                                             ↝⟨ Σ-cong (Eq.extensionality-isomorphism bad-ext) (λ _ → F.id) ⟩

    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ (Σ-map id
                         (λ {f} →
                            ≡⇒→ (cong (λ _⊑_ → ∀ n → f n ⊑ f (suc n))
                                      ⊑≡⊑))
                         s))                                             ↔⟨⟩

    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ ( proj₁ s
                  , ≡⇒→ (cong (λ _⊑_ →
                                 ∀ n → proj₁ s n ⊑ proj₁ s (suc n))
                              ⊑≡⊑)
                        (proj₂ s)
                  ))                                                     ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (λ eq → _ ≡ P₂.⨆ (_ , ≡⇒→ eq _)) $ sym $
                                                                                cong-∘ _ _ ⊑≡⊑) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ ( proj₁ s
                  , ≡⇒→ (cong (uncurry λ _⊑_ (f : ℕ → T) →
                                         ∀ n → f n ⊑ f (suc n))
                              (cong (_, _) ⊑≡⊑))
                        (proj₂ s)
                  ))                                                     ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (λ inc → _ ≡ P₂.⨆ (_ , inc)) $ sym $
                                                                                subst-in-terms-of-≡⇒↝ equivalence (cong (_, _) ⊑≡⊑) _ _) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ ( proj₁ s
                  , subst (uncurry λ _⊑_ (f : ℕ → T) →
                                     ∀ n → f n ⊑ f (suc n))
                          (cong (_, _) ⊑≡⊑)
                          (proj₂ s)
                  ))                                                     ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (λ eq → _ ≡
                                                                                P₂.⨆ (_ , subst (uncurry λ _⊑_ (f : ℕ → T) →
                                                                                ∀ n → f n ⊑ f (suc n))
                                                                                eq _)) $ sym $
                                                                                Σ-≡,≡→≡-subst-const ⊑≡⊑ refl) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ ( proj₁ s
                  , subst (uncurry λ _⊑_ (f : ℕ → T) →
                                     ∀ n → f n ⊑ f (suc n))
                          (Σ-≡,≡→≡ ⊑≡⊑ (subst-const ⊑≡⊑))
                          (proj₂ s)
                  ))                                                     ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (λ s → _ ≡ P₂.⨆ s) $ sym $
                                                                                push-subst-pair′ {y≡z = ⊑≡⊑} _ _ (subst-const ⊑≡⊑)) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ (subst (λ _⊑_ → ∃ λ f → ∀ n → f n ⊑ f (suc n))
                         ⊑≡⊑ s))                                         ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (λ eq → _ ≡
                                                                                P₂.⨆ (subst (λ _⊑_ → ∃ λ f → ∀ n →
                                                                                f n ⊑ f (suc n)) eq _)) $
                                                                                sym $ sym-sym ⊑≡⊑) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             P₂.⨆ (subst (λ _⊑_ → ∃ λ f → ∀ n → f n ⊑ f (suc n))
                         (sym (sym ⊑≡⊑)) s))                             ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ →
                                                                              ≡⇒↝ _ $ cong (_ ≡_) $ sym $
                                                                                subst-→-domain _ (sym ⊑≡⊑)) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡
             subst (λ _⊑_ → ∃ (λ f → ∀ n → f n ⊑ f (suc n)) → T)
                   (sym ⊑≡⊑) P₂.⨆ s)                                     ↔⟨ ∃-cong (λ _ → ∃-cong λ _ →
                                                                              Eq.extensionality-isomorphism ext
                                                                                ×-cong
                                                                              Eq.extensionality-isomorphism ext) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       P₁.now ≡ P₂.now
         ×
       P₁.⨆ ≡ subst _ (sym ⊑≡⊑) P₂.⨆)                                    ↝⟨ ∃-cong (λ ⊑≡⊑ → ∃-cong λ _ → ∃-cong λ _ →
                                                                              ≡⇒↝ _ $ elim (λ ⊑≡⊑ → ∀ {⨆₁ ⨆₂} →
                                                                                (⨆₁ ≡ subst _ (sym ⊑≡⊑) ⨆₂) ≡
                                                                                (subst _ ⊑≡⊑ ⨆₁ ≡ ⨆₂))
                                                                                (λ _ → refl) ⊑≡⊑) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       P₁.never ≡ P₂.never
         ×
       P₁.now ≡ P₂.now
         ×
       subst _ ⊑≡⊑ P₁.⨆ ≡ P₂.⨆)                                          ↝⟨ ∃-cong (λ ⊑≡⊑ →
                                                                              ≡⇒↝ _ (cong (_≡ _) $ sym $ subst-const ⊑≡⊑)
                                                                                ×-cong
                                                                              ≡⇒↝ _ (cong (_≡ _) $ sym $ subst-const ⊑≡⊑)
                                                                                ×-cong
                                                                              F.id) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       subst _ ⊑≡⊑ P₁.never ≡ P₂.never
         ×
       subst _ ⊑≡⊑ P₁.now ≡ P₂.now
         ×
       subst _ ⊑≡⊑ P₁.⨆ ≡ P₂.⨆)                                          ↝⟨ ∃-cong (λ _ → ∃-cong λ _ → ≡×≡↔≡) ⟩

    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       subst _ ⊑≡⊑ P₁.never ≡ P₂.never
         ×
       (subst _ ⊑≡⊑ P₁.now , subst _ ⊑≡⊑ P₁.⨆) ≡
       (P₂.now , P₂.⨆))                                                  ↝⟨ ∃-cong (λ _ → ≡×≡↔≡) ⟩

    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       (subst _ ⊑≡⊑ P₁.never , subst _ ⊑≡⊑ P₁.now , subst _ ⊑≡⊑ P₁.⨆) ≡
       (P₂.never , P₂.now , P₂.⨆))                                       ↝⟨ ∃-cong (λ ⊑≡⊑ → ≡⇒↝ _ $ cong (λ x → (subst _ ⊑≡⊑ P₁.never , x) ≡ _) $
                                                                              sym $ push-subst-, {y≡z = ⊑≡⊑} _
                                                                                (λ _⊑_ → (∃ λ f → ∀ n → f n ⊑ f (suc n)) → _)) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       (subst _ ⊑≡⊑ P₁.never , subst _ ⊑≡⊑ (P₁.now , P₁.⨆)) ≡
       (P₂.never , P₂.now , P₂.⨆))                                       ↝⟨ ∃-cong (λ ⊑≡⊑ → ≡⇒↝ _ $ cong (_≡ _) $ sym $
                                                                              push-subst-, {y≡z = ⊑≡⊑} _ _) ⟩
    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       subst _ ⊑≡⊑ (P₁.never , P₁.now , P₁.⨆) ≡
       (P₂.never , P₂.now , P₂.⨆))                                       ↔⟨⟩

    (∃ λ (⊑≡⊑ : P₁._⊑_ ≡ P₂._⊑_) →
       subst _ ⊑≡⊑ (proj₂ (proj₁ (_↔_.to rearrange P₁))) ≡
       proj₂ (proj₁ (_↔_.to rearrange P₂)))                              ↝⟨ Bijection.Σ-≡,≡↔≡ ⟩

    proj₁ (_↔_.to rearrange P₁) ≡ proj₁ (_↔_.to rearrange P₂)            ↝⟨ ignore-propositional-component
                                                                              (×-closure 1 (implicit-Π-closure ext 1 λ _ →
                                                                                implicit-Π-closure ext 1 λ _ →
                                                                                Π-closure ext 1 λ _ →
                                                                                Π-closure ext 1 λ _ →
                                                                                P₂.T-is-set) $
                                                                               ×-closure 1 (H-level-propositional ext 2) $
                                                                               ×-closure 1 (Π-closure ext 1 λ _ →
                                                                                P₂.⊑-propositional) $
                                                                               ×-closure 1 (implicit-Π-closure ext 1 λ _ →
                                                                                implicit-Π-closure ext 1 λ _ →
                                                                                implicit-Π-closure ext 1 λ _ →
                                                                                Π-closure ext 1 λ _ →
                                                                                Π-closure ext 1 λ _ →
                                                                                P₂.⊑-propositional) $
                                                                               ×-closure 1 (Π-closure ext 1 λ _ →
                                                                                P₂.⊑-propositional) $
                                                                               ×-closure 1 (Π-closure ext 1 λ _ →
                                                                                Π-closure ext 1 λ _ →
                                                                                P₂.⊑-propositional) $
                                                                               ×-closure 1 (Π-closure ext 1 λ _ →
                                                                                Π-closure ext 1 λ _ →
                                                                                Π-closure ext 1 λ _ →
                                                                                P₂.⊑-propositional)
                                                                                (implicit-Π-closure ext 1 λ _ →
                                                                                implicit-Π-closure ext 1 λ _ →
                                                                                Is-proposition-propositional ext)) ⟩
    _↔_.to rearrange P₁ ≡ _↔_.to rearrange P₂                            ↔⟨ Eq.≃-≡ (Eq.↔⇒≃ rearrange) ⟩□

    P₁ ≡ P₂                                                              □
    where
    module P₁ = Partiality-algebra-with P₁
    module P₂ = Partiality-algebra-with P₂

    rearrange :
      Partiality-algebra-with T q A
        ↔
      ∃ λ ((_⊑_ , never , _ , ⨆) :
           ∃ λ (_⊑_ : T → T → Type q) →
             T ×
             (A → T) ×
             ((∃ λ (f : ℕ → T) → ∀ n → f n ⊑ f (suc n)) → T)) →
        (∀ {x y} → x ⊑ y → y ⊑ x → x ≡ y)
          ×
        Is-set T
          ×
        (∀ x → x ⊑ x)
          ×
        (∀ {x y z} → x ⊑ y → y ⊑ z → x ⊑ z)
          ×
        (∀ x → never ⊑ x)
          ×
        (∀ s → ∀ n → proj₁ s n ⊑ ⨆ s)
          ×
        (∀ s ub → (∀ n → proj₁ s n ⊑ ub) → ⨆ s ⊑ ub)
          ×
        (∀ {x y} → Is-proposition (x ⊑ y))
    rearrange = record
      { surjection = record
        { logical-equivalence = record
          { to   = λ P → let open Partiality-algebra-with P in
                    ( _⊑_
                    , never
                    , now
                    , ⨆
                    )
                  , antisymmetry
                  , T-is-set-unused
                  , ⊑-refl
                  , ⊑-trans
                  , never⊑
                  , upper-bound
                  , least-upper-bound
                  , ⊑-propositional
          ; from = λ where
              ((LE , ne , n , l) , a , u , r , t , le , ub , lub , p) →
                record
                  { _⊑_               = LE
                  ; never             = ne
                  ; now               = n
                  ; ⨆                 = l
                  ; antisymmetry      = a
                  ; T-is-set-unused   = u
                  ; ⊑-refl            = r
                  ; ⊑-trans           = t
                  ; never⊑            = le
                  ; upper-bound       = ub
                  ; least-upper-bound = lub
                  ; ⊑-propositional   = p
                  }
          }
        ; right-inverse-of = λ _ → refl
        }
      ; left-inverse-of = λ _ → refl
      }

  -- Another equality characterisation lemma for
  -- Partiality-algebra-with.

  equality-characterisation-Partiality-algebra-with₂ :
    ∀ {a p q} {A : Type a} {T : Type p}
      {P₁ P₂ : Partiality-algebra-with T q A} →

    let module P₁ = Partiality-algebra-with P₁
        module P₂ = Partiality-algebra-with P₂
    in
    (∃ λ (⊑⇔⊑ : ∀ x y → x P₁.⊑ y ⇔ x P₂.⊑ y) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡ P₂.⨆ (Σ-map id (_⇔_.to (⊑⇔⊑ _ _) ∘_) s))
      ↔
    P₁ ≡ P₂
  equality-characterisation-Partiality-algebra-with₂
    {q = q} {A} {T} {P₁} {P₂} =

    (∃ λ (⊑⇔⊑ : ∀ x y → x P₁.⊑ y ⇔ x P₂.⊑ y) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡ P₂.⨆ (Σ-map id (_⇔_.to (⊑⇔⊑ _ _) ∘_) s))  ↝⟨ Σ-cong (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                             Eq.⇔↔≃ ext P₁.⊑-propositional P₂.⊑-propositional)
                                                                          (λ _ → F.id) ⟩
    (∃ λ (⊑≃⊑ : ∀ x y → (x P₁.⊑ y) ≃ (x P₂.⊑ y)) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡ P₂.⨆ (Σ-map id (_≃_.to (⊑≃⊑ _ _) ∘_) s))  ↝⟨ inverse $ Σ-cong
                                                                     (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                        ≡≃≃ (_≃_.to
                                                                               (Propositional-extensionality-is-univalence-for-propositions
                                                                                ext)
                                                                               prop-ext
                                                                               P₁.⊑-propositional
                                                                               P₂.⊑-propositional))
                                                                     (λ _ → F.id) ⟩
    (∃ λ (⊑≡⊑ : ∀ x y → (x P₁.⊑ y) ≡ (x P₂.⊑ y)) →
       P₁.never ≡ P₂.never
         ×
       (∀ x → P₁.now x ≡ P₂.now x)
         ×
       ∀ s → P₁.⨆ s ≡ P₂.⨆ (Σ-map id (≡⇒→ (⊑≡⊑ _ _) ∘_) s))     ↝⟨ equality-characterisation-Partiality-algebra-with₁ ⟩□

    P₁ ≡ P₂                                                     □
    where
    module P₁ = Partiality-algebra-with P₁
    module P₂ = Partiality-algebra-with P₂

------------------------------------------------------------------------
-- Partiality algebra categories

-- Partiality algebras (with fixed levels and types) form
-- precategories.

precategory :
  ∀ {a} p q (A : Type a) → Precategory (a ⊔ lsuc (p ⊔ q)) (a ⊔ p ⊔ q)
Precategory.precategory (precategory p q A) =
    Partiality-algebra p q A
  , (λ P Q → Morphism P Q , Morphism-set)
  , PA.id
  , PA._∘_
  , _↔_.to equality-characterisation-Morphism refl
  , _↔_.to equality-characterisation-Morphism refl
  , _↔_.to equality-characterisation-Morphism refl

-- A "standard notion of structure" built using
-- Partiality-algebra-with.

standard-notion-of-structure :
  ∀ {a} p q (A : Type a) →
  Standard-notion-of-structure _ _ (precategory-Set p ext)
standard-notion-of-structure p q A = record
  { P               = λ B → Partiality-algebra-with (proj₁ B) q A
  ; H               = Is-morphism-with
  ; H-prop          = λ { {p = P} {q = Q} _ →
                          Is-morphism-with-propositional P Q
                        }
  ; H-id            = λ { {p = P} →
                          proj₂ $
                            _↔_.to Morphism↔Morphism-as-Σ
                              (PA.id {P = ⟨ P ⟩})
                        }
  ; H-∘             = λ { {p = P} {q = Q} {r = R}
                          f-morphism g-morphism →
                          proj₂ $
                            _↔_.to Morphism↔Morphism-as-Σ
                              (_↔_.from
                                 (Morphism↔Morphism-as-Σ
                                    {P₁ = ⟨ Q ⟩} {P₂ = ⟨ R ⟩})
                                 (_ , g-morphism)
                                 PA.∘
                               _↔_.from
                                 (Morphism↔Morphism-as-Σ {P₁ = ⟨ P ⟩})
                                 (_ , f-morphism))
                        }
  ; H-antisymmetric = λ P Q id-morphism-P→Q id-morphism-Q→P →
      _↔_.to
        (equality-characterisation-Partiality-algebra-with₂)
        ( (λ x y → record { to   = proj₁ id-morphism-P→Q
                          ; from = proj₁ id-morphism-Q→P
                          })
        , proj₁ (proj₂ id-morphism-P→Q)
        , proj₁ (proj₂ (proj₂ id-morphism-P→Q))
        , proj₂ (proj₂ (proj₂ id-morphism-P→Q))
        )
  }

abstract

  -- The precategory obtained from the standard notion of structure is
  -- equal to the direct definition above.

  precategories-equal :
    ∀ {a p q} {A : Type a} →
    Standard-notion-of-structure.Str
      (standard-notion-of-structure p q A)
      ≡
    precategory p q A
  precategories-equal {p = p} {q} {A} =
    _↔_.to (equality-characterisation-Precategory ext univ univ)
      ( ≃Partiality-algebra
      , (λ _ _ → Eq.↔⇒≃ $ inverse $ Morphism↔Morphism-as-Σ)
      , (λ _ → refl)
      , (λ _ _ _ _ _ → refl)
      )
    where
    ≃Partiality-algebra :
      (∃ λ (T : Set p) → Partiality-algebra-with (proj₁ T) q A)
        ≃
      Partiality-algebra p q A
    ≃Partiality-algebra =
      (∃ λ (T : Set p) → Partiality-algebra-with (proj₁ T) q A)  ↔⟨ inverse Σ-assoc ⟩

      (∃ λ (T : Type p) →
         Is-set T × Partiality-algebra-with T q A)               ↔⟨ ∃-cong (λ _ → drop-⊤-left-× λ P → _⇔_.to contractible⇔↔⊤ $
                                                                      propositional⇒inhabited⇒contractible
                                                                        (H-level-propositional ext 2)
                                                                        (Partiality-algebra-with.T-is-set P)) ⟩
      (∃ λ (T : Type p) → Partiality-algebra-with T q A)         ↝⟨ Eq.↔⇒≃ record
                                                                      { surjection = record
                                                                        { logical-equivalence = record
                                                                          { to   = uncurry λ _ P → ⟨ P ⟩
                                                                          ; from = λ P → T P , partiality-algebra-with P
                                                                          }
                                                                        ; right-inverse-of = λ _ → refl
                                                                        }
                                                                      ; left-inverse-of = λ _ → refl
                                                                      } ⟩□
      Partiality-algebra p q A                                   □
      where
      open Partiality-algebra

-- Thus the precategory is a category.

category :
  ∀ {a} p q (A : Type a) →
  Category (a ⊔ lsuc (p ⊔ q)) (a ⊔ p ⊔ q)
Category.category (category p q A) =
    precategory _ _ A
  , subst (λ C → ∀ {P Q} → Eq.Is-equivalence
                             (Precategory.≡→≅ C {P} {Q}))
          precategories-equal
          (structure-identity-principle
             ext
             (category-Set _ ext (λ _ _ → univ))
             (standard-notion-of-structure p q A))

private

  precategory-category :
    ∀ {a p q} {A : Type a} →
    Category.precategory (category p q A) ≡ precategory p q A
  precategory-category = refl


-- {-# OPTIONS -v tc.term.exlam:100 -v extendedlambda:100 -v int2abs.reifyterm:100 -v tc.with:100 -v tc.mod.apply:100 #-}
module Issue778b (Param : Set) where

open import Issue778M Param

data D : (Nat → Nat) → Set where
  d : D pred → D pred

-- Ulf, 2013-11-11: With the fix to issue 59 that inlines with functions,
-- this no longer termination checks. The problem is having a termination
-- path going through a with-expression (the variable x in this case).
{-# TERMINATING #-}
test : (f : Nat → Nat) → D f → Nat
test .pred (d x) = bla
  where bla : Nat
        bla with (d x)  -- Andreas, 2014-11-06 "with x" has been outlawed.
        ... | (d (d y)) = test pred y


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

module Dijkstra.EitherLike where

open import Haskell.Prelude

open import Level
  renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_)
  public

module _ {ℓ₀ ℓ₁ ℓ₂ : Level} where
  EL-type = Set ℓ₁ → Set ℓ₂ → Set ℓ₀
  EL-level = ℓ₁ ℓ⊔ ℓ₂ ℓ⊔ ℓ₀

  -- Utility to make passing between `Either` and `EitherD` more convenient
  record EitherLike (E : EL-type) : Set (ℓ+1 EL-level) where
    field
      fromEither : ∀ {A : Set ℓ₁} {B : Set ℓ₂} → Either A B → E A B
      toEither   : ∀ {A : Set ℓ₁} {B : Set ℓ₂} → E A B → Either A B
  open EitherLike ⦃ ... ⦄ public

  EL-func : EL-type → Set (ℓ+1 EL-level)
  EL-func EL = ⦃ mel : EitherLike EL ⦄ → Set EL-level

instance
  EitherLike-Either : ∀ {ℓ₁ ℓ₂} → EitherLike{ℓ₁ ℓ⊔ ℓ₂}{ℓ₁}{ℓ₂} Either
  EitherLike.fromEither EitherLike-Either = id
  EitherLike.toEither   EitherLike-Either = id


{-# OPTIONS --rewriting #-}

module Examples.Run where

open import Agda.Builtin.Equality using (_≡_; refl)
open import Luau.Syntax using (nil; var; _$_; function_is_end; return; _∙_; done; _⟨_⟩; number; binexp; +)
open import Luau.Value using (nil; number)
open import Luau.Run using (run; return)
open import Luau.Heap using (lookup-next; next-emp; lookup-next-emp)

import Agda.Builtin.Equality.Rewrite
{-# REWRITE lookup-next next-emp lookup-next-emp #-}

ex1 : (run (function "id" ⟨ var "x" ⟩ is return (var "x") ∙ done end ∙ return (var "id" $ nil) ∙ done) ≡ return nil _)
ex1 = refl

ex2 : (run (function "fn" ⟨ var "x" ⟩ is return (number 123.0) ∙ done end ∙ return (var "fn" $ nil) ∙ done) ≡ return (number 123.0) _)
ex2 = refl

ex3 : (run (function "fn" ⟨ var "x" ⟩ is return (binexp (number 1.0) + (number 2.0)) ∙ done end ∙ return (var "fn" $ nil) ∙ done) ≡ return (number 3.0) _)
ex3 = refl


module TemporalOps.OtherOps where

open import CategoryTheory.Instances.Reactive
open import CategoryTheory.Functor
open import CategoryTheory.Monad
open import CategoryTheory.Comonad
open import CategoryTheory.NatTrans
open import CategoryTheory.BCCCs
open import CategoryTheory.CartesianStrength

open import TemporalOps.Next
open import TemporalOps.Delay
open import TemporalOps.Diamond
open import TemporalOps.Box
open import TemporalOps.Common.Other

open import Relation.Binary.PropositionalEquality as ≡
open import Data.Product
open import Data.Sum
open import Data.Nat hiding (_*_)
open import Data.Nat.Properties
            using (+-identityʳ ; +-comm ; +-suc ; +-assoc)

open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

open Monad M-◇
open Comonad W-□
private module F-◇ = Functor F-◇
private module F-□ = Functor F-□
open ≡.≡-Reasoning

-- | Natural transformations between modalities

-- delay A by 1 is the same as ▹ A
▹¹-to-▹ : F-delay 1 ⟺ F-▹
▹¹-to-▹ = record
    { to   = record { at = λ A n x → x ; nat-cond = refl }
    ; from = record { at = λ A n x → x ; nat-cond = refl }
    ; iso1 = refl
    ; iso2 = refl
    }

-- □ A is always available, in particular, after a delay by k
□-to-▹ᵏ : ∀(k : ℕ) -> F-□ ⟹ F-delay k
□-to-▹ᵏ k = record
    { at = at-□-▹ᵏ k
    ; nat-cond = nat-cond-□-▹ᵏ k
    }
    where
    at-□-▹ᵏ : ∀(k : ℕ)(A : τ) -> □ A ⇴ delay A by k
    at-□-▹ᵏ zero A n a = a n
    at-□-▹ᵏ (suc k) A zero a = top.tt
    at-□-▹ᵏ (suc k) A (suc n) a = at-□-▹ᵏ k A n a

    nat-cond-□-▹ᵏ : ∀(k : ℕ){A B : τ} {f : A ⇴ B} →
      Functor.fmap (F-delay k) f ∘ at-□-▹ᵏ k A ≈
      at-□-▹ᵏ k B ∘ Functor.fmap F-□ f
    nat-cond-□-▹ᵏ zero {A} {B} {f} {n} {a} = refl
    nat-cond-□-▹ᵏ (suc k) {A} {B} {f} {zero} {a} = refl
    nat-cond-□-▹ᵏ (suc k) {A} {B} {f} {suc n} {a} = nat-cond-□-▹ᵏ k

-- If A is delayed by k, then it is delayed
▹ᵏ-to-◇ : ∀(k : ℕ) -> F-delay k ⟹ F-◇
▹ᵏ-to-◇ k = record
    { at = λ A n a → k , a
    ; nat-cond = refl
    }

-- □ A is always available, in particular, after any delay
□-to-◇ : ∀{k} -> F-□ ⟹ F-◇
□-to-◇ {k} = ▹ᵏ-to-◇ k ⊚ □-to-▹ᵏ k

-- | Monadic operations for ◇

return : ∀{A : τ} -> A ⇴ ◇ A
return {A} = η.at A

-- Monadic extension
_⋆ : ∀{A B : τ} -> (A ⇴ ◇ B) -> (◇ A ⇴ ◇ B)
_⋆ {A} {B} f = μ.at B ∘ F-◇.fmap f
infixl 55 _⋆

-- Bind operator
_>>=_ : ∀{A B : τ}{n : ℕ} -> (◇ A) n -> (A ⇴ (◇ B)) -> (◇ B) n
_>>=_ {n = n} a f = (f ⋆) n a

-- Bind is associative
>>=-assoc : ∀{A B C : τ}{n : ℕ} -> (a : (◇ A) n) -> (f : (A ⇴ (◇ B))) -> (g : (B ⇴ (◇ C)))
         -> (a >>= f) >>= g ≡ a >>= (λ k x → (f k x) >>= g)
>>=-assoc {A}{B}{C} {n} a f g =
    begin
        ((a >>= f) >>= g)
    ≡⟨⟩
        μ.at C n ⌞ (((fmap g ∘ μ.at B) ∘ fmap f) n a) ⌟
    ≡⟨ cong! (≈-cong-left {f = fmap g} (μ.nat-cond {B} {◇ C} {g} {n} {fmap f n a}) {n} {a >>= f}) ⟩
        (((μ.at C ∘ μ.at (◇ C)) ∘ fmap (fmap g)) ∘ fmap f) n a
    ≡⟨ lemma ⟩
        (((μ.at C ∘ fmap (μ.at C)) ∘ fmap (fmap g)) ∘ fmap f) n a
    ≡⟨ cong (μ.at C n) (≈-cong-left {f = fmap g} (sym (fmap-∘ {a = fmap f n a})) {n} {a >>= f}) ⟩
        μ.at C n ((fmap (μ.at C ∘ fmap g) ∘ fmap f) n a)
    ≡⟨ cong (μ.at C n) (sym (fmap-∘ {a = a})) ⟩
        μ.at C n (fmap ((μ.at C ∘ fmap g) ∘ f) n a)
    ≡⟨⟩
        (a >>= (λ k x → f k x >>= g))
    ∎
    where
    open Functor F-◇
    lemma : (((μ.at C ∘ μ.at (◇ C)) ∘ fmap (fmap g)) ∘ fmap f) n a
          ≡ (((μ.at C ∘ fmap (μ.at C)) ∘ fmap (fmap g)) ∘ fmap f) n a
    lemma rewrite μ-assoc {C} {n} {((fmap (fmap g)) ∘ fmap f) n a} = refl

-- Return is left unit to bind
>>=-unit-left : ∀{A B : τ}{n : ℕ} -> (a : A n)(f : A ⇴ ◇ B)
             -> (η.at A n a) >>= f ≡ f n a
>>=-unit-left a f = η-unit1

-- Return is right unit to bind
>>=-unit-right : ∀{A : τ}{n : ℕ} -> (a : (◇ A) n)
              -> a >>= η.at A ≡ a
>>=-unit-right a = η-unit2


module Builtin.Reflection where

open import Prelude hiding (abs)
open import Prelude.Equality.Unsafe
open import Builtin.Float
open import Container.Traversable
open import Control.Monad.Zero

open import Agda.Builtin.Reflection as Builtin
open Builtin public
  hiding ( primQNameEquality
         ; primQNameLess
         ; primShowQName
         ; primMetaEquality
         ; primMetaLess
         ; primShowMeta )

--- Names ---

instance
  ShowName : Show Name
  showsPrec {{ShowName}} _ x = showString (primShowQName x)

instance
  EqName : Eq Name
  _==_ {{EqName}} x y with primQNameEquality x y
  ... | true  = yes unsafeEqual
  ... | false = no unsafeNotEqual

data LessName (x y : Name) : Set where
  less-name : primQNameLess x y ≡ true → LessName x y

private
  cmpName : ∀ x y → Comparison LessName x y
  cmpName x y with inspect (primQNameLess x y)
  ... | true  with≡ eq = less (less-name eq)
  ... | false with≡ _  with inspect (primQNameLess y x)
  ...   | true with≡ eq = greater (less-name eq)
  ...   | false with≡ _ = equal unsafeEqual

instance
  OrdName : Ord Name
  OrdName = defaultOrd cmpName

  OrdLawsName : Ord/Laws Name
  Ord/Laws.super OrdLawsName    = it
  less-antirefl {{OrdLawsName}} (less-name eq) = unsafeNotEqual eq
  less-trans    {{OrdLawsName}} (less-name _)  (less-name _)   = less-name unsafeEqual

--- Meta variables ---

instance
  ShowMeta : Show Meta
  showsPrec {{ShowMeta}} _ x = showString (primShowMeta x)

instance
  EqMeta : Eq Meta
  _==_ {{EqMeta}} x y with primMetaEquality x y
  ... | true  = yes unsafeEqual
  ... | false = no  unsafeNotEqual

data LessMeta (x y : Meta) : Set where
  less-meta : primMetaLess x y ≡ true → LessMeta x y

private
  cmpMeta : ∀ x y → Comparison LessMeta x y
  cmpMeta x y with inspect (primMetaLess x y)
  ... | true  with≡ eq = less (less-meta eq)
  ... | false with≡ _  with inspect (primMetaLess y x)
  ...   | true with≡ eq = greater (less-meta eq)
  ...   | false with≡ _ = equal unsafeEqual

instance
  OrdMeta : Ord Meta
  OrdMeta = defaultOrd cmpMeta

  OrdLawsMeta : Ord/Laws Meta
  Ord/Laws.super OrdLawsMeta = it
  less-antirefl {{OrdLawsMeta}} (less-meta eq) = unsafeNotEqual eq
  less-trans    {{OrdLawsMeta}} (less-meta _)  (less-meta _)   = less-meta unsafeEqual

--- Literals ---

instance
  ShowLiteral : Show Literal
  showsPrec {{ShowLiteral}} _ (nat n)    = shows n
  showsPrec {{ShowLiteral}} _ (word64 n) = shows n
  showsPrec {{ShowLiteral}} _ (float x)  = shows x
  showsPrec {{ShowLiteral}} _ (char c)   = shows c
  showsPrec {{ShowLiteral}} _ (string s) = shows s
  showsPrec {{ShowLiteral}} _ (name x)   = shows x
  showsPrec {{ShowLiteral}} _ (meta x)   = shows x

--- Terms ---

pattern vArg x = arg (arg-info visible relevant) x
pattern hArg x = arg (arg-info hidden relevant) x
pattern iArg x = arg (arg-info instance′ relevant) x

unArg : ∀ {A} → Arg A → A
unArg (arg _ x) = x

getArgInfo : ∀ {A} → Arg A → ArgInfo
getArgInfo (arg i _) = i

getVisibility : ∀ {A} → Arg A → Visibility
getVisibility (arg (arg-info v _) _) = v

getRelevance : ∀ {A} → Arg A → Relevance
getRelevance (arg (arg-info _ r) _) = r

isVisible : ∀ {A} → Arg A → Bool
isVisible (arg (arg-info visible _) _) = true
isVisible _ = false

instance
  FunctorArg : Functor Arg
  fmap {{FunctorArg}} f (arg i x) = arg i (f x)

  TraversableArg : Traversable Arg
  traverse {{TraversableArg}} f (arg i x) = ⦇ (arg i) (f x) ⦈

unAbs : ∀ {A} → Abs A → A
unAbs (abs _ x) = x

instance
  FunctorAbs : Functor Abs
  fmap {{FunctorAbs}} f (abs s x) = abs s (f x)

  TraversableAbs : Traversable Abs
  traverse {{TraversableAbs}} f (abs s x) = ⦇ (abs s) (f x) ⦈

absurd-lam : Term
absurd-lam = pat-lam (absurd-clause (vArg absurd ∷ []) ∷ []) []

--- TC monad ---

mapTC : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → TC A → TC B
mapTC f m = bindTC m λ x → returnTC (f x)

instance
  FunctorTC : ∀ {a} → Functor {a} TC
  fmap {{FunctorTC}} = mapTC

  ApplicativeTC : ∀ {a} → Applicative {a} TC
  pure  {{ApplicativeTC}} = returnTC
  _<*>_ {{ApplicativeTC}} = monadAp bindTC

  MonadTC : ∀ {a} → Monad {a} TC
  _>>=_  {{MonadTC}} = bindTC

  FunctorTC′ : ∀ {a b} → Functor′ {a} {b} TC
  fmap′ {{FunctorTC′}} = mapTC

  ApplicativeTC′ : ∀ {a b} → Applicative′ {a} {b} TC
  _<*>′_ {{ApplicativeTC′}} = monadAp′ bindTC

  MonadTC′ : ∀ {a b} → Monad′ {a} {b} TC
  _>>=′_ {{MonadTC′}} = bindTC

  FunctorZeroTC : ∀ {a} → FunctorZero {a} TC
  empty {{FunctorZeroTC}} = typeError []

  AlternativeTC : ∀ {a} → Alternative {a} TC
  _<|>_ {{AlternativeTC}} = catchTC

Tactic = Term → TC ⊤

give : Term → Tactic
give v = λ hole → unify hole v

define : Arg Name → Type → List Clause → TC ⊤
define f a cs = declareDef f a >> defineFun (unArg f) cs

newMeta : Type → TC Term
newMeta = checkType unknown

newMeta! : TC Term
newMeta! = newMeta unknown

typeErrorS : ∀ {a} {A : Set a} → String → TC A
typeErrorS s = typeError (strErr s ∷ [])

blockOnMeta! : ∀ {a} {A : Set a} → Meta → TC A
blockOnMeta! x = commitTC >>=′ λ _ → blockOnMeta x

inferNormalisedType : Term → TC Type
inferNormalisedType t = withNormalisation true (inferType t)

--- Convenient wrappers ---

-- Zero for non-datatypes
getParameters : Name → TC Nat
getParameters d =
  caseM getDefinition d of λ
  { (data-type n _) → pure n
  ; _ → pure 0 }

getConstructors : Name → TC (List Name)
getConstructors d =
  caseM getDefinition d of λ
  { (data-type _ cs) → pure cs
  ; (record-type c _) → pure (c ∷ [])
  ; _ → typeError (strErr "Cannot get constructors of non-data or record type" ∷ nameErr d ∷ [])
  }

getClauses : Name → TC (List Clause)
getClauses d =
  caseM getDefinition d of λ
  { (function cs) → pure cs
  ; _ → typeError (strErr "Cannot get constructors of non-function type" ∷ nameErr d ∷ [])
  }

-- Get the constructor of a record type (or single-constructor data type)
recordConstructor : Name → TC Name
recordConstructor r =
  caseM getConstructors r of λ
  { (c ∷ []) → pure c
  ; _ → typeError $ strErr "Cannot get constructor of non-record type" ∷ nameErr r ∷ [] }

-- Injectivity of constructors

arg-inj₁ : ∀ {A i i′} {x x′ : A} → arg i x ≡ arg i′ x′ → i ≡ i′
arg-inj₁ refl = refl

arg-inj₂ : ∀ {A i i′} {x x′ : A} → arg i x ≡ arg i′ x′ → x ≡ x′
arg-inj₂ refl = refl

arg-info-inj₁ : ∀ {v v′ r r′} → arg-info v r ≡ arg-info v′ r′ → v ≡ v′
arg-info-inj₁ refl = refl

arg-info-inj₂ : ∀ {v v′ r r′} → arg-info v r ≡ arg-info v′ r′ → r ≡ r′
arg-info-inj₂ refl = refl

abs-inj₁ : ∀ {A s s′} {x x′ : A} → abs s x ≡ abs s′ x′ → s ≡ s′
abs-inj₁ refl = refl

abs-inj₂ : ∀ {A s s′} {x x′ : A} → abs s x ≡ abs s′ x′ → x ≡ x′
abs-inj₂ refl = refl

--- Terms ---

var-inj₁ : ∀ {x x′ args args′} → Term.var x args ≡ var x′ args′ → x ≡ x′
var-inj₁ refl = refl

var-inj₂ : ∀ {x x′ args args′} → Term.var x args ≡ var x′ args′ → args ≡ args′
var-inj₂ refl = refl

con-inj₁ : ∀ {c c′ args args′} → Term.con c args ≡ con c′ args′ → c ≡ c′
con-inj₁ refl = refl

con-inj₂ : ∀ {c c′ args args′} → Term.con c args ≡ con c′ args′ → args ≡ args′
con-inj₂ refl = refl

def-inj₁ : ∀ {f f′ args args′} → def f args ≡ def f′ args′ → f ≡ f′
def-inj₁ refl = refl

def-inj₂ : ∀ {f f′ args args′} → def f args ≡ def f′ args′ → args ≡ args′
def-inj₂ refl = refl

meta-inj₁ : ∀ {f f′ args args′} → Term.meta f args ≡ meta f′ args′ → f ≡ f′
meta-inj₁ refl = refl

meta-inj₂ : ∀ {f f′ args args′} → Term.meta f args ≡ meta f′ args′ → args ≡ args′
meta-inj₂ refl = refl

lam-inj₁ : ∀ {v v′ t t′} → lam v t ≡ lam v′ t′ → v ≡ v′
lam-inj₁ refl = refl

lam-inj₂ : ∀ {v v′ t t′} → lam v t ≡ lam v′ t′ → t ≡ t′
lam-inj₂ refl = refl

pat-lam-inj₁ : ∀ {v v′ t t′} → pat-lam v t ≡ pat-lam v′ t′ → v ≡ v′
pat-lam-inj₁ refl = refl

pat-lam-inj₂ : ∀ {v v′ t t′} → pat-lam v t ≡ pat-lam v′ t′ → t ≡ t′
pat-lam-inj₂ refl = refl

pi-inj₁ : ∀ {t₁ t₁′ t₂ t₂′} → pi t₁ t₂ ≡ pi t₁′ t₂′ → t₁ ≡ t₁′
pi-inj₁ refl = refl

pi-inj₂ : ∀ {t₁ t₁′ t₂ t₂′} → pi t₁ t₂ ≡ pi t₁′ t₂′ → t₂ ≡ t₂′
pi-inj₂ refl = refl

sort-inj : ∀ {x y} → agda-sort x ≡ agda-sort y → x ≡ y
sort-inj refl = refl

lit-inj : ∀ {x y} → Term.lit x ≡ lit y → x ≡ y
lit-inj refl = refl

--- Sorts ---

set-inj : ∀ {x y} → set x ≡ set y → x ≡ y
set-inj refl = refl

slit-inj : ∀ {x y} → Sort.lit x ≡ lit y → x ≡ y
slit-inj refl = refl

--- Patterns ---

pcon-inj₁ : ∀ {x y z w} → Pattern.con x y ≡ con z w → x ≡ z
pcon-inj₁ refl = refl

pcon-inj₂ : ∀ {x y z w} → Pattern.con x y ≡ con z w → y ≡ w
pcon-inj₂ refl = refl

pvar-inj : ∀ {x y} → Pattern.var x ≡ var y → x ≡ y
pvar-inj refl = refl

plit-inj : ∀ {x y} → Pattern.lit x ≡ lit y → x ≡ y
plit-inj refl = refl

proj-inj : ∀ {x y} → Pattern.proj x ≡ proj y → x ≡ y
proj-inj refl = refl

--- Clauses ---

clause-inj₁ : ∀ {x y z w} → clause x y ≡ clause z w → x ≡ z
clause-inj₁ refl = refl

clause-inj₂ : ∀ {x y z w} → clause x y ≡ clause z w → y ≡ w
clause-inj₂ refl = refl

absurd-clause-inj : ∀ {x y} → absurd-clause x ≡ absurd-clause y → x ≡ y
absurd-clause-inj refl = refl

--- Literals ---

nat-inj : ∀ {x y} → nat x ≡ nat y → x ≡ y
nat-inj refl = refl

word64-inj : ∀ {x y} → word64 x ≡ word64 y → x ≡ y
word64-inj refl = refl

float-inj : ∀ {x y} → float x ≡ float y → x ≡ y
float-inj refl = refl

char-inj : ∀ {x y} → char x ≡ char y → x ≡ y
char-inj refl = refl

string-inj : ∀ {x y} → string x ≡ string y → x ≡ y
string-inj refl = refl

name-inj : ∀ {x y} → name x ≡ name y → x ≡ y
name-inj refl = refl

meta-inj : ∀ {x y} → Literal.meta x ≡ meta y → x ≡ y
meta-inj refl = refl


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

-- RWS monad implementation, and functionality for proving properties about
-- programs written using this RWS monad.
-- It includes constructors for branching code, to aid in the verification.

module Haskell.Modules.RWS where

open import Haskell.Prelude
------------------------------------------------------------------------------
open import Data.Product using (_×_; _,_)

-- (free) RWS : the AST of computations with state `St` reading from an environment
-- `Ev` and producing a list of outputs of type `Wr`
data RWS (Ev Wr St : Set) : Set → Set₁ where
  -- Primitive combinators
  RWS-return : ∀ {A}   → A                                       → RWS Ev Wr St A
  RWS-bind   : ∀ {A B} → RWS Ev Wr St A → (A → RWS Ev Wr St B)   → RWS Ev Wr St B
  RWS-gets   : ∀ {A} → (St → A)                                  → RWS Ev Wr St A
  RWS-put    : St                                                → RWS Ev Wr St Unit
  RWS-ask    :                                                     RWS Ev Wr St Ev
  RWS-tell   : List Wr                                           → RWS Ev Wr St Unit
  -- Branching combinators (used for creating more convenient contracts)
  RWS-if     : ∀ {A} → Guards (RWS Ev Wr St A)                   → RWS Ev Wr St A
  RWS-either : ∀ {A B C}
             → (B → RWS Ev Wr St A) → (C → RWS Ev Wr St A)
             → Either B C                                        → RWS Ev Wr St A
  RWS-ebind  : ∀ {A B C}
             → RWS Ev Wr St (Either C A)
             → (A → RWS Ev Wr St (Either C B))                   → RWS Ev Wr St (Either C B)
  RWS-maybe  : ∀ {A B}
             → (RWS Ev Wr St A) → (B → RWS Ev Wr St A) → Maybe B → RWS Ev Wr St A

private
  variable
    Ev Wr St : Set
    A B C    : Set

-- From this instance declaration, we get _<$>_, pure, and _<*>_ also.
instance
  RWS-Monad : Monad (RWS Ev Wr St)
  Monad.return RWS-Monad = RWS-return
  Monad._>>=_  RWS-Monad = RWS-bind

gets : (St → A) → RWS Ev Wr St A
gets = RWS-gets

get : RWS Ev Wr St St
get = gets id

put : St → RWS Ev Wr St Unit
put = RWS-put

modify : (St → St) → RWS Ev Wr St Unit
modify f = do
  st ← get
  put (f st)

ask : RWS Ev Wr St Ev
ask = RWS-ask

tell : List Wr → RWS Ev Wr St Unit
tell = RWS-tell

void : RWS Ev Wr St A → RWS Ev Wr St Unit
void m = do
  _ ← m
  pure unit

-- To execute an RWS program, you provide an environment and prestate.
-- This produces a result value, poststate, and list of outputs.
RWS-run : RWS Ev Wr St A → Ev → St → A × St × List Wr
RWS-run (RWS-return x)               ev st = x , st , []
RWS-run (RWS-bind m f)               ev st
   with RWS-run m ev st
...| x₁ , st₁ , outs₁
   with RWS-run (f x₁) ev st₁
...| x₂ , st₂ , outs₂                      = x₂ , st₂ , outs₁ ++ outs₂
RWS-run (RWS-gets f)                 ev st = f st , st , []
RWS-run (RWS-put st)                 ev _  = unit , st , []
RWS-run RWS-ask                      ev st = ev , st , []
RWS-run (RWS-tell outs)              ev st = unit , st , outs
RWS-run (RWS-if (clause (b ≔ c) gs)) ev st =
  if toBool b then RWS-run c ev st else RWS-run (RWS-if gs) ev st
RWS-run (RWS-if (otherwise≔ c))      ev st = RWS-run c ev st
RWS-run (RWS-either f₁ f₂ (Left x) ) ev st = RWS-run (f₁ x) ev st
RWS-run (RWS-either f₁ f₂ (Right y)) ev st = RWS-run (f₂ y) ev st
RWS-run (RWS-ebind m f)              ev st
   with RWS-run m ev st
...| Left  c , st₁ , outs₁ = Left c , st₁ , outs₁
...| Right a , st₁ , outs₁
   with RWS-run (f a) ev st₁
...|       r , st₂ , outs₂                 = r , st₂ , outs₁ ++ outs₂
RWS-run (RWS-maybe f₁ f₂ nothing )   ev st = RWS-run f₁ ev st
RWS-run (RWS-maybe f₁ f₂ (just x))   ev st = RWS-run (f₂ x) ev st

-- Accessors for the result, poststate, and outputs.
RWS-result : RWS Ev Wr St A → Ev → St → A
RWS-result m ev st =      fst (RWS-run m ev st)

RWS-post   : RWS Ev Wr St A → Ev → St → St
RWS-post   m ev st = fst (snd (RWS-run m ev st))

RWS-outs   : RWS Ev Wr St A → Ev → St → List Wr
RWS-outs   m ev st = snd (snd (RWS-run m ev st))


open import Data.Empty using (⊥-elim)
open import Data.Fin using (Fin; _≟_)
open import Data.Nat using (suc; zero)
open import Data.Nat.Properties using (suc-injective; 0≢1+n)
open import Data.Product using (∃-syntax; _×_; _,_; proj₁; proj₂)
open import Data.Sum using (inj₁; inj₂)
open import Data.Vec using (lookup; _[_]≔_)
open import Data.Vec.Properties using (lookup∘update; lookup∘update′)
open import Relation.Binary.PropositionalEquality using (refl; sym; cong; trans; _≡_; _≢_; module ≡-Reasoning)
open import Relation.Nullary using (yes; no)
open ≡-Reasoning

open import Common
open import Global
open import Local
open import Projection

completeness :
  ∀{ n } { act : Action n } { c c′ g g-size }
  -> { g-size-is-size-g : g-size ≡ size-g g }
  -> g ↔ c
  -> c - act →c c′
  -> ∃[ g′ ] g - act →g g′ × g′ ↔ c′
completeness assoc (→c-comm c p≢q lp≡c[p] lq≡c[q] c→c′ (→l-send p _ _) (→l-send .p _ _))
  = ⊥-elim (p≢q refl)
completeness assoc (→c-comm c p≢q lp≡c[p] lq≡c[q] c→c′ (→l-recv p _ _) (→l-send .p _ _))
  = ⊥-elim (p≢q refl)
completeness assoc (→c-comm c p≢q lp≡c[p] lq≡c[q] c→c′ (→l-recv p _ _) (→l-recv .p _ _))
  = ⊥-elim (p≢q refl)
completeness
  {n}
  {act}
  {c′ = c′}
  {g = g}
  {g-size = g-size}
  {g-size-is-size-g = g-size-is-size-g}
  assoc
  (→c-comm {p} {q} {l} c p≢q lp≡c[p] lq≡c[q] refl
    lpReduce@(→l-send {lp = lp} {lpSub = lp′} .p refl p≢q-p)
    lqReduce@(→l-recv {lp = lq} {lpSub = lq′} .q refl p≢q-q)
  )
  with proj-inv-send-recv {g = g}
    (trans (sym (_↔_.isProj assoc p)) (sym lp≡c[p]))
    (trans (sym (_↔_.isProj assoc q)) (sym lq≡c[q]))
... | inj₁ (p≢q , g′ , refl , refl , refl)
    = g′ , →g-prefix , record { isProj = isProj-g′ }
    where
      isProj-g′ : (r : Fin n) -> lookup c′ r ≡ project g′ r
      isProj-g′ r with r ≟ p | r ≟ q
      ...   | yes refl | yes refl = ⊥-elim (p≢q refl)
      ...   | no r≢p   | yes refl
        rewrite lookup∘update q (c [ p ]≔ lp′) lq′
        = refl
      ...   | yes refl | no r≢q
        rewrite lookup∘update′ p≢q (c [ p ]≔ lp′) lq′
        rewrite lookup∘update p c lp′
        = refl
      ...    | no r≢p  | no r≢q
        rewrite lookup∘update′ r≢q (c [ p ]≔ lp′) lq′
        rewrite lookup∘update′ r≢p c lp′
        rewrite sym (proj-prefix-other {l = l} p q r {p≢q} g′ (¬≡-flip r≢p) (¬≡-flip r≢q))
        rewrite _↔_.isProj assoc r
        = refl
... | inj₂ (r , s , r≢s , l′ , gSub , refl , r≢p , s≢p , r≢q , s≢q , gSub-proj-p , gSub-proj-q)
    with g-size
...   | zero
      = ⊥-elim (0≢1+n g-size-is-size-g)
...   | suc gSub-size
      = g′ , gReduce , record { isProj = isProj-g′ }
        where
          lrSub = project gSub r
          lsSub = project gSub s
          remove-prefix-g : ∃[ cSub ] cSub ≡ (c [ r ]≔ lrSub) [ s ]≔ lsSub × gSub ↔ cSub
          remove-prefix-g = config-gt-remove-prefix g c assoc refl
          completeness-gSub : ∃[ gSub′ ] gSub - act →g gSub′ × gSub′ ↔ ((((c [ r ]≔ lrSub) [ s ]≔ lsSub) [ p ]≔ lp′) [ q ]≔ lq′)
          completeness-gSub with remove-prefix-g
          ... | cSub , refl , gSub↔cSub
            = completeness {g = gSub} {g-size = gSub-size} {gSub-size-is-size-gSub} gSub↔cSub cSub→cSub′
            where
              gSub-size-is-size-gSub : gSub-size ≡ size-g gSub
              gSub-size-is-size-gSub = suc-injective g-size-is-size-g
              cSub′ = (cSub [ p ]≔ lp′) [ q ]≔ lq′
              cSub→cSub′ : cSub - act →c cSub′
              cSub→cSub′
                with remove-prefix-g
              ... | cSub , refl , gSub↔cSub = →c-comm cSub p≢q lp≡cSub[p] lq≡cSub[q] refl lpReduce lqReduce
                where
                  lp≡cSub[p] : lp ≡ lookup cSub p
                  lp≡cSub[p]
                    rewrite lp≡c[p]
                    rewrite sym (lookup∘update′ (¬≡-flip r≢p) c lrSub)
                    rewrite sym (lookup∘update′ (¬≡-flip s≢p) (c [ r ]≔ lrSub) lsSub)
                    = refl
                  lq≡cSub[q] : lq ≡ lookup cSub q
                  lq≡cSub[q]
                    rewrite lq≡c[q]
                    rewrite sym (lookup∘update′ (¬≡-flip r≢q) c lrSub)
                    rewrite sym (lookup∘update′ (¬≡-flip s≢q) (c [ r ]≔ lrSub) lsSub)
                    = refl
          g′ : Global n
          g′ with completeness-gSub
          ... | gSub′ , _ , _ = msgSingle r s r≢s l′ gSub′
          gReduce : g - act →g g′
          gReduce with completeness-gSub
          ... | gSub′ , gSubReduce , gSub′↔cSub′
            = →g-cont gSubReduce (¬≡-flip r≢p) (¬≡-flip r≢q) (¬≡-flip s≢p) (¬≡-flip s≢q)
          isProj-g′ : (t : Fin n) -> lookup c′ t ≡ project g′ t
          isProj-g′ t with remove-prefix-g | completeness-gSub
          ... | cSub , un-c′ , g′↔c′ | gSub′ , gSubReduce , gSub′↔cSub′
              with r ≟ t  | s ≟ t
          ... | yes refl | yes refl = ⊥-elim (r≢s refl)
          ... | no r≢t   | yes refl
              rewrite sym (_↔_.isProj gSub′↔cSub′ s)
              rewrite lookup∘update′ s≢q (c [ p ]≔ lp′) lq′
              rewrite lookup∘update′ s≢p c lp′
              rewrite _↔_.isProj assoc s
              rewrite proj-prefix-recv {l = l′} r s gSub r≢s
              rewrite lookup∘update′ s≢q (((c [ r ]≔ lrSub) [ s ]≔ lsSub) [ p ]≔ lp′) lq′
              rewrite lookup∘update′ s≢p ((c [ r ]≔ lrSub) [ s ]≔ lsSub) lp′
              rewrite lookup∘update s (c [ r ]≔ lrSub) lsSub
              = refl
          ... | yes refl | no s≢t
              rewrite sym (_↔_.isProj gSub′↔cSub′ r)
              rewrite lookup∘update′ r≢q (c [ p ]≔ lp′) lq′
              rewrite lookup∘update′ r≢p c lp′
              rewrite _↔_.isProj assoc r
              rewrite proj-prefix-send {l = l′} r s gSub r≢s
              rewrite lookup∘update′ r≢q (((c [ r ]≔ lrSub) [ s ]≔ lsSub) [ p ]≔ lp′) lq′
              rewrite lookup∘update′ r≢p ((c [ r ]≔ lrSub) [ s ]≔ lsSub) lp′
              rewrite lookup∘update′ r≢s (c [ r ]≔ lrSub) lsSub
              rewrite lookup∘update r c lrSub
              = refl
          ... | no r≢t  | no s≢t
              rewrite proj-prefix-other {l = l′} r s t {r≢s} gSub′ r≢t s≢t
              with p ≟ t  | q ≟ t
          ...   | yes refl | yes refl = ⊥-elim (p≢q refl)
          ...   | yes refl | no  q≢t
                  rewrite lookup∘update′ p≢q (c [ p ]≔ lp′) lq′
                  rewrite lookup∘update p c lp′
                  rewrite sym (_↔_.isProj gSub′↔cSub′ p)
                  rewrite lookup∘update′ p≢q (((c [ r ]≔ lrSub) [ s ]≔ lsSub) [ p ]≔ lp′) lq′
                  rewrite lookup∘update p ((c [ r ]≔ lrSub) [ s ]≔ lsSub) lp′
                  = refl
          ...   | no  p≢t  | yes refl
                  rewrite lookup∘update q (c [ p ]≔ lp′) lq′
                  rewrite sym (_↔_.isProj gSub′↔cSub′ q)
                  rewrite lookup∘update q (((c [ r ]≔ lrSub) [ s ]≔ lsSub) [ p ]≔ lp′) lq′
                  = refl
          ...   | no  p≢t  | no  q≢t
                  rewrite lookup∘update′ (¬≡-flip q≢t) (c [ p ]≔ lp′) lq′
                  rewrite lookup∘update′ (¬≡-flip p≢t) c lp′
                  rewrite sym (_↔_.isProj gSub′↔cSub′ t)
                  rewrite lookup∘update′ (¬≡-flip q≢t) (((c [ r ]≔ lrSub) [ s ]≔ lsSub) [ p ]≔ lp′) lq′
                  rewrite lookup∘update′ (¬≡-flip p≢t) ((c [ r ]≔ lrSub) [ s ]≔ lsSub) lp′
                  rewrite lookup∘update′ (¬≡-flip s≢t) (c [ r ]≔ lrSub) lsSub
                  rewrite lookup∘update′ (¬≡-flip r≢t) c lrSub
                  = refl


------------------------------------------------------------------------------
-- Reasoning partially about functions
------------------------------------------------------------------------------

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

-- We cannot reasoning partially about partial functions intended to
-- operate in total values.

module FOT.FOTC.Data.Nat.AddPartialRightIdentity where

open import FOTC.Base
open import FOTC.Data.Nat

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

-- How proceed?
+-partialRightIdentity : ∀ n → n + zero ≡ n
+-partialRightIdentity n = {!!}


------------------------------------------------------------------------
-- A delay monad with the possibility of crashing
------------------------------------------------------------------------

module Lambda.Delay-crash where

import Equality.Propositional as E
open import Logical-equivalence using (_⇔_)
open import Prelude
open import Prelude.Size

import Conat E.equality-with-J as Conat
open import Function-universe E.equality-with-J hiding (_∘_)
open import Maybe E.equality-with-J as Maybe hiding (raw-monad)
open import Monad E.equality-with-J as M
  using (Raw-monad; _>>=_)

open import Delay-monad
open import Delay-monad.Bisimilarity
open import Delay-monad.Bisimilarity.Kind
import Delay-monad.Monad as DM
import Delay-monad.Parallel as DP
import Delay-monad.Sequential as DS
open import Delay-monad.Termination

private

  variable
    A B C     : Type
    i         : Size
    f g k x y : A

------------------------------------------------------------------------
-- Types and operations

-- The monad.

Delay-crash : Type → Size → Type
Delay-crash A i = Delay (Maybe A) i

-- A raw-monad instance. (This definition is turned into an actual
-- instance at the end of this module, to avoid problems with instance
-- resolution.)

private

  raw-monad′ : Raw-monad (λ A → Delay-crash A i)
  raw-monad′ {i = i} =
    _⇔_.to (M.⇔→raw⇔raw {F = MaybeT (λ A → Delay A i)}
              (λ _ → record { to = run; from = wrap }))
      it

  module DC {i} = Raw-monad (raw-monad′ {i = i})

-- A crashing computation.

pattern crash = now nothing

private

  -- A computation that terminates now.

  pattern return x = now (just x)

-- Sequential composition of computations.
--
-- Note that if the first argument fails to terminate, and the other
-- one crashes, then the computation fails to terminate. However, if
-- the first argument crashes, then the computation always crashes.

infixl 6 _⊛ˢ_

_⊛ˢ_ : Delay-crash (A → B) i → Delay-crash A i → Delay-crash B i
f ⊛ˢ x = f DC.>>= λ f → x DC.>>= λ x → DC.return (f x)

-- Parallel composition of computations.
--
-- Note that if the first argument fails to terminate, and the other
-- one crashes, then the computation fails to terminate. However, if
-- the first argument crashes, then the computation always crashes.

infixl 6 _⊛ᵖ_

_⊛ᵖ_ : Delay-crash (A → B) i → Delay-crash A i → Delay-crash B i
crash    ⊛ᵖ _            = crash
return f ⊛ᵖ return x     = return (f x)
return f ⊛ᵖ crash        = crash
return f ⊛ᵖ later x      = later λ { .force → return f ⊛ᵖ x .force }
later f  ⊛ᵖ later x      = later λ { .force → f .force ⊛ᵖ x .force }
later f  ⊛ᵖ x            = later λ { .force → f .force ⊛ᵖ x }

------------------------------------------------------------------------
-- Some properties

-- Bind preserves strong and weak bisimilarity and the expansion
-- relation.

infixl 5 _>>=-cong_

_>>=-cong_ :
  [ i ] x ⟨ k ⟩ y →
  (∀ z → [ i ] f z ⟨ k ⟩ g z) →
  [ i ] x DC.>>= f ⟨ k ⟩ y DC.>>= g
p >>=-cong q = p DM.>>=-cong [ (λ _ → run fail ∎) , q ]

-- Sequential composition preserves strong and weak bisimilarity and
-- the expansion relation.

infixl 6 _⊛ˢ-cong_

_⊛ˢ-cong_ :
  [ i ] f ⟨ k ⟩ g →
  [ i ] x ⟨ k ⟩ y →
  [ i ] f ⊛ˢ x ⟨ k ⟩ g ⊛ˢ y
p ⊛ˢ-cong q = p >>=-cong λ _ → q >>=-cong λ _ → now

-- Parallel composition preserves strong and weak bisimilarity and the
-- expansion relation.

infixl 6 _⊛ᵖ-cong_

_⊛ᵖ-cong_ :
  [ i ] f ⟨ k ⟩ g →
  [ i ] x ⟨ k ⟩ y →
  [ i ] f ⊛ᵖ x ⟨ k ⟩ g ⊛ᵖ y
_⊛ᵖ-cong_ = λ p q → ⊛ᵖ-cong-helper _ _ p _ _ q
  where
  crash-lemma :
    [ i ] f ⟨ other k ⟩ crash → ∀ x → [ i ] f ⊛ᵖ x ⟨ other k ⟩ crash
  crash-lemma now        x         = now
  crash-lemma (laterˡ p) (now x)   = laterˡ (crash-lemma p _)
  crash-lemma (laterˡ p) (later x) = laterˡ (crash-lemma p _)

  ⊛ᵖ-cong-helper :
    (f g : Delay-crash (A → B) ∞) → [ i ] f ⟨ k ⟩ g →
    (x y : Delay-crash A ∞) →       [ i ] x ⟨ k ⟩ y →
    [ i ] f ⊛ᵖ x ⟨ k ⟩ g ⊛ᵖ y
  ⊛ᵖ-cong-helper crash crash now = λ _ _ _ → now

  ⊛ᵖ-cong-helper (return f) .(return f) now = λ where
    (later x)  (later y)   q          → later λ { .force → now ⊛ᵖ-cong later⁻¹ q }
    crash      crash       now        → now
    (return x) .(return x) now        → now
    _          _           (laterˡ q) → laterˡ (now ⊛ᵖ-cong q)
    _          _           (laterʳ q) → laterʳ (now ⊛ᵖ-cong q)

  ⊛ᵖ-cong-helper (later f) (later g) p = λ where
    crash      crash       now        → later λ { .force → later⁻¹ p ⊛ᵖ-cong now }
    (return x) .(return x) now        → later λ { .force → later⁻¹ p ⊛ᵖ-cong now }
    (later x)  (later y)   q          → later λ { .force → later⁻¹ p ⊛ᵖ-cong later⁻¹ q }
    _          crash       (laterˡ q) → later λ { .force → later⁻¹ p ⊛ᵖ-cong q }
    _          (return y)  (laterˡ q) → later λ { .force → later⁻¹ p ⊛ᵖ-cong q }
    crash      _           (laterʳ q) → later λ { .force → later⁻¹ p ⊛ᵖ-cong q }
    (return x) _           (laterʳ q) → later λ { .force → later⁻¹ p ⊛ᵖ-cong q }

  ⊛ᵖ-cong-helper _ (return g) (laterˡ p) = λ where
    crash      crash       now        → laterˡ (p ⊛ᵖ-cong now)
    (return x) .(return x) now        → laterˡ (p ⊛ᵖ-cong now)
    (later x)  (later y)   q          → later λ { .force → p ⊛ᵖ-cong later⁻¹ q }
    _          crash       (laterˡ q) → laterˡ (p ⊛ᵖ-cong q)
    _          (return y)  (laterˡ q) → laterˡ (p ⊛ᵖ-cong q)
    crash      _           (laterʳ q) → later λ { .force → p ⊛ᵖ-cong q }
    (return x) _           (laterʳ q) → later λ { .force → p ⊛ᵖ-cong q }

  ⊛ᵖ-cong-helper (return f) _ (laterʳ p) = λ where
    crash      crash       now        → laterʳ (p ⊛ᵖ-cong now)
    (return x) .(return x) now        → laterʳ (p ⊛ᵖ-cong now)
    (later x)  (later y)   q          → later λ { .force → p ⊛ᵖ-cong later⁻¹ q }
    _          crash       (laterˡ q) → later λ { .force → p ⊛ᵖ-cong q }
    _          (return y)  (laterˡ q) → later λ { .force → p ⊛ᵖ-cong q }
    crash      _           (laterʳ q) → laterʳ (p ⊛ᵖ-cong q)
    (return x) _           (laterʳ q) → laterʳ (p ⊛ᵖ-cong q)

  ⊛ᵖ-cong-helper _ crash p@(laterˡ _) = λ _ _ _ → crash-lemma p _

  ⊛ᵖ-cong-helper crash _ p@(laterʳ _) =
    λ _ _ _ → symmetric (crash-lemma (symmetric p) _)

-- The monad laws.

left-identity :
  ∀ x (f : A → Delay-crash B ∞) →
  [ ∞ ] DC.return x DC.>>= f ∼ f x
left-identity x f =
  f x  ∎

right-identity :
  (x : Delay-crash A ∞) →
  [ ∞ ] x DC.>>= DC.return ∼ x
right-identity x =
  x DC.>>= DC.return        ∼⟨⟩
  x >>= maybe return crash  ∼⟨ (x ∎) DM.>>=-cong [ (λ _ → run fail ∎) , (λ x → run (M.return x) ∎) ] ⟩
  x >>= M.return            ∼⟨ DM.right-identity′ _ ⟩
  x                         ∎

associativity :
  (x : Delay-crash A ∞)
  (f : A → Delay-crash B ∞) (g : B → Delay-crash C ∞) →
  x DC.>>= (λ x → f x DC.>>= g) ∼ x DC.>>= f DC.>>= g
associativity x f g =
  x DC.>>= (λ x → f x DC.>>= g)                      ∼⟨⟩
  x >>= maybe (λ x → f x DC.>>= g) crash             ∼⟨ (x ∎) DM.>>=-cong [ (λ _ → run fail ∎) , (λ x → f x DC.>>= g ∎) ] ⟩
  x >>= (λ x → maybe f crash x >>= maybe g crash)    ∼⟨ DM.associativity′ x _ _ ⟩
  x >>= maybe f crash >>= maybe g crash              ∼⟨⟩
  x DC.>>= f DC.>>= g                                ∎

-- Use of _⟨$⟩_ does not affect the number of steps in the
-- computation.

steps-⟨$⟩ : Conat.[ i ] steps (f DC.⟨$⟩ x) ∼ steps x
steps-⟨$⟩ {f = f} {x = x} =
  steps (f DC.⟨$⟩ x)                                 Conat.≡⟨⟩∼
  steps (x DC.>>= DC.return ∘ f)                     Conat.≡⟨⟩∼
  steps (x >>= maybe (return ∘ f) crash)             Conat.∼⟨ steps-cong ((x ∎) DM.>>=-cong [ (λ _ → run fail ∎)
                                                                                , (λ x → return (f x) ∎)
                                                                                ]) ⟩
  steps (x >>= M.return ∘ maybe (just ∘ f) nothing)  Conat.∼⟨ DM.steps-⟨$⟩ _ ⟩
  steps x                                            Conat.∎∼

-- Sequential composition is an expansion of parallel composition.

⊛ˢ≳⊛ᵖ : [ i ] f ⊛ˢ x ≳ f ⊛ᵖ x
⊛ˢ≳⊛ᵖ {f = return f} {x = return x} = now
⊛ˢ≳⊛ᵖ {f = return f} {x = crash}    = now
⊛ˢ≳⊛ᵖ {f = return f} {x = later x}  = later λ { .force → ⊛ˢ≳⊛ᵖ }
⊛ˢ≳⊛ᵖ {f = crash}                   = now
⊛ˢ≳⊛ᵖ {f = later f}  {x = now x}    = later λ { .force → ⊛ˢ≳⊛ᵖ }
⊛ˢ≳⊛ᵖ {f = later f}  {x = later x}  = later λ { .force →
  (f .force DC.>>= λ f → later x DC.>>= λ x → DC.return (f x))  ≳⟨ ((f .force ∎) >>=-cong λ _ → laterˡ (_ ∎)) ⟩
  f .force ⊛ˢ x .force                                          ≳⟨ ⊛ˢ≳⊛ᵖ ⟩∼
  f .force ⊛ᵖ x .force                                          ∎ }

-- The computation crash is a left zero for _⊛ˢ_ and _⊛ᵖ_.

crash-⊛ˢ : [ i ] crash ⊛ˢ x ∼ (crash ⦂ Delay-crash B ∞)
crash-⊛ˢ = reflexive _

crash-⊛ᵖ : [ i ] crash ⊛ᵖ x ∼ (crash ⦂ Delay-crash B ∞)
crash-⊛ᵖ = reflexive _

-- The computation never is a left zero for _⊛ˢ_ and _⊛ᵖ_.

never-⊛ˢ :
  (x : Delay-crash A ∞) →
  [ i ] never ⊛ˢ x ∼ (never ⦂ Delay-crash B ∞)
never-⊛ˢ x = later λ { .force → never-⊛ˢ x }

never-⊛ᵖ :
  (x : Delay-crash A ∞) →
  [ i ] never ⊛ᵖ x ∼ (never ⦂ Delay-crash B ∞)
never-⊛ᵖ (now x)   = later λ { .force → never-⊛ᵖ (now x) }
never-⊛ᵖ (later x) = later λ { .force → never-⊛ᵖ _ }

-- The computation never is a right zero for _⊛ˢ_ and _⊛ᵖ_ if the left
-- computation does not crash.

⊛ˢ-never : ¬ f ≈ crash → [ i ] f ⊛ˢ never ∼ never
⊛ˢ-never {f = return _} p = later λ { .force → ⊛ˢ-never p }
⊛ˢ-never {f = later _}  p = later λ { .force → ⊛ˢ-never (p ∘ laterˡ) }
⊛ˢ-never {f = crash}    p = ⊥-elim (p (_ ∎))

⊛ᵖ-never : ¬ f ≈ crash → [ i ] f ⊛ᵖ never ∼ never
⊛ᵖ-never {f = return _} p = later λ { .force → ⊛ᵖ-never p }
⊛ᵖ-never {f = later _}  p = later λ { .force → ⊛ᵖ-never (p ∘ laterˡ) }
⊛ᵖ-never {f = crash}    p = ⊥-elim (p (_ ∎))

-- The computation crash is a right zero for _⊛ˢ_ and _⊛ᵖ_ (up to
-- expansion) if the left computation terminates.

⊛ˢ-crash : f ⇓ g → [ i ] f ⊛ˢ crash ≳ crash
⊛ˢ-crash (now {x = nothing}) = now
⊛ˢ-crash (now {x = just _})  = now
⊛ˢ-crash (laterʳ p)          = laterˡ (⊛ˢ-crash p)

⊛ᵖ-crash : f ⇓ g → [ i ] f ⊛ᵖ crash ≳ crash
⊛ᵖ-crash (now {x = nothing}) = now
⊛ᵖ-crash (now {x = just _})  = now
⊛ᵖ-crash (laterʳ p)          = laterˡ (⊛ᵖ-crash p)

-- The _⊛ᵖ_ and _⊛ˢ_ operators are not (kind of) commutative.

¬-⊛ᵖ-comm :
  ¬ (∀ {f : Delay-crash (A → B) ∞} {x} →
     f ⊛ᵖ x ≈ flip _$_ DC.⟨$⟩ x ⊛ᵖ f)
¬-⊛ᵖ-comm {A = A} {B = B} =
  (∀ {f : Delay-crash (A → B) ∞} {x} → f ⊛ᵖ x ≈ flip _$_ DC.⟨$⟩ x ⊛ᵖ f)  ↝⟨ (λ hyp → hyp {f = crash} {x = never}) ⟩
  crash ≈ flip _$_ DC.⟨$⟩ never ⊛ᵖ crash                                 ↝⟨ flip transitive-∞∼ʳ lemma ⟩
  crash ≈ never                                                          ↝⟨ now≉never ⟩□
  ⊥                                                                      □
  where
  lemma : [ i ] flip _$_ DC.⟨$⟩ never ⊛ᵖ crash ∼ never
  lemma = later λ { .force → lemma }

¬-⊛ˢ-comm :
  ¬ (∀ {f : Delay-crash (A → B) ∞} {x} →
     f ⊛ˢ x ≈ flip _$_ DC.⟨$⟩ x ⊛ˢ f)
¬-⊛ˢ-comm {A = A} {B = B} =
  (∀ {f : Delay-crash (A → B) ∞} {x} → f ⊛ˢ x ≈ flip _$_ DC.⟨$⟩ x ⊛ˢ f)  ↝⟨ (λ hyp {f x} →

      f ⊛ᵖ x                                                                   ≈⟨ symmetric (≳→ ⊛ˢ≳⊛ᵖ) ⟩
      f ⊛ˢ x                                                                   ≈⟨ hyp {f = f} {x = x} ⟩
      flip _$_ DC.⟨$⟩ x ⊛ˢ f                                                   ≳⟨ ⊛ˢ≳⊛ᵖ ⟩
      flip _$_ DC.⟨$⟩ x ⊛ᵖ f                                                   ∎) ⟩

  (∀ {f : Delay-crash (A → B) ∞} {x} → f ⊛ᵖ x ≈ flip _$_ DC.⟨$⟩ x ⊛ᵖ f)  ↝⟨ ¬-⊛ᵖ-comm ⟩□
  ⊥                                                                      □

------------------------------------------------------------------------
-- The instance declaration

-- A raw-monad instance.

instance

  raw-monad : Raw-monad (λ A → Delay-crash A i)
  raw-monad = raw-monad′


{-# OPTIONS --rewriting #-}

open import Common.Prelude
open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

postulate
  f : Bool → Bool
  boolTrivial : ∀ (b c : Bool) → f b ≡ c

{-# REWRITE boolTrivial #-}

-- Should trigger an error that c is not bound on the lhs.


module Luau.Substitution where

open import Luau.Syntax using (Expr; Stat; Block; nil; addr; var; function⟨_⟩_end; _$_; block_is_end; local_←_; _∙_; done; function_⟨_⟩_end; return)
open import Luau.Value using (Value; val)
open import Luau.Var using (Var; _≡ⱽ_)
open import Properties.Dec using (Dec; yes; no)

_[_/_]ᴱ : Expr → Value → Var → Expr
_[_/_]ᴮ : Block → Value → Var → Block
var_[_/_]ᴱwhenever_ : ∀ {P} → Var → Value → Var → (Dec P) → Expr
_[_/_]ᴮunless_ : ∀ {P} → Block → Value → Var → (Dec P) → Block

nil [ v / x ]ᴱ = nil
var y [ v / x ]ᴱ = var y [ v / x ]ᴱwhenever (x ≡ⱽ y)
addr a [ v / x ]ᴱ = addr a
(M $ N) [ v / x ]ᴱ = (M [ v / x ]ᴱ) $ (N [ v / x ]ᴱ)
function⟨ y ⟩ C end [ v / x ]ᴱ = function⟨ y ⟩ C [ v / x ]ᴮunless (x ≡ⱽ y) end
block b is C end [ v / x ]ᴱ = block b is C [ v / x ]ᴮ end

(function f ⟨ y ⟩ C end ∙ B) [ v / x ]ᴮ = function f ⟨ y ⟩ (C [ v / x ]ᴮunless (x ≡ⱽ y)) end ∙ (B [ v / x ]ᴮunless (x ≡ⱽ f))
(local y ← M ∙ B) [ v / x ]ᴮ = local y ← (M [ v / x ]ᴱ) ∙ (B [ v / x ]ᴮunless (x ≡ⱽ y))
(return M ∙ B) [ v / x ]ᴮ = return (M [ v / x ]ᴱ) ∙ (B [ v / x ]ᴮ)
done [ v / x ]ᴮ = done

var y [ v / x ]ᴱwhenever yes p = val v
var y [ v / x ]ᴱwhenever no p = var y

B [ v / x ]ᴮunless yes p = B
B [ v / x ]ᴮunless no p = B [ v / x ]ᴮ


module SizedIO.coIOIOObject where

open import Data.Unit.Base
open import Data.Product
open import Data.String.Base

open import Size

open import SizedIO.Object

open import SizedIO.Base
open import SizedIO.Console
open import SizedIO.coIOIO
-- open import SizedIO.IOObject

record IOObject' (i : Size) (iface : Interface)(C : Set)(R : C → Set) : Set
  where
  coinductive
  field
    method : ∀{j : Size< i} (m : Method iface) →
             IO j C R (Response iface m × IOObject' j iface C R)
open IOObject' public

-- An IO object is like a simple object,
-- but the method returns IO applied to the result type of a simple object
-- which means the method returns an IO program which when terminating
-- returns the result of the simple object
record coIO²Object (i : Size) (iface : Interface)
                (Cin : Set)(Rin : Cin → Set)
                (Cext : Set)(Rext : Cext → Set)     : Set
  where
  coinductive
  field
    method' : ∀{j : Size< i} (m : Method iface) →
             coIO²∞  ∞  Cin Rin Cext Rext
                     (Response iface m × coIO²Object j iface Cin Rin Cext Rext)
open coIO²Object public

selfrefIOObject : (i : Size) (iface : Interface)
                  (Cext : Set) (Rext : Cext → Set) → Set
selfrefIOObject i iface Cext Rext = coIO²Object i iface (Method iface)
                                    (Response iface) Cext Rext

mutual
  compileSelfRef : (i : Size) (iface : Interface)
                   (Cext : Set) (Rext : Cext → Set)
                   (obj : selfrefIOObject i iface Cext Rext) →
                   IOObject' i iface Cext Rext
  IO.force (method (compileSelfRef i iface Cext Rext obj) {i'} m) {j} =
           compileSelfRefaux  i' j iface Cext Rext (Response iface m) (coIO²∞.force (method' obj {i'} m) j)

  compileSelfRefaux :
    (i : Size) (j : Size< i)
    (iface : Interface) (let M = Method iface) (let R = Response iface)
    (Cext : Set) (Rext : Cext → Set)
    (A : Set)
    (coObj : coIO² ∞ j M R Cext Rext (A × coIO²Object i iface M R Cext Rext))
    → IO' j Cext Rext (A × IOObject' i iface Cext Rext)
  compileSelfRefaux i j iface Cext Rext A (coIO².return (r , obj)) = return' (r , compileSelfRef i iface Cext Rext obj)
  compileSelfRefaux i j iface Cext Rext A (dof i' m f) = {! >>=!}
  compileSelfRefaux i j iface Cext Rext A (do∞ c f) =
         do' c (λ r → compileSelfRefaux'' i j iface Cext Rext A (f r))

  compileSelfRefaux'' : (i : Size) (j : Size< i)
    (iface : Interface) (let M = Method iface) (let R = Response iface)
    (Cext : Set) (Rext : Cext → Set)
    (A : Set)
    (coObj : coIO²∞ j M R Cext Rext (A × coIO²Object i iface M R Cext Rext))
      → IO j Cext Rext (A × IOObject' i iface Cext Rext)
  IO.force (compileSelfRefaux'' i j iface Cext Rext A coObj) {j''} = compileSelfRefaux i j'' iface Cext Rext A (coIO²∞.force coObj j'')

--  compileSelfRefaux'' i' j iface Cext Rext A coObj
--           = compileSelfRefaux' i' j iface Cext Rext A (coIO²∞.force coObj {!!})

{-
  compileSelfRefaux' :
    (i' : Size) (j : Size< i')
    (iface : Interface) (let M = Methods iface) (let R = Responses iface)
    (Cext : Set) (Rext : Cext → Set)
    (A : Set)
    (coObj : coIO² ∞ j M R Cext Rext (A × coIO²Object i' iface M R Cext Rext))
    → IO j Cext Rext (A × IOObject' i' iface Cext Rext)
  IO.force (compileSelfRefaux' i' j iface Cext Rext A coObj) = compileSelfRefaux i' j iface Cext Rext A coObj
-}
{-
123;456hallo789
123;456hallo789
123;789hallo456
123;789hallo456
123;789456
123;789456
123;456789
123;456789
123;456789
123;456789

C-x r k    -- kill rectangle
C-x r y    -- yank rectangle
C-x r t    -- text rectangle
-}

{-
M-x abbrev-mode

C-x ail

crosss
→

\
-}

-- method' obj {j'} m

{-
  compileSelfRefaux :  (j' : Size) (iface : Interface)
                       (Cext : Set) (Rext : Cext → Set)
                       (m : Methods iface)
                       ( p : coIO²∞ ∞ (Methods iface)
                                      (Responses iface) Cext Rext
                                      (Responses iface m ×
                                       coIO²Object j' iface (Methods iface)
                                       (Responses iface) Cext Rext))
                       → IO' j' Cext Rext
                         (Responses iface m ×
                          IOObject' j iface Cext Rext)IO' j' Cext Rext
                          (Responses iface m × IOObject' j iface Cext Rext)

  -}