module OlderBasicILP.Indirect.Translation where

open import OlderBasicILP.Indirect public

import OlderBasicILP.Indirect.Hilbert.Sequential as HS
import OlderBasicILP.Indirect.Hilbert.Nested as HN
import OlderBasicILP.Indirect.Gentzen as G

open HS using () renaming (_⊢×_ to HS⟨_⊢×_⟩ ; _⊢_ to HS⟨_⊢_⟩) public
open HN using () renaming (_⊢_ to HN⟨_⊢_⟩ ; _⊢⋆_ to HN⟨_⊢⋆_⟩) public
open G using  () renaming (_⊢_ to G⟨_⊢_⟩ ; _⊢⋆_ to G⟨_⊢⋆_⟩) public

-- Translation from sequential Hilbert-style to nested.

hs→hnᵀᵐ : HS.Tm → HN.Tm
hs→hnᵀᵐ TS = aux TS 0
  where
    aux : HS.Tm → ℕ → HN.Tm
    aux HS.NIL         zero    = {!!}
    aux (HS.VAR I TS)  zero    = HN.VAR I
    aux (HS.MP I J TS) zero    = HN.APP (aux TS I) (aux TS J)
    aux (HS.CI TS)     zero    = HN.CI
    aux (HS.CK TS)     zero    = HN.CK
    aux (HS.CS TS)     zero    = HN.CS
    aux (HS.NEC SS TS) zero    = HN.BOX (aux SS 0)
    aux (HS.CDIST TS)  zero    = HN.CDIST
    aux (HS.CUP TS)    zero    = HN.CUP
    aux (HS.CDOWN TS)  zero    = HN.CDOWN
    aux (HS.CPAIR TS)  zero    = HN.CPAIR
    aux (HS.CFST TS)   zero    = HN.CFST
    aux (HS.CSND TS)   zero    = HN.CSND
    aux (HS.UNIT TS)   zero    = HN.UNIT
    aux HS.NIL         (suc K) = {!!}
    aux (HS.VAR I TS)  (suc K) = aux TS K
    aux (HS.MP I J TS) (suc K) = aux TS K
    aux (HS.CI TS)     (suc K) = aux TS K
    aux (HS.CK TS)     (suc K) = aux TS K
    aux (HS.CS TS)     (suc K) = aux TS K
    aux (HS.NEC SS TS) (suc K) = aux TS K
    aux (HS.CDIST TS)  (suc K) = aux TS K
    aux (HS.CUP TS)    (suc K) = aux TS K
    aux (HS.CDOWN TS)  (suc K) = aux TS K
    aux (HS.CPAIR TS)  (suc K) = aux TS K
    aux (HS.CFST TS)   (suc K) = aux TS K
    aux (HS.CSND TS)   (suc K) = aux TS K
    aux (HS.UNIT TS)   (suc K) = aux TS K

hs→hnᵀʸ : Ty HS.Tm → Ty HN.Tm
hs→hnᵀʸ (α P)   = α P
hs→hnᵀʸ (A ▻ B) = hs→hnᵀʸ A ▻ hs→hnᵀʸ B
hs→hnᵀʸ (T ⦂ A) = hs→hnᵀᵐ T ⦂ hs→hnᵀʸ A
hs→hnᵀʸ (A ∧ B) = hs→hnᵀʸ A ∧ hs→hnᵀʸ B
hs→hnᵀʸ ⊤      = ⊤

hs→hnᵀʸ⋆ : Cx (Ty HS.Tm) → Cx (Ty HN.Tm)
hs→hnᵀʸ⋆ ∅       = ∅
hs→hnᵀʸ⋆ (Γ , A) = hs→hnᵀʸ⋆ Γ , hs→hnᵀʸ A

hs→hnᴵˣ : ∀ {A Γ} → A ∈ Γ → hs→hnᵀʸ A ∈ hs→hnᵀʸ⋆ Γ
hs→hnᴵˣ top     = top
hs→hnᴵˣ (pop i) = pop (hs→hnᴵˣ i)

hs→hn : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → HN⟨ hs→hnᵀʸ⋆ Γ ⊢ hs→hnᵀʸ A ⟩
hs→hn (Ξ , ts) = aux ts top
  where
    aux : ∀ {A Γ Ξ} → HS⟨ Γ ⊢× Ξ ⟩ → A ∈ Ξ → HN⟨ hs→hnᵀʸ⋆ Γ ⊢ hs→hnᵀʸ A ⟩
    aux (HS.var i ts)  top     = HN.var (hs→hnᴵˣ i)
    aux (HS.mp i j ts) top     = HN.app (aux ts i) (aux ts j)
    aux (HS.ci ts)     top     = HN.ci
    aux (HS.ck ts)     top     = HN.ck
    aux (HS.cs ts)     top     = HN.cs
    aux (HS.nec ss ts) top     = {!HN.box (aux ss top)!}
    aux (HS.cdist ts)  top     = {!HN.cdist!}
    aux (HS.cup ts)    top     = {!HN.cup!}
    aux (HS.cdown ts)  top     = HN.cdown
    aux (HS.cpair ts)  top     = HN.cpair
    aux (HS.cfst ts)   top     = HN.cfst
    aux (HS.csnd ts)   top     = HN.csnd
    aux (HS.unit ts)   top     = HN.unit
    aux (HS.var i ts)  (pop k) = aux ts k
    aux (HS.mp i j ts) (pop k) = aux ts k
    aux (HS.ci ts)     (pop k) = aux ts k
    aux (HS.ck ts)     (pop k) = aux ts k
    aux (HS.cs ts)     (pop k) = aux ts k
    aux (HS.nec ss ts) (pop k) = aux ts k
    aux (HS.cdist ts)  (pop k) = aux ts k
    aux (HS.cup ts)    (pop k) = aux ts k
    aux (HS.cdown ts)  (pop k) = aux ts k
    aux (HS.cpair ts)  (pop k) = aux ts k
    aux (HS.cfst ts)   (pop k) = aux ts k
    aux (HS.csnd ts)   (pop k) = aux ts k
    aux (HS.unit ts)   (pop k) = aux ts k

-- Translation from nested Hilbert-style to sequential.

hn→hsᵀᵐ : HN.Tm → HS.Tm
hn→hsᵀᵐ (HN.VAR I)   = HS.VAR I HS.NIL
hn→hsᵀᵐ (HN.APP T U) = HS.APP (hn→hsᵀᵐ T) (hn→hsᵀᵐ U)
hn→hsᵀᵐ HN.CI        = HS.CI HS.NIL
hn→hsᵀᵐ HN.CK        = HS.CK HS.NIL
hn→hsᵀᵐ HN.CS        = HS.CS HS.NIL
hn→hsᵀᵐ (HN.BOX T)   = HS.BOX (hn→hsᵀᵐ T)
hn→hsᵀᵐ HN.CDIST     = HS.CDIST HS.NIL
hn→hsᵀᵐ HN.CUP       = HS.CUP HS.NIL
hn→hsᵀᵐ HN.CDOWN     = HS.CDOWN HS.NIL
hn→hsᵀᵐ HN.CPAIR     = HS.CPAIR HS.NIL
hn→hsᵀᵐ HN.CFST      = HS.CFST HS.NIL
hn→hsᵀᵐ HN.CSND      = HS.CSND HS.NIL
hn→hsᵀᵐ HN.UNIT      = HS.UNIT HS.NIL

hn→hsᵀʸ : Ty HN.Tm → Ty HS.Tm
hn→hsᵀʸ (α P)   = α P
hn→hsᵀʸ (A ▻ B) = hn→hsᵀʸ A ▻ hn→hsᵀʸ B
hn→hsᵀʸ (T ⦂ A) = hn→hsᵀᵐ T ⦂ hn→hsᵀʸ A
hn→hsᵀʸ (A ∧ B) = hn→hsᵀʸ A ∧ hn→hsᵀʸ B
hn→hsᵀʸ ⊤      = ⊤

hn→hsᵀʸ⋆ : Cx (Ty HN.Tm) → Cx (Ty HS.Tm)
hn→hsᵀʸ⋆ ∅       = ∅
hn→hsᵀʸ⋆ (Γ , A) = hn→hsᵀʸ⋆ Γ , hn→hsᵀʸ A

hn→hsᴵˣ : ∀ {A Γ} → A ∈ Γ → hn→hsᵀʸ A ∈ hn→hsᵀʸ⋆ Γ
hn→hsᴵˣ top     = top
hn→hsᴵˣ (pop i) = pop (hn→hsᴵˣ i)

hn→hs : ∀ {A Γ} → HN⟨ Γ ⊢ A ⟩ → HS⟨ hn→hsᵀʸ⋆ Γ ⊢ hn→hsᵀʸ A ⟩
hn→hs (HN.var i)   = ∅ , HS.var (hn→hsᴵˣ i) HS.nil
hn→hs (HN.app t u) = HS.app (hn→hs t) (hn→hs u)
hn→hs HN.ci        = ∅ , HS.ci HS.nil
hn→hs HN.ck        = ∅ , HS.ck HS.nil
hn→hs HN.cs        = ∅ , HS.cs HS.nil
hn→hs (HN.box t)   = {!HS.box (hn→hs t)!}
hn→hs HN.cdist     = ∅ , HS.cdist HS.nil
hn→hs HN.cup       = ∅ , HS.cup HS.nil
hn→hs HN.cdown     = ∅ , HS.cdown HS.nil
hn→hs HN.cpair     = ∅ , HS.cpair HS.nil
hn→hs HN.cfst      = ∅ , HS.cfst HS.nil
hn→hs HN.csnd      = ∅ , HS.csnd HS.nil
hn→hs HN.unit      = ∅ , HS.unit HS.nil

-- Deduction theorem for sequential Hilbert-style.

hs→hn→hsᵀᵐ : ∀ {TS} → hn→hsᵀᵐ (hs→hnᵀᵐ TS) ≡ TS
hs→hn→hsᵀᵐ {HS.NIL}       = {!refl!}
hs→hn→hsᵀᵐ {HS.VAR I TS}  = cong² HS.VAR refl {!!}
hs→hn→hsᵀᵐ {HS.MP I J TS} = {!!}
hs→hn→hsᵀᵐ {HS.CI TS}     = {!!}
hs→hn→hsᵀᵐ {HS.CK TS}     = {!!}
hs→hn→hsᵀᵐ {HS.CS TS}     = {!!}
hs→hn→hsᵀᵐ {HS.NEC SS TS} = {!!}
hs→hn→hsᵀᵐ {HS.CDIST TS}  = {!!}
hs→hn→hsᵀᵐ {HS.CUP TS}    = {!!}
hs→hn→hsᵀᵐ {HS.CDOWN TS}  = {!!}
hs→hn→hsᵀᵐ {HS.CPAIR TS}  = {!!}
hs→hn→hsᵀᵐ {HS.CFST TS}   = {!!}
hs→hn→hsᵀᵐ {HS.CSND TS}   = {!!}
hs→hn→hsᵀᵐ {HS.UNIT TS}   = {!!}

hs→hn→hsᵀʸ : ∀ {A} → hn→hsᵀʸ (hs→hnᵀʸ A) ≡ A
hs→hn→hsᵀʸ {α P}   = refl
hs→hn→hsᵀʸ {A ▻ B} = cong² _▻_ hs→hn→hsᵀʸ hs→hn→hsᵀʸ
hs→hn→hsᵀʸ {T ⦂ A} = cong² _⦂_ hs→hn→hsᵀᵐ hs→hn→hsᵀʸ
hs→hn→hsᵀʸ {A ∧ B} = cong² _∧_ hs→hn→hsᵀʸ hs→hn→hsᵀʸ
hs→hn→hsᵀʸ {⊤}    = refl

-- hs-lam : ∀ {A B Γ} → HS⟨ Γ , A ⊢ B ⟩ → HS⟨ Γ ⊢ A ▻ B ⟩
-- hs-lam t = {!hn→hs (HN.lam (hs→hn t))!}
-- hn→hs ∘ HN.lam ∘ hs→hn

-- Translation from nested Hilbert-style to Gentzen-style.

hn→gᵀᵐ : HN.Tm → G.Tm
hn→gᵀᵐ (HN.VAR I)   = G.VAR I
hn→gᵀᵐ (HN.APP T U) = G.APP (hn→gᵀᵐ T) (hn→gᵀᵐ U)
hn→gᵀᵐ HN.CI        = G.CI
hn→gᵀᵐ HN.CK        = G.CK
hn→gᵀᵐ HN.CS        = G.CS
hn→gᵀᵐ (HN.BOX T)   = G.BOX (hn→gᵀᵐ T)
hn→gᵀᵐ HN.CDIST     = G.CDIST
hn→gᵀᵐ HN.CUP       = G.CUP
hn→gᵀᵐ HN.CDOWN     = G.CDOWN
hn→gᵀᵐ HN.CPAIR     = G.CPAIR
hn→gᵀᵐ HN.CFST      = G.CFST
hn→gᵀᵐ HN.CSND      = G.CSND
hn→gᵀᵐ HN.UNIT      = G.UNIT

hn→gᵀʸ : Ty HN.Tm → Ty G.Tm
hn→gᵀʸ (α P)   = α P
hn→gᵀʸ (A ▻ B) = hn→gᵀʸ A ▻ hn→gᵀʸ B
hn→gᵀʸ (T ⦂ A) = hn→gᵀᵐ T ⦂ hn→gᵀʸ A
hn→gᵀʸ (A ∧ B) = hn→gᵀʸ A ∧ hn→gᵀʸ B
hn→gᵀʸ ⊤      = ⊤

hn→gᵀʸ⋆ : Cx (Ty HN.Tm) → Cx (Ty G.Tm)
hn→gᵀʸ⋆ ∅       = ∅
hn→gᵀʸ⋆ (Γ , A) = hn→gᵀʸ⋆ Γ , hn→gᵀʸ A

hn→gᴵˣ : ∀ {A Γ} → A ∈ Γ → hn→gᵀʸ A ∈ hn→gᵀʸ⋆ Γ
hn→gᴵˣ top     = top
hn→gᴵˣ (pop i) = pop (hn→gᴵˣ i)

hn→g : ∀ {A Γ} → HN⟨ Γ ⊢ A ⟩ → G⟨ hn→gᵀʸ⋆ Γ ⊢ hn→gᵀʸ A ⟩
hn→g (HN.var i)   = G.var (hn→gᴵˣ i)
hn→g (HN.app t u) = G.app (hn→g t) (hn→g u)
hn→g HN.ci        = G.ci
hn→g HN.ck        = G.ck
hn→g HN.cs        = G.cs
hn→g (HN.box t)   = {!G.box (hn→g t)!}
hn→g HN.cdist     = {!G.cdist!}
hn→g HN.cup       = {!G.cup!}
hn→g HN.cdown     = G.cdown
hn→g HN.cpair     = G.cpair
hn→g HN.cfst      = G.cfst
hn→g HN.csnd      = G.csnd
hn→g HN.unit      = G.unit

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

hs→gᵀʸ : Ty HS.Tm → Ty G.Tm
hs→gᵀʸ = hn→gᵀʸ ∘ hs→hnᵀʸ

hs→gᵀʸ⋆ : Cx (Ty HS.Tm) → Cx (Ty G.Tm)
hs→gᵀʸ⋆ = hn→gᵀʸ⋆ ∘ hs→hnᵀʸ⋆

hs→g : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → G⟨ hs→gᵀʸ⋆ Γ ⊢ hs→gᵀʸ A ⟩
hs→g = hn→g ∘ hs→hn

-- Translation from Gentzen-style to Hilbert-style.

mutual
  g→hnᵀᵐ : G.Tm → HN.Tm
  g→hnᵀᵐ (G.VAR I)         = HN.VAR I
  g→hnᵀᵐ (G.LAM T)         = HN.LAM (g→hnᵀᵐ T)
  g→hnᵀᵐ (G.APP T U)       = HN.APP (g→hnᵀᵐ T) (g→hnᵀᵐ U)
  g→hnᵀᵐ (G.MULTIBOX TS U) = HN.MULTIBOX (g→hnᵀᵐ⋆ TS) (g→hnᵀᵐ U)
  g→hnᵀᵐ (G.DOWN T)        = HN.DOWN (g→hnᵀᵐ T)
  g→hnᵀᵐ (G.PAIR T U)      = HN.PAIR (g→hnᵀᵐ T) (g→hnᵀᵐ U)
  g→hnᵀᵐ (G.FST T)         = HN.FST (g→hnᵀᵐ T)
  g→hnᵀᵐ (G.SND T)         = HN.SND (g→hnᵀᵐ T)
  g→hnᵀᵐ G.UNIT            = HN.UNIT

  g→hnᵀᵐ⋆ : Cx G.Tm → Cx HN.Tm
  g→hnᵀᵐ⋆ ∅        = ∅
  g→hnᵀᵐ⋆ (TS , T) = g→hnᵀᵐ⋆ TS , g→hnᵀᵐ T

g→hnᵀʸ : Ty G.Tm → Ty HN.Tm
g→hnᵀʸ (α P)   = α P
g→hnᵀʸ (A ▻ B) = g→hnᵀʸ A ▻ g→hnᵀʸ B
g→hnᵀʸ (T ⦂ A) = g→hnᵀᵐ T ⦂ g→hnᵀʸ A
g→hnᵀʸ (A ∧ B) = g→hnᵀʸ A ∧ g→hnᵀʸ B
g→hnᵀʸ ⊤      = ⊤

g→hnᵀʸ⋆ : Cx (Ty G.Tm) → Cx (Ty HN.Tm)
g→hnᵀʸ⋆ ∅       = ∅
g→hnᵀʸ⋆ (Γ , A) = g→hnᵀʸ⋆ Γ , g→hnᵀʸ A

g→hnᴵˣ : ∀ {A Γ} → A ∈ Γ → g→hnᵀʸ A ∈ g→hnᵀʸ⋆ Γ
g→hnᴵˣ top     = top
g→hnᴵˣ (pop i) = pop (g→hnᴵˣ i)

mutual
  g→hn : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → HN⟨ g→hnᵀʸ⋆ Γ ⊢ g→hnᵀʸ A ⟩
  g→hn (G.var i)         = HN.var (g→hnᴵˣ i)
  g→hn (G.lam t)         = HN.lam (g→hn t)
  g→hn (G.app t u)       = HN.app (g→hn t) (g→hn u)
  g→hn (G.multibox ts u) = {!HN.multibox (g→hn⋆ ts) (g→hn u)!}
  g→hn (G.down t)        = HN.down (g→hn t)
  g→hn (G.pair t u)      = HN.pair (g→hn t) (g→hn u)
  g→hn (G.fst t)         = HN.fst (g→hn t)
  g→hn (G.snd t)         = HN.snd (g→hn t)
  g→hn G.unit            = HN.unit

  g→hn⋆ : ∀ {Ξ Γ} → G⟨ Γ ⊢⋆ Ξ ⟩ → HN⟨ g→hnᵀʸ⋆ Γ ⊢⋆ g→hnᵀʸ⋆ Ξ ⟩
  g→hn⋆ {∅}     ∙        = ∙
  g→hn⋆ {Ξ , A} (ts , t) = g→hn⋆ ts , g→hn t

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

g→hsᵀʸ : Ty G.Tm → Ty HS.Tm
g→hsᵀʸ = hn→hsᵀʸ ∘ g→hnᵀʸ

g→hsᵀʸ⋆ : Cx (Ty G.Tm) → Cx (Ty HS.Tm)
g→hsᵀʸ⋆ = hn→hsᵀʸ⋆ ∘ g→hnᵀʸ⋆

g→hs : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → HS⟨ g→hsᵀʸ⋆ Γ ⊢ g→hsᵀʸ A ⟩
g→hs = hn→hs ∘ g→hn


-- Andreas, 2017-09-09
-- Don't allow pattern synonyms where builtin constructor is expected

data Bool : Set where
  true  : Bool
  false : Bool

pattern You = false

{-# BUILTIN BOOL  Bool #-}
{-# BUILTIN TRUE  true #-}
{-# BUILTIN FALSE You  #-}  -- This should be rejected.

-- Expected error: ;-)
-- You must be a constructor in the binding to builtin FALSE
-- when checking the pragma BUILTIN FALSE You


------------------------------------------------------------------------
-- A self-interpreter (without correctness proof)
------------------------------------------------------------------------

module Self-interpreter where

open import Prelude hiding (const)

-- To simplify the development, let's work with actual natural numbers
-- as variables and constants (see
-- Atom.one-can-restrict-attention-to-χ-ℕ-atoms).

open import Atom

open import Chi            χ-ℕ-atoms
open import Constants      χ-ℕ-atoms
open import Free-variables χ-ℕ-atoms

open χ-atoms χ-ℕ-atoms

open import Combinators

-- Substitution.

internal-subst : Exp
internal-subst = lambda v-x (lambda v-new body)
  module Internal-subst where
  private
    rec-or-lambda : _ → _
    rec-or-lambda = λ c →
      branch c (v-y ∷ v-e ∷ []) (
        case (equal-ℕ (var v-x) (var v-y)) (
          branch c-true [] (const c (var v-y ∷ var v-e ∷ [])) ∷
          branch c-false [] (
            const c (var v-y ∷ apply (var v-subst) (var v-e) ∷ [])) ∷
          []))

  branches =
    branch c-apply (v-e₁ ∷ v-e₂ ∷ []) (
      const c-apply (apply (var v-subst) (var v-e₁) ∷
                     apply (var v-subst) (var v-e₂) ∷ [])) ∷
    branch c-case (v-e ∷ v-bs ∷ []) (
      const c-case (
        apply (var v-subst) (var v-e) ∷
        apply (var v-subst) (var v-bs) ∷ [])) ∷
    rec-or-lambda c-rec ∷
    rec-or-lambda c-lambda ∷
    branch c-const (v-c ∷ v-es ∷ []) (
      const c-const (var v-c ∷ apply (var v-subst) (var v-es) ∷ [])) ∷
    branch c-var (v-y ∷ []) (
      case (equal-ℕ (var v-x) (var v-y)) (
        branch c-true [] (var v-new) ∷
        branch c-false [] (const c-var (var v-y ∷ [])) ∷ [])) ∷
    branch c-branch (v-c ∷ v-ys ∷ v-e ∷ []) (
      const c-branch (
        var v-c ∷
        var v-ys ∷
        case (member (var v-x) (var v-ys)) (
          branch c-true [] (var v-e) ∷
          branch c-false [] (apply (var v-subst) (var v-e)) ∷
          []) ∷ [])) ∷
    branch c-nil [] (const c-nil []) ∷
    branch c-cons (v-e ∷ v-es ∷ []) (
      const c-cons (apply (var v-subst) (var v-e) ∷
                    apply (var v-subst) (var v-es) ∷ [])) ∷
    []

  body = rec v-subst (lambda v-e (case (var v-e) branches))

-- Searches for a branch matching a given natural number.

internal-lookup : Exp
internal-lookup =
  lambda v-c (rec v-lookup (lambda v-bs (case (var v-bs) (
    branch c-cons (v-b ∷ v-bs ∷ []) (case (var v-b) (
      branch c-branch (v-c′ ∷ v-underscore ∷ v-underscore ∷ []) (
        case (equal-ℕ (var v-c) (var v-c′)) (
          branch c-false [] (apply (var v-lookup) (var v-bs)) ∷
          branch c-true [] (var v-b) ∷ [])) ∷ [])) ∷ []))))

-- Tries to apply multiple substitutions.

internal-substs : Exp
internal-substs =
  rec v-substs (lambda v-xs (lambda v-es (lambda v-e′ (
    case (var v-xs) (
      branch c-nil [] (case (var v-es) (
        branch c-nil [] (var v-e′) ∷ [])) ∷
      branch c-cons (v-x ∷ v-xs ∷ []) (case (var v-es) (
        branch c-cons (v-e ∷ v-es ∷ []) (
          apply (apply (apply internal-subst (var v-x)) (var v-e))
            (apply (apply (apply (var v-substs) (var v-xs))
               (var v-es)) (var v-e′))) ∷ [])) ∷ [])))))

-- A map function. The application of map to the function is done at
-- the meta-level in order to simplify proofs.

map : Exp → Exp
map f = rec v-map (lambda v-xs (case (var v-xs) branches))
  module Map where
  branches =
    branch c-nil [] (const c-nil []) ∷
    branch c-cons (v-x ∷ v-xs ∷ []) (
      const c-cons (apply f (var v-x) ∷
                    apply (var v-map) (var v-xs) ∷
                    [])) ∷
    []

-- The self-interpreter.

eval : Exp
eval =
  rec v-eval (lambda v-p (case (var v-p) branches))
  module Eval where
  apply-branch =
    branch c-lambda (v-x ∷ v-e ∷ []) (
      apply (var v-eval) (
        apply (apply (apply internal-subst (var v-x))
                 (apply (var v-eval) (var v-e₂)))
          (var v-e))) ∷
    []

  case-body₂ =
    case (apply (apply internal-lookup (var v-c)) (var v-bs)) (
      branch c-branch (v-underscore ∷ v-xs ∷ v-e ∷ []) (
        apply (var v-eval) (
          apply (apply (apply internal-substs (var v-xs))
            (var v-es)) (var v-e))) ∷
      [])

  case-body₁ =
    case (apply (var v-eval) (var v-e)) (
      branch c-const (v-c ∷ v-es ∷ []) case-body₂ ∷
      [])

  branches =
    branch c-apply (v-e₁ ∷ v-e₂ ∷ []) (
      case (apply (var v-eval) (var v-e₁)) apply-branch) ∷
    branch c-case (v-e ∷ v-bs ∷ []) case-body₁ ∷
    branch c-rec (v-x ∷ v-e ∷ []) (
      apply (var v-eval) (
        apply (apply (apply internal-subst (var v-x))
                 (const c-rec (var v-x ∷ var v-e ∷ [])))
          (var v-e))) ∷
    branch c-lambda (v-x ∷ v-e ∷ []) (
      const c-lambda (var v-x ∷ var v-e ∷ [])) ∷
    branch c-const (v-c ∷ v-es ∷ []) (
      const c-const (var v-c ∷
                     apply (map (var v-eval)) (var v-es) ∷
                     [])) ∷
    []

eval-closed : Closed eval
eval-closed = from-⊎ (closed? eval)


-- Andreas, 2017-08-24, issue #2253
--
-- Better error message for matching on abstract constructor.

-- {-# OPTIONS -v tc.lhs.split:30 #-}
-- {-# OPTIONS -v tc.lhs:30 #-}
-- {-# OPTIONS -v tc.lhs.flex:60 #-}

abstract
  data B : Set where
    x : B

data C : Set where
  c : B → C

f : C → C
f (c x) = c x

-- WAS:
--
-- Not in scope:
--   AbstractPatternShadowsConstructor.B.x
--     (did you mean 'x'?)
-- when checking that the pattern c x has type C

-- Expected:
--
-- Cannot split on abstract data type B
-- when checking that the pattern x has type B


open import Agda.Primitive
open import Agda.Builtin.List
open import Agda.Builtin.Maybe

data Coercible (A : Set) (B : Set) : Set where
  TrustMe : Coercible A B

postulate coerce : {A B : Set} {{_ : Coercible A B}} → A → B

instance
  coerce-fun : {A B : Set} {{_ : Coercible A B}}
             → {C D : Set} {{_ : Coercible C D}}
             → Coercible (B → C) (A → D)
  coerce-fun = TrustMe

  coerce-refl : {A : Set} → Coercible A A
  coerce-refl = TrustMe

postulate
  primCatMaybes : {A : Set} → List (Maybe A) → List A

catMaybes : {A : Set} → List (Maybe A) → List A
catMaybes = coerce (primCatMaybes {_})


module Hide where

record 𝔹ottom : Set₁ where
  field
    ⊥ : Set

open 𝔹ottom ⦃ … ⦄ public

𝔹ottomPrelude : 𝔹ottom
𝔹ottomPrelude = record { ⊥ = P.⊥ } where
  open import Prelude.Empty as P

instance instance𝔹ottom : 𝔹ottom
instance𝔹ottom = 𝔹ottomPrelude


open import Agda.Builtin.String
open import Agda.Builtin.Equality

_ : primShowChar 'c' ≡ "'c'"
_ = refl

_ : primShowString "ccc" ≡ "\"ccc\""
_ = refl


open import Prelude

module Implicits.Semantics.Term where

open import Implicits.Syntax
open import Implicits.WellTyped
open import Implicits.Semantics.Type
open import Implicits.Semantics.Context
open import Implicits.Semantics.Lemmas
open import Implicits.Semantics.RewriteContext
open import SystemF.Everything as F using ()

module TermSemantics
  (_⊢ᵣ_ : ∀ {ν} → ICtx ν → Type ν → Set)
  (⟦_,_⟧r : ∀ {ν n} {K : Ktx ν n} {a} → (proj₂ K) ⊢ᵣ a → K# K →
            ∃ λ t → ⟦ proj₁ K ⟧ctx→ F.⊢ t ∈ ⟦ a ⟧tp→) where

  open TypingRules _⊢ᵣ_

  -- denotational semantics of well-typed terms
  ⟦_,_⟧ : ∀ {ν n} {K : Ktx ν n} {t} {a : Type ν} → K ⊢ t ∈ a → K# K → F.Term ν n
  ⟦_,_⟧ (var x) m = F.var x
  ⟦_,_⟧ (Λ t) m = F.Λ ⟦ t , #tvar m ⟧
  ⟦_,_⟧ (λ' a x) m = F.λ' ⟦ a ⟧tp→ ⟦ x , #var a m ⟧
  ⟦_,_⟧ (f [ b ]) m = F._[_] ⟦ f , m ⟧ ⟦ b ⟧tp→
  ⟦_,_⟧ (f · e) m = ⟦ f , m ⟧ F.· ⟦ e , m ⟧
  ⟦_,_⟧ (ρ {a = a} _ x) m = F.λ' ⟦ a ⟧tp→ ⟦ x , #ivar a m ⟧
  ⟦_,_⟧ (f ⟨ e∈Δ ⟩) m = ⟦ f , m ⟧ F.· (proj₁ ⟦ e∈Δ , m ⟧r)
  ⟦_,_⟧ (_with'_ r e) m = ⟦ r , m ⟧ F.· ⟦ e , m ⟧


{-# OPTIONS --cubical #-}

module Demos.Live where


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.Prod {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening as T hiding (wk; wkTerm; wkEqTerm)
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Weakening
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Reflexivity
open import Definition.LogicalRelation.Substitution.Introductions.Pi
open import Definition.LogicalRelation.Substitution.Introductions.SingleSubst

open import Tools.Product
import Tools.PropositionalEquality as PE

prod′ : ∀ {F G t u Γ l l′ l″}
       ([F] : Γ ⊩⟨ l ⟩ F)
       ([t] : Γ ⊩⟨ l ⟩ t ∷ F / [F])
       ([Gt] : Γ ⊩⟨ l″ ⟩ G [ t ])
       ([u] : Γ ⊩⟨ l″ ⟩ u ∷ G [ t ] / [Gt])
       ([ΣFG] : Γ ⊩⟨ l′ ⟩B⟨ BΣ ⟩ Σ F ▹ G)
     → Γ ⊩⟨ l′ ⟩ prod t u ∷ Σ F ▹ G / B-intr BΣ [ΣFG]
prod′ {F} {G} {t} {u} {Γ} {l} {l′} {l″} [F] [t] [Gt] [u]
      [ΣFG]@(noemb (Bᵣ F₁ G₁ D ⊢F ⊢G A≡A [F]₁ [G]₁ G-ext)) with
        B-PE-injectivity BΣ (whnfRed* (red D) Σₙ)
... | PE.refl , PE.refl =
  let ⊢t = escapeTerm [F] [t]
      ⊢u = escapeTerm [Gt] [u]
      ⊢Γ = wf ⊢F

      fst⇒t : Γ ⊢ fst (prod t u) ⇒ t ∷ F
      fst⇒t = Σ-β₁ ⊢F ⊢G ⊢t ⊢u
      [fstprod] , [fstprod≡t] = redSubstTerm fst⇒t [F] [t]
      [fstprod]′ = (irrelevanceTerm′ (PE.sym (wk-id F))
                                     [F] ([F]₁ id ⊢Γ)
                                     [fstprod])

      wkLiftIdEq = PE.cong (λ x → x [ fst (prod t u ) ]) (wk-lift-id G)
      [Gfst] = [G]₁ id ⊢Γ [fstprod]′
      [Gfst]′ = irrelevance′ wkLiftIdEq [Gfst]

      [t]′ = irrelevanceTerm′ (PE.sym (wk-id F))
                              [F] ([F]₁ id ⊢Γ)
                              [t]
      [fstprod≡t]′ = irrelevanceEqTerm′ (PE.sym (wk-id F))
                                        [F] ([F]₁ id ⊢Γ)
                                        [fstprod≡t]

      [Gfst≡Gt] = irrelevanceEq″ wkLiftIdEq (PE.cong (λ x → x [ t ]) (wk-lift-id G))
                                 [Gfst] [Gfst]′
                                 (G-ext id ⊢Γ [fstprod]′ [t]′ [fstprod≡t]′)
      [u]′ = convTerm₂ [Gfst]′ [Gt] [Gfst≡Gt] [u]

      snd⇒u : Γ ⊢ snd (prod t u) ⇒ u ∷ G [ fst (prod t u) ]
      snd⇒u = Σ-β₂ ⊢F ⊢G ⊢t ⊢u
      [sndprod] , [sndprod≡u] = redSubstTerm snd⇒u [Gfst]′ [u]′

      ⊢prod = prodⱼ ⊢F ⊢G ⊢t ⊢u

      [fstRefl] = transEqTerm [F] [fstprod≡t] (symEqTerm [F] [fstprod≡t])
      [sndRefl] = transEqTerm [Gfst]′ [sndprod≡u] (symEqTerm [Gfst]′ [sndprod≡u])
  in  Σₜ (prod t u)
         (idRedTerm:*: ⊢prod)
         prodₙ
         (≅-Σ-η ⊢F ⊢G ⊢prod ⊢prod prodₙ prodₙ
                (escapeTermEq [F] [fstRefl])
                (escapeTermEq [Gfst]′ [sndRefl]))
         [fstprod]′
         (irrelevanceTerm′ (PE.sym wkLiftIdEq)
                       [Gfst]′ [Gfst]
                       [sndprod])
prod′ {F} {G} {t} {u} {Γ} {l} {l′} [F] [t] [Gt] [u]
      [ΣFG]@(emb 0<1 x) = prod′ [F] [t] [Gt] [u] x

prod″ : ∀ {F G t u Γ l l′}
       ([F] : Γ ⊩⟨ l ⟩ F)
       ([t] : Γ ⊩⟨ l ⟩ t ∷ F / [F])
       ([Gt] : Γ ⊩⟨ l ⟩ G [ t ])
       ([u] : Γ ⊩⟨ l ⟩ u ∷ G [ t ] / [Gt])
       ([ΣFG] : Γ ⊩⟨ l′ ⟩ Σ F ▹ G)
     → Γ ⊩⟨ l′ ⟩ prod t u ∷ Σ F ▹ G / [ΣFG]
prod″ [F] [t] [Gt] [u] [ΣFG] =
      let [prod] = prod′ [F] [t] [Gt] [u] (B-elim BΣ [ΣFG])
      in  irrelevanceTerm (B-intr BΣ (B-elim BΣ [ΣFG])) [ΣFG] [prod]

prod-cong′ : ∀ {F G t t′ u u′ Γ l l′}
             ([F] : Γ ⊩⟨ l ⟩ F)
             ([t] : Γ ⊩⟨ l ⟩ t ∷ F / [F])
             ([t′] : Γ ⊩⟨ l ⟩ t′ ∷ F / [F])
             ([t≡t′] : Γ ⊩⟨ l ⟩ t ≡ t′ ∷ F / [F])
             ([Gt] : Γ ⊩⟨ l ⟩ G [ t ])
             ([u] : Γ ⊩⟨ l ⟩ u ∷ G [ t ] / [Gt])
             ([u′] : Γ ⊩⟨ l ⟩ u′ ∷ G [ t ] / [Gt])
             ([u≡u′] : Γ ⊩⟨ l ⟩ u ≡ u′ ∷ G [ t ] / [Gt])
             ([ΣFG] : Γ ⊩⟨ l′ ⟩B⟨ BΣ ⟩ Σ F ▹ G)
             → Γ ⊩⟨ l′ ⟩ prod t u ≡ prod t′ u′ ∷ Σ F ▹ G / B-intr BΣ [ΣFG]
prod-cong′ {F} {G} {t} {t′} {u} {u′} {Γ} {l} {l′}
           [F] [t] [t′] [t≡t′] [Gt] [u] [u′] [u≡u′]
           [ΣFG]@(noemb (Bᵣ F₁ G₁ D ⊢F ⊢G A≡A [F]₁ [G]₁ G-ext)) with
             B-PE-injectivity BΣ (whnfRed* (red D) Σₙ)
... | PE.refl , PE.refl =
  let [prod] = prod′ [F] [t] [Gt] [u] [ΣFG]

      ⊢Γ = wf ⊢F
      wk[F] = [F]₁ id ⊢Γ
      wk[t] = irrelevanceTerm′ (PE.sym (wk-id F)) [F] wk[F] [t]
      wk[t′] = irrelevanceTerm′ (PE.sym (wk-id F)) [F] wk[F] [t′]
      wk[t≡t′] = irrelevanceEqTerm′ (PE.sym (wk-id F)) [F] wk[F] [t≡t′]
      wk[Gt] = [G]₁ id ⊢Γ wk[t]
      wk[Gt′] = [G]₁ id ⊢Γ wk[t′]
      wk[Gt≡Gt′] = G-ext id ⊢Γ wk[t] wk[t′] wk[t≡t′]

      [Gt′] = irrelevance′ (PE.cong (λ x → x [ t′ ]) (wk-lift-id G)) wk[Gt′]
      [Gt≡Gt′] = irrelevanceEq″ (PE.cong (λ x → x [ t ]) (wk-lift-id G))
                                (PE.cong (λ x → x [ t′ ]) (wk-lift-id G))
                                wk[Gt] [Gt]
                                wk[Gt≡Gt′]

      [u′]Gt′ = convTerm₁ [Gt] [Gt′] [Gt≡Gt′] [u′]

      [prod′] = prod′ [F] [t′] [Gt′] [u′]Gt′ [ΣFG]

      ⊢t = escapeTerm [F] [t]
      ⊢t′ = escapeTerm [F] [t′]
      ⊢u = escapeTerm [Gt] [u]
      ⊢u′ = escapeTerm [Gt′] [u′]Gt′

      fst⇒t = Σ-β₁ ⊢F ⊢G ⊢t ⊢u
      [fst] , [fst≡t] = redSubstTerm fst⇒t [F] [t]
      fst⇒t′ = Σ-β₁ ⊢F ⊢G ⊢t′ ⊢u′
      [fst′] , [fst≡t′] = redSubstTerm fst⇒t′ [F] [t′]

      wk[fst≡t] = irrelevanceEqTerm′ (PE.sym (wk-id F))
                                      [F] wk[F]
                                      [fst≡t]
      wk[fst≡t′] = irrelevanceEqTerm′ (PE.sym (wk-id F))
                                      [F] wk[F]
                                      [fst≡t′]

      wk[fst] = irrelevanceTerm′ (PE.sym (wk-id F))
                                 [F] wk[F]
                                 [fst]
      wk[fst′] = irrelevanceTerm′ (PE.sym (wk-id F))
                                 [F] wk[F]
                                 [fst′]

      -- fst t ≡ fst t′ ∷ F
      [fst≡fst′] = transEqTerm [F] [fst≡t] (transEqTerm [F] [t≡t′] (symEqTerm [F] [fst≡t′]))
      wk[fst≡fst′] = irrelevanceEqTerm′ (PE.sym (wk-id F))
                                        [F] wk[F]
                                        [fst≡fst′]

      -- snd (prod t u) ≡ u ∷ G [ fst (prod t u) ]
      wkLiftIdEq = PE.cong (λ x → x [ fst (prod t u ) ]) (wk-lift-id G)
      wk[Gfst] = [G]₁ id ⊢Γ wk[fst]
      [Gfst] = irrelevance′ wkLiftIdEq wk[Gfst]
      [Gfst≡Gt] = irrelevanceEq″ wkLiftIdEq (PE.cong (λ x → x [ t ])
                                                     (wk-lift-id G))
                                 wk[Gfst] [Gfst]
                                 (G-ext id ⊢Γ wk[fst] wk[t] wk[fst≡t])

      [u]fst = convTerm₂ [Gfst] [Gt] [Gfst≡Gt] [u]
      snd⇒u = Σ-β₂ ⊢F ⊢G ⊢t ⊢u
      [snd] , [snd≡u] = redSubstTerm snd⇒u [Gfst] [u]fst

      -- u ≡ u′ ∷ G [ fst (prod t u) ]
      [u≡u′]Gfst = convEqTerm₂ [Gfst] [Gt] [Gfst≡Gt] [u≡u′]

      -- u′ ≡ snd (prod t′ u′) ∷ G [ fst (prod t u) ]
      wkLiftIdEq′ = PE.cong (λ x → x [ fst (prod t′ u′) ]) (wk-lift-id G)
      wk[Gfst′] = [G]₁ id ⊢Γ wk[fst′]
      [Gfst′] = irrelevance′ wkLiftIdEq′ wk[Gfst′]
      [Gfst′≡Gt′] = irrelevanceEq″ wkLiftIdEq′ (PE.cong (λ x → x [ t′ ])
                                                        (wk-lift-id G))
                                   wk[Gfst′] [Gfst′]
                                   (G-ext id ⊢Γ wk[fst′] wk[t′] wk[fst≡t′])

      snd⇒u′ = Σ-β₂ ⊢F ⊢G ⊢t′ ⊢u′

      [u′]Gfst′ = convTerm₂ [Gfst′] [Gt′] [Gfst′≡Gt′] [u′]Gt′
      [snd≡u′]Gfst′ = proj₂ (redSubstTerm snd⇒u′ [Gfst′] [u′]Gfst′)

      [Gfst≡Gfst′] = irrelevanceEq″ wkLiftIdEq wkLiftIdEq′
                                    wk[Gfst] [Gfst]
                                    (G-ext id ⊢Γ wk[fst] wk[fst′] wk[fst≡fst′])

      [snd≡u′]Gfst = convEqTerm₂ [Gfst] [Gfst′] [Gfst≡Gfst′] [snd≡u′]Gfst′

      [snd≡snd′] = transEqTerm [Gfst] [snd≡u]
                               (transEqTerm [Gfst] [u≡u′]Gfst
                                            (symEqTerm [Gfst] [snd≡u′]Gfst))
      wk[snd≡snd′] = irrelevanceEqTerm′ (PE.cong (λ x → x [ fst (prod t u) ])
                                                 (PE.sym (wk-lift-id G)))
                                        [Gfst] wk[Gfst]
                                        [snd≡snd′]

      ⊢prod = escapeTerm (B-intr BΣ [ΣFG]) [prod]
      ⊢prod′ = escapeTerm (B-intr BΣ [ΣFG]) [prod′]
  in Σₜ₌ (prod t u)
         (prod t′ u′)
         (idRedTerm:*: ⊢prod)
         (idRedTerm:*: ⊢prod′)
         prodₙ prodₙ
         (≅-Σ-η ⊢F ⊢G ⊢prod ⊢prod′ prodₙ prodₙ
                (escapeTermEq [F] [fst≡fst′])
                (escapeTermEq [Gfst] [snd≡snd′]))
         [prod] [prod′]
         wk[fst] wk[fst′]
         wk[fst≡fst′]
         wk[snd≡snd′]
prod-cong′ [F] [t] [t′] [t≡t′] [Gt] [u] [u′] [u≡u′] (emb 0<1 x) =
  prod-cong′ [F] [t] [t′] [t≡t′] [Gt] [u] [u′] [u≡u′] x

prod-cong″ : ∀ {F G t t′ u u′ Γ l l′}
             ([F] : Γ ⊩⟨ l ⟩ F)
             ([t] : Γ ⊩⟨ l ⟩ t ∷ F / [F])
             ([t′] : Γ ⊩⟨ l ⟩ t′ ∷ F / [F])
             ([t≡t′] : Γ ⊩⟨ l ⟩ t ≡ t′ ∷ F / [F])
             ([Gt] : Γ ⊩⟨ l ⟩ G [ t ])
             ([u] : Γ ⊩⟨ l ⟩ u ∷ G [ t ] / [Gt])
             ([u′] : Γ ⊩⟨ l ⟩ u′ ∷ G [ t ] / [Gt])
             ([u≡u′] : Γ ⊩⟨ l ⟩ u ≡ u′ ∷ G [ t ] / [Gt])
             ([ΣFG] : Γ ⊩⟨ l′ ⟩ Σ F ▹ G)
             → Γ ⊩⟨ l′ ⟩ prod t u ≡ prod t′ u′ ∷ Σ F ▹ G / [ΣFG]
prod-cong″ [F] [t] [t′] [t≡t′] [Gt] [u] [u′] [u≡u′] [ΣFG] =
  let [prod≡] = prod-cong′ [F] [t] [t′] [t≡t′] [Gt] [u] [u′] [u≡u′] (B-elim BΣ [ΣFG])
  in  irrelevanceEqTerm (B-intr BΣ (B-elim BΣ [ΣFG])) [ΣFG] [prod≡]

prod-congᵛ : ∀ {F G t t′ u u′ Γ l}
             ([Γ] : ⊩ᵛ Γ)
             ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
             ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / [Γ] ∙ [F])
             ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ F / [Γ] / [F])
             ([t′] : Γ ⊩ᵛ⟨ l ⟩ t′ ∷ F / [Γ] / [F])
             ([t≡t′] : Γ ⊩ᵛ⟨ l ⟩ t ≡ t′ ∷ F / [Γ] / [F])
             ([u] : Γ ⊩ᵛ⟨ l ⟩ u ∷ G [ t ] / [Γ] / substS {F} {G} [Γ] [F] [G] [t])
             ([u′] : Γ ⊩ᵛ⟨ l ⟩ u′ ∷ G [ t′ ] / [Γ] / substS {F} {G} [Γ] [F] [G] [t′])
             ([u≡u′] : Γ ⊩ᵛ⟨ l ⟩ u ≡ u′ ∷ G [ t ] / [Γ] / substS {F} {G} [Γ] [F] [G] [t])
             → Γ ⊩ᵛ⟨ l ⟩ prod t u ≡ prod t′ u′ ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G]
prod-congᵛ {F} {G} {t} {t′} {u} {u′} {Γ} [Γ] [F] [G] [t] [t′] [t≡t′] [u] [u′] [u≡u′] {Δ} {σ} ⊢Δ [σ] =
  let ⊩σF = proj₁ ([F] ⊢Δ [σ])
      ⊩σt = proj₁ ([t] ⊢Δ [σ])
      ⊩σt′ = proj₁ ([t′] ⊢Δ [σ])
      σt≡σt′ = [t≡t′] ⊢Δ [σ]

      [Gt] = substS {F} {G} [Γ] [F] [G] [t]
      ⊩σGt₁ = proj₁ ([Gt] ⊢Δ [σ])
      ⊩σGt = irrelevance′ (singleSubstLift G t) ⊩σGt₁

      ⊩σu = irrelevanceTerm′ (singleSubstLift G t)
                             ⊩σGt₁ ⊩σGt
                             (proj₁ ([u] ⊢Δ [σ]))

      [Gt≡Gt′] = substSEq {F = F} {F′ = F} {G = G} {G′ = G} {t = t} {t′ = t′} [Γ]
                          [F] [F] (reflᵛ {A = F} [Γ] [F])
                          [G] [G] (reflᵛ {A = G} {Γ = Γ ∙ F} ([Γ] ∙ [F]) [G])
                          [t] [t′] [t≡t′]
      σGt≡σGt′ = [Gt≡Gt′] ⊢Δ [σ]

      ⊩σGt′ = proj₁ (substS {F} {G} [Γ] [F] [G] [t′] ⊢Δ [σ])
      ⊩σu′₂ = proj₁ ([u′] ⊢Δ [σ])
      ⊩σu′₁ = convTerm₂ ⊩σGt₁ ⊩σGt′ σGt≡σGt′ ⊩σu′₂
      ⊩σu′ = irrelevanceTerm′ (singleSubstLift G t) ⊩σGt₁ ⊩σGt ⊩σu′₁

      σu≡σu′ = irrelevanceEqTerm′ (singleSubstLift G t)
                                  ⊩σGt₁ ⊩σGt
                                  ([u≡u′] ⊢Δ [σ])

      ⊩σΣFG = proj₁ (Σᵛ {F} {G} [Γ] [F] [G] ⊢Δ [σ])
  in prod-cong″ ⊩σF ⊩σt ⊩σt′ σt≡σt′ ⊩σGt ⊩σu ⊩σu′ σu≡σu′ ⊩σΣFG

prodᵛ : ∀ {F G t u Γ l}
       ([Γ] : ⊩ᵛ Γ)
       ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
       ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / [Γ] ∙ [F])
       ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ F / [Γ] / [F])
       ([u] : Γ ⊩ᵛ⟨ l ⟩ u ∷ G [ t ] / [Γ] / substS {F} {G} [Γ] [F] [G] [t])
     → Γ ⊩ᵛ⟨ l ⟩ prod t u ∷ Σ F ▹ G / [Γ] / Σᵛ {F} {G} [Γ] [F] [G]
prodᵛ {F} {G} {t} {u} {Γ} {l} [Γ] [F] [G] [t] [u] {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let [Gt] = substS {F} {G} [Γ] [F] [G] [t]
      [ΣFG] = Σᵛ {F} {G} [Γ] [F] [G]

      ⊩σF = proj₁ ([F] ⊢Δ [σ])
      ⊢σF = escape ⊩σF
      ⊩σt = proj₁ ([t] ⊢Δ [σ])
      ⊩σGt′ : Δ ⊩⟨ l ⟩ subst σ (G [ t ])
      ⊩σGt′ = proj₁ ([Gt] ⊢Δ [σ])
      ⊩σGt : Δ ⊩⟨ l ⟩ subst (liftSubst σ) G [ subst σ t ]
      ⊩σGt = irrelevance′ (singleSubstLift G t) ⊩σGt′
      ⊩σu′ = proj₁ ([u] ⊢Δ [σ])
      ⊩σu : Δ ⊩⟨ l ⟩ subst σ u ∷ subst (liftSubst σ) G [ subst σ t ] / ⊩σGt
      ⊩σu = irrelevanceTerm′ (singleSubstLift G t) ⊩σGt′ ⊩σGt ⊩σu′
      ⊩σΣFG = proj₁ ([ΣFG] ⊢Δ [σ])

  in  prod″ ⊩σF ⊩σt ⊩σGt ⊩σu ⊩σΣFG ,
      (λ {σ′} [σ′] [σ≡σ′] →
        let ⊩σ′F = proj₁ ([F] ⊢Δ [σ′])
            σF≡σ′F = proj₂ ([F] ⊢Δ [σ]) [σ′] [σ≡σ′]

            ⊩σ′t = proj₁ ([t] ⊢Δ [σ′])
            ⊩σ′t = convTerm₂ ⊩σF ⊩σ′F σF≡σ′F ⊩σ′t
            σt≡σ′t = proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′]

            ⊩σ′Gt′ = proj₁ ([Gt] ⊢Δ [σ′])
            ⊩σ′Gt = irrelevance′ (singleSubstLift G t) ⊩σ′Gt′

            σGt≡σ′Gt = proj₂ ([Gt] ⊢Δ [σ]) [σ′] [σ≡σ′]

            ⊩σ′u″ = proj₁ ([u] ⊢Δ [σ′])
            ⊩σ′u′ = convTerm₂ ⊩σGt′ ⊩σ′Gt′ σGt≡σ′Gt ⊩σ′u″
            ⊩σ′u = irrelevanceTerm′ (singleSubstLift G t) ⊩σGt′ ⊩σGt ⊩σ′u′

            σu≡σ′u : Δ ⊩⟨ l ⟩ subst σ u ≡ subst σ′ u ∷ subst (liftSubst σ) G [ subst σ t ] / ⊩σGt
            σu≡σ′u = irrelevanceEqTerm′ (singleSubstLift G t) ⊩σGt′ ⊩σGt (proj₂ ([u] ⊢Δ [σ]) [σ′] [σ≡σ′])
        in  prod-cong″ ⊩σF ⊩σt ⊩σ′t σt≡σ′t ⊩σGt ⊩σu ⊩σ′u σu≡σ′u ⊩σΣFG)


------------------------------------------------------------------------
-- Precedence-correct expressions
------------------------------------------------------------------------

module Mixfix.Expr where

open import Data.Vec  using (Vec)
open import Data.List using (List; []; _∷_)
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.Product using (∃; _,_)

open import Mixfix.Fixity
open import Mixfix.Operator

------------------------------------------------------------------------
-- An abstract definition of precedence graphs

-- The interface of precedence graphs.

record PrecedenceGraphInterface : Set₁ where
  field
    -- Precedence graphs.
    PrecedenceGraph : Set

    -- Precedence levels.
    Precedence : PrecedenceGraph → Set

    -- The operators of the given precedence.
    ops : (g : PrecedenceGraph) →
          Precedence g → (fix : Fixity) → List (∃ (Operator fix))

    -- The immediate successors of the precedence level.
    ↑ : (g : PrecedenceGraph) → Precedence g → List (Precedence g)

    -- All precedence levels in the graph.
    anyPrecedence : (g : PrecedenceGraph) → List (Precedence g)

-- When a precedence graph is given the following module may be
-- convenient to avoid having to write "g" all the time.

module PrecedenceGraph
         (i : PrecedenceGraphInterface)
         (g : PrecedenceGraphInterface.PrecedenceGraph i)
         where

  PrecedenceGraph : Set
  PrecedenceGraph = PrecedenceGraphInterface.PrecedenceGraph i

  Precedence : Set
  Precedence = PrecedenceGraphInterface.Precedence i g

  ops : Precedence → (fix : Fixity) → List (∃ (Operator fix))
  ops = PrecedenceGraphInterface.ops i g

  ↑ : Precedence → List Precedence
  ↑ = PrecedenceGraphInterface.↑ i g

  anyPrecedence : List Precedence
  anyPrecedence = PrecedenceGraphInterface.anyPrecedence i g

------------------------------------------------------------------------
-- Precedence-correct operator applications

-- Parameterised on a precedence graph.

module PrecedenceCorrect
         (i : PrecedenceGraphInterface)
         (g : PrecedenceGraphInterface.PrecedenceGraph i)
         where

  open PrecedenceGraph i g public

  mutual

    infixl 4 _⟨_⟩ˡ_
    infixr 4 _⟨_⟩ʳ_
    infix  4 _⟨_⟩_ _⟨_⟫ ⟪_⟩_ _∙_

    -- Expr ps contains expressions where the outermost operator has
    -- one of the precedences in ps.

    data Expr (ps : List Precedence) : Set where
      _∙_ : ∀ {p assoc} (p∈ps : p ∈ ps) (e : ExprIn p assoc) → Expr ps

    -- ExprIn p assoc contains expressions where the outermost
    -- operator has precedence p (is /in/ precedence level p) and the
    -- associativity assoc.

    data ExprIn (p : Precedence) : Associativity → Set where
      ⟪_⟫    :                    (op : Inner (ops p closed      ))                     → ExprIn p non
      _⟨_⟫   : (l : Outer p left) (op : Inner (ops p postfx      ))                     → ExprIn p left
      ⟪_⟩_   :                    (op : Inner (ops p prefx       )) (r : Outer p right) → ExprIn p right
      _⟨_⟩_  : (l : Expr (↑ p)  ) (op : Inner (ops p (infx non  ))) (r : Expr (↑ p)   ) → ExprIn p non
      _⟨_⟩ˡ_ : (l : Outer p left) (op : Inner (ops p (infx left ))) (r : Expr (↑ p)   ) → ExprIn p left
      _⟨_⟩ʳ_ : (l : Expr (↑ p)  ) (op : Inner (ops p (infx right))) (r : Outer p right) → ExprIn p right

    -- Outer p fix contains expressions where the head operator either
    --   ⑴ has precedence p and associativity assoc or
    --   ⑵ binds strictly tighter than p.

    data Outer (p : Precedence) (assoc : Associativity) : Set where
      similar : (e : ExprIn p assoc) → Outer p assoc
      tighter : (e : Expr (↑ p))     → Outer p assoc

    -- Inner ops contains the internal parts (operator plus
    -- internal arguments) of operator applications. The operators
    -- have to be members of ops.

    data Inner {fix} (ops : List (∃ (Operator fix))) : Set where
      _∙_ : ∀ {arity op}
            (op∈ops : (arity , op) ∈ ops)
            (args : Vec (Expr anyPrecedence) arity) →
            Inner ops

  -- "Weakening".

  weakenE : ∀ {p ps} → Expr ps → Expr (p ∷ ps)
  weakenE (p∈ps ∙ e) = there p∈ps ∙ e

  weakenI : ∀ {fix ops} {op : ∃ (Operator fix)} →
            Inner ops → Inner (op ∷ ops)
  weakenI (op∈ops ∙ args) = there op∈ops ∙ args


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness #-}

import Level

open import Data.Empty
open import Data.Product
open import Data.List using (_∷_; []; _++_)
open import Data.List.Properties using (∷-injectiveʳ)

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

open import Common

module TraceSet {ℙ : Set} (message : Message ℙ)
  where

open import Trace message
open import SessionType message
open import Transitions message
open import HasTrace message

TraceSet : Set₁
TraceSet = Pred Trace Level.zero

⟦_⟧ : SessionType -> TraceSet
⟦_⟧ = _HasTrace_

_⊆⊇_ : TraceSet -> TraceSet -> Set
X ⊆⊇ Y = X ⊆ Y × Y ⊆ X

PrefixClosed : TraceSet -> Set
PrefixClosed X = ∀{φ ψ} -> ψ ⊑ φ -> X φ -> X ψ

Coherent : TraceSet -> Set
Coherent X = ∀{φ ψ₁ ψ₂ x y} -> X (φ ++ I x ∷ ψ₁) -> X (φ ++ O y ∷ ψ₂) -> ⊥

_∂_ : TraceSet -> Action -> TraceSet
(X ∂ α) φ = X (α ∷ φ)

--| CO-SETS |--

CoSet : TraceSet -> TraceSet
CoSet X φ = X (co-trace φ)

co-set-involution : ∀{X} -> CoSet (CoSet X) ≡ X
co-set-involution {X} =
  extensionality λ φ -> subst (λ z -> X z ≡ X φ) (sym (co-trace-involution φ)) refl

co-set-⊆ : ∀{X Y} -> X ⊆ Y -> CoSet X ⊆ CoSet Y
co-set-⊆ sub xcφ = sub xcφ

co-set-right->left : ∀{X Y} -> X ⊆ CoSet Y -> CoSet X ⊆ Y
co-set-right->left {X} {Y} sub xcφ with co-set-⊆ {X} {CoSet Y} sub
... | sub' = subst Y (co-trace-involution _) (sub' xcφ)

co-definition : ∀{X φ} -> φ ∈ X -> co-trace φ ∈ CoSet X
co-definition {_} {φ} xφ rewrite co-trace-involution φ = xφ

co-inversion : ∀{X φ} -> co-trace φ ∈ CoSet X -> φ ∈ X
co-inversion {_} {φ} coφ rewrite co-trace-involution φ = coφ

--| MAXIMAL TRACES |--

data Maximal : TraceSet -> Trace -> Set where
  maximal : ∀{X φ} (wit : φ ∈ X) (F : ∀{ψ} -> φ ⊑ ψ -> ψ ∈ X -> ψ ≡ φ) -> Maximal X φ

maximal-sub : ∀{X} -> Maximal X ⊆ X
maximal-sub (maximal x _) = x

derive-maximal : ∀{α φ X} -> α ∷ φ ∈ Maximal X -> φ ∈ Maximal (X ∂ α)
derive-maximal (maximal wit F) = maximal wit λ le p -> ∷-injectiveʳ (F (some le) p)

input-maximal : ∀{x φ f} -> I x ∷ φ ∈ Maximal ⟦ inp f ⟧ -> φ ∈ Maximal ⟦ f x .force ⟧
input-maximal (maximal (_ , def , step inp tr) F) =
  maximal (_ , def , tr) λ { le tψ -> ∷-injectiveʳ (F (some le) (inp-has-trace tψ)) }

output-maximal : ∀{x φ f} -> O x ∷ φ ∈ Maximal ⟦ out f ⟧ -> φ ∈ Maximal ⟦ f x .force ⟧
output-maximal (maximal (_ , def , step (out _) tr) F) =
  maximal (_ , def , tr) λ { le tψ -> ∷-injectiveʳ (F (some le) (out-has-trace tψ)) }


module PiQ.Properties where
open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Sum
open import Data.Product
open import Data.Maybe
open import Data.Maybe.Properties
open import Data.Nat hiding (_≟_)
open import Data.Nat.Induction
open import Data.Nat.Properties hiding (_≟_)
open import Function using (_∘_)
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import PiQ.Syntax
open import PiQ.Opsem
open import PiQ.AuxLemmas
open import PiQ.NoRepeat
open import PiQ.Invariants
open import PiQ.Eval
open import PiQ.Interp

-- Change the direction of the given state
flip : (st : State) → st ≢ ⊠ → State
flip ⟨ c ∣ v ∣ κ ⟩▷ _ = ⟨ c ∣ v ∣ κ ⟩◁
flip ［ c ∣ v ∣ κ ］▷ _ = ［ c ∣ v ∣ κ ］◁
flip ⟨ c ∣ v ∣ κ ⟩◁ _ = ⟨ c ∣ v ∣ κ ⟩▷
flip ［ c ∣ v ∣ κ ］◁ _ = ［ c ∣ v ∣ κ ］▷
flip ⊠ st≢⊠ = ⊥-elim (st≢⊠ refl)

Rev : ∀ {st st'} → st ↦ st' → (nf : st ≢ ⊠) (nf' : st' ≢ ⊠)
    → flip st' nf' ↦ flip st nf
Rev ↦⃗₁ _ _ = ↦⃖₁
Rev ↦⃗₂ _ _ = ↦⃖₂
Rev ↦⃗₃ _ _ = ↦⃖₃
Rev ↦⃗₄ _ _ = ↦⃖₄
Rev ↦⃗₅ _ _ = ↦⃖₅
Rev ↦⃗₆ _ _ = ↦⃖₆
Rev ↦⃗₇ _ _ = ↦⃖₇
Rev ↦⃗₈ _ _ = ↦⃖₈
Rev ↦⃗₉ _ _ = ↦⃖₉
Rev ↦⃗₁₀ _ _ = ↦⃖₁₀
Rev ↦⃗₁₁ _ _ = ↦⃖₁₁
Rev ↦⃗₁₂ _ _ = ↦⃖₁₂
Rev ↦⃖₁ _ _ = ↦⃗₁
Rev ↦⃖₂ _ _ = ↦⃗₂
Rev ↦⃖₃ _ _ = ↦⃗₃
Rev ↦⃖₄ _ _ = ↦⃗₄
Rev ↦⃖₅ _ _ = ↦⃗₅
Rev ↦⃖₆ _ _ = ↦⃗₆
Rev ↦⃖₇ _ _ = ↦⃗₇
Rev ↦⃖₈ _ _ = ↦⃗₈
Rev ↦⃖₉ _ _ = ↦⃗₉
Rev ↦⃖₁₀ _ _ = ↦⃗₁₀
Rev ↦⃖₁₁ _ _ = ↦⃗₁₁
Rev ↦⃖₁₂ _ _ = ↦⃗₁₂
Rev ↦η₊₁ _ _ = ↦η₊₂
Rev ↦η₊₂ _ _ = ↦η₊₁
Rev ↦ε₊₁ _ _ = ↦ε₊₂
Rev ↦ε₊₂ _ _ = ↦ε₊₁
Rev ↦⃗ηₓ _ _ = ↦⃖ηₓ₁ {eq = refl}
Rev (↦⃖ηₓ₁ {eq = refl}) _ _ = ↦⃗ηₓ
Rev ↦⃖ηₓ₂ _ nf' = ⊥-elim (nf' refl)
Rev (↦⃗εₓ₁ {eq = refl}) _ _ = ↦⃖εₓ
Rev ↦⃗εₓ₂ _ nf' = ⊥-elim (nf' refl)
Rev ↦⃖εₓ _ _ = ↦⃗εₓ₁ {eq = refl}

Rev* : ∀ {st st'} → st ↦* st' → (nf : st ≢ ⊠) → (nf' : st' ≢ ⊠) → flip st' nf' ↦* flip st nf
Rev* {⟨ _ ∣ _ ∣ _ ⟩▷} ◾ _ _ = ◾
Rev* {［ _ ∣ _ ∣ _ ］▷} ◾ _ _ = ◾
Rev* {⟨ _ ∣ _ ∣ _ ⟩◁} ◾ _ _ = ◾
Rev* {［ _ ∣ _ ∣ _ ］◁} ◾ _ _ = ◾
Rev* {⊠} ◾ nf _ = ⊥-elim (nf refl)
Rev* (r ∷ ◾) nf nf' = Rev r nf nf' ∷ ◾
Rev* (r ∷ (r' ∷ rs)) nf nf' = Rev* (r' ∷ rs) nf'' nf' ++↦ (Rev r nf nf'' ∷ ◾)
  where
  nf'' = λ eq → ⊠-is-stuck eq (_ , r')

-- Helper functions
inspect⊎ : ∀ {ℓ ℓ₁ ℓ₂ ℓ₃} {P : Set ℓ} {Q : Set ℓ₁} {R : Set ℓ₂} {S : Set ℓ₃}
         → (f : P → Q ⊎ R ⊎ S) → (p : P) → (∃[ q ] (inj₁ q ≡ f p)) ⊎ (∃[ r ] (inj₂ (inj₁ r) ≡ f p)) ⊎ (∃[ s ] (inj₂ (inj₂ s) ≡ f p))
inspect⊎ f p with f p
... | inj₁ q = inj₁ (q , refl)
... | inj₂ (inj₁ r) = inj₂ (inj₁ (r , refl))
... | inj₂ (inj₂ r) = inj₂ (inj₂ (r , refl))

Val≢ : ∀ {A B v₁ v₂} → _⃗ {A} {B} v₁ ≢ v₂ ⃖
Val≢ ()

Maybe≢ : ∀ {ℓ} {A : Set ℓ} {a : A} → just a ≢ nothing
Maybe≢ ()

toState : ∀ {A B} → (A ↔ B) → Maybe (Val B A) → State
toState c (just (b ⃗)) = ［ c ∣ b ∣ ☐ ］▷
toState c (just (a ⃖)) = ⟨ c ∣ a ∣ ☐ ⟩◁
toState c nothing = ⊠

is-stuck-toState : ∀ {A B} → (c : A ↔ B) → (v : Maybe (Val B A)) → is-stuck (toState c v)
is-stuck-toState c (just (b ⃗)) = λ ()
is-stuck-toState c (just (a ⃖)) = λ ()
is-stuck-toState c nothing = λ ()

toStateEq₁ : ∀ {A B b} → (c : A ↔ B) → (x : Maybe (Val B A)) → ［ c ∣ b ∣ ☐ ］▷ ≡ toState c x → just (b ⃗) ≡ x
toStateEq₁ c (just (x ⃗)) refl = refl

toStateEq₂ : ∀ {A B a} → (c : A ↔ B) → (x : Maybe (Val B A)) → ⟨ c ∣ a ∣ ☐ ⟩◁ ≡ toState c x → just (a ⃖) ≡ x
toStateEq₂ c (just (x ⃖)) refl = refl

toStateEq₃ : ∀ {A B} → (c : A ↔ B) → (x : Maybe (Val B A)) → ⊠ ≡ toState c x → nothing ≡ x
toStateEq₃ c nothing refl = refl
toStateEq₃ c (just (x ⃗)) ()
toStateEq₃ c (just (x ⃖)) ()

toState≡₁ : ∀ {A B b x} {c : A ↔ B} → toState c x ≡ ［ c ∣ b ∣ ☐ ］▷ → x ≡ just (b ⃗)
toState≡₁ {x = just (x ⃗)} refl = refl

toState≡₂ : ∀ {A B a x} {c : A ↔ B} → toState c x ≡ ⟨ c ∣ a ∣ ☐ ⟩◁ → x ≡ just (a ⃖)
toState≡₂ {x = just (x ⃖)} refl = refl

toState≡₃ : ∀ {A B x} {c : A ↔ B} → toState c x ≡ ⊠ → x ≡ nothing
toState≡₃ {x = nothing} refl = refl
toState≡₃ {x = just (x ⃗)} ()
toState≡₃ {x = just (x ⃖)} ()

eval-toState₁ : ∀ {A B a x} {c : A ↔ B} → ⟨ c ∣ a ∣ ☐ ⟩▷ ↦* (toState c x) → eval c (a ⃗) ≡ x
eval-toState₁ {a = a} {just (b ⃗)} {c} rs with inspect⊎ (run ⟨ c ∣ a ∣ ☐ ⟩▷) (λ ())
eval-toState₁ {a = a} {just (b ⃗)} {c} rs | inj₁ ((a' , rs') , eq) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₁ {a = a} {just (b ⃗)} {c} rs | inj₂ (inj₁ ((b' , rs') , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (b ⃗)) eq refl
eval-toState₁ {a = a} {just (b ⃗)} {c} rs | inj₂ (inj₂ (rs' , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₁ {a = a} {just (a' ⃖)} {c} rs with inspect⊎ (run ⟨ c ∣ a ∣ ☐ ⟩▷) (λ ())
eval-toState₁ {a = a} {just (a' ⃖)} {c} rs | inj₁ ((a'' , rs') , eq) with deterministic* rs rs' (λ ()) (λ ())
... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (a' ⃖)) eq refl
eval-toState₁ {a = a} {just (a' ⃖)} {c} rs | inj₂ (inj₁ ((b' , rs') , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₁ {a = a} {just (a' ⃖)} {c} rs | inj₂ (inj₂ (rs' , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₁ {a = a} {nothing} {c} rs with inspect⊎ (run ⟨ c ∣ a ∣ ☐ ⟩▷) (λ ())
eval-toState₁ {a = a} {nothing} {c} rs | inj₁ ((a' , rs') , eq) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₁ {a = a} {nothing} {c} rs | inj₂ (inj₁ ((b' , rs') , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₁ {a = a} {nothing} {c} rs | inj₂ (inj₂ (rs' , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ nothing) eq refl

eval-toState₂ : ∀ {A B b x} {c : A ↔ B} → ［ c ∣ b ∣ ☐ ］◁ ↦* (toState c x) → eval c (b ⃖) ≡ x
eval-toState₂ {b = b} {just (b' ⃗)} {c} rs with inspect⊎ (run ［ c ∣ b ∣ ☐ ］◁) (λ ())
eval-toState₂ {b = b} {just (b' ⃗)} {c} rs | inj₁ ((a' , rs') , eq) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₂ {b = b} {just (b' ⃗)} {c} rs | inj₂ (inj₁ ((b'' , rs') , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (b' ⃗)) eq refl
eval-toState₂ {b = b} {just (b' ⃗)} {c} rs | inj₂ (inj₂ (rs' , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₂ {b = b} {just (a ⃖)} {c} rs with inspect⊎ (run ［ c ∣ b ∣ ☐ ］◁) (λ ())
eval-toState₂ {b = b} {just (a ⃖)} {c} rs | inj₁ ((a'' , rs') , eq) with deterministic* rs rs' (λ ()) (λ ())
... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (a ⃖)) eq refl
eval-toState₂ {b = b} {just (a ⃖)} {c} rs | inj₂ (inj₁ ((b' , rs') , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₂ {b = b} {just (a ⃖)} {c} rs | inj₂ (inj₂ (rs' , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₂ {b = b} {nothing} {c} rs with inspect⊎ (run ［ c ∣ b ∣ ☐ ］◁) (λ ())
eval-toState₂ {b = b} {nothing} {c} rs | inj₁ ((a' , rs') , eq) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₂ {b = b} {nothing} {c} rs | inj₂ (inj₁ ((b' , rs') , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | ()
eval-toState₂ {b = b} {nothing} {c} rs | inj₂ (inj₂ (rs' , eq)) with deterministic* rs rs' (λ ()) (λ ())
... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ nothing) eq refl

getₜᵣ⃗ : ∀ {A B} → (c : A ↔ B) → {v : ⟦ A ⟧} {v' : Maybe (Val B A)} → eval c (v ⃗) ≡ v'
       → ⟨ c ∣ v ∣ ☐ ⟩▷ ↦* toState c v'
getₜᵣ⃗ c {v} {v'} eq with inspect⊎ (run ⟨ c ∣ v ∣ ☐ ⟩▷) (λ ())
getₜᵣ⃗ c {v} {nothing} eq | inj₁ ((x₁ , rs₁) , eq₁) with trans (subst (λ x → just (x₁ ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃗ c {v} {just (x ⃗)} eq | inj₁ ((x₁ , rs₁) , eq₁) with trans (subst (λ x → just (x₁ ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃗ c {v} {just (x ⃖)} eq | inj₁ ((x₁ , rs₁) , eq₁) with trans (subst (λ x → just (x₁ ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | refl = rs₁
getₜᵣ⃗ c {v} {nothing} eq | inj₂ (inj₁ ((x₁ , rs₁) , eq₁)) with trans (subst (λ x → just (x₁ ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃗ c {v} {just (x ⃗)} eq | inj₂ (inj₁ ((x₁ , rs₁) , eq₁)) with trans (subst (λ x → just (x₁ ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | refl = rs₁
getₜᵣ⃗ c {v} {just (x ⃖)} eq | inj₂ (inj₁ ((x₁ , rs₁) , eq₁)) with trans (subst (λ x → just (x₁ ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃗ c {v} {nothing} eq | inj₂ (inj₂ (rs₁ , eq₁)) with trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | refl = rs₁
getₜᵣ⃗ c {v} {just (x ⃗)} eq | inj₂ (inj₂ (rs₁ , eq₁)) with trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃗ c {v} {just (x ⃖)} eq | inj₂ (inj₂ (rs₁ , eq₁)) with trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()

getₜᵣ⃖ : ∀ {A B} → (c : A ↔ B) → {v : ⟦ B ⟧} {v' : Maybe (Val B A)} → eval c (v ⃖) ≡ v'
       → ［ c ∣ v ∣ ☐ ］◁ ↦* toState c v'
getₜᵣ⃖ c {v} {v'} eq with inspect⊎ (run ［ c ∣ v ∣ ☐ ］◁) (λ ())
getₜᵣ⃖ c {v} {nothing} eq | inj₁ ((x₁ , rs₁) , eq₁) with trans (subst (λ x → just (x₁ ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃖ c {v} {just (x ⃗)} eq | inj₁ ((x₁ , rs₁) , eq₁) with trans (subst (λ x → just (x₁ ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃖ c {v} {just (x ⃖)} eq | inj₁ ((x₁ , rs₁) , eq₁) with trans (subst (λ x → just (x₁ ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | refl = rs₁
getₜᵣ⃖ c {v} {nothing} eq | inj₂ (inj₁ ((x₁ , rs₁) , eq₁)) with trans (subst (λ x → just (x₁ ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃖ c {v} {just (x ⃗)} eq | inj₂ (inj₁ ((x₁ , rs₁) , eq₁)) with trans (subst (λ x → just (x₁ ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | refl = rs₁
getₜᵣ⃖ c {v} {just (x ⃖)} eq | inj₂ (inj₁ ((x₁ , rs₁) , eq₁)) with trans (subst (λ x → just (x₁ ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃖ c {v} {nothing} eq | inj₂ (inj₂ (rs₁ , eq₁)) with trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | refl = rs₁
getₜᵣ⃖ c {v} {just (x ⃗)} eq | inj₂ (inj₂ (rs₁ , eq₁)) with trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()
getₜᵣ⃖ c {v} {just (x ⃖)} eq | inj₂ (inj₂ (rs₁ , eq₁)) with trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq₁ refl) eq
... | ()

-- Forward evaluator is reversible
evalIsRev : ∀ {A B} → (c : A ↔ B) (v₁ : Val A B) (v₂ : Val B A)
          → eval c v₁ ≡ (just v₂) → evalᵣₑᵥ c v₂ ≡ (just v₁)
evalIsRev c (v₁ ⃗) (v₂ ⃗) eq with inspect⊎ (run ⟨ c ∣ v₁ ∣ ☐ ⟩▷) (λ ())
evalIsRev c (v₁ ⃗) (v₂ ⃗) eq | inj₁ ((u , rs) , eq') = ⊥-elim (Val≢ (sym (just-injective contr)))
  where
  contr : just (u ⃖) ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalIsRev c (v₁ ⃗) (v₂ ⃗) eq | inj₂ (inj₁ ((u , rs) , eq')) = subst (λ x → evalᵣₑᵥ c x ≡ just (v₁ ⃗)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃗) ≡ (v₂ ⃗)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : evalᵣₑᵥ c (u ⃗) ≡ just (v₁ ⃗)
  rsinv with u≡v₂ | inspect⊎ (run ［ c ∣ v₂ ∣ ☐ ］◁) (λ ())
  rsinv | refl | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃗)) eq'' refl
  rsinv | refl | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | refl | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalIsRev c (v₁ ⃗) (v₂ ⃗) eq | inj₂ (inj₂ (rs , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalIsRev c (v₁ ⃗) (v₂ ⃖) eq with inspect⊎ (run ⟨ c ∣ v₁ ∣ ☐ ⟩▷) (λ ())
evalIsRev c (v₁ ⃗) (v₂ ⃖) eq | inj₁ ((u , rs) , eq') = subst (λ x → evalᵣₑᵥ c x ≡ just (v₁ ⃗)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃖) ≡ (v₂ ⃖)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : evalᵣₑᵥ c (u ⃖) ≡ just (v₁ ⃗)
  rsinv with u≡v₂ | inspect⊎ (run ⟨ c ∣ u ∣ ☐ ⟩▷) (λ ())
  rsinv | refl | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃗)) eq'' refl
  rsinv | refl | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | refl | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalIsRev c (v₁ ⃗) (v₂ ⃖) eq | inj₂ (inj₁ ((u , rs) , eq')) = ⊥-elim (Val≢ (just-injective contr))
  where
  contr : just (u ⃗) ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalIsRev c (v₁ ⃗) (v₂ ⃖) eq | inj₂ (inj₂ (rs , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalIsRev c (v₁ ⃖) (v₂ ⃗) eq with inspect⊎ (run ［ c ∣ v₁ ∣ ☐ ］◁) (λ ())
evalIsRev c (v₁ ⃖) (v₂ ⃗) eq | inj₁ ((u , rs) , eq') = ⊥-elim (Val≢ (just-injective (sym contr)))
  where
  contr : just (u ⃖) ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalIsRev c (v₁ ⃖) (v₂ ⃗) eq | inj₂ (inj₁ ((u , rs) , eq')) = subst (λ x → evalᵣₑᵥ c x ≡ just (v₁ ⃖)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃗) ≡ (v₂ ⃗)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : evalᵣₑᵥ c (u ⃗) ≡ just (v₁ ⃖)
  rsinv with u≡v₂ | inspect⊎ (run ［ c ∣ u ∣ ☐ ］◁) (λ ())
  rsinv | refl | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | refl | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃖)) eq'' refl
  rsinv | refl | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalIsRev c (v₁ ⃖) (v₂ ⃗) eq | inj₂ (inj₂ (rs , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalIsRev c (v₁ ⃖) (v₂ ⃖) eq with inspect⊎ (run ［ c ∣ v₁ ∣ ☐ ］◁) (λ ())
evalIsRev c (v₁ ⃖) (v₂ ⃖) eq | inj₁ ((u , rs) , eq') = subst (λ x → evalᵣₑᵥ c x ≡ just (v₁ ⃖)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃖) ≡ (v₂ ⃖)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : evalᵣₑᵥ c (u ⃖) ≡ just (v₁ ⃖)
  rsinv with u≡v₂ | inspect⊎ (run ⟨ c ∣ u ∣ ☐ ⟩▷) (λ ())
  rsinv | refl | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | refl | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃖)) eq'' refl
  rsinv | refl | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalIsRev c (v₁ ⃖) (v₂ ⃖) eq | inj₂ (inj₁ ((u , rs) , eq')) = ⊥-elim (Val≢ (just-injective contr))
  where
  contr : just (u ⃗) ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalIsRev c (v₁ ⃖) (v₂ ⃖) eq | inj₂ (inj₂ (rs , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq

-- Backward evaluator is reversible
evalᵣₑᵥIsRev : ∀ {A B} → (c : A ↔ B) (v₁ : Val B A) (v₂ : Val A B)
             → evalᵣₑᵥ c v₁ ≡ (just v₂) → eval c v₂ ≡ (just v₁)
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃗) eq with inspect⊎ (run ［ c ∣ v₁ ∣ ☐ ］◁) (λ ())
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃗) eq | inj₁ ((u , rs) , eq') = subst (λ x → eval c x ≡ just (v₁ ⃗)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃗) ≡ (v₂ ⃗)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : eval c (u ⃗) ≡ just (v₁ ⃗)
  rsinv with inspect⊎ (run ⟨ c ∣ u ∣ ☐ ⟩▷) (λ ())
  rsinv | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃗)) eq'' refl
  rsinv | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃗) eq | inj₂ (inj₁ ((u , rs) , eq')) = ⊥-elim (Val≢ (sym (just-injective contr)))
  where
  contr : just (u ⃖) ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃗) eq | inj₂ (inj₂ (rs' , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃖) eq with inspect⊎ (run ［ c ∣ v₁ ∣ ☐ ］◁) (λ ())
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃖) eq | inj₁ ((u , rs) , eq') = ⊥-elim (Val≢ (just-injective contr))
  where
  contr : just (u ⃗) ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃖) eq | inj₂ (inj₁ ((u , rs) , eq')) = subst (λ x → eval c x ≡ just (v₁ ⃗)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃖) ≡ (v₂ ⃖)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : eval c (u ⃖) ≡ just (v₁ ⃗)
  rsinv with inspect⊎ (run ［ c ∣ u ∣ ☐ ］◁) (λ ())
  rsinv | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃗)) eq'' refl
  rsinv | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalᵣₑᵥIsRev c (v₁ ⃗) (v₂ ⃖) eq | inj₂ (inj₂ (rs' , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃗) eq with inspect⊎ (run ⟨ c ∣ v₁ ∣ ☐ ⟩▷) (λ ())
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃗) eq | inj₁ ((u , rs) , eq') = subst (λ x → eval c x ≡ just (v₁ ⃖)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃗) ≡ (v₂ ⃗)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : eval c (u ⃗) ≡ just (v₁ ⃖)
  rsinv with inspect⊎ (run ⟨ c ∣ u ∣ ☐ ⟩▷) (λ ())
  rsinv | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃖)) eq'' refl
  rsinv | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃗) eq | inj₂ (inj₁ ((u , rs) , eq')) = ⊥-elim (Val≢ (sym (just-injective contr)))
  where
  contr : just (u ⃖) ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃗) eq | inj₂ (inj₂ (rs' , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃗)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃖) eq with inspect⊎ (run ⟨ c ∣ v₁ ∣ ☐ ⟩▷) (λ ())
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃖) eq | inj₁ ((u , rs) , eq') = ⊥-elim (Val≢ (just-injective contr))
  where
  contr : just (u ⃗) ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → just (u ⃗) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃖) eq | inj₂ (inj₁ ((u , rs) , eq')) = subst (λ x → eval c x ≡ just (v₁ ⃖)) u≡v₂ rsinv
  where
  u≡v₂ : (u ⃖) ≡ (v₂ ⃖)
  u≡v₂ = just-injective (trans (subst (λ x → just (u ⃖) ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq)

  rsinv : eval c (u ⃖) ≡ just (v₁ ⃖)
  rsinv with inspect⊎ (run ［ c ∣ u ∣ ☐ ］◁) (λ ())
  rsinv | inj₁ ((w , rs') , eq'') with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | refl = subst (λ x → [ just ∘ _⃖ ∘ proj₁ , [ just ∘ _⃗ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x ≡ just (v₁ ⃖)) eq'' refl
  rsinv | inj₂ (inj₁ ((w , rs') , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
  rsinv | inj₂ (inj₂ (rs' , eq'')) with deterministic* rs' (Rev* rs (λ ()) (λ ())) (λ ()) (λ ())
  ... | ()
evalᵣₑᵥIsRev c (v₁ ⃖) (v₂ ⃖) eq | inj₂ (inj₂ (rs' , eq')) = ⊥-elim (Maybe≢ (sym contr))
  where
  contr : nothing ≡ just (v₂ ⃖)
  contr = trans (subst (λ x → nothing ≡ [ just ∘ _⃗ ∘ proj₁ , [ just ∘ _⃖ ∘ proj₁ , (λ _ → nothing) ]′ ]′ x) eq' refl) eq

-- The abstract machine semantics is equivalent to the big-step semantics
mutual
  eval≡interp : ∀ {A B} → (c : A ↔ B) → (v : Val A B) → eval c v ≡ interp c v
  eval≡interp unite₊l (inj₂ v ⃗) = refl
  eval≡interp unite₊l (v ⃖) = refl
  eval≡interp uniti₊l (v ⃗) = refl
  eval≡interp uniti₊l (inj₂ v ⃖) = refl
  eval≡interp swap₊ (inj₁ x ⃗) = refl
  eval≡interp swap₊ (inj₂ y ⃗) = refl
  eval≡interp swap₊ (inj₁ x ⃖) = refl
  eval≡interp swap₊ (inj₂ y ⃖) = refl
  eval≡interp assocl₊ (inj₁ x ⃗) = refl
  eval≡interp assocl₊ (inj₂ (inj₁ y) ⃗) = refl
  eval≡interp assocl₊ (inj₂ (inj₂ z) ⃗) = refl
  eval≡interp assocl₊ (inj₁ (inj₁ x) ⃖) = refl
  eval≡interp assocl₊ (inj₁ (inj₂ y) ⃖) = refl
  eval≡interp assocl₊ (inj₂ z ⃖) = refl
  eval≡interp assocr₊ (inj₁ (inj₁ x) ⃗) = refl
  eval≡interp assocr₊ (inj₁ (inj₂ y) ⃗) = refl
  eval≡interp assocr₊ (inj₂ z ⃗) = refl
  eval≡interp assocr₊ (inj₁ x ⃖) = refl
  eval≡interp assocr₊ (inj₂ (inj₁ y) ⃖) = refl
  eval≡interp assocr₊ (inj₂ (inj₂ z) ⃖) = refl
  eval≡interp unite⋆l ((tt , v) ⃗) = refl
  eval≡interp unite⋆l (v ⃖) = refl
  eval≡interp uniti⋆l (v ⃗) = refl
  eval≡interp uniti⋆l ((tt , v) ⃖) = refl
  eval≡interp swap⋆ ((x , y) ⃗) = refl
  eval≡interp swap⋆ ((y , x) ⃖) = refl
  eval≡interp assocl⋆ ((x , (y , z)) ⃗) = refl
  eval≡interp assocl⋆ (((x , y) , z) ⃖) = refl
  eval≡interp assocr⋆ (((x , y) , z) ⃗) = refl
  eval≡interp assocr⋆ ((x , (y , z)) ⃖) = refl
  eval≡interp absorbr (() ⃗)
  eval≡interp absorbr (() ⃖)
  eval≡interp factorzl (() ⃗)
  eval≡interp factorzl (() ⃖)
  eval≡interp dist ((inj₁ x , z) ⃗) = refl
  eval≡interp dist ((inj₂ y , z) ⃗) = refl
  eval≡interp dist (inj₁ (x , z) ⃖) = refl
  eval≡interp dist (inj₂ (y , z) ⃖) = refl
  eval≡interp factor (inj₁ (x , z) ⃗) = refl
  eval≡interp factor (inj₂ (y , z) ⃗) = refl
  eval≡interp factor ((inj₁ x , z) ⃖) = refl
  eval≡interp factor ((inj₂ y , z) ⃖) = refl
  eval≡interp id↔ (v ⃗) = refl
  eval≡interp id↔ (v ⃖) = refl
  eval≡interp η₊ (inj₁ x ⃖) = refl
  eval≡interp η₊ (inj₂ (- x) ⃖) = refl
  eval≡interp ε₊ (inj₁ x ⃗) = refl
  eval≡interp ε₊ (inj₂ (- x) ⃗) = refl
  eval≡interp (ηₓ v) (tt ⃗) = refl
  eval≡interp (ηₓ v) ((v' , ↻) ⃖) with v ≟ v'
  ... | yes refl = refl
  ... | no  neq  = refl
  eval≡interp (εₓ v) ((v' , ↻) ⃗) with v ≟ v'
  ... | yes refl = refl
  ... | no  neq  = refl
  eval≡interp (εₓ v) (tt ⃖) = refl
  eval≡interp (c₁ ⨾ c₂) (a ⃗) with interp c₁ (a ⃗) | inspect (interp c₁) (a ⃗)
  eval≡interp (c₁ ⨾ c₂) (a ⃗) | just (b ⃗)  | [ eq₁ ] = lem
    where
    rs : ⟨ c₁ ⨾ c₂ ∣ a ∣ ☐ ⟩▷ ↦* ［ c₁ ∣ b ∣ ☐⨾ c₂ • ☐ ］▷
    rs = ↦⃗₃ ∷ appendκ↦* ((getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (a ⃗)) eq₁))) (λ ()) (λ ()) refl (☐⨾ c₂ • ☐)

    rs' : ［ c₁ ∣ b ∣ ☐⨾ c₂ • ☐ ］▷ ↦* (toState (c₁ ⨾ c₂) (eval (c₁ ⨾ c₂) (a ⃗)))
    rs' = proj₁ (deterministic*' rs (getₜᵣ⃗ (c₁ ⨾ c₂) refl) (is-stuck-toState _ _))

    lem : eval (c₁ ⨾ c₂) (a ⃗) ≡ (c₁ ⨾[ b ⃗]⨾ c₂)
    lem = proj₁ (loop (len↦ rs') b) rs' refl
  eval≡interp (c₁ ⨾ c₂) (a ⃗) | just (a₁ ⃖) | [ eq₁ ] = lem
    where
    rs : ⟨ c₁ ⨾ c₂ ∣ a ∣ ☐ ⟩▷ ↦* ⟨ c₁ ⨾ c₂ ∣ a₁ ∣ ☐ ⟩◁
    rs = ↦⃗₃ ∷ appendκ↦* ((getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (a ⃗)) eq₁))) (λ ()) (λ ()) refl (☐⨾ c₂ • ☐) ++↦ ↦⃖₃ ∷ ◾

    lem : eval (c₁ ⨾ c₂) (a ⃗) ≡ just (a₁ ⃖)
    lem = eval-toState₁ rs
  eval≡interp (c₁ ⨾ c₂) (a ⃗) | nothing     | [ eq₁ ] = lem
    where
    rs' : ⟨ c₁ ⨾ c₂ ∣ a ∣ ☐ ⟩▷ ↦* ⊠
    rs' = ↦⃗₃ ∷ appendκ↦*⊠ ((getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (a ⃗)) eq₁))) (λ ()) (☐⨾ c₂ • ☐)

    lem : eval (c₁ ⨾ c₂) (a ⃗) ≡ nothing
    lem = eval-toState₁ rs'
  eval≡interp (c₁ ⨾ c₂) (c ⃖) with interp c₂ (c ⃖) | inspect (interp c₂) (c ⃖)
  eval≡interp (c₁ ⨾ c₂) (c ⃖) | just (c' ⃗) | [ eq' ] = lem
    where
    rs' : ［ c₁ ⨾ c₂ ∣ c ∣ ☐ ］◁ ↦* ［ c₁ ⨾ c₂ ∣ c' ∣ ☐ ］▷
    rs' = ↦⃖₁₀ ∷ appendκ↦* ((getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (c ⃖)) eq'))) (λ ()) (λ ()) refl (c₁ ⨾☐• ☐) ++↦ ↦⃗₁₀ ∷ ◾

    lem : eval (c₁ ⨾ c₂) (c ⃖) ≡ just (c' ⃗)
    lem = eval-toState₂ rs'
  eval≡interp (c₁ ⨾ c₂) (c ⃖) | just (b ⃖)  | [ eq' ] = lem
    where
    rs : ［ c₁ ⨾ c₂ ∣ c ∣ ☐ ］◁ ↦* ⟨ c₂ ∣ b ∣ c₁ ⨾☐• ☐ ⟩◁
    rs = ↦⃖₁₀ ∷ appendκ↦* ((getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (c ⃖)) eq'))) (λ ()) (λ ()) refl (c₁ ⨾☐• ☐)

    rs' : ⟨ c₂ ∣ b ∣ c₁ ⨾☐• ☐ ⟩◁ ↦* (toState (c₁ ⨾ c₂) (eval (c₁ ⨾ c₂) (c ⃖)))
    rs' = proj₁ (deterministic*' rs (getₜᵣ⃖ (c₁ ⨾ c₂) refl) (is-stuck-toState _ _))

    lem : eval (c₁ ⨾ c₂) (c ⃖) ≡ (c₁ ⨾[ b ⃖]⨾ c₂)
    lem = proj₂ (loop (len↦ rs') b) rs' refl
  eval≡interp (c₁ ⨾ c₂) (c ⃖) | nothing     | [ eq' ] = lem
    where
    rs' : ［ c₁ ⨾ c₂ ∣ c ∣ ☐ ］◁ ↦* ⊠
    rs' = ↦⃖₁₀ ∷ appendκ↦*⊠ ((getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (c ⃖)) eq'))) (λ ()) (c₁ ⨾☐• ☐)

    lem : eval (c₁ ⨾ c₂) (c ⃖) ≡ nothing
    lem = eval-toState₂ rs'
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃗) with interp c₁ (x ⃗) | inspect (interp c₁) (x ⃗)
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃗) | just (x₁ ⃗) | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊕ c₂ ∣ inj₁ x ∣ ☐ ⟩▷ ↦* ［ c₁ ⊕ c₂ ∣ inj₁ x₁ ∣ ☐ ］▷
    rs' = ↦⃗₄ ∷ appendκ↦* (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (λ ()) refl (☐⊕ c₂ • ☐) ++↦ ↦⃗₁₁ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃗) | just (x₁ ⃖) | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊕ c₂ ∣ inj₁ x ∣ ☐ ⟩▷ ↦* ⟨ c₁ ⊕ c₂ ∣ inj₁ x₁ ∣ ☐ ⟩◁
    rs' = ↦⃗₄ ∷ appendκ↦* (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (λ ()) refl (☐⊕ c₂ • ☐) ++↦ ↦⃖₄ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃗) | nothing      | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊕ c₂ ∣ inj₁ x ∣ ☐ ⟩▷ ↦* ⊠
    rs' = ↦⃗₄ ∷ appendκ↦*⊠ (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (☐⊕ c₂ • ☐)
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃗) with interp c₂ (y ⃗) | inspect (interp c₂) (y ⃗)
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃗) | just (y₁ ⃗) | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊕ c₂ ∣ inj₂ y ∣ ☐ ⟩▷ ↦* ［ c₁ ⊕ c₂ ∣ inj₂ y₁ ∣ ☐ ］▷
    rs' = ↦⃗₅ ∷ appendκ↦* (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (y ⃗)) eq₁)) (λ ()) (λ ()) refl (c₁ ⊕☐• ☐) ++↦ ↦⃗₁₂ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃗) | just (y₁ ⃖) | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊕ c₂ ∣ inj₂ y ∣ ☐ ⟩▷ ↦* ⟨ c₁ ⊕ c₂ ∣ inj₂ y₁ ∣ ☐ ⟩◁
    rs' = ↦⃗₅ ∷ appendκ↦* (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (y ⃗)) eq₁)) (λ ()) (λ ()) refl (c₁ ⊕☐• ☐) ++↦ ↦⃖₅ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃗) | nothing      | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊕ c₂ ∣ inj₂ y ∣ ☐ ⟩▷ ↦* ⊠
    rs' = ↦⃗₅ ∷ appendκ↦*⊠ (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (y ⃗)) eq₁)) (λ ()) (c₁ ⊕☐• ☐)
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃖) with interp c₁ (x ⃖) | inspect (interp c₁) (x ⃖)
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃖) | just (x₁ ⃗) | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊕ c₂ ∣ inj₁ x ∣ ☐ ］◁ ↦* ［ c₁ ⊕ c₂ ∣ inj₁ x₁ ∣ ☐ ］▷
    rs' = ↦⃖₁₁ ∷ appendκ↦* (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (x ⃖)) eq₁)) (λ ()) (λ ()) refl (☐⊕ c₂ • ☐) ++↦ ↦⃗₁₁ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃖) | just (x₁ ⃖) | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊕ c₂ ∣ inj₁ x ∣ ☐ ］◁ ↦* ⟨ c₁ ⊕ c₂ ∣ inj₁ x₁ ∣ ☐ ⟩◁
    rs' = ↦⃖₁₁ ∷ appendκ↦* (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (x ⃖)) eq₁)) (λ ()) (λ ()) refl (☐⊕ c₂ • ☐) ++↦ ↦⃖₄ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₁ x ⃖) | nothing     | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊕ c₂ ∣ inj₁ x ∣ ☐ ］◁ ↦* ⊠
    rs' = ↦⃖₁₁ ∷ appendκ↦*⊠ (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (x ⃖)) eq₁)) (λ ()) (☐⊕ c₂ • ☐)
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃖) with interp c₂ (y ⃖) | inspect (interp c₂) (y ⃖)
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃖) | just (y₁ ⃗) | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊕ c₂ ∣ inj₂ y ∣ ☐ ］◁ ↦* ［ c₁ ⊕ c₂ ∣ inj₂ y₁ ∣ ☐ ］▷
    rs' = ↦⃖₁₂ ∷ appendκ↦* (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₁)) (λ ()) (λ ()) refl (c₁ ⊕☐• ☐) ++↦ ↦⃗₁₂ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃖) | just (y₁ ⃖) | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊕ c₂ ∣ inj₂ y ∣ ☐ ］◁ ↦* ⟨ c₁ ⊕ c₂ ∣ inj₂ y₁ ∣ ☐ ⟩◁
    rs' = ↦⃖₁₂ ∷ appendκ↦* (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₁)) (λ ()) (λ ()) refl (c₁ ⊕☐• ☐) ++↦ ↦⃖₅ ∷ ◾
  eval≡interp (c₁ ⊕ c₂) (inj₂ y ⃖) | nothing     | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊕ c₂ ∣ inj₂ y ∣ ☐ ］◁ ↦* ⊠
    rs' = ↦⃖₁₂ ∷ appendκ↦*⊠ (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₁)) (λ ()) (c₁ ⊕☐• ☐)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃗) with interp c₁ (x ⃗) | inspect (interp c₁) (x ⃗)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃗) | just (x₁ ⃗) | [ eq₁ ] with interp c₂ (y ⃗) | inspect (interp c₂) (y ⃗)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃗) | just (x₁ ⃗) | [ eq₁ ] | just (y₁ ⃗) | [ eq₂ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ⟩▷ ↦* ［ c₁ ⊗ c₂ ∣ (x₁ , y₁) ∣ ☐ ］▷
    rs' = ↦⃗₆ ∷ appendκ↦* (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (λ ()) refl (☐⊗[ c₂ , y ]• ☐) ++↦
          ↦⃗₈ ∷ appendκ↦* (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (y ⃗)) eq₂)) (λ ()) (λ ()) refl ([ c₁ , x₁ ]⊗☐• ☐) ++↦ ↦⃗₉ ∷ ◾
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃗) | just (x₁ ⃗) | [ eq₁ ] | just (y₁ ⃖) | [ eq₂ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ⟩▷ ↦* ⟨ c₁ ⊗ c₂ ∣ (x , y₁) ∣ ☐ ⟩◁
    rs' = ↦⃗₆ ∷ appendκ↦* (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (λ ()) refl (☐⊗[ c₂ , y ]• ☐) ++↦
          ↦⃗₈ ∷ appendκ↦* (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (y ⃗)) eq₂)) (λ ()) (λ ()) refl ([ c₁ , x₁ ]⊗☐• ☐) ++↦
          ↦⃖₈ ∷ Rev* (appendκ↦* (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (λ ()) refl (☐⊗[ c₂ , y₁ ]• ☐)) (λ ()) (λ ()) ++↦ ↦⃖₆ ∷ ◾
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃗) | just (x₁ ⃗) | [ eq₁ ] | nothing     | [ eq₂ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ⟩▷ ↦* ⊠
    rs' = ↦⃗₆ ∷ appendκ↦* (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (λ ()) refl (☐⊗[ c₂ , y ]• ☐) ++↦
          ↦⃗₈ ∷ appendκ↦*⊠ (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (y ⃗)) eq₂)) (λ ()) ([ c₁ , x₁ ]⊗☐• ☐)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃗) | just (x₁ ⃖) | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ⟩▷ ↦* ⟨ c₁ ⊗ c₂ ∣ (x₁ , y) ∣ ☐ ⟩◁
    rs' = ↦⃗₆ ∷ appendκ↦* (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (λ ()) refl (☐⊗[ c₂ , y ]• ☐) ++↦ ↦⃖₆ ∷ ◾
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃗) | nothing     | [ eq₁ ] = eval-toState₁ rs'
    where
    rs' : ⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ⟩▷ ↦* ⊠
    rs' = ↦⃗₆ ∷ appendκ↦*⊠ (getₜᵣ⃗ c₁ (trans (eval≡interp c₁ (x ⃗)) eq₁)) (λ ()) (☐⊗[ c₂ , y ]• ☐)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃖) with interp c₂ (y ⃖) | inspect (interp c₂) (y ⃖)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃖) | just (y₁ ⃗) | [ eq₂ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ］◁ ↦* ［ c₁ ⊗ c₂ ∣ (x , y₁) ∣ ☐ ］▷
    rs' = ↦⃖₉ ∷ appendκ↦* (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₂)) (λ ()) (λ ()) refl ([ c₁ , x ]⊗☐• ☐) ++↦ ↦⃗₉ ∷ ◾
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃖) | just (y₁ ⃖) | [ eq₂ ] with interp c₁ (x ⃖) | inspect (interp c₁) (x ⃖)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃖) | just (y₁ ⃖) | [ eq₂ ] | just (x₁ ⃗) | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ］◁ ↦* ［ c₁ ⊗ c₂ ∣ (x₁ , y) ∣ ☐ ］▷
    rs' = ↦⃖₉ ∷ appendκ↦* (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₂)) (λ ()) (λ ()) refl ([ c₁ , x ]⊗☐• ☐) ++↦
          ↦⃖₈ ∷ appendκ↦* (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (x ⃖)) eq₁)) (λ ()) (λ ()) refl (☐⊗[ c₂ , y₁ ]• ☐) ++↦
          ↦⃗₈ ∷ Rev* (appendκ↦* (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₂)) (λ ()) (λ ()) refl ([ c₁ , x₁ ]⊗☐• ☐)) (λ ()) (λ ()) ++↦ ↦⃗₉ ∷ ◾
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃖) | just (y₁ ⃖) | [ eq₂ ] | just (x₁ ⃖) | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ］◁ ↦* ⟨ c₁ ⊗ c₂ ∣ (x₁ , y₁) ∣ ☐ ⟩◁
    rs' = ↦⃖₉ ∷ appendκ↦* (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₂)) (λ ()) (λ ()) refl ([ c₁ , x ]⊗☐• ☐) ++↦
          ↦⃖₈ ∷ appendκ↦* (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (x ⃖)) eq₁)) (λ ()) (λ ()) refl (☐⊗[ c₂ , y₁ ]• ☐) ++↦ ↦⃖₆ ∷ ◾
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃖) | just (y₁ ⃖) | [ eq₂ ] | nothing     | [ eq₁ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ］◁ ↦* ⊠
    rs' = ↦⃖₉ ∷ appendκ↦* (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₂)) (λ ()) (λ ()) refl ([ c₁ , x ]⊗☐• ☐) ++↦
          ↦⃖₈ ∷ appendκ↦*⊠ (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (x ⃖)) eq₁)) (λ ()) (☐⊗[ c₂ , y₁ ]• ☐)
  eval≡interp (c₁ ⊗ c₂) ((x , y) ⃖) | nothing     | [ eq₂ ] = eval-toState₂ rs'
    where
    rs' : ［ c₁ ⊗ c₂ ∣ (x , y) ∣ ☐ ］◁ ↦* ⊠
    rs' = ↦⃖₉ ∷ appendκ↦*⊠ (getₜᵣ⃖ c₂ (trans (eval≡interp c₂ (y ⃖)) eq₂)) (λ ()) ([ c₁ , x ]⊗☐• ☐)

  private
    loop : ∀ {A B C x} {c₁ : A ↔ B} {c₂ : B ↔ C} (n : ℕ)
         → ∀ b → ((rs : ［ c₁ ∣ b ∣ ☐⨾ c₂ • ☐ ］▷ ↦* toState (c₁ ⨾ c₂) x) → len↦ rs ≡ n → x ≡ c₁ ⨾[ b ⃗]⨾ c₂)
               × ((rs : ⟨ c₂ ∣ b ∣ c₁ ⨾☐• ☐ ⟩◁ ↦* toState (c₁ ⨾ c₂) x) → len↦ rs ≡ n → x ≡ c₁ ⨾[ b ⃖]⨾ c₂)
    loop {A} {B} {C} {x} {c₁} {c₂} = <′-rec (λ n → _) loop-rec
      where
      loop-rec : (n : ℕ) → (∀ m → m <′ n → _) → _
      loop-rec n R b = loop₁ , loop₂
        where
        loop₁ : (rs : ［ c₁ ∣ b ∣ ☐⨾ c₂ • ☐ ］▷ ↦* toState (c₁ ⨾ c₂) x) → len↦ rs ≡ n → x ≡ c₁ ⨾[ b ⃗]⨾ c₂
        loop₁ rs refl with interp c₂ (b ⃗) | inspect (interp c₂) (b ⃗)
        loop₁ rs refl | just (c ⃗)  | [ eq ] = toState≡₁ (deterministic* rs rs' (is-stuck-toState _ _) (λ ()))
          where
          rs' : ［ c₁ ∣ b ∣ ☐⨾ c₂ • ☐ ］▷ ↦* ［ c₁ ⨾ c₂ ∣ c ∣ ☐ ］▷
          rs' = ↦⃗₇ ∷ appendκ↦* (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (b ⃗)) eq)) (λ ()) (λ ()) refl (c₁ ⨾☐• ☐) ++↦ ↦⃗₁₀ ∷ ◾
        loop₁ rs refl | just (b' ⃖) | [ eq ] = proj₂ (R (len↦ rs'') le b') rs'' refl
          where
          rs' : ［ c₁ ∣ b ∣ ☐⨾ c₂ • ☐ ］▷ ↦* ⟨ c₂ ∣ b' ∣ c₁ ⨾☐• ☐ ⟩◁
          rs' = ↦⃗₇ ∷ appendκ↦* (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (b ⃗)) eq)) (λ ()) (λ ()) refl (c₁ ⨾☐• ☐)

          rs'' : ⟨ c₂ ∣ b' ∣ c₁ ⨾☐• ☐ ⟩◁ ↦* toState (c₁ ⨾ c₂) x
          rs'' = proj₁ (deterministic*' rs' rs (is-stuck-toState _ _))

          req : len↦ rs ≡ len↦ rs' + len↦ rs''
          req = proj₂ (deterministic*' rs' rs (is-stuck-toState _ _))

          le : len↦ rs'' <′ len↦ rs
          le rewrite req = s≤′s (n≤′m+n _ _)
        loop₁ rs refl | nothing     | [ eq ] = toState≡₃ (deterministic* rs rs' (is-stuck-toState _ _) (λ ()))
          where
          rs' : ［ c₁ ∣ b ∣ ☐⨾ c₂ • ☐ ］▷ ↦* ⊠
          rs' = ↦⃗₇ ∷ appendκ↦*⊠ (getₜᵣ⃗ c₂ (trans (eval≡interp c₂ (b ⃗)) eq)) (λ ()) (c₁ ⨾☐• ☐)
        loop₂ : (rs : ⟨ c₂ ∣ b ∣ c₁ ⨾☐• ☐ ⟩◁ ↦* toState (c₁ ⨾ c₂) x) → len↦ rs ≡ n → x ≡ c₁ ⨾[ b ⃖]⨾ c₂
        loop₂ rs refl with interp c₁ (b ⃖) | inspect (interp c₁) (b ⃖)
        loop₂ rs refl | just (b' ⃗) | [ eq ] = proj₁ (R (len↦ rs'') le b') rs'' refl
          where
          rs' : ⟨ c₂ ∣ b ∣ c₁ ⨾☐• ☐ ⟩◁ ↦* ［ c₁ ∣ b' ∣ ☐⨾ c₂ • ☐ ］▷
          rs' = ↦⃖₇ ∷ appendκ↦* (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (b ⃖)) eq)) (λ ()) (λ ()) refl (☐⨾ c₂ • ☐)

          rs'' : ［ c₁ ∣ b' ∣ ☐⨾ c₂ • ☐ ］▷ ↦* toState (c₁ ⨾ c₂) x
          rs'' = proj₁ (deterministic*' rs' rs (is-stuck-toState _ _))

          req : len↦ rs ≡ len↦ rs' + len↦ rs''
          req = proj₂ (deterministic*' rs' rs (is-stuck-toState _ _))

          le : len↦ rs'' <′ len↦ rs
          le rewrite req = s≤′s (n≤′m+n _ _)
        loop₂ rs refl | just (a ⃖)  | [ eq ] = toState≡₂ (deterministic* rs rs' (is-stuck-toState _ _) (λ ()))
          where
          rs' : ⟨ c₂ ∣ b ∣ c₁ ⨾☐• ☐ ⟩◁ ↦* ⟨ c₁ ⨾ c₂ ∣ a ∣ ☐ ⟩◁
          rs' = ↦⃖₇ ∷ appendκ↦* (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (b ⃖)) eq)) (λ ()) (λ ()) refl (☐⨾ c₂ • ☐) ++↦ ↦⃖₃ ∷ ◾
        loop₂ rs refl | nothing     | [ eq ] = toState≡₃ (deterministic* rs rs' (is-stuck-toState _ _) (λ ()))
          where
          rs' : ⟨ c₂ ∣ b ∣ c₁ ⨾☐• ☐ ⟩◁ ↦* ⊠
          rs' = ↦⃖₇ ∷ appendκ↦*⊠ (getₜᵣ⃖ c₁ (trans (eval≡interp c₁ (b ⃖)) eq)) (λ ()) (☐⨾ c₂ • ☐)


open import Data.Empty using (⊥-elim)
open import Data.Fin using (Fin; _≟_)
open import Data.Nat using (ℕ)
open import Data.Vec using (lookup; _[_]≔_)
open import Data.Vec.Properties using (lookup∘update; lookup∘update′; []≔-commutes; []≔-idempotent; []≔-lookup)
open import Relation.Nullary using (yes; no; ¬_)
open import Relation.Binary.PropositionalEquality using (sym; trans; _≡_; refl; cong; _≢_; module ≡-Reasoning)
open import Data.Product using (∃-syntax; _,_; proj₁; proj₂; _×_)
open ≡-Reasoning

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

soundness :
  ∀ { n : ℕ } { act : Action n } { c g g′ }
  -> g ↔ c
  -> g - act →g g′
  -> ∃[ c′ ] c - act →c c′ × g′ ↔ c′
soundness
  {n = n}
  {act = act@(action .p .q p≢q .l)}
  {c = c}
  {g = g@(msgSingle p q p≢q-gt l g′)}
  {g′ = .g′}
  assoc
  →g-prefix
  = c′ , (→c-comm c p≢q refl refl refl lpReduce lqReduce , g′↔c′)
  where
    config-without-prefix = config-gt-remove-prefix g c assoc refl
    c′ = proj₁ config-without-prefix
    g′↔c′ : g′ ↔ c′
    g′↔c′ = proj₂ (proj₂ config-without-prefix)
    lpReduce : (p , lookup c p) - act →l (p , project g′ p)
    lpReduce rewrite _↔_.isProj assoc p
      = →l-send p (proj-prefix-send p q g′ p≢q-gt) p≢q
    lqReduce : (q , lookup c q) - act →l (q , project g′ q)
    lqReduce rewrite _↔_.isProj assoc q
      = →l-recv q (proj-prefix-recv p q g′ p≢q-gt) p≢q
soundness
  {n = n}
  {act = act@(.action p q p≢q l)}
  {c = c}
  {g = g@(msgSingle r s r≢s l′ gSub)}
  {g′ = g′@(.msgSingle r s r≢s l′ gSub′)}
  assoc
  (→g-cont gReduce p≢r q≢r p≢s q≢s)
  = c′ , cReduce , assoc′
  where
    config-without-prefix = config-gt-remove-prefix g c assoc refl
    cSub = proj₁ config-without-prefix
    gSub↔cSub : gSub ↔ cSub
    gSub↔cSub = proj₂ (proj₂ config-without-prefix)
    soundness-gSub : ∃[ cSub′ ] cSub - act →c cSub′ × gSub′ ↔ cSub′
    soundness-gSub = soundness gSub↔cSub gReduce
    c′ : Configuration n
    c′ with soundness-gSub
    ... | cSub′ , _ , _ = (cSub′ [ r ]≔ lr′) [ s ]≔ ls′
      where
        lr′ : Local n
        lr′ with soundness-gSub
        ...   | cSub′ , _ , _ = sendSingle s l′ (lookup cSub′ r)
        ls′ : Local n
        ls′ with soundness-gSub
        ...   | cSub′ , _ , _ = recvSingle r l′ (lookup cSub′ s)
    isProj-g′ : ∀(t : Fin n) -> lookup c′ t ≡ project g′ t
    isProj-g′ t with soundness-gSub
    ...   | cSub′ , _ , gSub′↔cSub′
        with r ≟ t   | s ≟ t
    ...   | yes r≡t  | no _
        rewrite sym r≡t
        rewrite lookup∘update′ r≢s (cSub′ [ r ]≔ sendSingle s l′ (lookup cSub′ r)) (recvSingle r l′ (lookup cSub′ s))
        rewrite lookup∘update r cSub′ (sendSingle s l′ (lookup cSub′ r))
        rewrite _↔_.isProj gSub′↔cSub′ r = refl
    ...   | no _     | yes s≡t
        rewrite sym s≡t
        rewrite lookup∘update s (cSub′ [ r ]≔ sendSingle s l′ (lookup cSub′ r)) (recvSingle r l′ (lookup cSub′ s))
        rewrite _↔_.isProj gSub′↔cSub′ s = refl
    ...   | no r≢t   | no s≢t
        rewrite lookup∘update′ (¬≡-flip s≢t) (cSub′ [ r ]≔ sendSingle s l′ (lookup cSub′ r)) (recvSingle r l′ (lookup cSub′ s))
        rewrite lookup∘update′ (¬≡-flip r≢t) cSub′ (sendSingle s l′ (lookup cSub′ r))
        rewrite _↔_.isProj gSub′↔cSub′ t = refl
    ...   | yes refl | yes refl = ⊥-elim (r≢s refl)
    assoc′ : g′ ↔ c′
    assoc′ = record { isProj = isProj-g′ }
    cReduce : c - act →c c′
    cReduce with soundness-gSub
    ...   | cSub′ , →c-comm {lp = lp} {lp′ = lp′} {lq = lq} {lq′ = lq′} .cSub .p≢q refl refl refl lpReduce lqReduce , gSub′↔cSub′
            = →c-comm c p≢q lp≡c[p] lq≡c[q] c→c′ lpReduce lqReduce
      where
        lr′ = sendSingle s l′ (lookup cSub′ r)
        ls′ = recvSingle r l′ (lookup cSub′ s)
        lp≡c[p] : lp ≡ lookup c p
        lp≡c[p]
          rewrite lookup∘update′ p≢s (c [ r ]≔ project gSub r) (project gSub s)
          rewrite lookup∘update′ p≢r c (project gSub r) = refl
        lq≡c[q] : lq ≡ lookup c q
        lq≡c[q]
          rewrite lookup∘update′ q≢s (c [ r ]≔ project gSub r) (project gSub s)
          rewrite lookup∘update′ q≢r c (project gSub r) = refl
        lr′≡c[r] : lr′ ≡ lookup c r
        lr′≡c[r]
          rewrite lookup∘update′ (¬≡-flip q≢r) (cSub [ p ]≔ lp′) lq′
          rewrite lookup∘update′ (¬≡-flip p≢r) cSub lp′
          rewrite _↔_.isProj assoc r
          rewrite proj-prefix-send {l = l′} r s gSub r≢s
          rewrite lookup∘update′ r≢s (c [ r ]≔ project gSub r) (project gSub s)
          rewrite lookup∘update r c (project gSub r)
          = refl
        ls′≡c[s] : ls′ ≡ lookup c s
        ls′≡c[s]
          rewrite lookup∘update′ (¬≡-flip q≢s) (cSub [ p ]≔ lp′) lq′
          rewrite lookup∘update′ (¬≡-flip p≢s) cSub lp′
          rewrite _↔_.isProj assoc s
          rewrite proj-prefix-recv {l = l′} r s gSub r≢s
          rewrite lookup∘update s (c [ r ]≔ project gSub r) (project gSub s)
          = refl
        c→c′ : (cSub′ [ r ]≔ lr′) [ s ]≔ ls′ ≡ (c [ p ]≔ lp′) [ q ]≔ lq′
        c→c′
          rewrite []≔-commutes ((((c [ r ]≔ project gSub r) [ s ]≔ project gSub s) [ p ]≔ lp′) [ q ]≔ lq′) r s {lr′} {ls′} r≢s
          rewrite []≔-commutes (((c [ r ]≔ project gSub r) [ s ]≔ project gSub s) [ p ]≔ lp′) q s {lq′} {ls′} q≢s
          rewrite []≔-commutes ((c [ r ]≔ project gSub r) [ s ]≔ project gSub s) p s {lp′} {ls′} p≢s
          rewrite []≔-idempotent (c [ r ]≔ project gSub r) s {project gSub s} {ls′}
          rewrite []≔-commutes (((c [ r ]≔ project gSub r) [ s ]≔ ls′) [ p ]≔ lp′) q r {lq′} {lr′} q≢r
          rewrite []≔-commutes ((c [ r ]≔ project gSub r) [ s ]≔ ls′) p r {lp′} {lr′} p≢r
          rewrite []≔-commutes (c [ r ]≔ project gSub r) s r {ls′} {lr′} (¬≡-flip r≢s)
          rewrite []≔-idempotent c r {project gSub r} {lr′}
          rewrite lr′≡c[r]
          rewrite ls′≡c[s]
          rewrite []≔-lookup c r
          rewrite []≔-lookup c s
          = refl


open import Prelude hiding (begin_; step-≡; _∎)

module MJ.Classtable.Core (c : ℕ) where

open import Data.Product.Relation.Binary.Pointwise.NonDependent using (_×-≟_)
open import Data.List
open import Data.List.Membership.Propositional
open import Data.List.Relation.Binary.Pointwise using (decidable-≡)
open import Relation.Binary
open import Data.Vec
open import Data.Maybe
open import Data.String

open import Relation.Binary using (Decidable)

open import MJ.Types as Types

{-
To model that a class may define both field and methods in a uniform manner, we
choose to introduce two namespaces.
-}
data NS : Set where
  METHOD : NS
  FIELD  : NS

typing : NS → Set
typing METHOD = Sig c
typing FIELD = Ty c

-- decidable equality on typings
_typing-≟_ : ∀ {ns} → Decidable (_≡_ {A = typing ns})
_typing-≟_ {METHOD} = (decidable-≡ Types._≟_) ×-≟ Types._≟_
_typing-≟_ {FIELD}  = Types._≟_

{-
We choose to make parent declarations obligatory and have a distinguished class
identifier Object in which inheritance chains find their foundation.

The field constr of this record provides access to the constructor parameter types.

The field decls returns a list of named members for each namespace, where the
type of the member is namespace-dependent. The uniformity of member definitions
permits a notion of membership that works for both fields and methods:
-}
record Class : Set where
  constructor class
  field
    parent  : Cid c
    constr  : List (Ty c) -- argument types
    decls   : (ns : NS) → List (String × typing ns)

ObjectClass = class Object [] (λ _ → [])

{-
Conceptually a class table stores the types of all members of all classes.
It is modeled by a total function from class identifiers to instances of
a record Class.
-}
PreClasstable = Cid c → Class

{-
We can define inheritance as the transitive closure of a step relation
between class identifiers under a given classtable Σ:
-}
data _⊢_<:ₛ_ (Σ : PreClasstable) : Cid c → Cid c → Set where
  super : ∀ {cid} → Σ ⊢ cls cid <:ₛ (Class.parent (Σ (cls cid)))

open import Data.Star
_⊢_<:_ : (Σ : PreClasstable)(cid : Cid c) → (pid : Cid c) → Set
_⊢_<:_ Σ = Star (_⊢_<:ₛ_ Σ)

{-
We'll restrict classtables to those that satisfy three properties:

- founded: says that Object is at the base of sub-typing
- rooted: says that every class inherits from Object
- Σ-object: gives meaning to the distinguished Object class identifier
-}
record Classtable : Set where
  field
    Σ        : PreClasstable
    founded  : Class.parent (Σ Object) ≡ Object
    rooted   : ∀ C → Σ ⊢ C <: Object
    Σ-Object : Σ Object ≡ ObjectClass

  _<∶_ : ∀ (cid pid : Cid c) → Set
  a <∶ b = Σ ⊢ a <: b

  open import Relation.Binary
  open import Data.Nat.Properties

  {-
  We can show that the subtyping relation is indeed reflexive and transitive
  -}
  <:-reflexive  : Reflexive (_⊢_<:_ Σ)
  <:-reflexive  = ε

  <:-transitive : Transitive (_⊢_<:_ Σ)
  <:-transitive = _◅◅_

  {-
  From the axioms of the classtable we can derive the important properties
  that cyclic inheritance is impossible and that consequently inheritance
  proofs are unique.

  The proof is slightly involved because we have to make sure that Agda
  believes that it is total.
  -}
  private
    len : ∀ {c p} → Σ ⊢ c <: p → ℕ
    len ε = 0
    len (x ◅ px) = suc $ len px

    len-◅◅ : ∀ {c p p'}(s : Σ ⊢ c <: p)(s' : Σ ⊢ p <: p') → len (s ◅◅ s') ≡ len s + len s'
    len-◅◅ ε _ = refl
    len-◅◅ (x ◅ s) s' rewrite len-◅◅ s s' = refl

    lem-len : ∀ {c p}(px : Σ ⊢ c <: p)(qx : Σ ⊢ c <: Object) → len px ≤ len qx
    lem-len ε ε = z≤n
    lem-len ε (x ◅ qx) = z≤n
    lem-len (() ◅ px) ε
    lem-len (super ◅ px) (super ◅ qx) = s≤s (lem-len px qx)

    open ≤-Reasoning

    -- generate an inheritance proof of arbitrary length,
    -- given an inheritance proof from a parent to a child
    lem-inf : ∀ c → Σ ⊢ Class.parent (Σ (cls c)) <: (cls c) → ∀ n → ∃ λ (px : Σ ⊢ (cls c) <: (cls c)) → len px > n
    lem-inf c px n with helper px n
      where
        helper : (p : Σ ⊢ Class.parent (Σ (cls c)) <: (cls c)) → ∀ gap → ∃ λ (px : Σ ⊢ (cls c) <: (cls c)) → len px ≥ gap + len p
        helper p zero = (super ◅ p) , ≤-step ≤-refl
        helper p (suc gap) with gap ≤? len p
        ... | yes q = (super ◅ p ◅◅ (super ◅ p)) , s≤s (begin
            (gap + len p)
              ≤⟨ +-mono-≤ q (≤-step ≤-refl) ⟩
            len p + (suc (len p))
              ≡⟨ sym (len-◅◅ p (super ◅ p)) ⟩
            len (p ◅◅ super ◅ p)
          ∎)
        ... | no ¬q with helper (p ◅◅ (super ◅ p)) gap
        ... | z , q = z , (begin
            suc (gap + len p)
              ≡⟨ sym $ m+n+o≡n+m+o gap 1 (len p) ⟩
            gap + (len (super ◅ p))
              ≤⟨ +-mono-≤ { gap } ≤-refl (≤-stepsˡ (len p) ≤-refl) ⟩
            gap + (len p + len (super ◅ p))
              ≡⟨ cong (_+_ gap) (sym $ len-◅◅ p (super ◅ p)) ⟩
            gap + (len (p ◅◅ (super ◅ p)))
              ≤⟨ q ⟩
            len z ∎)
          where open import Data.Nat.Properties.Extra
    ... | py , z = super ◅ px ◅◅ py , s≤s (subst (_≤_ n) (sym $ len-◅◅ px py) (≤-stepsˡ (len px) (m+n≤o⇒m≤o n z)))

  -- Proves that a parent can't inherit from it's children,
  Σ-acyclic : ∀ c → ¬ Σ ⊢ Class.parent (Σ (cls c)) <: (cls c)
  Σ-acyclic c px with lem-inf c px (len $ rooted (cls c))
  ... | qx , impossible with lem-len qx (rooted (cls c))
  ... | z = ⊥-elim (<⇒≱ impossible z)

  -- Trivially we have that Object cannot inherit from any class
  ¬Object<:x : ∀ {cid} → ¬ Σ ⊢ Object <: cls cid
  ¬Object<:x (() ◅ p)

  -- Using acyclicity we can show that inheritance proofs are unique
  <:-unique : ∀ {c p} → (l r : Σ ⊢ c <: p) → l ≡ r
  <:-unique ε ε = refl
  <:-unique ε ch@(super ◅ r) = ⊥-elim (Σ-acyclic _ r)
  <:-unique ch@(super ◅ l) ε = ⊥-elim (Σ-acyclic _ l)
  <:-unique (super ◅ l) (super ◅ r) with <:-unique l r
  ... | refl = refl


-- Andreas, 2019-06-17, LAIM 2019, issue #3855
-- Only allow erased definitions in erased context.

open import Common.IO
open import Common.Unit
open import Common.String
open import Common.Bool

@0 noWorld : String
noWorld = "Hallo, Welt!"

-- Illegal definition, should raise a type error.

world : Bool → String
world true  = "Hello world!"
world false = noWorld

main = putStrLn (world false)


data Nat : Set where

record Ord (A : Set) : Set where
  field f : A → A

instance
  OrdNat : Ord Nat
  OrdNat = record { f = λ x → x }

postulate
  T : Nat → Set
  R : ∀ {A} {{_ : Ord A}} → A → Set

-- Before solving the type of m, instance search considers it to
-- be a potential candidate for Ord Nat. It then proceeds to check
-- uniqueness by comparing m and OrdNat. The problem was that this
-- left a constraint m == OrdNat that leaked into the state.
foo : Set
foo = ∀ (n : Nat) m → R n → T m


{-# OPTIONS --erased-cubical #-}

-- Modules that use --cubical can be imported when --erased-cubical is
-- used.

open import Erased-cubical-Open-public.Cubical

-- However, re-exports from such modules, made using module
-- application, can only be used in erased contexts.

_ : Set
_ = A


{-# OPTIONS  --sized-types --show-implicit #-}

module SizedTypesScopeViolationInMeta where

open import Size

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

-- exposing a bug in size constraint solving

-- *** Exception: Inconsistent meta: _73 [[CtxId 420],[CtxId 418]]
A : Set1
A = (Id : {i : Size} -> Nat {_} -> Set)
    (k : Size)(m : Nat {↑ k}) -> Id {k} m
    ->
    (j : Size)(n : Nat {j}) -> Id {j} n

{-
mutual

--   id : {i : Size} -> Nat {_} -> Nat {i}  -- FAILS
  id : {i : Size} -> Nat {i} -> Nat {i}
  id x = x

  succ : {i : Size} -> Nat {i} -> Nat {↑ i}
  succ x = suc (id x)
-}


-- Andreas, 2016-12-29, issue #2363

data Nat : Set where
  zero : Nat
  suc : Nat → Nat

test : Nat → Nat
test (suc n) with zero
test zero | q = zero
test zero = zero

-- Error WAS:
-- With clause pattern zero is not an instance of its parent pattern (suc "n")

-- Expected error:
-- With clause pattern zero is not an instance of its parent pattern (suc n)


module ListTest where
import AlonzoPrelude
import PreludeList
open AlonzoPrelude
open PreludeList
mynil : {A:Set} -> List A
mynil = []

mycons : {A:Set} -> A -> List A -> List A
mycons x xs = x :: xs

head : (A:Set) -> List A -> A
head A (x :: xs) = x


module Issue318 where

data Bool : Set where

module A where
  data _≤_ : Bool → Bool → Set where

open A hiding (_≤_)

data _≤_ : Bool → Bool → Set where


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

open import Base
open import Homotopy.Pushout
open import Homotopy.VanKampen.Guide

module Homotopy.VanKampen.Code.LemmaPackA {i} (d : pushout-diag i)
  (l : legend i (pushout-diag.C d)) where

  open import Homotopy.Truncation
  open import Homotopy.PathTruncation

  private
    module PackA1 (d : pushout-diag i)
      (l : legend i (pushout-diag.C d)) (n : legend.name l) where
      open pushout-diag d
      open legend l

      -- Code from A.
      open import Homotopy.VanKampen.SplitCode d l (f $ loc n)
      -- Code from B. F for `flipped'.
      import Homotopy.VanKampen.SplitCode (pushout-diag-flip d) l (g $ loc n) as F

      private
        ap⇒bp-split : (∀ {a₂} → code-a a₂ → F.code-b a₂)
                    × (∀ {b₂} → code-b b₂ → F.code-a b₂)
        ap⇒bp-split = code-rec-nondep
          F.code-b ⦃ λ _ → F.code-b-is-set _ ⦄
          F.code-a ⦃ λ _ → F.code-a-is-set _ ⦄
          (λ p → F.⟧a refl₀ F.a⟦ n ⟧b p)
          (λ n₁ pco p → pco F.a⟦ n₁ ⟧b p)
          (λ n₁ pco p → pco F.b⟦ n₁ ⟧a p)
          (λ n₁ pco → F.code-b-refl-refl n₁ pco)
          (λ n₁ pco → F.code-a-refl-refl n₁ pco)
          (λ n₁ pco n₂ r → F.code-ba-swap n₁ pco n₂ r)

      aa⇒ba : ∀ {a₂} → code-a a₂ → F.code-b a₂
      aa⇒ba = π₁ ap⇒bp-split
      ab⇒bb : ∀ {b₂} → code-b b₂ → F.code-a b₂
      ab⇒bb = π₂ ap⇒bp-split

  private
    module PackA2 (d : pushout-diag i)
      (l : legend i (pushout-diag.C d)) (n : legend.name l) where
      open pushout-diag d
      open legend l

      -- Code from A.
      open import Homotopy.VanKampen.SplitCode d l (f $ loc n)
      open PackA1 d l n public
      -- Code from B. F for `flipped'.
      private
        module F where
          open import Homotopy.VanKampen.SplitCode (pushout-diag-flip d) l (g $ loc n) public
          open PackA1 (pushout-diag-flip d) l n public

      private
        aba-glue-code-split : (∀ {a₂} (co : code-a a₂) → F.ab⇒bb (aa⇒ba co) ≡ co)
                            × (∀ {b₂} (co : code-b b₂) → F.aa⇒ba (ab⇒bb co) ≡ co)
      abstract
        aba-glue-code-split = code-rec
          (λ {a} co → F.ab⇒bb (aa⇒ba co) ≡ co)
          ⦃ λ _ → ≡-is-set $ code-a-is-set _ ⦄
          (λ {b} co → F.aa⇒ba (ab⇒bb co) ≡ co)
          ⦃ λ _ → ≡-is-set $ code-b-is-set _ ⦄
          (λ p →
            ⟧a refl₀ a⟦ n ⟧b refl₀ b⟦ n ⟧a p
                ≡⟨ code-a-merge n refl₀ p ⟩
            ⟧a refl₀ ∘₀ p
                ≡⟨ ap (λ x → ⟧a x) $ refl₀-left-unit p ⟩∎
            ⟧a p
                ∎)
          (λ n₁ {co} eq p → ap (λ x → x b⟦ n₁ ⟧a p) eq)
          (λ n₁ {co} eq p → ap (λ x → x a⟦ n₁ ⟧b p) eq)
          (λ _ _ → code-has-all-cells₂-a _ _)
          (λ _ _ → code-has-all-cells₂-b _ _)
          (λ _ _ _ _ → code-has-all-cells₂-a _ _)

      aba-glue-code-a : ∀ {a₂} (co : code-a a₂) → F.ab⇒bb (aa⇒ba co) ≡ co
      aba-glue-code-a = π₁ aba-glue-code-split
      aba-glue-code-b : ∀ {b₂} (co : code-b b₂) → F.aa⇒ba (ab⇒bb co) ≡ co
      aba-glue-code-b = π₂ aba-glue-code-split

  private
    module PackA3 (d : pushout-diag i)
      (l : legend i (pushout-diag.C d)) (n : legend.name l) where
      open pushout-diag d
      open legend l

      -- Code from A.
      open import Homotopy.VanKampen.SplitCode d l (f $ loc n)
      open PackA2 d l n public
      -- Code from B. F for `flipped'.
      private
        module F where
          open import Homotopy.VanKampen.SplitCode (pushout-diag-flip d) l (g $ loc n) public
          open PackA2 (pushout-diag-flip d) l n public

      flipped-code : P → Set i
      flipped-code = F.code ◯ pushout-flip

      private
        ap⇒bp-glue : ∀ c → transport (λ p → code p → flipped-code p) (glue c) aa⇒ba ≡ ab⇒bb
      abstract
        ap⇒bp-glue = loc-fiber-rec l
          (λ c → transport (λ p → code p → flipped-code p) (glue c) aa⇒ba ≡ ab⇒bb)
          ⦃ λ _ → Π-is-set (λ _ → F.code-a-is-set _) _ _ ⦄
          (λ n → funext λ co →
            transport (λ p → code p → flipped-code p) (glue $ loc n) aa⇒ba co
                ≡⟨ trans-→ code flipped-code (glue $ loc n) aa⇒ba co ⟩
            transport flipped-code (glue $ loc n)
              (aa⇒ba $ transport code (! $ glue $ loc n) co)
                ≡⟨ ap (λ x → transport flipped-code (glue $ loc n) $ aa⇒ba x)
                    $ trans-code-!glue-loc n co ⟩
            transport flipped-code (glue $ loc n) (aa⇒ba $ b⇒a n co)
                ≡⟨ refl ⟩
            transport flipped-code (glue $ loc n) (F.a⇒b n $ ab⇒bb co)
                ≡⟨ ! $ trans-ap F.code pushout-flip (glue $ loc n)
                     $ F.a⇒b n $ ab⇒bb co ⟩
            transport F.code (ap pushout-flip $ glue $ loc n) (F.a⇒b n $ ab⇒bb co)
                ≡⟨ ap (λ x → transport F.code x $ F.a⇒b n $ ab⇒bb co)
                      $ pushout-β-glue-nondep _ right left (! ◯ glue) $ loc n ⟩
            transport F.code (! $ glue $ loc n) (F.a⇒b n $ ab⇒bb co)
                ≡⟨ F.trans-code-!glue-loc n (F.a⇒b n $ ab⇒bb co) ⟩
            F.b⇒a n (F.a⇒b n $ ab⇒bb co)
                ≡⟨ F.code-a-refl-refl n $ ab⇒bb co ⟩∎
            ab⇒bb co
                ∎)

      ap⇒bp : ∀ {p} → code p → flipped-code p
      ap⇒bp {p} = pushout-rec
        (λ x → code x → flipped-code x)
        (λ _ → aa⇒ba)
        (λ _ → ab⇒bb)
        ap⇒bp-glue
        p

  open PackA3 d l public


-- Andreas, 2012-01-17
-- {-# OPTIONS -v tc.proj.like:50 #-}
-- {-# OPTIONS -v tc.conv.atom:50 #-}
module Issue553c where

postulate
  A : Set
  a : A

data Bool : Set where
  true false : Bool

data WrapBool (C : Set) : Set where
  wrap : Bool -> WrapBool C

-- a projection-like function (must not be constructor-headed!)
-- the dummy C is to make Agda accept f as projection like
f : {C : Set} -> WrapBool C -> A
f (wrap true)  = a
f (wrap false) = a

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

-- it is important that f does not reduce, in order to enter compareAtom
test : (b : Bool) -> f {C = A} (wrap b) ≡ f (wrap b)
test b = refl
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:335

-- the problem is fixed now, since f is no longer projection-like
-- because of deep matching


module FFI.IO where

open import Agda.Builtin.IO using (IO)
open import Agda.Builtin.Unit using (⊤)
open import Agda.Builtin.String using (String)

open import FFI.Data.HaskellString using (HaskellString; pack ; unpack)

infixl 1 _>>=_
infixl 1 _>>_

postulate
  return : ∀ {a} {A : Set a} → A → IO A
  _>>=_  : ∀ {a b} {A : Set a} {B : Set b} → IO A → (A → IO B) → IO B
  fmap : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → IO A → IO B

{-# COMPILE GHC return = \_ _ -> return    #-}
{-# COMPILE GHC _>>=_  = \_ _ _ _ -> (>>=) #-}
{-# COMPILE GHC fmap  = \_ _ _ _ -> fmap #-}

postulate getHContents : IO HaskellString
{-# COMPILE GHC getHContents = getContents #-}

postulate putHStrLn : HaskellString → IO ⊤
{-# COMPILE GHC putHStrLn = putStrLn #-}

getContents : IO String
getContents = fmap pack getHContents

putStrLn : String → IO ⊤
putStrLn txt = putHStrLn (unpack txt)

_>>_ : ∀ {a} {A : Set a} → IO ⊤ → IO A → IO A
a >> b = a >>= (λ _ → b )