{-# OPTIONS --rewriting --prop --confluence-check --cumulativity  #-}

open import Agda.Primitive
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat
open import Agda.Builtin.List
open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite
open import Agda.Builtin.Sigma
open import Agda.Builtin.Unit
open import Data.Vec.Base
open import Data.Bool
open import Data.Sum
open import Data.Product using (_×_)
open import ett-rr

{- Axiomatisation of the Cast calculus -}

{- diagonal cases -}

postulate cast : (A : Set ℓ) (B : Set ℓ₁) → A → B

postulate cast-set : (A : Set ℓ) → cast (Set ℓ) (Set ℓ) A ≡ A

{-# REWRITE cast-set #-}

postulate cast-prop : (A : Prop ℓ) → cast (Prop ℓ) (Prop ℓ) A ≡ A

{-# REWRITE cast-prop #-}

postulate cast-Pi : (A : Set ℓ) (B : A → Set ℓ₁) (A' : Set ℓ₂) (B' : A' → Set ℓ₃) (f : (a : A) → B a)  →
                    cast ((a : A) → B a) ((a' : A') → B' a') f ≡
                    λ (a' : A') → cast _ _ (f (cast A' A a'))

{-# REWRITE cast-Pi #-}

postulate cast-Sigma : (A : Set ℓ) (B : A → Set ℓ₁) (A' : Set ℓ₂) (B' : A' → Set ℓ₃) (p : Σ {a = ℓ} {b = ℓ₁} A B) →
                       cast (Σ A B) (Σ A' B') p ≡ (cast {ℓ = ℓ} {ℓ₁ = ℓ₂} A A' (p .fst) , cast (B (p .fst)) (B' (cast A A' (p .fst))) (p .snd))

{-# REWRITE cast-Sigma #-}

postulate cast-Sum-inj₁ : (A A' : Set ℓ) (B B' : Set ℓ₁) (a : A) →
                    cast (A ⊎ B) (A' ⊎ B') (inj₁ a) ≡ inj₁ (cast A A' a)

postulate cast-Sum-inj₂ : (A A' : Set ℓ) (B B' : Set ℓ₁) (b : B) →
                    cast (A ⊎ B) (A' ⊎ B') (inj₂ b) ≡ inj₂ (cast B B' b)

postulate cast-Sum-raise : (A A' : Set ℓ) (B B' : Set ℓ₁) (a : A) →
                    cast (A ⊎ B) (A' ⊎ B') (raise _) ≡ raise _

postulate cast-Sum-unk : (A A' : Set ℓ) (B B' : Set ℓ₁) (a : A) →
                    cast (A ⊎ B) (A' ⊎ B') (unk _) ≡ unk _

{-# REWRITE cast-Sum-inj₁ #-}
{-# REWRITE cast-Sum-inj₂ cast-Sum-raise cast-Sum-unk #-}

postulate cast-List-nil : (A A' : Set ℓ) →
                          cast (List A) (List A') [] ≡ []

postulate cast-List-cons : (A A' : Set ℓ) (a : A) (l : List {a = ℓ} A) →
                           cast (List A) (List {a = ℓ} A') (a ∷ l) ≡
                           cast A A' a ∷ cast (List A) (List A') l

postulate cast-List-raise : (A A' : Set ℓ) →
                          cast (List A) (List A') (raise (List _)) ≡ raise (List _)
postulate cast-List-unk : (A A' : Set ℓ) →
                          cast (List A) (List A') (unk (List _)) ≡ unk (List _)

{-# REWRITE cast-List-nil #-}
{-# REWRITE cast-List-cons cast-List-raise cast-List-unk #-}

postulate cast-Nat-zero : cast Nat Nat 0 ≡ 0

postulate cast-Nat-suc : (n : Nat ) → cast Nat Nat (suc n) ≡ suc (cast _ _ n)

postulate cast-Nat-raise : cast Nat Nat (raise Nat) ≡ raise Nat

postulate cast-Nat-unk : cast Nat Nat (unk Nat) ≡ unk Nat

{-# REWRITE cast-Nat-zero cast-Nat-suc cast-Nat-raise cast-Nat-unk #-}

postulate cast-Bool-true : cast Bool Bool true ≡ true

postulate cast-Bool-false : cast Bool Bool false ≡ false

postulate cast-Bool-raise : cast Bool Bool (raise Bool) ≡ raise Bool

postulate cast-Bool-unk : cast Bool Bool (unk Bool) ≡ unk Bool

{-# REWRITE cast-Bool-true cast-Bool-false cast-Bool-raise cast-Bool-unk #-}

postulate cast-Unit : cast ⊤ ⊤ tt ≡ tt
{- Beware that raise ⊤ ≡ tt ≡ unk ⊤ because of definitional singleton -}
postulate cast-Unit-raise : cast ⊤ ⊤ (raise ⊤) ≡ raise ⊤
postulate cast-Unit-unk : cast ⊤ ⊤ (unk ⊤) ≡ unk ⊤

{-# REWRITE cast-Unit cast-Unit-raise cast-Unit-unk #-}

{- non-diagonal cases -}

postulate cast-Set-bad : (A : Set (lsuc ℓ)) → cast (Set (lsuc ℓ)) (Set ℓ) A ≡ raise _

{-# REWRITE cast-Set-bad #-}

postulate cast-raise :  ∀ ℓ ℓ₁ → (x : raise {ℓ = lsuc ℓ} (Set ℓ)) (A : Set ℓ₁) → cast (raise {ℓ = lsuc ℓ} (Set ℓ)) A x ≡ raise _

{-# REWRITE cast-raise #-}

postulate cast-Pi-Sigma : (A A' : Set ℓ) (B : A → Set ℓ₁) (B' : A' → Set ℓ₁) (f : (a : A) → B a)  →
                    cast ((a : A) → B a) (Σ {a = ℓ} {b = ℓ₁} A' B') f ≡ raise (Σ A' B')

{-# REWRITE cast-Pi-Sigma #-}

postulate cast-Pi-Nat : (A : Set ℓ) (B : A → Set ℓ₁) (f : (a : A) → B a) →
                    cast ((a : A) → B a) Nat f ≡ raise Nat

{-# REWRITE cast-Pi-Nat #-}

-- missing many conflict rules

{- Rules specific to Unk -}

{- unk-cast ℓ A a  is just a copy of  cast A (Unk ℓ) a
   but we need to split it off for rewriting.
   Making it private so that the only closed  values we can create in Unk ℓ come from cast -}
private
  postulate unk-cast : ∀ (A : Set ℓ) → A → Unk (lsuc ℓ)

postulate cast-Unk : (A : Set ℓ) (B : Set ℓ₁) (f : A) →
                        cast (Unk (lsuc ℓ)) B (unk-cast A f) ≡ cast A B f
{-# REWRITE cast-Unk #-}

postulate cast-Unk-raise : ∀ ℓ → (B : Set ℓ₁)  →
                           cast (Unk ℓ) B (raise _) ≡ raise _
{-# REWRITE cast-Unk-raise #-}

postulate cast-Pi-Unk : (A : Set ℓ) (B : A → Set ℓ₁) (f : (a : A) → B a) →
                        cast ((a : A) → B a) (Unk (lsuc (ℓ ⊔ ℓ₁))) f ≡  unk-cast (Unk ℓ → Unk ℓ₁) (cast ((a : A) → B a) (Unk ℓ → Unk ℓ₁) f)

{-# REWRITE cast-Pi-Unk #-}

postulate cast-Pi-Unk-bad : (f : Unk ℓ → Unk ℓ₁) →
                            cast (Unk ℓ → Unk ℓ₁) (Unk (ℓ ⊔ ℓ₁)) f ≡ raise _

{-# REWRITE cast-Pi-Unk-bad #-}

postulate cast-Sigma-Unk : (A : Set ℓ) (B : A → Set ℓ₁) (x : Σ {a = ℓ} {b = ℓ₁} A B) →
                        cast (Σ A B) (Unk (lsuc (ℓ ⊔ ℓ₁))) x ≡ unk-cast (_×_ {a = ℓ} {b = ℓ₁} (Unk ℓ) (Unk ℓ₁)) (cast (Σ A B) (Unk ℓ × Unk ℓ₁) x)

{-# REWRITE cast-Sigma-Unk #-}

delta : Unk ℓ → Unk ℓ
delta {ℓ} x = cast (Unk ℓ) (Unk ℓ → Unk ℓ) x x

omega : Unk ℓ
omega {ℓ} = delta {ℓ = ℓ} (cast (Unk ℓ → Unk ℓ) (Unk ℓ) (delta {ℓ = ℓ}))

foo : Unk (lsuc lzero)
foo = cast (Nat → Nat → Nat) (Unk _) _+_

postulate cast-Nat-Unk : (n : Nat) → cast Nat (Unk (lsuc lzero)) n ≡ unk-cast Nat n

record i (A : Set ℓ) : Set (ℓ ⊔ ℓ₁) where
  constructor inj
  field
    uninj : A

open i public

postulate cast-Nat-Unk' : (n : Nat) → cast (i {ℓ = ℓ} {ℓ₁ = ℓ₁} Nat) (Unk (lsuc ℓ)) (inj n) ≡ unk-cast Nat n

postulate cast-Nat-iNat : (n : Nat) → cast Nat (i {ℓ = ℓ} {ℓ₁ = ℓ₁} Nat) n ≡ inj n

{-# REWRITE cast-Nat-Unk cast-Nat-Unk' cast-Nat-iNat #-}

retr : (A : Set ℓ) (a : A) → A
retr {ℓ} A a = cast (Unk (lsuc ℓ)) A (cast A (Unk (lsuc ℓ)) a)

retr-0 : retr {lzero} Nat 0 ≡ 0
retr-0 = refl

retr-arr : (A : Set ℓ) (a : A) → A
retr-arr {ℓ} A = retr (A → A) (λ a → a)

zero' : Nat
zero' = uninj (retr-arr {lsuc lzero} (i {ℓ₁ = lsuc lzero} Nat) (inj 0))


module BasicIS4.Metatheory.DyadicGentzenSpinalNormalForm-HereditarySubstitution where

open import BasicIS4.Syntax.DyadicGentzenSpinalNormalForm public

-- Hereditary substitution and reduction.

mutual
  [_≔_]ⁿᶠ_ : ∀ {A B Γ Δ} → (i : A ∈ Γ) → Γ ∖ i ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ B → Γ ∖ i ⁏ Δ ⊢ⁿᶠ B
  [ i ≔ s ]ⁿᶠ neⁿᶠ (spⁿᵉ j  xs y) with i ≟∈ j
  [ i ≔ s ]ⁿᶠ neⁿᶠ (spⁿᵉ .i xs y) | same   = reduce s ([ i ≔ s ]ˢᵖ xs) ([ i ≔ s ]ᵗᵖ y)
  [ i ≔ s ]ⁿᶠ neⁿᶠ (spⁿᵉ ._ xs y) | diff j = neⁿᶠ (spⁿᵉ j ([ i ≔ s ]ˢᵖ xs) ([ i ≔ s ]ᵗᵖ y))
  [ i ≔ s ]ⁿᶠ neⁿᶠ (mspⁿᵉ j xs y) = neⁿᶠ (mspⁿᵉ j ([ i ≔ s ]ˢᵖ xs) ([ i ≔ s ]ᵗᵖ y))
  [ i ≔ s ]ⁿᶠ lamⁿᶠ t             = lamⁿᶠ ([ pop i ≔ mono⊢ⁿᶠ weak⊆ s ]ⁿᶠ t)
  [ i ≔ s ]ⁿᶠ boxⁿᶠ t             = boxⁿᶠ t
  [ i ≔ s ]ⁿᶠ pairⁿᶠ t u          = pairⁿᶠ ([ i ≔ s ]ⁿᶠ t) ([ i ≔ s ]ⁿᶠ u)
  [ i ≔ s ]ⁿᶠ unitⁿᶠ              = unitⁿᶠ

  [_≔_]ˢᵖ_ : ∀ {A B C Γ Δ} → (i : A ∈ Γ) → Γ ∖ i ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ˢᵖ B ⦙ C → Γ ∖ i ⁏ Δ ⊢ˢᵖ B ⦙ C
  [ i ≔ s ]ˢᵖ nilˢᵖ      = nilˢᵖ
  [ i ≔ s ]ˢᵖ appˢᵖ xs u = appˢᵖ ([ i ≔ s ]ˢᵖ xs) ([ i ≔ s ]ⁿᶠ u)
  [ i ≔ s ]ˢᵖ fstˢᵖ xs   = fstˢᵖ ([ i ≔ s ]ˢᵖ xs)
  [ i ≔ s ]ˢᵖ sndˢᵖ xs   = sndˢᵖ ([ i ≔ s ]ˢᵖ xs)

  [_≔_]ᵗᵖ_ : ∀ {A B C Γ Δ} → (i : A ∈ Γ) → Γ ∖ i ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ᵗᵖ B ⦙ C → Γ ∖ i ⁏ Δ ⊢ᵗᵖ B ⦙ C
  [ i ≔ s ]ᵗᵖ nilᵗᵖ     = nilᵗᵖ
  [ i ≔ s ]ᵗᵖ unboxᵗᵖ u = unboxᵗᵖ u′
    where u′ = [ i ≔ mmono⊢ⁿᶠ weak⊆ s ]ⁿᶠ u

  m[_≔_]ⁿᶠ_ : ∀ {A B Γ Δ} → (i : A ∈ Δ) → ∅ ⁏ Δ ∖ i ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ∖ i ⊢ⁿᶠ B
  m[ i ≔ s ]ⁿᶠ neⁿᶠ (spⁿᵉ j xs y)   = neⁿᶠ (spⁿᵉ j (m[ i ≔ s ]ˢᵖ xs) (m[ i ≔ s ]ᵗᵖ y))
  m[ i ≔ s ]ⁿᶠ neⁿᶠ (mspⁿᵉ j xs y)  with i ≟∈ j
  m[ i ≔ s ]ⁿᶠ neⁿᶠ (mspⁿᵉ .i xs y) | same   = reduce (mono⊢ⁿᶠ bot⊆ s) (m[ i ≔ s ]ˢᵖ xs) (m[ i ≔ s ]ᵗᵖ y)
  m[ i ≔ s ]ⁿᶠ neⁿᶠ (mspⁿᵉ ._ xs y) | diff j = neⁿᶠ (mspⁿᵉ j (m[ i ≔ s ]ˢᵖ xs) (m[ i ≔ s ]ᵗᵖ y))
  m[ i ≔ s ]ⁿᶠ lamⁿᶠ t              = lamⁿᶠ (m[ i ≔ s ]ⁿᶠ t)
  m[ i ≔ s ]ⁿᶠ boxⁿᶠ t              = boxⁿᶠ (m[ i ≔ s ]ⁿᶠ t)
  m[ i ≔ s ]ⁿᶠ pairⁿᶠ t u           = pairⁿᶠ (m[ i ≔ s ]ⁿᶠ t) (m[ i ≔ s ]ⁿᶠ u)
  m[ i ≔ s ]ⁿᶠ unitⁿᶠ               = unitⁿᶠ

  m[_≔_]ˢᵖ_ : ∀ {A B C Γ Δ} → (i : A ∈ Δ) → ∅ ⁏ Δ ∖ i ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ˢᵖ B ⦙ C → Γ ⁏ Δ ∖ i ⊢ˢᵖ B ⦙ C
  m[ i ≔ s ]ˢᵖ nilˢᵖ      = nilˢᵖ
  m[ i ≔ s ]ˢᵖ appˢᵖ xs u = appˢᵖ (m[ i ≔ s ]ˢᵖ xs) (m[ i ≔ s ]ⁿᶠ u)
  m[ i ≔ s ]ˢᵖ fstˢᵖ xs   = fstˢᵖ (m[ i ≔ s ]ˢᵖ xs)
  m[ i ≔ s ]ˢᵖ sndˢᵖ xs   = sndˢᵖ (m[ i ≔ s ]ˢᵖ xs)

  m[_≔_]ᵗᵖ_ : ∀ {A B C Γ Δ} → (i : A ∈ Δ) → ∅ ⁏ Δ ∖ i ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ᵗᵖ B ⦙ C → Γ ⁏ Δ ∖ i ⊢ᵗᵖ B ⦙ C
  m[ i ≔ s ]ᵗᵖ nilᵗᵖ     = nilᵗᵖ
  m[ i ≔ s ]ᵗᵖ unboxᵗᵖ u = unboxᵗᵖ u′
    where u′ = m[ pop i ≔ mmono⊢ⁿᶠ weak⊆ s ]ⁿᶠ u

  reduce : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ˢᵖ A ⦙ B → Γ ⁏ Δ ⊢ᵗᵖ B ⦙ C → {{_ : Tyⁿᵉ C}} → Γ ⁏ Δ ⊢ⁿᶠ C
  reduce t                               nilˢᵖ        nilᵗᵖ       = t
  reduce (neⁿᶠ (spⁿᵉ i xs nilᵗᵖ))        nilˢᵖ        y           = neⁿᶠ (spⁿᵉ i xs y)
  reduce (neⁿᶠ (spⁿᵉ i xs (unboxᵗᵖ u)))  nilˢᵖ        y           = neⁿᶠ (spⁿᵉ i xs (unboxᵗᵖ u′))
    where u′ = reduce u nilˢᵖ (mmono⊢ᵗᵖ weak⊆ y)
  reduce (neⁿᶠ (mspⁿᵉ i xs nilᵗᵖ))       nilˢᵖ        y           = neⁿᶠ (mspⁿᵉ i xs y)
  reduce (neⁿᶠ (mspⁿᵉ i xs (unboxᵗᵖ u))) nilˢᵖ        y           = neⁿᶠ (mspⁿᵉ i xs (unboxᵗᵖ u′))
    where u′ = reduce u nilˢᵖ (mmono⊢ᵗᵖ weak⊆ y)
  reduce (neⁿᶠ t {{()}})                 (appˢᵖ xs u) y
  reduce (neⁿᶠ t {{()}})                 (fstˢᵖ xs)   y
  reduce (neⁿᶠ t {{()}})                 (sndˢᵖ xs)   y
  reduce (lamⁿᶠ t)                       (appˢᵖ xs u) y           = reduce ([ top ≔ u ]ⁿᶠ t) xs y
  reduce (boxⁿᶠ t)                       nilˢᵖ        (unboxᵗᵖ u) = m[ top ≔ t ]ⁿᶠ u
  reduce (pairⁿᶠ t u)                    (fstˢᵖ xs)   y           = reduce t xs y
  reduce (pairⁿᶠ t u)                    (sndˢᵖ xs)   y           = reduce u xs y

-- Reduction-based normal forms.

appⁿᶠ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ A ▻ B → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ B
appⁿᶠ (neⁿᶠ t {{()}})
appⁿᶠ (lamⁿᶠ t) u = [ top ≔ u ]ⁿᶠ t

fstⁿᶠ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ A ∧ B → Γ ⁏ Δ ⊢ⁿᶠ A
fstⁿᶠ (neⁿᶠ t {{()}})
fstⁿᶠ (pairⁿᶠ t u) = t

sndⁿᶠ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ A ∧ B → Γ ⁏ Δ ⊢ⁿᶠ B
sndⁿᶠ (neⁿᶠ t {{()}})
sndⁿᶠ (pairⁿᶠ t u) = u

-- Useful equipment for deriving neutrals.

≪appˢᵖ : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ˢᵖ C ⦙ A ▻ B → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ˢᵖ C ⦙ B
≪appˢᵖ nilˢᵖ        t = appˢᵖ nilˢᵖ t
≪appˢᵖ (appˢᵖ xs u) t = appˢᵖ (≪appˢᵖ xs t) u
≪appˢᵖ (fstˢᵖ xs)   t = fstˢᵖ (≪appˢᵖ xs t)
≪appˢᵖ (sndˢᵖ xs)   t = sndˢᵖ (≪appˢᵖ xs t)

≪fstˢᵖ : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ˢᵖ C ⦙ A ∧ B → Γ ⁏ Δ ⊢ˢᵖ C ⦙ A
≪fstˢᵖ nilˢᵖ        = fstˢᵖ nilˢᵖ
≪fstˢᵖ (appˢᵖ xs u) = appˢᵖ (≪fstˢᵖ xs) u
≪fstˢᵖ (fstˢᵖ xs)   = fstˢᵖ (≪fstˢᵖ xs)
≪fstˢᵖ (sndˢᵖ xs)   = sndˢᵖ (≪fstˢᵖ xs)

≪sndˢᵖ : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ˢᵖ C ⦙ A ∧ B → Γ ⁏ Δ ⊢ˢᵖ C ⦙ B
≪sndˢᵖ nilˢᵖ        = sndˢᵖ nilˢᵖ
≪sndˢᵖ (appˢᵖ xs u) = appˢᵖ (≪sndˢᵖ xs) u
≪sndˢᵖ (fstˢᵖ xs)   = fstˢᵖ (≪sndˢᵖ xs)
≪sndˢᵖ (sndˢᵖ xs)   = sndˢᵖ (≪sndˢᵖ xs)

-- Derived neutrals.

varⁿᵉ : ∀ {A Γ Δ} → A ∈ Γ → Γ ⁏ Δ ⊢ⁿᵉ A
varⁿᵉ i = spⁿᵉ i nilˢᵖ nilᵗᵖ

appⁿᵉ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ A ▻ B → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᵉ B
appⁿᵉ (spⁿᵉ i xs nilᵗᵖ)        t = spⁿᵉ i (≪appˢᵖ xs t) nilᵗᵖ
appⁿᵉ (spⁿᵉ i xs (unboxᵗᵖ u))  t = spⁿᵉ i xs (unboxᵗᵖ u′)
  where u′ = appⁿᶠ u (mmono⊢ⁿᶠ weak⊆ t)
appⁿᵉ (mspⁿᵉ i xs nilᵗᵖ)       t = mspⁿᵉ i (≪appˢᵖ xs t) nilᵗᵖ
appⁿᵉ (mspⁿᵉ i xs (unboxᵗᵖ u)) t = mspⁿᵉ i xs (unboxᵗᵖ u′)
  where u′ = appⁿᶠ u (mmono⊢ⁿᶠ weak⊆ t)

mvarⁿᵉ : ∀ {A Γ Δ} → A ∈ Δ → Γ ⁏ Δ ⊢ⁿᵉ A
mvarⁿᵉ i = mspⁿᵉ i nilˢᵖ nilᵗᵖ

fstⁿᵉ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ A ∧ B → Γ ⁏ Δ ⊢ⁿᵉ A
fstⁿᵉ (spⁿᵉ i xs nilᵗᵖ)        = spⁿᵉ i (≪fstˢᵖ xs) nilᵗᵖ
fstⁿᵉ (spⁿᵉ i xs (unboxᵗᵖ u))  = spⁿᵉ i xs (unboxᵗᵖ (fstⁿᶠ u))
fstⁿᵉ (mspⁿᵉ i xs nilᵗᵖ)       = mspⁿᵉ i (≪fstˢᵖ xs) nilᵗᵖ
fstⁿᵉ (mspⁿᵉ i xs (unboxᵗᵖ u)) = mspⁿᵉ i xs (unboxᵗᵖ (fstⁿᶠ u))

sndⁿᵉ : ∀ {A B Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ A ∧ B → Γ ⁏ Δ ⊢ⁿᵉ B
sndⁿᵉ (spⁿᵉ i xs nilᵗᵖ)        = spⁿᵉ i (≪sndˢᵖ xs) nilᵗᵖ
sndⁿᵉ (spⁿᵉ i xs (unboxᵗᵖ u))  = spⁿᵉ i xs (unboxᵗᵖ (sndⁿᶠ u))
sndⁿᵉ (mspⁿᵉ i xs nilᵗᵖ)       = mspⁿᵉ i (≪sndˢᵖ xs) nilᵗᵖ
sndⁿᵉ (mspⁿᵉ i xs (unboxᵗᵖ u)) = mspⁿᵉ i xs (unboxᵗᵖ (sndⁿᶠ u))

-- Iterated expansion.

expand : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ ⊢ⁿᶠ A
expand {α P}   t = neⁿᶠ t {{α P}}
expand {A ▻ B} t = lamⁿᶠ (expand (appⁿᵉ (mono⊢ⁿᵉ weak⊆ t) (expand (varⁿᵉ top))))
expand {□ A}   t = neⁿᶠ t {{□ A}}
expand {A ∧ B} t = pairⁿᶠ (expand (fstⁿᵉ t)) (expand (sndⁿᵉ t))
expand {⊤}    t = unitⁿᶠ

-- Expansion-based normal forms.

varⁿᶠ : ∀ {A Γ Δ} → A ∈ Γ → Γ ⁏ Δ ⊢ⁿᶠ A
varⁿᶠ i = expand (varⁿᵉ i)

mvarⁿᶠ : ∀ {A Γ Δ} → A ∈ Δ → Γ ⁏ Δ ⊢ⁿᶠ A
mvarⁿᶠ i = expand (mvarⁿᵉ i)

mutual
  unboxⁿᶠ : ∀ {A C Γ Δ} → Γ ⁏ Δ ⊢ⁿᶠ □ A → Γ ⁏ Δ , A ⊢ⁿᶠ C → Γ ⁏ Δ ⊢ⁿᶠ C
  unboxⁿᶠ (neⁿᶠ t)  u = expand (unboxⁿᵉ t u)
  unboxⁿᶠ (boxⁿᶠ t) u = m[ top ≔ t ]ⁿᶠ u

  unboxⁿᵉ : ∀ {A C Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ □ A → Γ ⁏ Δ , A ⊢ⁿᶠ C → Γ ⁏ Δ ⊢ⁿᵉ C
  unboxⁿᵉ (spⁿᵉ i xs nilᵗᵖ)        u = spⁿᵉ i xs (unboxᵗᵖ u)
  unboxⁿᵉ (spⁿᵉ i xs (unboxᵗᵖ t))  u = spⁿᵉ i xs (unboxᵗᵖ u′)
    where u′ = unboxⁿᶠ t (mmono⊢ⁿᶠ (keep (weak⊆)) u)
  unboxⁿᵉ (mspⁿᵉ i xs nilᵗᵖ)       u = mspⁿᵉ i xs (unboxᵗᵖ u)
  unboxⁿᵉ (mspⁿᵉ i xs (unboxᵗᵖ t)) u = mspⁿᵉ i xs (unboxᵗᵖ u′)
    where u′ = unboxⁿᶠ t (mmono⊢ⁿᶠ (keep (weak⊆)) u)

-- Translation from terms to normal forms.

tm→nf : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ⁿᶠ A
tm→nf (var i)     = varⁿᶠ i
tm→nf (lam t)     = lamⁿᶠ (tm→nf t)
tm→nf (app t u)   = appⁿᶠ (tm→nf t) (tm→nf u)
tm→nf (mvar i)    = mvarⁿᶠ i
tm→nf (box t)     = boxⁿᶠ (tm→nf t)
tm→nf (unbox t u) = unboxⁿᶠ (tm→nf t) (tm→nf u)
tm→nf (pair t u)  = pairⁿᶠ (tm→nf t) (tm→nf u)
tm→nf (fst t)     = fstⁿᶠ (tm→nf t)
tm→nf (snd t)     = sndⁿᶠ (tm→nf t)
tm→nf unit        = unitⁿᶠ

-- Normalisation by hereditary substitution.

norm : ∀ {A Γ Δ} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ A
norm = nf→tm ∘ tm→nf


------------------------------------------------------------------------
-- A simplified parser type
------------------------------------------------------------------------

module StructurallyRecursiveDescentParsing.Simplified where

open import Category.Monad
open import Codata.Musical.Notation
open import Data.Bool
open import Data.List using (List; _∷_; []; _++_)
import Data.List.Categorical as ListMonad
import Data.List.Properties as ListProp
open import Data.List.Relation.Binary.BagAndSetEquality
open import Data.List.NonEmpty
  using (List⁺; _∷_; [_]; _⁺++_; head; tail)
import Data.List.NonEmpty.Categorical as List⁺
open import Data.List.NonEmpty.Properties
open import Level
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open RawMonad {f = zero} ListMonad.monad
  using () renaming (_>>=_ to _>>=′_)
open RawMonad {f = zero} List⁺.monad
  using () renaming (_>>=_ to _>>=⁺_)
private
  open module BagS {A : Set} = Setoid ([ bag ]-Equality A)
    using () renaming (_≈_ to _Bag-≈_)

open import TotalParserCombinators.Parser as P
  hiding (Parser; module Parser)

------------------------------------------------------------------------
-- Parsers

infixl 10 _!>>=_ _?>>=_
infixl  5 _∣_

-- A type for parsers which are not left recursive.
--
-- The boolean index is true iff the parser is nullable (accepts the
-- empty string).

data Parser (Tok : Set) : Bool → Set → Set1 where
  return : ∀ {R} (x : R) → Parser Tok true R
  fail   : ∀ {R} → Parser Tok false R
  token  : Parser Tok false Tok
  _∣_    : ∀ {e₁ e₂ R}
           (p₁ : Parser Tok  e₁       R)
           (p₂ : Parser Tok       e₂  R) →
                 Parser Tok (e₁ ∨ e₂) R
  _?>>=_ : ∀ {e₂ R₁ R₂}
           (p₁ :      Parser Tok true R₁)
           (p₂ : R₁ → Parser Tok e₂   R₂) →
                      Parser Tok e₂   R₂
  _!>>=_ : ∀ {R₁ R₂} {e₂ : R₁ → Bool}
           (p₁ :               Parser Tok false  R₁)
           (p₂ : (x : R₁) → ∞ (Parser Tok (e₂ x) R₂)) →
                               Parser Tok false  R₂

-- Note that Parser has only one coinductive recursive component.
-- Making any other recursive component coinductive would allow left
-- recursive grammars to be formed, but it is safe to use coinduction
-- in _>>=_ when we know that a token has been consumed, because for
-- every successive use of coinduction we are at least one step closer
-- to the end of the input.

------------------------------------------------------------------------
-- "Initial bags"

-- The initial bag of a parser is calculated in such a way that it is
-- obvious, given the nullability of the parser, whether or not the
-- bag is empty.

mutual

  initial⁺ : ∀ {Tok e R} → Parser Tok e R → e ≡ true → List⁺ R
  initial⁺ (return x)                  refl = [ x ]
  initial⁺ fail                        ()
  initial⁺ token                       ()
  initial⁺ (_∣_ {true}          p₁ p₂) refl = initial⁺ p₁ refl ⁺++ initial p₂
  initial⁺ (_∣_ {false} {true}  p₁ p₂) refl = initial⁺ p₂ refl
  initial⁺ (_∣_ {false} {false} p₁ p₂) ()
  initial⁺ (p₁ ?>>= p₂)                refl = initial⁺ p₁     refl >>=⁺ λ x →
                                              initial⁺ (p₂ x) refl
  initial⁺ (p₁ !>>= p₂)                ()

  initial : ∀ {e Tok R} → Parser Tok e R → List R
  initial {false} p = []
  initial {true}  p = head is ∷ tail is
    where is = initial⁺ p refl

-- Some boring lemmas.

private

  ∣-lemma : ∀ {e₁ e₂ Tok R}
            (p₁ : Parser Tok e₁ R) (p₂ : Parser Tok e₂ R) →
            initial p₁ ++ initial p₂ ≡ initial (p₁ ∣ p₂)
  ∣-lemma {false} {false} p₁ p₂ = refl
  ∣-lemma {false} {true}  p₁ p₂ = refl
  ∣-lemma {true}          p₁ p₂ = refl

  ?>>=-lemma : ∀ {e₂ Tok R₁ R₂}
               (p₁ : Parser Tok true R₁) (p₂ : R₁ → Parser Tok e₂ R₂) →
               initial (p₂ (head (initial⁺ p₁ refl))) ++
                 (tail (initial⁺ p₁ refl) >>=′ λ x → initial (p₂ x)) ≡
               initial (p₁ ?>>= p₂)
  ?>>=-lemma {false} p₁ p₂ = ListMonad.MonadProperties.right-zero
                               (tail (initial⁺ p₁ refl))
  ?>>=-lemma {true}  p₁ p₂ = toList->>= f xs
    where f  = λ x → initial⁺ (p₂ x) refl
          xs = initial⁺ p₁ refl

------------------------------------------------------------------------
-- Semantics

-- The semantics of simplified parsers is defined by translation.

⟦_⟧ : ∀ {Tok e R} (p : Parser Tok e R) → P.Parser Tok R (initial p)
⟦ return x   ⟧ = return x
⟦ fail       ⟧ = fail
⟦ token      ⟧ = token
⟦ p₁ ∣ p₂    ⟧ = cast lem (⟦ p₁ ⟧ ∣ ⟦ p₂ ⟧)
                 where
                 lem : _ Bag-≈ _
                 lem = BagS.reflexive (∣-lemma p₁ p₂)
⟦ p₁ !>>= p₂ ⟧ =           ⟦ p₁ ⟧ >>= λ x → ♯ ⟦ ♭ (p₂ x) ⟧
⟦ p₁ ?>>= p₂ ⟧ = cast lem (⟦ p₁ ⟧ >>= λ x →   ⟦    p₂ x  ⟧)
                 where
                 lem : _ Bag-≈ _
                 lem = BagS.reflexive (?>>=-lemma p₁ p₂)


------------------------------------------------------------------------
-- "Basic" infinite grammars
------------------------------------------------------------------------

-- For a larger and possibly more convenient, but equivalent, grammar
-- interface, see Grammar.Infinite.

{-# OPTIONS --guardedness #-}

module Grammar.Infinite.Basic where

open import Algebra
open import Category.Monad
open import Codata.Musical.Notation
open import Data.Bool hiding (_≤_)
open import Data.Char hiding (_≤_)
open import Data.Empty
open import Data.List as List
import Data.List.Categorical
open import Data.List.Membership.Propositional
import Data.List.Membership.Propositional.Properties as ∈
open import Data.List.Properties
import Data.List.Relation.Unary.Any as Any
open import Data.List.Relation.Unary.Any.Properties
open import Data.Nat
open import Data.Nat.Properties as NatP
open import Data.Product as Prod
import Data.Product.Function.Dependent.Propositional as Σ
open import Data.Product.Function.NonDependent.Propositional
open import Data.Sum
open import Data.Unit using (tt)
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as Inv using (_↔_; module Inverse)
import Function.Related as Related
open import Function.Related.TypeIsomorphisms
import Level
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)
import Relation.Binary.PropositionalEquality.WithK as P
open import Relation.Nullary

private
  module LMi {A : Set} = Monoid (++-monoid A)
  module LMa = RawMonad (Data.List.Categorical.monad {ℓ = Level.zero})
open Any.Any

------------------------------------------------------------------------
-- Simple, potentially infinite grammars

-- These grammars are very general: they can represent every
-- recursively enumerable language (see Grammars.Infinite.expressive).
-- In practice one may want to restrict attention to languages that
-- can be parsed. I use general grammars to illustrate that this
-- approach to pretty-printing is not restricted to a small class of
-- languages.

infixl 15 _>>=_
infixl 10 _∣_

data Grammar : Set → Set₁ where

  -- The empty string.

  return : ∀ {A} → A → Grammar A

  -- A single, arbitrary token.

  token  : Grammar Char

  -- Monadic sequencing.

  _>>=_  : ∀ {A B} → ∞ (Grammar A) → (A → ∞ (Grammar B)) → Grammar B

  -- Symmetric choice.

  _∣_    : ∀ {A} → ∞ (Grammar A) → ∞ (Grammar A) → Grammar A

-- Semantics of grammars (parse trees). Here x ∈ g · s means that the
-- value x and string s are generated by the grammar g.

infix 4 _∈_·_

data _∈_·_ : ∀ {A} → A → Grammar A → List Char → Set₁ where
  return-sem : ∀ {A} {x : A} → x ∈ return x · []
  token-sem  : ∀ {t} → t ∈ token · [ t ]
  >>=-sem    : ∀ {A B x y s₁ s₂} {g₁ : ∞ (Grammar A)}
                 {g₂ : A → ∞ (Grammar B)} →
               x ∈ ♭ g₁ · s₁ → y ∈ ♭ (g₂ x) · s₂ →
               y ∈ g₁ >>= g₂ · s₁ ++ s₂
  left-sem   : ∀ {A} {g₁ g₂ : ∞ (Grammar A)} {x s} →
               x ∈ ♭ g₁ · s → x ∈ g₁ ∣ g₂ · s
  right-sem  : ∀ {A} {g₁ g₂ : ∞ (Grammar A)} {x s} →
               x ∈ ♭ g₂ · s → x ∈ g₁ ∣ g₂ · s

----------------------------------------------------------------------
-- Some grammar combinators

-- Failure.

fail : ∀ {A} → Grammar A
fail = ♯ fail ∣ ♯ fail

-- Map.

infixl 20 _<$>_ _<$_

_<$>_ : ∀ {A B} → (A → B) → Grammar A → Grammar B
f <$> g = ♯ g >>= λ x → ♯ return (f x)

_<$_ : ∀ {A B} → A → Grammar B → Grammar A
x <$ g = const x <$> g

-- The empty string if the argument is true, otherwise failure.

if-true : (b : Bool) → Grammar (T b)
if-true true  = return tt
if-true false = fail

-- A token satisfying a given predicate.

sat : (p : Char → Bool) → Grammar (∃ λ t → T (p t))
sat p = ♯ token >>= λ t → ♯ (_,_ t <$> if-true (p t))

-- A specific token.

tok : Char → Grammar Char
tok t = t <$ sat (λ t′ → t == t′)

------------------------------------------------------------------------
-- Some semantics combinators

-- Cast lemma.

cast : ∀ {A} {g : Grammar A} {x s₁ s₂} →
       s₁ ≡ s₂ → x ∈ g · s₁ → x ∈ g · s₂
cast refl = id

fail-sem⁻¹ : ∀ {A} {x : A} {s} → ¬ (x ∈ fail · s)
fail-sem⁻¹ (left-sem  ∈fail) = fail-sem⁻¹ ∈fail
fail-sem⁻¹ (right-sem ∈fail) = fail-sem⁻¹ ∈fail

<$>-sem : ∀ {A B} {f : A → B} {g : Grammar A} {y s} →
          y ∈ f <$> g · s ↔ ∃ λ x → x ∈ g · s × y ≡ f x
<$>-sem {A} {B} {f} {g} = record
  { to         = P.→-to-⟶ to
  ; from       = P.→-to-⟶ from
  ; inverse-of = record
    { left-inverse-of  = from∘to
    ; right-inverse-of = to∘from
    }
  }
  where
  lemma : ∀ s → s ++ [] ≡ s
  lemma s = proj₂ LMi.identity s

  to : ∀ {s g y} → y ∈ f <$> g · s → ∃ λ x → x ∈ g · s × y ≡ f x
  to (>>=-sem x∈ return-sem) =
    _ , cast (P.sym $ lemma _) x∈ , refl

  from : ∀ {s y g} → (∃ λ x → x ∈ g · s × y ≡ f x) → y ∈ f <$> g · s
  from (x , x∈ , refl) = cast (lemma _) (>>=-sem x∈ return-sem)

  >>=-cast : ∀ {x y s₁ s₂ s}
               {g₁ : ∞ (Grammar A)} {g₂ : A → ∞ (Grammar B)}
             (eq : s₁ ≡ s₂)
             (x∈ : x ∈ ♭ g₁ · s₁) (y∈ : y ∈ ♭ (g₂ x) · s) →
             >>=-sem {g₁ = g₁} {g₂ = g₂} (cast eq x∈) y∈ ≡
             cast (P.cong (λ s′ → s′ ++ s) eq) (>>=-sem x∈ y∈)
  >>=-cast refl _ _ = refl

  cast-cast : ∀ {A g s₁ s₂} {z : A} {z∈ : z ∈ g · s₂}
              (eq₁ : s₁ ≡ s₂) (eq₂ : s₂ ≡ s₁) →
              cast eq₁ (cast eq₂ z∈) ≡ z∈
  cast-cast refl refl = refl

  from∘to : ∀ {s g y} (y∈ : y ∈ f <$> g · s) → from (to y∈) ≡ y∈
  from∘to (>>=-sem {s₁ = s} x∈ return-sem) = begin
    cast (lemma (s ++ []))
         (>>=-sem (cast (P.sym $ lemma s) x∈) return-sem)  ≡⟨ P.cong (cast (lemma (s ++ []))) $
                                                                     >>=-cast (P.sym (lemma s)) x∈ return-sem ⟩
    cast (lemma (s ++ []))
         (cast (P.cong (λ s → s ++ []) (P.sym $ lemma s))
               (>>=-sem x∈ return-sem))                    ≡⟨ cast-cast (lemma (s ++ []))
                                                                        (P.cong (λ s → s ++ []) (P.sym $ lemma s)) ⟩
    >>=-sem x∈ return-sem                                  ∎
    where open P.≡-Reasoning

  to-cast : ∀ {s₁ s₂ y g} (eq : s₁ ≡ s₂) (y∈ : y ∈ f <$> g · s₁) →
            to (cast eq y∈) ≡
            P.subst (λ s → ∃ λ x → x ∈ g · s × y ≡ f x) eq (to y∈)
  to-cast refl y∈ = refl

  to∘from : ∀ {s y g}
            (x∈ : ∃ λ x → x ∈ g · s × y ≡ f x) → to (from x∈) ≡ x∈
  to∘from {s} (x , x∈ , refl)
    rewrite to-cast (lemma s) (>>=-sem x∈ return-sem)
          | lemma s
    = refl

if-true-sem : ∀ {b} x {s} → x ∈ if-true b · s ↔ s ≡ []
if-true-sem x = record
  { to         = P.→-to-⟶ (to _)
  ; from       = P.→-to-⟶ (from _ _)
  ; inverse-of = record
    { left-inverse-of  = from∘to _
    ; right-inverse-of = to∘from _ x
    }
  }
  where
  to : ∀ b {x s} → x ∈ if-true b · s → s ≡ []
  to true  return-sem = refl
  to false ∈fail      = ⊥-elim $ fail-sem⁻¹ ∈fail

  from : ∀ b x {s} → s ≡ [] → x ∈ if-true b · s
  from true  _  refl = return-sem
  from false () refl

  from∘to : ∀ b {x s} (x∈ : x ∈ if-true b · s) → from b x (to b x∈) ≡ x∈
  from∘to true  return-sem = refl
  from∘to false ∈fail      = ⊥-elim $ fail-sem⁻¹ ∈fail

  to∘from : ∀ b x {s} (eq : s ≡ []) → to b (from b x eq) ≡ eq
  to∘from true  _  refl = refl
  to∘from false () refl

sat-sem : ∀ {p : Char → Bool} {t pt s} →
          (t , pt) ∈ sat p · s ↔ s ≡ [ t ]
sat-sem {p} {t} {pt} = record
  { to         = P.→-to-⟶ to
  ; from       = P.→-to-⟶ from
  ; inverse-of = record
    { left-inverse-of  = from∘to
    ; right-inverse-of = to∘from
    }
  }
  where
  to : ∀ {s} → (t , pt) ∈ sat p · s → s ≡ [ t ]
  to (>>=-sem token-sem (>>=-sem tt∈ return-sem)) =
    P.cong (λ s → t ∷ s ++ []) (Inverse.to (if-true-sem pt) ⟨$⟩ tt∈)

  from : ∀ {s} → s ≡ [ t ] → (t , pt) ∈ sat p · s
  from refl =
    >>=-sem token-sem
            (>>=-sem (Inverse.from (if-true-sem pt) ⟨$⟩ refl)
                     return-sem)

  from∘to : ∀ {s} (t∈ : (t , pt) ∈ sat p · s) → from (to t∈) ≡ t∈
  from∘to (>>=-sem token-sem (>>=-sem tt∈ return-sem))
    with Inverse.to (if-true-sem pt) ⟨$⟩ tt∈
       | Inverse.left-inverse-of (if-true-sem pt) tt∈
  from∘to (>>=-sem token-sem
             (>>=-sem .(Inverse.from (if-true-sem pt) ⟨$⟩ refl)
                      return-sem))
    | refl | refl = refl

  to∘from : ∀ {s} (eq : s ≡ [ t ]) → to (from eq) ≡ eq
  to∘from refl
    rewrite Inverse.right-inverse-of (if-true-sem pt) refl
    = refl

abstract

  -- Grammar.Infinite requires a lot more memory to type-check if this
  -- definition is made concrete (at the time of writing).

  tok-sem : ∀ {t′ t s} → t′ ∈ tok t · s ↔ (t ≡ t′ × s ≡ [ t ])
  tok-sem {t′} {t} {s} =
    t′ ∈ tok t · s                                   ↔⟨ <$>-sem ⟩
    (∃ λ p → p ∈ sat (λ t′ → t == t′) · s × t′ ≡ t)  ↔⟨ Σ.cong Inv.id (sat-sem ×-cong Inv.id) ⟩
    (∃ λ p → s ≡ [ proj₁ p ] × t′ ≡ t)               ↔⟨ Σ-assoc ⟩
    (∃ λ t″ → T (t == t″) × s ≡ [ t″ ] × t′ ≡ t)     ↔⟨ Σ.cong Inv.id (True↔ _ P.≡-irrelevant ×-cong Inv.id) ⟩
    (∃ λ t″ → t ≡ t″ × s ≡ [ t″ ] × t′ ≡ t)          ↔⟨ lemma ⟩
    (t ≡ t′ × s ≡ [ t ])                             ∎
    where
    open Related.EquationalReasoning

    lemma : (∃ λ t″ → t ≡ t″ × s ≡ [ t″ ] × t′ ≡ t) ↔
            (t ≡ t′ × s ≡ [ t ])
    lemma = record
      { to         = P.→-to-⟶ to
      ; from       = P.→-to-⟶ from
      ; inverse-of = record
        { left-inverse-of  = from∘to
        ; right-inverse-of = to∘from
        }
      }
      where
      to : ∀ {t′ t : Char} {s} →
           (∃ λ t″ → t ≡ t″ × s ≡ [ t″ ] × t′ ≡ t) → t ≡ t′ × s ≡ [ t ]
      to (_ , refl , refl , refl) = (refl , refl)

      from : ∀ {t′ t : Char} {s} →
             t ≡ t′ × s ≡ [ t ] → ∃ λ t″ → t ≡ t″ × s ≡ [ t″ ] × t′ ≡ t
      from (refl , refl) = (_ , refl , refl , refl)

      from∘to : ∀ {t′ t : Char} {s}
                (eqs : ∃ λ t″ → t ≡ t″ × s ≡ [ t″ ] × t′ ≡ t) →
                from (to eqs) ≡ eqs
      from∘to (_ , refl , refl , refl) = refl

      to∘from : ∀ {t′ t : Char} {s} (eqs : t ≡ t′ × s ≡ [ t ]) →
                to (from eqs) ≡ eqs
      to∘from (refl , refl) = refl

------------------------------------------------------------------------
-- An aside: An inductive version of the grammar type above wouldn't
-- be very useful (assuming that Char is finite)

module Aside (finite-number-of-tokens :
                ∃ λ (ts : List Char) → ∀ t → t ∈ ts) where

  open ≤-Reasoning

  infixl 15 _>>=_
  infixl 10 _∣_

  data GrammarI : Set → Set₁ where
    return : ∀ {A} → A → GrammarI A
    token  : GrammarI Char
    _>>=_  : ∀ {A B} → GrammarI A → (A → GrammarI B) → GrammarI B
    _∣_    : ∀ {A} → GrammarI A → GrammarI A → GrammarI A

  infix 4 _∈I_·_

  data _∈I_·_ : ∀ {A} → A → GrammarI A → List Char → Set₁ where
    return-sem : ∀ {A} {x : A} → x ∈I return x · []
    token-sem  : ∀ {t} → t ∈I token · [ t ]
    >>=-sem    : ∀ {A B x y s₁ s₂} {g₁ : GrammarI A}
                   {g₂ : A → GrammarI B} →
                 x ∈I g₁ · s₁ → y ∈I g₂ x · s₂ →
                 y ∈I g₁ >>= g₂ · s₁ ++ s₂
    left-sem   : ∀ {A} {g₁ g₂ : GrammarI A} {x s} →
                 x ∈I g₁ · s → x ∈I g₁ ∣ g₂ · s
    right-sem  : ∀ {A} {g₁ g₂ : GrammarI A} {x s} →
                 x ∈I g₂ · s → x ∈I g₁ ∣ g₂ · s

  -- A kind of parser for the inductive grammars, used to prove
  -- finite-number-of-results. Note that the "parser" is not quite
  -- correct when seen as a parser: it sometimes returns too many
  -- results. (The derivative of return x should be a failing
  -- grammar.)

  initial-bag : ∀ {A} (g : GrammarI A) →
                ∃ λ xs → ∀ {x} → x ∈I g · [] → x ∈ xs

  derivative : ∀ {A} (g : GrammarI A) t →
               ∃ λ g′ → ∀ {x s} → x ∈I g · t ∷ s → x ∈I g′ · s

  parse : ∀ {A} (g : GrammarI A) s →
          ∃ λ xs → ∀ {x} → x ∈I g · s → x ∈ xs
  parse g []      = initial-bag g
  parse g (t ∷ s) with derivative g t
  ... | g′ , ok₁ with parse g′ s
  ...   | xs , ok₂ = xs , ok₂ ∘ ok₁

  initial-bag (return x) = [ x ] , λ { .{x = x} return-sem → here refl }
  initial-bag token      = []    , λ ()
  initial-bag (g₁ ∣ g₂)  =
    Prod.zip
      _++_
      (λ {xs} i₁ i₂ →
       λ { (left-sem  ∈g₁) → Inverse.to ++↔             ⟨$⟩ inj₁ (i₁ ∈g₁)
         ; (right-sem ∈g₂) → Inverse.to (++↔ {xs = xs}) ⟨$⟩ inj₂ (i₂ ∈g₂)
         })
      (initial-bag g₁)
      (initial-bag g₂)
  initial-bag (_>>=_ {A = A} {B = B} g₁ g₂) with initial-bag g₁
  ... | xs , xs-ok = ys xs , λ ∈g₁>>=g₂ → lemma₁ ∈g₁>>=g₂ refl
    where
    ys : List A → List B
    ys xs = xs LMa.>>= λ x → proj₁ (initial-bag (g₂ x))

    lemma₂ : ∀ {x y} xs → x ∈ xs → y ∈I g₂ x · [] → y ∈ ys xs
    lemma₂ (x ∷ xs) (here refl) ∈g₂ =
      Inverse.to ++↔ ⟨$⟩ inj₁ (proj₂ (initial-bag (g₂ x)) ∈g₂)
    lemma₂ (z ∷ xs) (there x∈) ∈g₂ =
      Inverse.to (++↔ {xs = proj₁ (initial-bag (g₂ z))}) ⟨$⟩
        inj₂ (lemma₂ xs x∈ ∈g₂)

    lemma₁ : ∀ {x s} → x ∈I g₁ >>= g₂ · s → s ≡ [] → x ∈ ys xs
    lemma₁ (>>=-sem {s₁ = []}    ∈g₁ ∈g₂) refl = lemma₂ xs (xs-ok ∈g₁) ∈g₂
    lemma₁ (>>=-sem {s₁ = _ ∷ _} ∈g₁ ∈g₂) ()

  derivative (return x) t = return x , λ ()
  derivative token      t = return t , λ { .{s = []} token-sem → return-sem }
  derivative (g₁ ∣ g₂)  t =
    Prod.zip _∣_
             (λ {g₁′ g₂′} ok₁ ok₂ →
              λ { (left-sem  ∈g₁) → left-sem  (ok₁ ∈g₁)
                ; (right-sem ∈g₂) → right-sem (ok₂ ∈g₂)
                })
             (derivative g₁ t)
             (derivative g₂ t)
  derivative (_>>=_ {A = A} {B = B} g₁ g₂) t
    with derivative g₁ t | initial-bag g₁
  ... | g₁′ , g₁′-ok | xs , xs-ok =
    g′ xs , λ ∈g₁>>=g₂ → lemma₁ ∈g₁>>=g₂ refl
    where
    g′ : List A → GrammarI B
    g′ []       = g₁′ >>= g₂
    g′ (x ∷ xs) = return x >>= (λ x → proj₁ (derivative (g₂ x) t))
                ∣ g′ xs

    lemma₂ : ∀ {x y s} xs →
             x ∈ xs → y ∈I g₂ x · t ∷ s → y ∈I g′ xs · s
    lemma₂ (x ∷ xs) (here refl) ∈g₂ = left-sem (>>=-sem return-sem
                                        (proj₂ (derivative (g₂ x) t) ∈g₂))
    lemma₂ (z ∷ xs) (there x∈)  ∈g₂ = right-sem (lemma₂ xs x∈ ∈g₂)

    lemma₃ : ∀ {x y s₁ s₂} xs →
             x ∈I g₁′ · s₁ → y ∈I g₂ x · s₂ → y ∈I g′ xs · s₁ ++ s₂
    lemma₃ []       ∈g₁′ ∈g₂ = >>=-sem ∈g₁′ ∈g₂
    lemma₃ (x ∷ xs) ∈g₁′ ∈g₂ = right-sem (lemma₃ xs ∈g₁′ ∈g₂)

    lemma₁ : ∀ {y s s′} →
             y ∈I g₁ >>= g₂ · s → s ≡ t ∷ s′ → y ∈I g′ xs · s′
    lemma₁ (>>=-sem {s₁ = []}     ∈g₁ ∈g₂) refl = lemma₂ xs (xs-ok  ∈g₁) ∈g₂
    lemma₁ (>>=-sem {s₁ = .t ∷ _} ∈g₁ ∈g₂) refl = lemma₃ xs (g₁′-ok ∈g₁) ∈g₂

  -- If strings are restricted to have a given maximum length, then an
  -- inductive grammar generates a finite number of distinct results.

  finite-number-of-results :
    ∀ {A} (g : GrammarI A) n →
    ∃ λ xs → ∀ {x s} → length s ≤ n → x ∈I g · s → x ∈ xs
  finite-number-of-results g n =
    (all-strings n LMa.>>= proj₁ ∘ parse g) ,
    λ {_} {s} ≤n ∈g →
      Inverse.to ∈.>>=-∈↔ ⟨$⟩
        (_ , all-strings-ok s n ≤n , proj₂ (parse g s) ∈g)
    where
    all-strings : ℕ → List (List Char)
    all-strings 0       = [ [] ]
    all-strings (suc n) = all-strings n ++
                          (proj₁ finite-number-of-tokens LMa.>>= λ t →
                           List.map (_∷_ t) (all-strings n))

    all-strings-ok : ∀ s n → length s ≤ n → s ∈ all-strings n
    all-strings-ok []      zero    z≤n      = here refl
    all-strings-ok []      (suc n) z≤n      = Inverse.to ++↔ ⟨$⟩
                                                inj₁ (all-strings-ok [] n z≤n)
    all-strings-ok (t ∷ s) (suc n) (s≤s ≤n) =
      Inverse.to (++↔ {xs = all-strings n}) ⟨$⟩
        inj₂ (Inverse.to ∈.>>=-∈↔ ⟨$⟩
                (_ , proj₂ finite-number-of-tokens t
                   , Inverse.to (∈.map-∈↔ _) ⟨$⟩
                       (_ , all-strings-ok s n ≤n , refl)))

  -- No inductive grammar can generate strings of unbounded length.

  bounded-length :
    ∀ {A} (g : GrammarI A) →
    ∃ λ n → ∀ {x s} → x ∈I g · s → length s ≤ n
  bounded-length (return x) = 0 , λ { .{s = []}    return-sem → z≤n }
  bounded-length token      = 1 , λ { .{s = [ _ ]} token-sem  → s≤s z≤n }
  bounded-length (g₁ ∣ g₂)  =
    Prod.zip _+_
             (λ {n₁ n₂} b₁ b₂ →
              λ { {s = s} (left-sem ∈g₁) → begin
                  length s  ≤⟨ b₁ ∈g₁ ⟩
                  n₁        ≤⟨ m≤m+n _ _ ⟩
                  n₁ + n₂   ∎
                ; {s = s} (right-sem ∈g₂) → begin
                  length s  ≤⟨ b₂ ∈g₂ ⟩
                  n₂        ≤⟨ m≤n+m _ n₁ ⟩
                  n₁ + n₂   ∎
                })
             (bounded-length g₁)
             (bounded-length g₂)
  bounded-length (_>>=_ {A = A} g₁ g₂) with bounded-length g₁
  ... | n₁ , b₁ with finite-number-of-results g₁ n₁
  ...   | xs , xs-ok =
    n₁ + n₂ xs ,
    λ { .{s = _} (>>=-sem {s₁ = s₁} {s₂ = s₂} ∈g₁ ∈g₂) → begin
        length (s₁ ++ s₂)      ≡⟨ length-++ s₁ ⟩
        length s₁ + length s₂  ≤⟨ +-mono-≤ (b₁ ∈g₁) (lemma xs (xs-ok (b₁ ∈g₁) ∈g₁) ∈g₂) ⟩
        n₁        + n₂ xs      ∎ }
    where
    n₂ : List A → ℕ
    n₂ = foldr _⊔_ 0 ∘ List.map (λ x → proj₁ (bounded-length (g₂ x)))

    lemma : ∀ {x y s} xs → x ∈ xs → y ∈I g₂ x · s → length s ≤ n₂ xs
    lemma {s = s} (x ∷ xs) (here refl) y∈ = begin
      length s                               ≤⟨ proj₂ (bounded-length (g₂ x)) y∈ ⟩
      proj₁ (bounded-length (g₂ x))          ≤⟨ m≤m⊔n _ _ ⟩
      proj₁ (bounded-length (g₂ x)) ⊔ n₂ xs  ∎
    lemma {s = s} (z ∷ xs) (there x∈) y∈ = begin
      length s                               ≤⟨ lemma xs x∈ y∈ ⟩
      n₂ xs                                  ≤⟨ m≤m⊔n _ _ ⟩
      n₂ xs ⊔ proj₁ (bounded-length (g₂ z))  ≡⟨ ∧-comm (n₂ xs) _ ⟩
      proj₁ (bounded-length (g₂ z)) ⊔ n₂ xs  ∎
      where open DistributiveLattice NatP.⊓-⊔-distributiveLattice


{-# OPTIONS --rewriting #-}

module Properties.TypeCheck where

open import Agda.Builtin.Equality using (_≡_; refl)
open import Agda.Builtin.Bool using (Bool; true; false)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import FFI.Data.Either using (Either)
open import Luau.TypeCheck using (_⊢ᴱ_∈_; _⊢ᴮ_∈_; ⊢ᴼ_; ⊢ᴴ_; _⊢ᴴᴱ_▷_∈_; _⊢ᴴᴮ_▷_∈_; nil; var; addr; number; bool; string; app; function; block; binexp; done; return; local; nothing; orUnknown; tgtBinOp)
open import Luau.Syntax using (Block; Expr; Value; BinaryOperator; yes; nil; addr; number; bool; string; val; var; binexp; _$_; function_is_end; block_is_end; _∙_; return; done; local_←_; _⟨_⟩; _⟨_⟩∈_; var_∈_; name; fun; arg; +; -; *; /; <; >; ==; ~=; <=; >=)
open import Luau.Type using (Type; nil; unknown; never; number; boolean; string; _⇒_; src; tgt)
open import Luau.RuntimeType using (RuntimeType; nil; number; function; string; valueType)
open import Luau.VarCtxt using (VarCtxt; ∅; _↦_; _⊕_↦_; _⋒_; _⊝_) renaming (_[_] to _[_]ⱽ)
open import Luau.Addr using (Addr)
open import Luau.Var using (Var; _≡ⱽ_)
open import Luau.Heap using (Heap; Object; function_is_end) renaming (_[_] to _[_]ᴴ)
open import Properties.Contradiction using (CONTRADICTION)
open import Properties.Dec using (yes; no)
open import Properties.Equality using (_≢_; sym; trans; cong)
open import Properties.Product using (_×_; _,_)
open import Properties.Remember using (Remember; remember; _,_)

typeOfᴼ : Object yes → Type
typeOfᴼ (function f ⟨ var x ∈ S ⟩∈ T is B end) = (S ⇒ T)

typeOfᴹᴼ : Maybe(Object yes) → Maybe Type
typeOfᴹᴼ nothing = nothing
typeOfᴹᴼ (just O) = just (typeOfᴼ O)

typeOfⱽ : Heap yes → Value → Maybe Type
typeOfⱽ H nil = just nil
typeOfⱽ H (bool b) = just boolean
typeOfⱽ H (addr a) = typeOfᴹᴼ (H [ a ]ᴴ)
typeOfⱽ H (number n) = just number
typeOfⱽ H (string x) = just string

typeOfᴱ : Heap yes → VarCtxt → (Expr yes) → Type
typeOfᴮ : Heap yes → VarCtxt → (Block yes) → Type

typeOfᴱ H Γ (var x) = orUnknown(Γ [ x ]ⱽ)
typeOfᴱ H Γ (val v) = orUnknown(typeOfⱽ H v)
typeOfᴱ H Γ (M $ N) = tgt(typeOfᴱ H Γ M)
typeOfᴱ H Γ (function f ⟨ var x ∈ S ⟩∈ T is B end) = S ⇒ T
typeOfᴱ H Γ (block var b ∈ T is B end) = T
typeOfᴱ H Γ (binexp M op N) = tgtBinOp op

typeOfᴮ H Γ (function f ⟨ var x ∈ S ⟩∈ T is C end ∙ B) = typeOfᴮ H (Γ ⊕ f ↦ (S ⇒ T)) B
typeOfᴮ H Γ (local var x ∈ T ← M ∙ B) = typeOfᴮ H (Γ ⊕ x ↦ T) B
typeOfᴮ H Γ (return M ∙ B) = typeOfᴱ H Γ M
typeOfᴮ H Γ done = nil

mustBeFunction : ∀ H Γ v → (never ≢ src (typeOfᴱ H Γ (val v))) → (function ≡ valueType(v))
mustBeFunction H Γ nil p = CONTRADICTION (p refl)
mustBeFunction H Γ (addr a) p = refl
mustBeFunction H Γ (number n) p = CONTRADICTION (p refl)
mustBeFunction H Γ (bool true) p = CONTRADICTION (p refl)
mustBeFunction H Γ (bool false) p = CONTRADICTION (p refl)
mustBeFunction H Γ (string x) p = CONTRADICTION (p refl)

mustBeNumber : ∀ H Γ v → (typeOfᴱ H Γ (val v) ≡ number) → (valueType(v) ≡ number)
mustBeNumber H Γ (addr a) p with remember (H [ a ]ᴴ)
mustBeNumber H Γ (addr a) p | (just O , q) with trans (cong orUnknown (cong typeOfᴹᴼ (sym q))) p
mustBeNumber H Γ (addr a) p | (just function f ⟨ var x ∈ T ⟩∈ U is B end , q) | ()
mustBeNumber H Γ (addr a) p | (nothing , q) with trans (cong orUnknown (cong typeOfᴹᴼ (sym q))) p
mustBeNumber H Γ (addr a) p | nothing , q | ()
mustBeNumber H Γ (number n) p = refl

mustBeString : ∀ H Γ v → (typeOfᴱ H Γ (val v) ≡ string) → (valueType(v) ≡ string)
mustBeString H Γ (addr a) p with remember (H [ a ]ᴴ)
mustBeString H Γ (addr a) p | (just O , q) with trans (cong orUnknown (cong typeOfᴹᴼ (sym q))) p
mustBeString H Γ (addr a) p | (just function f ⟨ var x ∈ T ⟩∈ U is B end , q) | ()
mustBeString H Γ (addr a) p | (nothing , q) with trans (cong orUnknown (cong typeOfᴹᴼ (sym q))) p
mustBeString H Γ (addr a) p | (nothing , q) | ()
mustBeString H Γ (string x) p = refl

typeCheckᴱ : ∀ H Γ M → (Γ ⊢ᴱ M ∈ (typeOfᴱ H Γ M))
typeCheckᴮ : ∀ H Γ B → (Γ ⊢ᴮ B ∈ (typeOfᴮ H Γ B))

typeCheckᴱ H Γ (var x) = var refl
typeCheckᴱ H Γ (val nil) = nil
typeCheckᴱ H Γ (val (addr a)) = addr (orUnknown (typeOfᴹᴼ (H [ a ]ᴴ)))
typeCheckᴱ H Γ (val (number n)) = number
typeCheckᴱ H Γ (val (bool b)) = bool
typeCheckᴱ H Γ (val (string x)) = string
typeCheckᴱ H Γ (M $ N) = app (typeCheckᴱ H Γ M) (typeCheckᴱ H Γ N)
typeCheckᴱ H Γ (function f ⟨ var x ∈ T ⟩∈ U is B end) = function (typeCheckᴮ H (Γ ⊕ x ↦ T) B)
typeCheckᴱ H Γ (block var b ∈ T is B end) = block (typeCheckᴮ H Γ B)
typeCheckᴱ H Γ (binexp M op N) = binexp (typeCheckᴱ H Γ M) (typeCheckᴱ H Γ N)

typeCheckᴮ H Γ (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) = function (typeCheckᴮ H (Γ ⊕ x ↦ T) C) (typeCheckᴮ H (Γ ⊕ f ↦ (T ⇒ U)) B)
typeCheckᴮ H Γ (local var x ∈ T ← M ∙ B) = local (typeCheckᴱ H Γ M) (typeCheckᴮ H (Γ ⊕ x ↦ T) B)
typeCheckᴮ H Γ (return M ∙ B) = return (typeCheckᴱ H Γ M) (typeCheckᴮ H Γ B)
typeCheckᴮ H Γ done = done

typeCheckᴼ : ∀ H O → (⊢ᴼ O)
typeCheckᴼ H nothing = nothing
typeCheckᴼ H (just function f ⟨ var x ∈ T ⟩∈ U is B end) = function (typeCheckᴮ H (x ↦ T) B)

typeCheckᴴ : ∀ H → (⊢ᴴ H)
typeCheckᴴ H a {O} p = typeCheckᴼ H (O)

typeCheckᴴᴱ : ∀ H Γ M → (Γ ⊢ᴴᴱ H ▷ M ∈ typeOfᴱ H Γ M)
typeCheckᴴᴱ H Γ M = (typeCheckᴴ H , typeCheckᴱ H Γ M)

typeCheckᴴᴮ : ∀ H Γ M → (Γ ⊢ᴴᴮ H ▷ M ∈ typeOfᴮ H Γ M)
typeCheckᴴᴮ H Γ M = (typeCheckᴴ H , typeCheckᴮ H Γ M)


{-# NON_TERMINATING #-}

mutual

  record R : Set where
    inductive
    field
      x : T

  T : Set
  T = T → R


{- 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
-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.KVMap
open import LibraBFT.Base.PKCS
open import LibraBFT.Hash
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Handle
open import LibraBFT.Concrete.System.Parameters
open        EpochConfig
open import LibraBFT.Concrete.System
open import LibraBFT.Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms PeerCanSignForPK (λ {st} {part} {pk} → PeerCanSignForPK-stable {st} {part} {pk})

-- This module contains placeholders for the future analog of the
-- corresponding VotesOnce property.  Defining the implementation
-- obligation and proving that it is an invariant of an implementation
-- is a substantial undertaking.  We are working first on proving the
-- simpler VotesOnce property to settle down the structural aspects
-- before tackling the harder semantic issues.
module LibraBFT.Concrete.Properties.PreferredRound where
 -- TODO-3: define the implementation obligation
 ImplObligation₁ : Set
 ImplObligation₁ = Unit

 -- Next, we prove that given the necessary obligations,
 module Proof
   (sps-corr : StepPeerState-AllValidParts)
   (Impl-PR1 : ImplObligation₁)
   where
  -- Any reachable state satisfies the PR rule for any epoch in the system.
  module _ (st : SystemState)(r : ReachableSystemState st)(𝓔 : EpochConfig) where
   -- Bring in 'unwind', 'ext-unforgeability' and friends
   open Structural sps-corr
   -- Bring in IntSystemState
   open WithSPS sps-corr
   open        PerState st r
   open        PerEpoch 𝓔
   open import LibraBFT.Concrete.Obligations.PreferredRound 𝓔 (ConcreteVoteEvidence 𝓔) as PR

   postulate  -- TODO-3: prove it
     prr : PR.Type IntSystemState


{-# OPTIONS --no-unreachable-check #-}

module Issue424 where

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

f : Set → Set
f A = A
f A = A

fails : (A : Set) → f A ≡ A
fails A = refl

-- The case tree compiler used to treat f as a definition with an
-- absurd pattern.


{- 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
-}
{-# OPTIONS --allow-unsolved-metas #-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Encode
open import LibraBFT.Base.KVMap as KVMap
open import LibraBFT.Base.Types
open import Data.String using (String)

-- This module defines types for an out-of-date implementation, based
-- on a previous version of LibraBFT.  It will be updated to model a
-- more recent version in future.
--
-- One important trick here is that the EventProcessor type separayes
-- types that /define/ the EpochConfig and types that /use/ the
-- /EpochConfig/. The advantage of doing this separation can be seen
-- in Util.Util.liftEC, where we define a lifting of a function that
-- does not change the bits that define the EpochConfig into the whole
-- state.  This enables a more elegant approach for reasoning about
-- functions that do not change parts of the state responsible for
-- defining the epoch config.  However, the separation is not perfect,
-- so sometimes fields may be modified in EpochIndep even though there
-- is no epoch change.

module LibraBFT.Impl.Consensus.Types where
  open import LibraBFT.Impl.Base.Types                       public
  open import LibraBFT.Impl.NetworkMsg                       public
  open import LibraBFT.Abstract.Types.EpochConfig UID NodeId public
  open import LibraBFT.Impl.Consensus.Types.EpochIndep       public
  open import LibraBFT.Impl.Consensus.Types.EpochDep         public

  -- The parts of the state of a peer that are used to
  -- define the EpochConfig are the SafetyRules and ValidatorVerifier:
  record EventProcessorEC : Set where
    constructor mkEventProcessorPreEC
    field
      ₋epSafetyRules  : SafetyRules
      ₋epValidators   : ValidatorVerifier
  open EventProcessorEC public
  unquoteDecl epSafetyRules epValidators = mkLens (quote EventProcessorEC)
    (epSafetyRules ∷ epValidators ∷ [])

  epEpoch : Lens EventProcessorEC EpochId
  epEpoch = epSafetyRules ∙ srPersistentStorage ∙ psEpoch

  epLastVotedRound : Lens EventProcessorEC Round
  epLastVotedRound = epSafetyRules ∙ srPersistentStorage ∙ psLastVotedRound

  -- We need enough authors to withstand the desired number of
  -- byzantine failures.  We enforce this with a predicate over
  -- 'EventProcessorEC'.
  EventProcessorEC-correct : EventProcessorEC → Set
  EventProcessorEC-correct epec =
    let numAuthors = kvm-size (epec ^∙ epValidators ∙ vvAddressToValidatorInfo)
        qsize      = epec ^∙ epValidators ∙ vvQuorumVotingPower
        bizF       = numAuthors ∸ qsize
     in suc (3 * bizF) ≤ numAuthors

  EventProcessorEC-correct-≡ : (epec1 : EventProcessorEC)
                             → (epec2 : EventProcessorEC)
                             → (epec1 ^∙ epValidators) ≡ (epec2 ^∙ epValidators)
                             → EventProcessorEC-correct epec1
                             → EventProcessorEC-correct epec2
  EventProcessorEC-correct-≡ epec1 epec2 refl = id

  -- Given a well-formed set of definitions that defines an EpochConfig,
  -- α-EC will compute this EpochConfig by abstracting away the unecessary
  -- pieces from EventProcessorEC.
  -- TODO-2: update and complete when definitions are updated to more recent version
  α-EC : Σ EventProcessorEC EventProcessorEC-correct → EpochConfig
  α-EC (epec , ok) =
    let numAuthors = kvm-size (epec ^∙ epValidators ∙ vvAddressToValidatorInfo)
        qsize      = epec ^∙ epValidators ∙ vvQuorumVotingPower
        bizF       = numAuthors ∸ qsize
     in (mkEpochConfig {! someHash?!}
                (epec ^∙ epEpoch) numAuthors {!!} {!!} {!!} {!!} {!!} {!!} {!!} {!!})

  postulate
    α-EC-≡ : (epec1  : EventProcessorEC)
           → (epec2  : EventProcessorEC)
           → (vals≡  : (epec1 ^∙ epValidators) ≡ (epec2 ^∙ epValidators))
           → (epoch≡ : (epec1 ^∙ epEpoch)      ≡ (epec2 ^∙ epEpoch))
           → (epec1-corr : EventProcessorEC-correct epec1)
           → α-EC (epec1 , epec1-corr) ≡ α-EC (epec2 , EventProcessorEC-correct-≡ epec1 epec2 vals≡ epec1-corr)
  {-
  α-EC-≡ epec1 epec2 refl refl epec1-corr = refl
  -}

  -- Finally, the EventProcessor is split in two pieces: those
  -- that are used to make an EpochConfig versus those that
  -- use an EpochConfig.
  record EventProcessor : Set where
    constructor mkEventProcessor
    field
      ₋epEC           : EventProcessorEC
      ₋epEC-correct   : EventProcessorEC-correct ₋epEC
      ₋epWithEC       : EventProcessorWithEC (α-EC (₋epEC , ₋epEC-correct))
     -- If we want to add pieces that neither contribute to the
     -- construction of the EC nor need one, they should be defined in
     -- EventProcessor directly
  open EventProcessor public

  α-EC-EP : EventProcessor → EpochConfig
  α-EC-EP ep = α-EC ((₋epEC ep) , (₋epEC-correct ep))

  ₋epHighestQC : (ep : EventProcessor) → QuorumCert
  ₋epHighestQC ep = ₋btHighestQuorumCert ((₋epWithEC ep) ^∙ (lBlockTree (α-EC-EP ep)))

  epHighestQC : Lens EventProcessor QuorumCert
  epHighestQC = mkLens' ₋epHighestQC
                        (λ (mkEventProcessor ec ecc (mkEventProcessorWithEC (mkBlockStore bsInner))) qc
                          → mkEventProcessor ec ecc (mkEventProcessorWithEC (mkBlockStore (record bsInner {₋btHighestQuorumCert = qc}))))

  ₋epHighestCommitQC : (ep : EventProcessor) → QuorumCert
  ₋epHighestCommitQC ep = ₋btHighestCommitCert ((₋epWithEC ep) ^∙ (lBlockTree (α-EC-EP ep)))

  epHighestCommitQC : Lens EventProcessor QuorumCert
  epHighestCommitQC = mkLens' ₋epHighestCommitQC
                        (λ (mkEventProcessor ec ecc (mkEventProcessorWithEC (mkBlockStore bsInner))) qc
                          → mkEventProcessor ec ecc (mkEventProcessorWithEC (mkBlockStore (record bsInner {₋btHighestCommitCert = qc}))))


{-# OPTIONS --safe #-}

module Definition.Typed.Consequences.Canonicity where

open import Definition.Untyped

open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Fundamental.Reducibility

open import Tools.Empty
open import Tools.Nat
open import Tools.Product

-- Turns a natural number into its term representation
sucᵏ : Nat → Term
sucᵏ 0 = zero
sucᵏ (1+ n) = suc (sucᵏ n)

-- No neutral terms are well-formed in an empty context

-- we need to postulate consistency
-- as we have several uninhabited propositions, we build an predicate
-- to characterize them

-- Note that we could also have defined reductions to Empty of other
-- forms of unihabited types

data isFalse : Term → Set where
  isEmpty : ∀ {lEmpty} → isFalse (Empty lEmpty)
  isIdℕΠ : ∀ {r A rA B} → isFalse (Id (Univ r ⁰) ℕ (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰))
  isIdΠℕ : ∀ {r A rA B} → isFalse (Id (Univ r ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) ℕ)
  isIdΠΠ%! : ∀ {r A B A' B'} → isFalse (Id (Univ r ⁰) (Π A ^ % ° ⁰ ▹ B ° ⁰ ° ⁰) (Π A' ^ ! ° ⁰ ▹ B' ° ⁰ ° ⁰))
  isIdΠΠ!% : ∀ {r A B A' B'} → isFalse (Id (Univ r ⁰) (Π A ^ ! ° ⁰ ▹ B ° ⁰ ° ⁰) (Π A' ^ % ° ⁰ ▹ B' ° ⁰ ° ⁰))

consistency = ∀ {t A l} → isFalse A → ε ⊢ t ∷ A ^ [ % , l ] → ⊥

noNe : ∀ {t A r} → consistency → ε ⊢ t ∷ A ^ r → Neutral t → ⊥

-- impossible cases thanks to consistency
noNe consistency (Emptyrecⱼ A ⊢e) Emptyrecₙ = consistency isEmpty ⊢e
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) castℕΠₙ = consistency isIdℕΠ [A]₂
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) castΠℕₙ = consistency isIdΠℕ [A]₂
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) castΠΠ%!ₙ = consistency isIdΠΠ%! [A]₂
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) castΠΠ!%ₙ = consistency isIdΠΠ!% [A]₂

-- possible cases proven by induction
noNe consistency (⊢t ∘ⱼ ⊢t₁) (∘ₙ neT) = noNe consistency  ⊢t neT
noNe consistency (natrecⱼ x ⊢t ⊢t₁ ⊢t₂) (natrecₙ neT) = noNe consistency ⊢t₂ neT
noNe consistency (var x₁ ()) (var x)
noNe consistency (Idⱼ [A] [A]₁ [A]₂) (Idₙ neT) = noNe consistency [A] neT
noNe consistency (Idⱼ [A] [A]₁ [A]₂) (Idℕₙ neT) = noNe consistency [A]₁ neT
noNe consistency (Idⱼ [A] [A]₁ [A]₂) (Idℕ0ₙ neT) = noNe consistency [A]₂ neT
noNe consistency (Idⱼ [A] [A]₁ [A]₂) (IdℕSₙ neT) = noNe consistency [A]₂ neT
noNe consistency (Idⱼ [A] [A]₁ [A]₂) (IdUₙ neT) = noNe consistency [A]₁ neT
noNe consistency (Idⱼ [A] [A]₁ [A]₂) (IdUℕₙ neT) = noNe consistency [A]₂ neT
noNe consistency (Idⱼ [A] [A]₁ [A]₂) (IdUΠₙ neT) = noNe consistency [A]₂ neT
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) (castₙ neT) = noNe consistency [A] neT
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) (castℕₙ neT) = noNe consistency [A]₁ neT
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) (castΠₙ neT) = noNe consistency [A]₁ neT
noNe consistency (castⱼ [A] [A]₁ [A]₂ [A]₃) (castℕℕₙ neT) = noNe consistency [A]₃ neT
noNe consistency (conv ⊢t x) (var n) = noNe consistency ⊢t (var n)
noNe consistency (conv ⊢t x) (∘ₙ neT) = noNe consistency ⊢t (∘ₙ neT)
noNe consistency (conv ⊢t x) (natrecₙ neT) = noNe consistency ⊢t (natrecₙ neT)
noNe consistency (conv ⊢t x) (Idₙ neT) = noNe consistency ⊢t (Idₙ neT)
noNe consistency (conv ⊢t x) (Idℕₙ neT) = noNe consistency ⊢t (Idℕₙ neT)
noNe consistency (conv ⊢t x) (Idℕ0ₙ neT) = noNe consistency ⊢t (Idℕ0ₙ neT)
noNe consistency (conv ⊢t x) (IdℕSₙ neT) = noNe consistency ⊢t (IdℕSₙ neT)
noNe consistency (conv ⊢t x) (IdUₙ neT) = noNe consistency ⊢t (IdUₙ neT)
noNe consistency (conv ⊢t x) (IdUℕₙ neT) = noNe consistency ⊢t (IdUℕₙ neT)
noNe consistency (conv ⊢t x) (IdUΠₙ neT) = noNe consistency ⊢t (IdUΠₙ neT)
noNe consistency (conv ⊢t x) (castₙ neT) = noNe consistency ⊢t (castₙ neT)
noNe consistency (conv ⊢t x) (castℕₙ neT) = noNe consistency ⊢t (castℕₙ neT)
noNe consistency (conv ⊢t x) (castΠₙ neT) = noNe consistency ⊢t (castΠₙ neT)
noNe consistency (conv ⊢t x) (castℕℕₙ neT) = noNe consistency ⊢t (castℕℕₙ neT)
noNe consistency (conv ⊢t x) castℕΠₙ = noNe consistency ⊢t castℕΠₙ
noNe consistency (conv ⊢t x) castΠℕₙ = noNe consistency ⊢t castΠℕₙ
noNe consistency (conv ⊢t x) castΠΠ%!ₙ = noNe consistency ⊢t castΠΠ%!ₙ
noNe consistency (conv ⊢t x) castΠΠ!%ₙ = noNe consistency ⊢t castΠΠ!%ₙ
noNe consistency (conv ⊢t x) Emptyrecₙ = noNe consistency ⊢t Emptyrecₙ

-- Helper function for canonicity for reducible natural properties
canonicity″ : ∀ {t}
              → consistency
              → Natural-prop ε t
              → ∃ λ k → ε ⊢ t ≡ sucᵏ k ∷ ℕ ^ [ ! , ι ⁰ ]
canonicity″ consistency (sucᵣ (ℕₜ n₁ d n≡n prop)) =
  let a , b = canonicity″ consistency prop
  in  1+ a , suc-cong (trans (subset*Term (redₜ d)) b)
canonicity″ consistency zeroᵣ = 0 , refl (zeroⱼ ε)
canonicity″ consistency (ne (neNfₜ neK ⊢k k≡k)) = ⊥-elim (noNe consistency ⊢k neK)

-- Helper function for canonicity for specific reducible natural numbers
canonicity′ : ∀ {t l}
             → consistency
             → ([ℕ] : ε ⊩⟨ l ⟩ℕ ℕ)
             → ε ⊩⟨ l ⟩ t ∷ ℕ ^ [ ! , ι ⁰ ] / ℕ-intr [ℕ]
             → ∃ λ k → ε ⊢ t ≡ sucᵏ k ∷ ℕ ^ [ ! , ι ⁰ ]
canonicity′ consistency (noemb [ℕ]) (ℕₜ n d n≡n prop) = let a , b = canonicity″ consistency prop
                                          in  a , trans (subset*Term (redₜ d)) b
canonicity′ consistency (emb emb< [ℕ]) [t] = canonicity′ consistency [ℕ] [t]
canonicity′ consistency (emb ∞< [ℕ]) [t] = canonicity′ consistency [ℕ] [t]

-- Canonicity of natural numbers
canonicity : ∀ {t} →
             consistency →
             ε ⊢ t ∷ ℕ ^ [ ! , ι ⁰ ] →
             ∃ λ k → ε ⊢ t ≡ sucᵏ k ∷ ℕ ^ [ ! , ι ⁰ ]
canonicity consistency ⊢t with reducibleTerm ⊢t
canonicity consistency ⊢t | [ℕ] , [t] =
  canonicity′ consistency (ℕ-elim [ℕ]) (irrelevanceTerm [ℕ] (ℕ-intr (ℕ-elim [ℕ])) [t])


-- Andreas, 2018-10-18, re #2757
-- Runtime-irrelevance analogue to issue #2640

-- {-# OPTIONS -v tc.lhs.unify:65 #-}
-- {-# OPTIONS -v tc.irr:20 #-}
-- {-# OPTIONS -v tc:30 #-}
-- {-# OPTIONS -v treeless:20 #-}

open import Common.Prelude

data D : (n : Nat) → Set where
  c : (m : Nat) → D m

test : (@0 n : Nat) → D n → Nat
test n (c m) = m

-- Should be rejected (projecting a forced argument).

main = printNat (test 142 (c _))

-- The generated Haskell program segfaults.


module Lemmachine.Resource where
import Lemmachine.Resource.Universe
open import Data.Product
open import Data.List

private
  module U = Lemmachine.Resource.Universe
  open U using (Code; El)

Hook = Σ Code El
Hooks = List Hook

_⇒_ : {A : Set}{B : A → Set} → (a : A) → B a → (Σ A B)
_⇒_ = _,_

record Resource : Set where
  field
    resourceExists : El U.resourceExists
    serviceAvailable : El U.serviceAvailable
    isAuthorized : El U.isAuthorized
    forbidden : El U.forbidden
    allowMissingPost : El U.allowMissingPost
    malformedRequest : El U.malformedRequest
    uriTooLong : El U.uriTooLong
    knownContentType : El U.knownContentType
    validContentHeaders : El U.validContentHeaders
    validEntityLength : El U.validEntityLength
    options : El U.options
    allowedMethods : El U.allowedMethods
    knownMethods : El U.knownMethods
    deleteResource : El U.deleteResource
    deleteCompleted : El U.deleteCompleted
    postIsCreate : El U.postIsCreate
    createPath : El U.createPath
    processPost : El U.processPost
    contentTypesProvided : El U.contentTypesProvided
    languageAvailable : El U.languageAvailable
    contentTypesAccepted : El U.contentTypesAccepted
    charsetsProvided : El U.charsetsProvided
    encodingsProvided : El U.encodingsProvided
    variances : El U.variances
    isConflict : El U.isConflict
    multipleChoices : El U.multipleChoices
    previouslyExisted : El U.previouslyExisted
    movedPermanently : El U.movedPermanently
    movedTemporarily : El U.movedTemporarily
    lastModified : El U.lastModified
    expires : El U.expires
    generateETag : El U.generateETag
    finishRequest : El U.finishRequest
    body : El U.body


{-# OPTIONS --rewriting --confluence-check #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

record Box (A : Set) : Set where
  constructor box
  field
    unbox : A
open Box

postulate
  A : Set
  a b : A

  f : (X : Set) → X → A
  g : (X : Set) → X

  rewf₁ : f (Box A) (box a) ≡ a
  rewf₂ : (X : Set) → f X (g X) ≡ b

  rewg : g (Box A) .unbox ≡ a

test = f (Box A) (g (Box A))

{-# REWRITE rewf₁ rewg #-}

rewg-contracted : g (Box A) ≡ box a
rewg-contracted = refl

foo : test ≡ a
foo = refl

{-# REWRITE rewf₂ #-}

bar : test ≡ b
bar = refl

fails : a ≡ b
fails = refl


module Imports.Issue5357-D where
A : Set₁
A = Set₁


module Human.Char where

open import Human.Nat
open import Human.Bool

postulate Char : Set
{-# BUILTIN CHAR Char #-}

primitive
  primIsLower             : Char → Bool
  primIsDigit             : Char → Bool
  primIsAlpha             : Char → Bool
  primIsSpace             : Char → Bool
  primIsAscii             : Char → Bool
  primIsLatin1            : Char → Bool
  primIsPrint             : Char → Bool
  primIsHexDigit          : Char → Bool
  primToUpper primToLower : Char → Char
  primCharToNat           : Char → Nat
  primNatToChar           : Nat → Char
  primCharEquality        : Char → Char → Bool

-- {-# COMPILE JS primCharToNat = function(c) { return c.charCodeAt(0); } #-}
-- {-# COMPILE JS primNatToChar = function(c) { return JSON.stringify(c); } #-}
-- {-# COMPILE JS primCharEquality = function(c) { return function(d) { return c === d; }; } #-}


{- 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
-}

open import LibraBFT.Base.Types
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Util.Crypto
open import Optics.All
open import Util.Hash
open import Util.KVMap
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open EpochConfig

-- This module defines an abstract system state (represented by a value of type
-- 'IntermediateSystemState') for a given concrete state.  The culminaton of this
-- module is the 'intSystemState' "function" at the bottom, which is probably the
-- best place to start understanding this.  Longer term, we will also need
-- higher-level, cross-epoch properties.

open import Yasm.Base
open import Yasm.System ℓ-RoundManager ℓ-VSFP ConcSysParms

module LibraBFT.Concrete.System where

 module PerEpoch (𝓔 : EpochConfig) where
   open WithEC
   open import LibraBFT.Abstract.Abstract     UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Abs hiding (qcVotes; Vote)
   open import LibraBFT.Concrete.Intermediate                   𝓔 (ConcreteVoteEvidence 𝓔)
   open import LibraBFT.Concrete.Records as LCR
   open LCR.WithEC 𝓔

   module PerState (st : SystemState) where

     -- * Auxiliary definitions;
     -- Here we capture the idea that there exists a vote message that
     -- witnesses the existence of a given Abs.Vote
     record ∃VoteMsgFor (v : Abs.Vote) : Set where
       constructor mk∃VoteMsgFor
       field
         -- A message that was actually sent
         nm            : NetworkMsg
         cv            : Vote
         cv∈nm         : cv ⊂Msg nm
         -- And contained a valid vote that, once abstracted, yeilds v.
         vmsgMember    : EpochConfig.Member 𝓔
         vmsgSigned    : WithVerSig (getPubKey 𝓔 vmsgMember) cv
         vmsg≈v        : α-ValidVote 𝓔 cv vmsgMember ≡ v
         vmsgEpoch     : cv ^∙ vEpoch ≡ epoch 𝓔
     open ∃VoteMsgFor public

     record ∃VoteMsgSentFor (sm : SentMessages)(v : Abs.Vote) : Set where
       constructor mk∃VoteMsgSentFor
       field
         vmFor        : ∃VoteMsgFor v
         vmSender     : NodeId
         nmSentByAuth : (vmSender , (nm vmFor)) ∈ sm
     open ∃VoteMsgSentFor public

     ∈QC⇒sent : ∀{st : SystemState} {q α}
              → Abs.Q q α-Sent (msgPool st)
              → Meta-Honest-Member α
              → (vα : α Abs.∈QC q)
              → ∃VoteMsgSentFor (msgPool st) (Abs.∈QC-Vote q vα)
     ∈QC⇒sent vsent@(ws {sender} {nm} e≡ nm∈st (qc∈NM {cqc} .{nm} valid cqc∈nm)) ha va
       with All-reduce⁻ {vdq = Any-lookup va} (α-Vote cqc valid) All-self
                        (Any-lookup-correctP va)
     ...| as , as∈cqc , α≡
       with  α-Vote-evidence cqc valid  as∈cqc | inspect
            (α-Vote-evidence cqc valid) as∈cqc
     ...| ev | [ refl ]
        with vote∈qc {vs = as} as∈cqc refl cqc∈nm
     ...| v∈nm = mk∃VoteMsgSentFor
                   (mk∃VoteMsgFor nm (_cveVote ev) v∈nm
                                  (_ivvMember (_cveIsValidVote ev))
                                  (_ivvSigned (_cveIsValidVote ev)) (sym α≡)
                                  (_ivvEpoch  (_cveIsValidVote ev)))
                   sender
                   nm∈st

     -- Finally, we can define the abstract system state corresponding to the concrete state st
     intSystemState : IntermediateSystemState ℓ0
     intSystemState = record
       { InSys           = λ { r → r α-Sent (msgPool st) }
       ; HasBeenSent     = λ { v → ∃VoteMsgSentFor (msgPool st) v }
       ; ∈QC⇒HasBeenSent = ∈QC⇒sent {st = st}
       }

   module InSys (siah : SystemInitAndHandlers ℓ-RoundManager ConcSysParms) where
     open WithInitAndHandlers siah
     open All-InSys-props

     stable : ∀ {st0 st1 : SystemState} → Step st0 st1 → {r : Abs.Record}
              → IntermediateSystemState.InSys (PerState.intSystemState st0) r
              → IntermediateSystemState.InSys (PerState.intSystemState st1) r
     stable theStep (_α-Sent_.ws refl x₁ x₂) = _α-Sent_.ws refl (msgs-stable theStep x₁) x₂

     ais-stable : ∀ {st0 st1 : SystemState} → Step st0 st1 → {o r : Abs.Record} → (rc : RecordChainFrom o r)
                  → All-InSys (IntermediateSystemState.InSys (PerState.intSystemState st0)) rc
                  → All-InSys (IntermediateSystemState.InSys (PerState.intSystemState st1)) rc
     ais-stable theStep rc ais = λ x → stable theStep (ais x)


module Mockingbird.Forest where

open import Mockingbird.Forest.Base public


module Issue848 where

A : Set1
A = B module _ where
  B : Set1
  B = Set

C : Set1
C = B

D : Set1
D = E module _ where
  E : Set1
  E = Set

F : Set1
F = G module _ where
  G : Set1
  G = H module _ where
    H : Set1
    H = Set


module Examples.PingPong where

open import ActorMonad public
open import Prelude

-- An example including three actors: spawner, pinger, ponger
--
-- Spawner is the actor that starts it all.
-- Spawner spawns both pinger and ponger.
-- Then spawner send the reference of ponger to pinger,
-- and the reference of pinger to ponger.
--
-- Pinger is an actor that can receive Bool messages.
-- Pinger counts the number of 'false' messages it receives, until it receives a 'true'
--
-- Ponger is an actor that can receive Nat messages.
-- Ponger keeps sending 'false' until it receives a message containing 10.

Spawnbox : InboxShape
Spawnbox = []

mutual
  PingValues = [ Bool ]ˡ
  PongValues = [ ℕ ]ˡ

  PingRefs : TypingContext
  PingRefs = [ ⊠-of-values PongValues ]ˡ
  PongRefs : TypingContext
  PongRefs = [ ⊠-of-values PingValues ]ˡ

  PongReferenceMessage : MessageType
  PongReferenceMessage = [ ReferenceType (⊠-of-values PongValues) ]ˡ

  BoolMessage : MessageType
  BoolMessage = [ ValueType Bool ]ˡ

  Pingbox : InboxShape
  Pingbox = BoolMessage ∷ [ PongReferenceMessage ]ˡ

  PingReferenceMessage : MessageType
  PingReferenceMessage = [ ReferenceType (⊠-of-values PingValues) ]ˡ

  NatMessage : MessageType
  NatMessage = [ ValueType ℕ ]ˡ

  Pongbox : InboxShape
  Pongbox = NatMessage ∷ [ PingReferenceMessage ]ˡ

constPingrefs : {A : Set₁} → (A → TypingContext)
constPingrefs _ =  PingRefs

pingMainActor : (i : Size) (A : Set₁) → Set₂
pingMainActor i A = ∞ActorM i Pingbox A PingRefs constPingrefs

mutual
  pingReceive : ∀ {i} (msg : Message Pingbox) → ∞ActorM i Pingbox (Lift (lsuc lzero) Bool) (add-references PingRefs msg) constPingrefs
  pingReceive (Msg Z (b ∷ [])) = return b
  pingReceive (Msg (S Z) _) = strengthen [ S Z ]ᵐ >> loopTillPingValue
  pingReceive (Msg (S (S ())) x₁)

  loopTillPingValue : ∀ {i} → pingMainActor i (Lift (lsuc lzero) Bool)
  loopTillPingValue .force = receive ∞>>= pingReceive

pinger : ∀ {i} → ∞ActorM (↑ i) Pingbox ⊤₁ [] constPingrefs
pinger .force = loopTillPong ∞>> pingMain 0
  where
    loopTillPong : ∀ {i} → ∞ActorM i Pingbox ⊤₁ [] constPingrefs
    loopTillPong .force = receive ∞>>= ((λ
      { (Msg Z x₁) → loopTillPong
      ; (Msg (S Z) x₁) → return _
      ; (Msg (S (S ())) x₁)
      }))
    pingMain : ∀ {i} → ℕ → pingMainActor i ⊤₁
    pingMain n .force = loopTillPingValue ∞>>= λ
      { (lift false) → (Z ![t: Z ] ( [ lift n ]ᵃ)) >> pingMain (suc n)
      ; (lift true) → return _}

constPongrefs : {A : Set₁} → (A → TypingContext)
constPongrefs _ = PongRefs

pongMainActor : (i : Size) (A : Set₁) → Set₂
pongMainActor i A = ∞ActorM i Pongbox A PongRefs constPongrefs

mutual
  pongReceive : ∀ {i} (msg : Message Pongbox) → ∞ActorM i Pongbox (Lift (lsuc lzero) ℕ) (add-references PongRefs msg) constPongrefs
  pongReceive (Msg Z (n ∷ [])) = return n
  pongReceive (Msg (S Z) _) = strengthen [ S Z ]ᵐ >> loopTillPongValue
  pongReceive (Msg (S (S ())) _)
  loopTillPongValue : ∀ {i} → pongMainActor i (Lift (lsuc lzero) ℕ)
  loopTillPongValue .force = receive ∞>>= pongReceive

ponger : ∀ {i} → ∞ActorM (↑ i) Pongbox ⊤₁ [] constPongrefs
ponger .force = loopTillPing ∞>> ((Z ![t: Z ] ([ lift false ]ᵃ)) >> pongMain)
  where
    loopTillPing : ∀ {i} → ∞ActorM i Pongbox ⊤₁ [] constPongrefs
    loopTillPing .force = receive ∞>>= λ {
      (Msg Z _) → loopTillPing
      ; (Msg (S Z) _) → return _
      ; (Msg (S (S ())) _)
      }
    pongMain : ∀ {i} → pongMainActor i ⊤₁
    pongMain .force = loopTillPongValue ∞>>= λ {
      (lift 10) → Z ![t: Z ] [ lift true ]ᵃ
      ; (lift n) → Z ![t: Z ] [ lift false ]ᵃ >> pongMain
      }

spawner : ∀ {i} → ∞ActorM i Spawnbox ⊤₁ [] (λ _ → Pingbox ∷ [ Pongbox ]ˡ)
spawner = do
  spawn∞ ponger
  spawn∞ pinger
  Z ![t: S Z ] [ [ S Z ]>: [ Z ]ᵐ ]ᵃ
  S Z ![t: S Z ] [ [ Z ]>: [ Z ]ᵐ ]ᵃ


module STLC1.Kovacs.Soundness where

open import STLC1.Kovacs.Convertibility public
open import STLC1.Kovacs.PresheafRefinement public

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

infix 3 _≈_
_≈_ : ∀ {A Γ} → Γ ⊩ A → Γ ⊩ A → Set

_≈_ {⎵}      {Γ} M₁ M₂ = M₁ ≡ M₂

_≈_ {A ⇒ B} {Γ} f₁ f₂ = ∀ {Γ′} → (η : Γ′ ⊇ Γ) {a₁ a₂ : Γ′ ⊩ A}
                                → (p : a₁ ≈ a₂) (u₁ : 𝒰 a₁) (u₂ : 𝒰 a₂)
                                → f₁ η a₁ ≈ f₂ η a₂

_≈_ {A ⩕ B}  {Γ} s₁ s₂ = proj₁ s₁ ≈ proj₁ s₂ × proj₂ s₁ ≈ proj₂ s₂

_≈_ {⫪}     {Γ} s₁ s₂ = ⊤

-- (≈ᶜ ; ∙ ; _,_)
infix 3 _≈⋆_
data _≈⋆_ : ∀ {Γ Ξ} → Γ ⊩⋆ Ξ → Γ ⊩⋆ Ξ → Set
  where
    ∅   : ∀ {Γ} → ∅ {Γ} ≈⋆ ∅

    _,_ : ∀ {Γ Ξ A} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ} {M₁ M₂ : Γ ⊩ A}
                    → (χ : ρ₁ ≈⋆ ρ₂) (p : M₁ ≈ M₂)
                    → ρ₁ , M₁ ≈⋆ ρ₂ , M₂

-- (_≈⁻¹)
_⁻¹≈ : ∀ {A Γ} → {a₁ a₂ : Γ ⊩ A}
               → a₁ ≈ a₂
               → a₂ ≈ a₁
_⁻¹≈ {⎵}      p = p ⁻¹
_⁻¹≈ {A ⇒ B} F = λ η p u₁ u₂ →
                    F η (p ⁻¹≈) u₂ u₁ ⁻¹≈
_⁻¹≈ {A ⩕ B}  p = proj₁ p ⁻¹≈ , proj₂ p ⁻¹≈
_⁻¹≈ {⫪}     p = tt

-- (_≈ᶜ⁻¹)
_⁻¹≈⋆ : ∀ {Γ Ξ} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                → ρ₁ ≈⋆ ρ₂
                → ρ₂ ≈⋆ ρ₁
∅       ⁻¹≈⋆ = ∅
(χ , p) ⁻¹≈⋆ = χ ⁻¹≈⋆ , p ⁻¹≈

-- (_≈◾_)
_⦙≈_ : ∀ {A Γ} → {a₁ a₂ a₃ : Γ ⊩ A}
               → a₁ ≈ a₂ → a₂ ≈ a₃
               → a₁ ≈ a₃
_⦙≈_ {⎵}      p q = p ⦙ q
_⦙≈_ {A ⇒ B} F G = λ η p u₁ u₂ →
                       F η (p ⦙≈ (p ⁻¹≈)) u₁ u₁
                    ⦙≈ G η p u₁ u₂
_⦙≈_ {A ⩕ B}  p q = proj₁ p ⦙≈ proj₁ q , proj₂ p ⦙≈ proj₂ q
_⦙≈_ {⫪}     p q = tt

-- (_≈ᶜ◾_)
_⦙≈⋆_ : ∀ {Γ Ξ} → {ρ₁ ρ₂ ρ₃ : Γ ⊩⋆ Ξ}
                → ρ₁ ≈⋆ ρ₂ → ρ₂ ≈⋆ ρ₃
                → ρ₁ ≈⋆ ρ₃
∅        ⦙≈⋆ ∅        = ∅
(χ₁ , p) ⦙≈⋆ (χ₂ , q) = χ₁ ⦙≈⋆ χ₂ , p ⦙≈ q

instance
  per≈ : ∀ {Γ A} → PER (Γ ⊩ A) _≈_
  per≈ =
    record
      { _⁻¹ = _⁻¹≈
      ; _⦙_ = _⦙≈_
      }

instance
  per≈⋆ : ∀ {Γ Ξ} → PER (Γ ⊩⋆ Ξ) _≈⋆_
  per≈⋆ =
    record
      { _⁻¹ = _⁻¹≈⋆
      ; _⦙_ = _⦙≈⋆_
      }

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

-- (≈ₑ)
acc≈ : ∀ {A Γ Γ′} → {a₁ a₂ : Γ ⊩ A}
                  → (η : Γ′ ⊇ Γ) → a₁ ≈ a₂
                  → acc η a₁ ≈ acc η a₂
acc≈ {⎵}      η p = renⁿᶠ η & p
acc≈ {A ⇒ B} η F = λ η′ → F (η ○ η′)
acc≈ {A ⩕ B}  η p = acc≈ η (proj₁ p) , acc≈ η (proj₂ p)
acc≈ {⫪}     η p = tt

-- (≈ᶜₑ)
_⬖≈_ : ∀ {Γ Γ′ Ξ} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                  → ρ₁ ≈⋆ ρ₂ → (η : Γ′ ⊇ Γ)
                  → ρ₁ ⬖ η ≈⋆ ρ₂ ⬖ η
∅       ⬖≈ η = ∅
(χ , p) ⬖≈ η = χ ⬖≈ η , acc≈ η p

-- (∈≈)
get≈ : ∀ {Γ Ξ A} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                 → ρ₁ ≈⋆ ρ₂ → (i : Ξ ∋ A)
                 → getᵥ ρ₁ i ≈ getᵥ ρ₂ i
get≈ (χ , p) zero    = p
get≈ (χ , p) (suc i) = get≈ χ i

-- (Tm≈)
eval≈ : ∀ {Γ Ξ A} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                  → ρ₁ ≈⋆ ρ₂ → 𝒰⋆ ρ₁ → 𝒰⋆ ρ₂ → (M : Ξ ⊢ A)
                  → eval ρ₁ M ≈ eval ρ₂ M
eval≈ χ υ₁ υ₂ (𝓋 i)   = get≈ χ i
eval≈ χ υ₁ υ₂ (ƛ M)   = λ η p u₁ u₂ →
                          eval≈ (χ ⬖≈ η , p)
                                (υ₁ ⬖𝒰 η , u₁)
                                (υ₂ ⬖𝒰 η , u₂)
                                M
eval≈ χ υ₁ υ₂ (M ∙ N) = eval≈ χ υ₁ υ₂ M idₑ
                              (eval≈ χ υ₁ υ₂ N)
                              (eval𝒰 υ₁ N)
                              (eval𝒰 υ₂ N)
eval≈ χ υ₁ υ₂ (M , N) = eval≈ χ υ₁ υ₂ M , eval≈ χ υ₁ υ₂ N
eval≈ χ υ₁ υ₂ (π₁ M)  = proj₁ (eval≈ χ υ₁ υ₂ M)
eval≈ χ υ₁ υ₂ (π₂ M)  = proj₂ (eval≈ χ υ₁ υ₂ M)
eval≈ χ υ₁ υ₂ τ       = tt

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

-- (Subᴺᴾ)
-- NOTE: _◆𝒰_ = eval𝒰⋆
_◆𝒰_ : ∀ {Γ Ξ Φ} → {ρ : Γ ⊩⋆ Ξ}
                 → (σ : Ξ ⊢⋆ Φ) → 𝒰⋆ ρ
                 → 𝒰⋆ (σ ◆ ρ)
∅       ◆𝒰 υ = ∅
(σ , M) ◆𝒰 υ = σ ◆𝒰 υ , eval𝒰 υ M

-- (Subᴺ≈ᶜ)
-- NOTE: _◆≈_ = eval≈⋆
_◆≈_ : ∀ {Γ Ξ Φ} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                 → (σ : Ξ ⊢⋆ Φ) → ρ₁ ≈⋆ ρ₂ → 𝒰⋆ ρ₁ → 𝒰⋆ ρ₂
                 → σ ◆ ρ₁ ≈⋆ σ ◆ ρ₂
(∅ ◆≈ χ)       υ₁ υ₂ = ∅
((σ , M) ◆≈ χ) υ₁ υ₂ = (σ ◆≈ χ) υ₁ υ₂ , eval≈ χ υ₁ υ₂ M

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

-- (Tmₛᴺ)
eval◆ : ∀ {Γ Ξ Φ A} → {ρ : Γ ⊩⋆ Ξ}
                    → ρ ≈⋆ ρ → 𝒰⋆ ρ → (σ : Ξ ⊢⋆ Φ) (M : Φ ⊢ A)
                    → eval ρ (sub σ M) ≈ eval (σ ◆ ρ) M

eval◆ {ρ = ρ} χ υ σ (𝓋 i)
  rewrite get◆ ρ σ i
  = eval≈ χ υ υ (getₛ σ i)

eval◆ {ρ = ρ} χ υ σ (ƛ M) η {a₁} {a₂} p u₁ u₂
  rewrite comp◆⬖ η υ σ
  = let
      υ′ = υ ⬖𝒰 η
    in
      eval◆ {ρ = ρ ⬖ η , a₁}
            ((χ ⬖≈ η) , (p ⦙ p ⁻¹))
            (υ ⬖𝒰 η , u₁)
            (liftₛ σ)
            M
    ⦙ coe ((λ ρ′ → eval (ρ′ , a₁) M ≈ _)
           & ( comp◆⬗ (ρ ⬖ η , a₁) (wkₑ idₑ) σ
             ⦙ (σ ◆_) & lid⬗ (ρ ⬖ η)
             ) ⁻¹)
          (eval≈ ((σ ◆≈ (χ ⬖≈ η)) υ′ υ′ , p)
                 (σ ◆𝒰 υ′ , u₁)
                 (σ ◆𝒰 υ′ , u₂)
                 M)

eval◆ {ρ = ρ} χ υ σ (M ∙ N)
  = eval◆ χ υ σ M
          idₑ
          (eval◆ χ υ σ N)
          (eval𝒰 υ (sub σ N))
          (eval𝒰 (σ ◆𝒰 υ) N)

eval◆ {ρ = ρ} χ υ σ (M , N) = eval◆ χ υ σ M , eval◆ χ υ σ N
eval◆ {ρ = ρ} χ υ σ (π₁ M)  = proj₁ (eval◆ χ υ σ M)
eval◆ {ρ = ρ} χ υ σ (π₂ M)  = proj₂ (eval◆ χ υ σ M)
eval◆ {ρ = ρ} χ υ σ τ       = tt

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

-- (~≈)
eval∼ : ∀ {Γ Ξ A} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                  → ρ₁ ≈⋆ ρ₂ → 𝒰⋆ ρ₁ → 𝒰⋆ ρ₂
                  → {M₁ M₂ : Ξ ⊢ A}
                  → M₁ ∼ M₂
                  → eval ρ₁ M₁ ≈ eval ρ₂ M₂

eval∼ χ υ₁ υ₂ {M} refl∼ = eval≈ χ υ₁ υ₂ M
eval∼ χ υ₁ υ₂ (p ⁻¹∼)   = eval∼ (χ ⁻¹) υ₂ υ₁ p ⁻¹
eval∼ χ υ₁ υ₂ (p ⦙∼ q)  = eval∼ (χ ⦙ χ ⁻¹) υ₁ υ₁ p
                        ⦙ eval∼ χ υ₁ υ₂ q

eval∼ χ υ₁ υ₂ (ƛ∼ p)
  = λ η q u₁ u₂ →
      eval∼ (χ ⬖≈ η , q)
            (υ₁ ⬖𝒰 η , u₁)
            (υ₂ ⬖𝒰 η , u₂)
            p

eval∼ χ υ₁ υ₂ (_∙∼_ {N₁ = N₁} {N₂} p q)
  = eval∼ χ υ₁ υ₂ p
          idₑ
          (eval∼ χ υ₁ υ₂ q)
          (eval𝒰 υ₁ N₁)
          (eval𝒰 υ₂ N₂)

eval∼ χ υ₁ υ₂ (p ,∼ q) = eval∼ χ υ₁ υ₂ p , eval∼ χ υ₁ υ₂ q
eval∼ χ υ₁ υ₂ (π₁∼ p ) = proj₁ (eval∼ χ υ₁ υ₂ p)
eval∼ χ υ₁ υ₂ (π₂∼ p ) = proj₂ (eval∼ χ υ₁ υ₂ p)

eval∼ {ρ₁ = ρ₁} {ρ₂} χ υ₁ υ₂ (red⇒ M N)
  = coe ((λ ρ₁′ ρ₂′ → eval (ρ₁′ , eval ρ₁ N) M ≈ eval (ρ₂′ , eval ρ₂ N) M)
         & (lid⬖ ρ₁ ⁻¹)
         ⊗ (lid◆ ρ₂ ⁻¹))
        (eval≈ (χ , eval≈ χ υ₁ υ₂ N)
               (υ₁ , eval𝒰 υ₁ N)
               (υ₂ , eval𝒰 υ₂ N)
               M)
  ⦙ eval◆ (χ ⁻¹ ⦙ χ) υ₂ (idₛ , N) M ⁻¹

eval∼ χ υ₁ υ₂ (red⩕₁ M N) = eval≈ χ υ₁ υ₂ M
eval∼ χ υ₁ υ₂ (red⩕₂ M N) = eval≈ χ υ₁ υ₂ N

eval∼ {ρ₂ = ρ₂} χ υ₁ υ₂ (exp⇒ M) η {a₂ = a₂} p u₁ u₂
  rewrite eval⬗ (ρ₂ ⬖ η , a₂) (wkₑ idₑ) M ⁻¹
        | lid⬗ (ρ₂ ⬖ η)
        | eval⬖ η υ₂ M
        | rid○ η
  = eval≈ χ υ₁ υ₂ M η p u₁ u₂

eval∼ χ υ₁ υ₂ (exp⩕ M)  = eval≈ χ υ₁ υ₂ M
eval∼ χ υ₁ υ₂ (exp⫪ M) = tt

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

mutual
  -- (q≈)
  reify≈ : ∀ {A Γ} → {a₁ a₂ : Γ ⊩ A}
                   → a₁ ≈ a₂
                   → reify a₁ ≡ reify a₂
  reify≈ {⎵}      p = p
  reify≈ {A ⇒ B} F = ƛ & reify≈ (F (wkₑ {A = A} idₑ)
                                    (reflect≈ refl)
                                    (reflect𝒰 {A} 0)
                                    (reflect𝒰 {A} 0))
  reify≈ {A ⩕ B}  p = _,_ & reify≈ (proj₁ p)
                          ⊗ reify≈ (proj₂ p)
  reify≈ {⫪}     p = refl

  -- (u≈)
  reflect≈ : ∀ {A Γ} → {M₁ M₂ : Γ ⊢ⁿᵉ A}
                     → M₁ ≡ M₂
                     → reflect M₁ ≈ reflect M₂
  reflect≈ {⎵}      p = ne & p
  reflect≈ {A ⇒ B} p = λ η q u₁ u₂ →
                          reflect≈ (_∙_ & (renⁿᵉ η & p)
                                        ⊗ reify≈ q)
  reflect≈ {A ⩕ B}  p = reflect≈ (π₁ & p) , reflect≈ (π₂ & p)
  reflect≈ {⫪}     p = tt

-- (uᶜ≈)
id≈ : ∀ {Γ} → idᵥ {Γ} ≈⋆ idᵥ
id≈ {∅}     = ∅
id≈ {Γ , A} = id≈ ⬖≈ wkₑ idₑ , reflect≈ refl

sound : ∀ {Γ A} → {M₁ M₂ : Γ ⊢ A}
                → M₁ ∼ M₂
                → nf M₁ ≡ nf M₂
sound p = reify≈ (eval∼ id≈ id𝒰 id𝒰 p)

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


{-#  OPTIONS --type-in-type #-}
module ArgsWrongOrder where

open import AgdaPrelude

myFun : (a : Set) -> a -> Nat -> Nat
myFun _ x y = y

myApp = myFun _ Zero (Nil Nat)


module OldBasicILP.UntypedSyntax.Translation where

open import OldBasicILP.UntypedSyntax.Common public

import OldBasicILP.UntypedSyntax.ClosedHilbertSequential as CHS
import OldBasicILP.UntypedSyntax.ClosedHilbert as CH

-- Translation of types parametrised by a closed, untyped representation of syntax.

_↦ᵀ_ : ∀ {Rep Rep′} → (Rep → Rep′) → ClosedSyntax.Ty Rep → ClosedSyntax.Ty Rep′
f ↦ᵀ (ClosedSyntax.α P)   = ClosedSyntax.α P
f ↦ᵀ (A ClosedSyntax.▻ B) = f ↦ᵀ A ClosedSyntax.▻ f ↦ᵀ B
f ↦ᵀ (p ClosedSyntax.⦂ A) = f p ClosedSyntax.⦂ f ↦ᵀ A
f ↦ᵀ (A ClosedSyntax.∧ B) = f ↦ᵀ A ClosedSyntax.∧ f ↦ᵀ B
f ↦ᵀ ClosedSyntax.⊤      = ClosedSyntax.⊤

-- Translation from closed Hilbert-style sequential to closed Hilbert-style.

chsᴿ→chᴿ : ∀ {n} → CHS.Rep n → Fin n → CH.Rep
chsᴿ→chᴿ (CHS.MP i j r) zero    = CH.APP (chsᴿ→chᴿ r i) (chsᴿ→chᴿ r j)
chsᴿ→chᴿ (CHS.CI r)     zero    = CH.CI
chsᴿ→chᴿ (CHS.CK r)     zero    = CH.CK
chsᴿ→chᴿ (CHS.CS r)     zero    = CH.CS
chsᴿ→chᴿ (CHS.NEC `r r) zero    = CH.BOX (chsᴿ→chᴿ `r zero)
chsᴿ→chᴿ (CHS.CDIST r)  zero    = CH.CDIST
chsᴿ→chᴿ (CHS.CUP r)    zero    = CH.CUP
chsᴿ→chᴿ (CHS.CDOWN r)  zero    = CH.CDOWN
chsᴿ→chᴿ (CHS.CPAIR r)  zero    = CH.CPAIR
chsᴿ→chᴿ (CHS.CFST r)   zero    = CH.CFST
chsᴿ→chᴿ (CHS.CSND r)   zero    = CH.CSND
chsᴿ→chᴿ (CHS.UNIT r)   zero    = CH.UNIT
chsᴿ→chᴿ (CHS.MP i j r) (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CI r)     (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CK r)     (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CS r)     (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.NEC `r r) (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CDIST r)  (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CUP r)    (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CDOWN r)  (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CPAIR r)  (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CFST r)   (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.CSND r)   (suc k) = chsᴿ→chᴿ r k
chsᴿ→chᴿ (CHS.UNIT r)   (suc k) = chsᴿ→chᴿ r k

chsᴾ→chᴾ : CHS.Proof → CH.Proof
chsᴾ→chᴾ CHS.[ r ] = CH.[ chsᴿ→chᴿ r zero ]

chsᵀ→chᵀ : CHS.Ty → CH.Ty
chsᵀ→chᵀ = chsᴾ→chᴾ ↦ᵀ_

-- FIXME: What is going on here?
postulate
  ᴬlem₁ : ∀ {n₁ n₂} → (r₁ : CHS.Rep (suc n₁)) → (r₂ : CHS.Rep (suc n₂))
          → chsᴿ→chᴿ (CHS.APP r₁ r₂) zero ≡ CH.APP (chsᴿ→chᴿ r₁ zero) (chsᴿ→chᴿ r₂ zero)

mutual
  chsᴰ→ch : ∀ {Ξ A} → CHS.⊢ᴰ Ξ → A ∈ Ξ → CH.⊢ chsᵀ→chᵀ A
  chsᴰ→ch (CHS.mp i j d)               top     = CH.app (chsᴰ→ch d i) (chsᴰ→ch d j)
  chsᴰ→ch (CHS.ci d)                   top     = CH.ci
  chsᴰ→ch (CHS.ck d)                   top     = CH.ck
  chsᴰ→ch (CHS.cs d)                   top     = CH.cs
  chsᴰ→ch (CHS.nec `d d)               top     rewrite ᴬlem₂ `d top = CH.box (chsᴰ→ch `d top)
  chsᴰ→ch (CHS.cdist {r₁ = r₁} {r₂} d) top     rewrite ᴬlem₁ r₁ r₂  = CH.cdist
  chsᴰ→ch (CHS.cup d)                  top     = CH.cup
  chsᴰ→ch (CHS.cdown d)                top     = CH.cdown
  chsᴰ→ch (CHS.cpair d)                top     = CH.cpair
  chsᴰ→ch (CHS.cfst d)                 top     = CH.cfst
  chsᴰ→ch (CHS.csnd d)                 top     = CH.csnd
  chsᴰ→ch (CHS.unit d)                 top     = CH.unit
  chsᴰ→ch (CHS.mp i j d)               (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.ci d)                   (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.ck d)                   (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cs d)                   (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.nec `d d)               (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cdist d)                (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cup d)                  (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cdown d)                (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cpair d)                (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cfst d)                 (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.csnd d)                 (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.unit d)                 (pop k) = chsᴰ→ch d k

  ᴬlem₂ : ∀ {Ξ A} → (d : CHS.⊢ᴰ Ξ) → (k : A ∈ Ξ)
         → chsᴿ→chᴿ CHS.ᴿ⌊ d ⌋ ⁱ⌊ k ⌋ ≡ CH.ᴿ⌊ chsᴰ→ch d k ⌋
  ᴬlem₂ CHS.nil                      ()
  ᴬlem₂ (CHS.mp i j d)               top     = cong² CH.APP (ᴬlem₂ d i) (ᴬlem₂ d j)
  ᴬlem₂ (CHS.ci d)                   top     = refl
  ᴬlem₂ (CHS.ck d)                   top     = refl
  ᴬlem₂ (CHS.cs d)                   top     = refl
  ᴬlem₂ (CHS.nec `d d)               top     rewrite ᴬlem₂ `d top = cong CH.BOX refl
  ᴬlem₂ (CHS.cdist {r₁ = r₁} {r₂} d) top     rewrite ᴬlem₁ r₁ r₂ = refl
  ᴬlem₂ (CHS.cup d)                  top     = refl
  ᴬlem₂ (CHS.cdown d)                top     = refl
  ᴬlem₂ (CHS.cpair d)                top     = refl
  ᴬlem₂ (CHS.cfst d)                 top     = refl
  ᴬlem₂ (CHS.csnd d)                 top     = refl
  ᴬlem₂ (CHS.unit d)                 top     = refl
  ᴬlem₂ (CHS.mp i j d)               (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.ci d)                   (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.ck d)                   (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.cs d)                   (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.nec `d d)               (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.cdist d)                (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.cup d)                  (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.cdown d)                (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.cpair d)                (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.cfst d)                 (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.csnd d)                 (pop k) = ᴬlem₂ d k
  ᴬlem₂ (CHS.unit d)                 (pop k) = ᴬlem₂ d k

chs→ch : ∀ {A} → CHS.⊢ A → CH.⊢ chsᵀ→chᵀ A
chs→ch (Ξ , d) = chsᴰ→ch d top

-- Translation from closed Hilbert-style to closed Hilbert-style sequential.

chᴿ→chsᴿ : CH.Rep → ∃ (λ n → CHS.Rep (suc n))
chᴿ→chsᴿ (CH.APP r₁ r₂) with chᴿ→chsᴿ r₁ | chᴿ→chsᴿ r₂
chᴿ→chsᴿ (CH.APP r₁ r₂) | (n₁ , r₁′) | (n₂ , r₂′) = suc n₂ + suc n₁ , CHS.APP r₁′ r₂′
chᴿ→chsᴿ CH.CI          = zero , CHS.CI CHS.NIL
chᴿ→chsᴿ CH.CK          = zero , CHS.CK CHS.NIL
chᴿ→chsᴿ CH.CS          = zero , CHS.CS CHS.NIL
chᴿ→chsᴿ (CH.BOX r)     with chᴿ→chsᴿ r
chᴿ→chsᴿ (CH.BOX r)     | (n , r′) = zero , CHS.BOX r′
chᴿ→chsᴿ CH.CDIST       = zero , CHS.CDIST CHS.NIL
chᴿ→chsᴿ CH.CUP         = zero , CHS.CUP CHS.NIL
chᴿ→chsᴿ CH.CDOWN       = zero , CHS.CDOWN CHS.NIL
chᴿ→chsᴿ CH.CPAIR       = zero , CHS.CPAIR CHS.NIL
chᴿ→chsᴿ CH.CFST        = zero , CHS.CFST CHS.NIL
chᴿ→chsᴿ CH.CSND        = zero , CHS.CSND CHS.NIL
chᴿ→chsᴿ CH.UNIT        = zero , CHS.UNIT CHS.NIL

chᴾ→chsᴾ : CH.Proof → CHS.Proof
chᴾ→chsᴾ CH.[ r ] with chᴿ→chsᴿ r
chᴾ→chsᴾ CH.[ r ] | (n , r′) = CHS.[ r′ ]

chᵀ→chsᵀ : CH.Ty → CHS.Ty
chᵀ→chsᵀ = chᴾ→chsᴾ ↦ᵀ_

distᴺ⌊⌋+ : ∀ {U} → (Γ Γ′ : Cx U) → ᴺ⌊ Γ ⧺ Γ′ ⌋ ≡ ᴺ⌊ Γ ⌋ + ᴺ⌊ Γ′ ⌋
distᴺ⌊⌋+ Γ ∅        = refl
distᴺ⌊⌋+ Γ (Γ′ , A) = cong suc (distᴺ⌊⌋+ Γ Γ′)

mutual
  ch→chs : ∀ {A} → CH.⊢ A → CHS.⊢ chᵀ→chsᵀ A
  ch→chs (CH.app d₁ d₂) = CHS.app (ch→chs d₁) (ch→chs d₂)
  ch→chs CH.ci          = ∅ , CHS.ci CHS.nil
  ch→chs CH.ck          = ∅ , CHS.ck CHS.nil
  ch→chs CH.cs          = ∅ , CHS.cs CHS.nil
  ch→chs (CH.box d)     rewrite ᴮlem₁ d = CHS.box (ch→chs d)
  ch→chs CH.cdist       = ∅ , CHS.cdist CHS.nil
  ch→chs CH.cup         = ∅ , CHS.cup CHS.nil
  ch→chs CH.cdown       = ∅ , CHS.cdown CHS.nil
  ch→chs CH.cpair       = ∅ , CHS.cpair CHS.nil
  ch→chs CH.cfst        = ∅ , CHS.cfst CHS.nil
  ch→chs CH.csnd        = ∅ , CHS.csnd CHS.nil
  ch→chs CH.unit        = ∅ , CHS.unit CHS.nil

  -- FIXME: This should hold by ᴮlem₂.
  postulate
    ᴮlem₁ : ∀ {A} → (d : CH.⊢ A)
           → chᴿ→chsᴿ CH.ᴿ⌊ d ⌋ ≡ ᴺ⌊ π₁ (ch→chs d) ⌋ , CHS.ᴿ⌊ π₂ (ch→chs d) ⌋

  ᴮlem₂ : ∀ {A} → (d : CH.⊢ A)
         → ᴺ⌊ π₁ (ch→chs d) ⌋ ≡ π₁ (chᴿ→chsᴿ CH.ᴿ⌊ d ⌋)
  ᴮlem₂ (CH.app d₁ d₂) rewrite ᴮlem₂ d₂ | ᴮlem₃ d₁ d₂ = cong suc refl
  ᴮlem₂ CH.ci          = refl
  ᴮlem₂ CH.ck          = refl
  ᴮlem₂ CH.cs          = refl
  ᴮlem₂ (CH.box d)     rewrite ᴮlem₂ d | ᴮlem₁ d = refl
  ᴮlem₂ CH.cdist       = refl
  ᴮlem₂ CH.cup         = refl
  ᴮlem₂ CH.cdown       = refl
  ᴮlem₂ CH.cpair       = refl
  ᴮlem₂ CH.cfst        = refl
  ᴮlem₂ CH.csnd        = refl
  ᴮlem₂ CH.unit        = refl

  ᴮlem₃ : ∀ {A B} → (d₁ : CH.⊢ A CH.▻ B) → (d₂ : CH.⊢ A)
         → ᴺ⌊ (π₁ (ch→chs d₂) , chᵀ→chsᵀ A) ⧺ π₁ (ch→chs d₁) ⌋ ≡
            suc (π₁ (chᴿ→chsᴿ CH.ᴿ⌊ d₂ ⌋)) + π₁ (chᴿ→chsᴿ CH.ᴿ⌊ d₁ ⌋)
  ᴮlem₃ {A} d₁ d₂ rewrite distᴺ⌊⌋+ (π₁ (ch→chs d₂) , chᵀ→chsᵀ A) (π₁ (ch→chs d₁)) =
                  cong² _+_ (cong suc (ᴮlem₂ d₂)) (ᴮlem₂ d₁)


module TooManyArgumentsInLHS where

F : Set -> Set
F X Y = Y


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

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

open import LibraBFT.Base.Types
open import LibraBFT.Impl.OBM.Logging.Logging
import      LibraBFT.Impl.Types.LedgerInfoWithSignatures as LIWS
open import LibraBFT.ImplShared.Consensus.Types
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Types.EpochState where

verify : EpochState → LedgerInfoWithSignatures → Either ErrLog Unit
verify self ledgerInfo = do
  lcheck (self ^∙ esEpoch == ledgerInfo ^∙ liwsLedgerInfo ∙ liEpoch)
         ( "EpochState" ∷ "LedgerInfo has unexpected epoch" ∷ [])
         --, show (self^.esEpoch), show (ledgerInfo^.liwsLedgerInfo.liEpoch) ]
  LIWS.verifySignatures ledgerInfo (self ^∙ esVerifier)

epochChangeVerificationRequired : EpochState → Epoch → Bool
epochChangeVerificationRequired self epoch = ⌊ self ^∙ esEpoch <? epoch ⌋

isLedgerInfoStale : EpochState → LedgerInfo → Bool
isLedgerInfoStale self ledgerInfo = ⌊ ledgerInfo ^∙ liEpoch <? self ^∙ esEpoch ⌋


module par-swap.properties where

open import par-swap
open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Context
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Data.Product

Context1-∥R : ∀{p p'} → (C1 : Context1) → p ∥R p' → ((C1 ∷ []) ⟦ p ⟧c) ∥R ((C1 ∷ []) ⟦ p' ⟧c)
Context1-∥R (ceval (epar₁ q₁)) (∥Rstep dc) = ∥Rstep (dcpar₁ dc)
Context1-∥R (ceval (epar₂ p₂)) (∥Rstep dc) = ∥Rstep (dcpar₂ dc)
Context1-∥R (ceval (eseq q₁)) (∥Rstep dc) = ∥Rstep (dcseq₁ dc)
Context1-∥R (ceval (eloopˢ q₁)) (∥Rstep dc) = ∥Rstep (dcloopˢ₁ dc)
Context1-∥R (ceval (esuspend S)) (∥Rstep dc) = ∥Rstep (dcsuspend dc)
Context1-∥R (ceval etrap) (∥Rstep dc) = ∥Rstep (dctrap dc)
Context1-∥R (csignl S) (∥Rstep dc) = ∥Rstep (dcsignl dc)
Context1-∥R (cpresent₁ S q₁) (∥Rstep dc) = ∥Rstep (dcpresent₁ dc)
Context1-∥R (cpresent₂ S p₂) (∥Rstep dc) = ∥Rstep (dcpresent₂ dc)
Context1-∥R cloop (∥Rstep dc) = ∥Rstep (dcloop dc)
Context1-∥R (cloopˢ₂ p₂) (∥Rstep dc) = ∥Rstep (dcloopˢ₂ dc)
Context1-∥R (cseq₂ p₂) (∥Rstep dc) = ∥Rstep (dcseq₂ dc)
Context1-∥R (cshared s e) (∥Rstep dc) = ∥Rstep (dcshared dc)
Context1-∥R (cvar x e) (∥Rstep dc) = ∥Rstep (dcvar dc)
Context1-∥R (cif₁ x q₁) (∥Rstep dc) = ∥Rstep (dcif₁ dc)
Context1-∥R (cif₂ x p₂) (∥Rstep dc) = ∥Rstep (dcif₂ dc)
Context1-∥R (cenv θ A) (∥Rstep dc) = ∥Rstep (dcenv dc)

Context1-∥R* : ∀ {p q} -> (C1 : Context1) -> p ∥R* q -> ((C1 ∷ []) ⟦ p ⟧c) ∥R* ((C1 ∷ []) ⟦ q ⟧c)
Context1-∥R* C1 ∥R0 = ∥R0
Context1-∥R* C1 (∥Rn p∥Rq q∥R*r) = ∥Rn (Context1-∥R C1 p∥Rq) (Context1-∥R* C1 q∥R*r)