------------------------------------------------------------------------
-- Operations and lemmas related to application of substitutions
------------------------------------------------------------------------

open import Data.Universe.Indexed

module deBruijn.Substitution.Data.Application.Application1
  {i u e} {Uni : IndexedUniverse i u e} where

import deBruijn.Context; open deBruijn.Context Uni
open import deBruijn.Substitution.Data.Application.Application22
open import deBruijn.Substitution.Data.Basics
open import deBruijn.Substitution.Data.Map
open import deBruijn.Substitution.Data.Simple
open import Function using (_$_)
open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open P.≡-Reasoning

-- More operations and lemmas related to application. In this module
-- the application operator is assumed to be homogeneous, so some
-- previously proved lemmas can be stated in a less complicated way.

record Application₁ {t} (T : Term-like t) : Set (i ⊔ u ⊔ e ⊔ t) where

  open Term-like T

  field
    -- Simple substitutions.
    simple : Simple T

    -- The homogeneous variant is defined in terms of the
    -- heterogeneous one.
    application₂₂ : Application₂₂ simple simple ([id] {T = T})

  open Simple simple public
  open Application₂₂ application₂₂ public
    hiding ( ∘⋆; ∘⋆-cong; /∋-∘⋆
           ; trans-cong; id-∘; map-trans-wk-subst; map-trans-↑; wk-∘-↑
           )

  -- Composition of multiple substitutions.
  --
  -- Note that singleton sequences are handled specially, to avoid the
  -- introduction of unnecessary identity substitutions.

  ∘⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Subs T ρ̂ → Sub T ρ̂
  ∘⋆ ε        = id
  ∘⋆ (ε  ▻ ρ) = ρ
  ∘⋆ (ρs ▻ ρ) = ∘⋆ ρs ∘ ρ

  -- A congruence lemma.

  ∘⋆-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρs₁ : Subs T ρ̂₁}
              {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρs₂ : Subs T ρ̂₂} →
            ρs₁ ≅-⇨⋆ ρs₂ → ∘⋆ ρs₁ ≅-⇨ ∘⋆ ρs₂
  ∘⋆-cong P.refl = P.refl

  abstract

    -- Applying a composed substitution to a variable is equivalent to
    -- applying all the substitutions one after another.

    /∋-∘⋆ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ σ) (ρs : Subs T ρ̂) →
            x /∋ ∘⋆ ρs ≅-⊢ var · x /⊢⋆ ρs
    /∋-∘⋆ x ε = begin
      [ x /∋ id ]  ≡⟨ /∋-id x ⟩
      [ var · x ]  ∎
    /∋-∘⋆ x (ε ▻ ρ) = begin
      [ x /∋ ρ       ]  ≡⟨ P.sym $ var-/⊢ x ρ ⟩
      [ var · x /⊢ ρ ]  ∎
    /∋-∘⋆ x (ρs ▻ ρ₁ ▻ ρ₂) = begin
      [ x /∋ ∘⋆ (ρs ▻ ρ₁) ∘ ρ₂      ]  ≡⟨ /∋-∘ x (∘⋆ (ρs ▻ ρ₁)) ρ₂ ⟩
      [ x /∋ ∘⋆ (ρs ▻ ρ₁) /⊢ ρ₂     ]  ≡⟨ /⊢-cong (/∋-∘⋆ x (ρs ▻ ρ₁)) P.refl ⟩
      [ var · x /⊢⋆ (ρs ▻ ρ₁) /⊢ ρ₂ ]  ∎

    -- Yet another variant of var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆.

    ∘⋆-⇒-/⊢⋆ :
      ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρs₁ : Subs T ρ̂) (ρs₂ : Subs T ρ̂) →
      ∘⋆ ρs₁ ≅-⇨ ∘⋆ ρs₂ → ∀ {σ} (t : Γ ⊢ σ) → t /⊢⋆ ρs₁ ≅-⊢ t /⊢⋆ ρs₂
    ∘⋆-⇒-/⊢⋆ ρs₁ ρs₂ hyp = var-/⊢⋆-⇒-/⊢⋆ ρs₁ ρs₂ (λ x → begin
      [ var · x /⊢⋆ ρs₁ ]  ≡⟨ P.sym $ /∋-∘⋆ x ρs₁ ⟩
      [ x /∋ ∘⋆ ρs₁     ]  ≡⟨ /∋-cong (P.refl {x = [ x ]}) hyp ⟩
      [ x /∋ ∘⋆ ρs₂     ]  ≡⟨ /∋-∘⋆ x ρs₂ ⟩
      [ var · x /⊢⋆ ρs₂ ]  ∎)

    -- id is a left identity of _∘_.

    id-∘ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) → id ∘ ρ ≅-⇨ ρ
    id-∘ ρ = begin
      [ id ∘ ρ     ]  ≡⟨ Application₂₂.id-∘ application₂₂ ρ ⟩
      [ map [id] ρ ]  ≡⟨ map-[id] ρ ⟩
      [ ρ          ]  ∎

    -- The wk substitution commutes with any other (modulo lifting
    -- etc.).

    wk-∘-↑ : ∀ {Γ Δ} σ {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) →
             ρ ∘ wk {σ = σ / ρ} ≅-⇨ wk {σ = σ} ∘ ρ ↑
    wk-∘-↑ σ ρ = begin
      [ ρ ∘ wk           ]  ≡⟨ ∘-cong (P.sym $ map-[id] ρ) P.refl ⟩
      [ map [id] ρ ∘ wk  ]  ≡⟨ Application₂₂.wk-∘-↑ application₂₂ σ ρ ⟩
      [ wk {σ = σ} ∘ ρ ↑ ]  ∎

    -- Applying a composed substitution is equivalent to applying one
    -- substitution and then the other.

    /⊢-∘ : ∀ {Γ Δ Ε σ} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε}
           (t : Γ ⊢ σ) (ρ₁ : Sub T ρ̂₁) (ρ₂ : Sub T ρ̂₂) →
           t /⊢ ρ₁ ∘ ρ₂ ≅-⊢ t /⊢ ρ₁ /⊢ ρ₂
    /⊢-∘ t ρ₁ ρ₂ = ∘⋆-⇒-/⊢⋆ (ε ▻ ρ₁ ∘ ρ₂) (ε ▻ ρ₁ ▻ ρ₂) P.refl t

    -- _∘_ is associative.

    ∘-∘ : ∀ {Γ Δ Ε Ζ} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} {ρ̂₃ : Ε ⇨̂ Ζ}
          (ρ₁ : Sub T ρ̂₁) (ρ₂ : Sub T ρ̂₂) (ρ₃ : Sub T ρ̂₃) →
          ρ₁ ∘ (ρ₂ ∘ ρ₃) ≅-⇨ (ρ₁ ∘ ρ₂) ∘ ρ₃
    ∘-∘ ρ₁ ρ₂ ρ₃ = extensionality P.refl λ x → begin
      [ x /∋ ρ₁ ∘ (ρ₂ ∘ ρ₃) ]  ≡⟨ /∋-∘ x ρ₁ (ρ₂ ∘ ρ₃) ⟩
      [ x /∋ ρ₁ /⊢ ρ₂ ∘ ρ₃  ]  ≡⟨ /⊢-∘ (x /∋ ρ₁) ρ₂ ρ₃ ⟩
      [ x /∋ ρ₁ /⊢ ρ₂ /⊢ ρ₃ ]  ≡⟨ /⊢-cong (P.sym $ /∋-∘ x ρ₁ ρ₂) (P.refl {x = [ ρ₃ ]}) ⟩
      [ x /∋ ρ₁ ∘ ρ₂ /⊢ ρ₃  ]  ≡⟨ P.sym $ /∋-∘ x (ρ₁ ∘ ρ₂) ρ₃ ⟩
      [ x /∋ (ρ₁ ∘ ρ₂) ∘ ρ₃ ]  ∎

    -- If sub t is applied to variable zero then t is returned.

    zero-/⊢-sub : ∀ {Γ σ} (t : Γ ⊢ σ) → var · zero /⊢ sub t ≅-⊢ t
    zero-/⊢-sub t = begin
      [ var · zero /⊢ sub t ]  ≡⟨ var-/⊢ zero (sub t) ⟩
      [ zero /∋ sub t       ]  ≡⟨ P.refl ⟩
      [ t                   ]  ∎

    -- The sub substitution commutes with any other (modulo lifting
    -- etc.).

    ↑-∘-sub : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (t : Γ ⊢ σ) (ρ : Sub T ρ̂) →
              sub t ∘ ρ ≅-⇨ ρ ↑ σ ∘ sub (t /⊢ ρ)
    ↑-∘-sub t ρ =
      let lemma = begin
            [ id ∘ ρ                    ]  ≡⟨ id-∘ ρ ⟩
            [ ρ                         ]  ≡⟨ P.sym $ wk-subst-∘-sub ρ (t /⊢ ρ) ⟩
            [ wk-subst ρ ∘ sub (t /⊢ ρ) ]  ∎

      in begin
        [ sub t ∘ ρ                                              ]  ≡⟨ P.refl ⟩
        [ (id ▻ t) ∘ ρ                                           ]  ≡⟨ ▻-∘ id t ρ ⟩
        [ id ∘ ρ ▻ t /⊢ ρ                                        ]  ≡⟨ ▻⇨-cong P.refl lemma (P.sym $ zero-/⊢-sub (t /⊢ ρ)) ⟩
        [ wk-subst ρ ∘ sub (t /⊢ ρ) ▻ var · zero /⊢ sub (t /⊢ ρ) ]  ≡⟨ P.sym $ ▻-∘ (wk-subst ρ) (var · zero) (sub (t /⊢ ρ)) ⟩
        [ (wk-subst ρ ▻ var · zero) ∘ sub (t /⊢ ρ)               ]  ≡⟨ ∘-cong (P.sym $ unfold-↑ ρ) P.refl ⟩
        [ ρ ↑ ∘ sub (t /⊢ ρ)                                     ]  ∎

  -- wk-subst⁺ can be expressed using composition and wk⁺.

  ∘-wk⁺ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) (Δ⁺ : Ctxt⁺ Δ) →
          ρ ∘ wk⁺ Δ⁺ ≅-⇨ wk-subst⁺ Δ⁺ ρ
  ∘-wk⁺ ρ ε = begin
    [ ρ ∘ wk⁺ ε     ]  ≡⟨ P.refl ⟩
    [ ρ ∘ id        ]  ≡⟨ ∘-id ρ ⟩
    [ ρ             ]  ≡⟨ P.refl ⟩
    [ wk-subst⁺ ε ρ ]  ∎
  ∘-wk⁺ ρ (Δ⁺ ▻ σ) = begin
    [ ρ ∘ wk⁺ (Δ⁺ ▻ σ)          ]  ≡⟨ ∘-cong (P.refl {x = [ ρ ]}) (wk⁺-▻ Δ⁺) ⟩
    [ ρ ∘ (wk⁺ Δ⁺ ∘ wk)         ]  ≡⟨ ∘-∘ ρ (wk⁺ Δ⁺) wk ⟩
    [ (ρ ∘ wk⁺ Δ⁺) ∘ wk         ]  ≡⟨ ∘-cong (∘-wk⁺ ρ Δ⁺) P.refl ⟩
    [ wk-subst⁺ Δ⁺ ρ ∘ wk       ]  ≡⟨ ∘-wk (wk-subst⁺ Δ⁺ ρ) ⟩
    [ wk-subst (wk-subst⁺ Δ⁺ ρ) ]  ≡⟨ P.refl ⟩
    [ wk-subst⁺ (Δ⁺ ▻ σ) ρ      ]  ∎

  mutual

    -- wk-subst₊ can be expressed using composition and wk₊.

    ∘-wk₊ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T ρ̂) (Δ₊ : Ctxt₊ Δ) →
            ρ ∘ wk₊ Δ₊ ≅-⇨ wk-subst₊ Δ₊ ρ
    ∘-wk₊ ρ ε = begin
      [ ρ ∘ wk₊ ε     ]  ≡⟨ P.refl ⟩
      [ ρ ∘ id        ]  ≡⟨ ∘-id ρ ⟩
      [ ρ             ]  ≡⟨ P.refl ⟩
      [ wk-subst₊ ε ρ ]  ∎
    ∘-wk₊ ρ (σ ◅ Δ₊) = begin
      [ ρ ∘ wk₊ (σ ◅ Δ₊)          ]  ≡⟨ ∘-cong (P.refl {x = [ ρ ]}) (wk₊-◅ Δ₊) ⟩
      [ ρ ∘ (wk ∘ wk₊ Δ₊)         ]  ≡⟨ ∘-∘ ρ wk (wk₊ Δ₊) ⟩
      [ (ρ ∘ wk) ∘ wk₊ Δ₊         ]  ≡⟨ ∘-cong (∘-wk ρ) P.refl ⟩
      [ wk-subst ρ ∘ wk₊ Δ₊       ]  ≡⟨ ∘-wk₊ (wk-subst ρ) Δ₊ ⟩
      [ wk-subst₊ Δ₊ (wk-subst ρ) ]  ≡⟨ P.refl ⟩
      [ wk-subst₊ (σ ◅ Δ₊) ρ      ]  ∎

    -- Unfolding lemma for wk₊.

    wk₊-◅ : ∀ {Γ σ} (Γ₊ : Ctxt₊ (Γ ▻ σ)) →
            wk₊ (σ ◅ Γ₊) ≅-⇨ wk ∘ wk₊ Γ₊
    wk₊-◅ {σ = σ} Γ₊ = begin
      [ wk₊ (σ ◅ Γ₊)    ]  ≡⟨ P.refl ⟩
      [ wk-subst₊ Γ₊ wk ]  ≡⟨ P.sym $ ∘-wk₊ wk Γ₊ ⟩
      [ wk ∘ wk₊ Γ₊     ]  ∎

  -- A consequence of wk₊-◅.

  /∋-wk₊-◅ : ∀ {Γ τ σ} (x : Γ ∋ τ) (Γ₊ : Ctxt₊ (Γ ▻ σ)) →
             x /∋ wk₊ (σ ◅ Γ₊) ≅-⊢ suc x /∋ wk₊ Γ₊
  /∋-wk₊-◅ {σ = σ} x Γ₊ = begin
    [ x /∋ wk₊ (σ ◅ Γ₊)     ]  ≡⟨ /∋-cong (P.refl {x = [ x ]}) (wk₊-◅ Γ₊) ⟩
    [ x /∋ wk ∘ wk₊ Γ₊      ]  ≡⟨ /∋-∘ x wk (wk₊ Γ₊) ⟩
    [ x /∋ wk /⊢ wk₊ Γ₊     ]  ≡⟨ /⊢-cong (/∋-wk x) P.refl ⟩
    [ var · suc x /⊢ wk₊ Γ₊ ]  ≡⟨ var-/⊢ (suc x) (wk₊ Γ₊) ⟩
    [ suc x /∋ wk₊ Γ₊       ]  ∎


------------------------------------------------------------------------
-- Strict ω-continuous functions
------------------------------------------------------------------------

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

module Partiality-algebra.Strict-omega-continuous where

open import Equality.Propositional.Cubical
open import Prelude hiding (⊥)

open import Bijection equality-with-J using (_↔_)
import Equivalence equality-with-J as Eq
open import Function-universe equality-with-J hiding (_∘_)
open import H-level.Closure equality-with-J
open import Monad equality-with-J

open import Partiality-algebra as PA
open import Partiality-algebra.Monotone
open import Partiality-algebra.Omega-continuous

-- Definition of strict ω-continuous functions.

record [_⟶_]⊥
         {a₁ p₁ q₁} {A₁ : Type a₁} (P₁ : Partiality-algebra p₁ q₁ A₁)
         {a₂ p₂ q₂} {A₂ : Type a₂} (P₂ : Partiality-algebra p₂ q₂ A₂) :
         Type (p₁ ⊔ p₂ ⊔ q₁ ⊔ q₂) where
  private
    module P₁ = Partiality-algebra P₁
    module P₂ = Partiality-algebra P₂

  field
    ω-continuous-function : [ P₁ ⟶ P₂ ]

  open [_⟶_] ω-continuous-function public

  field
    strict : function P₁.never ≡ P₂.never

open [_⟶_]⊥

-- Identity.

id⊥ : ∀ {a p q} {A : Type a} {P : Partiality-algebra p q A} →
      [ P ⟶ P ]⊥
ω-continuous-function id⊥ = idω
strict                id⊥ = refl

-- Composition.

infixr 40 _∘⊥_

_∘⊥_ :
  ∀ {a₁ p₁ q₁} {A₁ : Type a₁} {P₁ : Partiality-algebra p₁ q₁ A₁}
    {a₂ p₂ q₂} {A₂ : Type a₂} {P₂ : Partiality-algebra p₂ q₂ A₂}
    {a₃ p₃ q₃} {A₃ : Type a₃} {P₃ : Partiality-algebra p₃ q₃ A₃} →
  [ P₂ ⟶ P₃ ]⊥ → [ P₁ ⟶ P₂ ]⊥ → [ P₁ ⟶ P₃ ]⊥
ω-continuous-function (f ∘⊥ g) =
  ω-continuous-function f ∘ω ω-continuous-function g

strict (_∘⊥_ {P₁ = P₁} {P₂ = P₂} {P₃ = P₃} f g) =
  function f (function g P₁.never)  ≡⟨ cong (function f) (strict g) ⟩
  function f P₂.never               ≡⟨ strict f ⟩∎
  P₃.never                          ∎
  where
  module P₁ = Partiality-algebra P₁
  module P₂ = Partiality-algebra P₂
  module P₃ = Partiality-algebra P₃

-- Equality characterisation lemma for strict ω-continuous functions.

equality-characterisation-strict :
  ∀ {a₁ p₁ q₁} {A₁ : Type a₁} {P₁ : Partiality-algebra p₁ q₁ A₁}
    {a₂ p₂ q₂} {A₂ : Type a₂} {P₂ : Partiality-algebra p₂ q₂ A₂}
    {f g : [ P₁ ⟶ P₂ ]⊥} →
  (∀ x → function f x ≡ function g x) ↔ f ≡ g
equality-characterisation-strict {P₁ = P₁} {P₂ = P₂} {f} {g} =
  (∀ x → function f x ≡ function g x)                ↝⟨ equality-characterisation-continuous ⟩
  ω-continuous-function f ≡ ω-continuous-function g  ↝⟨ ignore-propositional-component P₂.T-is-set ⟩
  _↔_.to rearrange f ≡ _↔_.to rearrange g            ↔⟨ Eq.≃-≡ (Eq.↔⇒≃ rearrange) ⟩□
  f ≡ g                                              □
  where
  module P₁ = Partiality-algebra P₁
  module P₂ = Partiality-algebra P₂

  rearrange :
    [ P₁ ⟶ P₂ ]⊥
      ↔
    ∃ λ (h : [ P₁ ⟶ P₂ ]) → [_⟶_].function h P₁.never ≡ P₂.never
  rearrange = record
    { surjection = record
      { logical-equivalence = record
        { to   = λ f → ω-continuous-function f , strict f
        ; from = uncurry λ f c → record { ω-continuous-function = f
                                        ; strict                = c
                                        }
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ _ → refl
    }
    where
    open Partiality-algebra

-- Composition is associative.

∘⊥-assoc :
  ∀ {a₁ p₁ q₁} {A₁ : Type a₁} {P₁ : Partiality-algebra p₁ q₁ A₁}
    {a₂ p₂ q₂} {A₂ : Type a₂} {P₂ : Partiality-algebra p₂ q₂ A₂}
    {a₃ p₃ q₃} {A₃ : Type a₃} {P₃ : Partiality-algebra p₃ q₃ A₃}
    {a₄ p₄ q₄} {A₄ : Type a₄} {P₄ : Partiality-algebra p₄ q₄ A₄}
  (f : [ P₃ ⟶ P₄ ]⊥) (g : [ P₂ ⟶ P₃ ]⊥) (h : [ P₁ ⟶ P₂ ]⊥) →
  f ∘⊥ (g ∘⊥ h) ≡ (f ∘⊥ g) ∘⊥ h
∘⊥-assoc _ _ _ =
  _↔_.to equality-characterisation-strict λ _ → refl


------------------------------------------------------------------------
-- Small parser combinator library used by Mixfix.Acyclic.Grammar
------------------------------------------------------------------------

-- Note that while Mixfix.Acyclic.Lib and Mixfix.Cyclic.Lib may appear
-- to be very similar, there are some important differences:
--
-- • Mixfix.Cyclic.Lib._⊛∞_ accepts delayed parsers,
--   Mixfix.Acyclic.Lib._⊛_ does not.
--
-- • There is a translation from the parsers in Mixfix.Acyclic.Lib to
--   the /simplified/ parsers in
--   StructurallyRecursiveDescentParsing.Simplified; no such
--   translation is defined for the parsers in Mixfix.Cyclic.Lib. Note
--   that the depth-first backend in
--   StructurallyRecursiveDescentParsing.DepthFirst only handles
--   simplified parsers.

module Mixfix.Acyclic.Lib where

open import Algebra
open import Codata.Musical.Notation
open import Data.Bool using (Bool; true; false)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.List using (List; []; _∷_; _++_)
open import Data.List.NonEmpty using (List⁺; _∷_; [_]; _∷⁺_; _⁺∷ʳ_)
import Data.List.Properties
private module LM {A : Set} = Monoid (Data.List.Properties.++-monoid A)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Product
import Data.String.Properties as String
open import Relation.Binary
open DecSetoid String.≡-decSetoid using (_≟_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; cong)

import StructurallyRecursiveDescentParsing.Simplified as Simplified
open Simplified hiding (⟦_⟧)
open import StructurallyRecursiveDescentParsing.Simplified.Semantics
  as Sem hiding (cast∈; sound; complete)
open import Mixfix.Operator using (NamePart)

------------------------------------------------------------------------
-- Programs

-- Agda's termination checker only accepts corecursive definitions if
-- they are /syntactically/ guarded by constructors. The following
-- small language of "parser programs" reifies a selection of parser
-- combinators as /constructors/. These constructors are then used in
-- Mixfix.Acyclic.Grammar in order to ensure that Agda accepts the
-- grammars defined there.

infix  55 _+
infixl 50 _⊛_ _<$>_
infixl  5 _∣_
infixr  5 _∥_

data ParserProg : Set → Set1 where
  fail      : ∀ {R} → ParserProg R
  _∣_       : ∀ {R}
              (p₁ : ParserProg R)
              (p₂ : ParserProg R) →
                    ParserProg R
  _⊛_       : ∀ {R₁ R₂}
              (p₁ : ParserProg (R₁ → R₂))
              (p₂ : ParserProg R₁) →
                    ParserProg R₂
  _<$>_     : ∀ {R₁ R₂} (f : R₁ → R₂)
              (p : ParserProg R₁) →
                   ParserProg R₂
  _+        : ∀ {R} (p : ParserProg R) →
                         ParserProg (List⁺ R)
  _between_ : ∀ {R n}
              (p : ∞ (ParserProg R)) (toks : Vec NamePart (1 + n)) →
              ParserProg (Vec R n)
  _∥_       : ∀ {I i} {R : I → Set}
              (p₁ : ParserProg (R i))
              (p₂ : ParserProg (∃ R)) →
                    ParserProg (∃ R)

-- Parses a given token.

tok : NamePart → Parser NamePart false NamePart
tok tok = token !>>= λ tok′ → ♯ ok tok′
  module TheToken where
  okIndex : NamePart → Bool
  okIndex tok′ with tok ≟ tok′
  ... | yes _ = true
  ... | no  _ = false

  ok : (tok′ : NamePart) → Parser NamePart (okIndex tok′) NamePart
  ok tok′ with tok ≟ tok′
  ... | yes _ = return tok′
  ... | no  _ = fail

-- Interprets the parser programs as parsers.

private
  infix 10 ♯′_

  ♯′_ : {A : Set₁} → A → ∞ A
  ♯′ x = ♯ x

⟦_⟧ : ∀ {R} → ParserProg R → Parser NamePart false R
⟦ fail                    ⟧ = fail
⟦ p₁ ∣ p₂                 ⟧ = ⟦ p₁ ⟧ ∣ ⟦ p₂ ⟧
⟦ p₁ ⊛ p₂                 ⟧ = ⟦ p₁ ⟧ !>>= λ f → ♯ ⟦ f <$> p₂ ⟧
⟦ f <$> p                 ⟧ = ⟦ p  ⟧ !>>= λ x → ♯′ return (f x)
⟦ p +                     ⟧ = ⟦ p  ⟧ !>>= λ x → ♯
                              (⟦ _∷⁺_ x <$> p + ⟧ ∣ return [ x ])
⟦ p between (t ∷ [])      ⟧ = tok t !>>= λ _ → ♯′ return []
⟦ p between (t ∷ t′ ∷ ts) ⟧ = tok t !>>= λ _ → ♯
                              ⟦ _∷_ <$> ♭ p ⊛ (p between (t′ ∷ ts)) ⟧
⟦ p₁ ∥ p₂                 ⟧ = (⟦ p₁ ⟧ !>>= λ x → ♯′ return (-, x)) ∣
                              ⟦ p₂ ⟧

------------------------------------------------------------------------
-- Semantics of the programs

module Semantics where

  -- This definition may seem unnecessary: why not simply define
  --
  --   x ∈⟦ p ⟧· s  =  x ∈ ⟦ p ⟧ · s?
  --
  -- One reason is that it is hard for Agda to infer the value of p
  -- from ⟦ p ⟧ (note that ⟦_⟧ is a function which evaluates). By
  -- using the definition below this problem is avoided. A more
  -- important reason may be that the definition below ensures that
  -- the details of ⟦_⟧ do not need to be understood.

  infix  60 <$>_
  infixl 50 _⊛_
  infix  4  _∈⟦_⟧·_

  data _∈⟦_⟧·_ : ∀ {R} → R → ParserProg R → List NamePart → Set₁ where
    ∣ˡ         : ∀ {R x s}
                   {p₁ : ParserProg R} {p₂ : ParserProg R}
                 (x∈p₁ : x ∈⟦ p₁ ⟧· s) → x ∈⟦ p₁ ∣ p₂ ⟧· s
    ∣ʳ         : ∀ {R x s}
                   {p₁ : ParserProg R} {p₂ : ParserProg R}
                 (x∈p₂ : x ∈⟦ p₂ ⟧· s) → x ∈⟦ p₁ ∣ p₂ ⟧· s
    _⊛_        : ∀ {s₁ s₂ R₁ R₂ f x}
                   {p₁ : ParserProg (R₁ → R₂)}
                   {p₂ : ParserProg R₁}
                 (f∈p₁ : f ∈⟦ p₁ ⟧· s₁)
                 (x∈p₂ : x ∈⟦ p₂ ⟧· s₂) →
                 f x ∈⟦ p₁ ⊛ p₂ ⟧· s₁ ++ s₂
    <$>_       : ∀ {s R₁ R₂ x} {f : R₁ → R₂} {p : ParserProg R₁}
                 (x∈p : x ∈⟦ p ⟧· s) → f x ∈⟦ f <$> p ⟧· s
    +-[]       : ∀ {R x s} {p : ParserProg R}
                 (x∈p : x ∈⟦ p ⟧· s) → [ x ] ∈⟦ p + ⟧· s
    +-∷        : ∀ {R x s₁ s₂ xs} {p : ParserProg R}
                 (x∈p : x ∈⟦ p ⟧· s₁) (xs∈p : xs ∈⟦ p + ⟧· s₂) →
                 x ∷⁺ xs ∈⟦ p + ⟧· s₁ ++ s₂
    between-[] : ∀ {R t} {p : ∞ (ParserProg R)} →
                 [] ∈⟦ p between (t ∷ []) ⟧· t ∷ []
    between-∷  : ∀ {R n t x xs s₁ s₂}
                   {p : ∞ (ParserProg R)} {ts : Vec NamePart (suc n)}
                 (x∈p : x ∈⟦ ♭ p ⟧· s₁)
                 (xs∈⋯ : xs ∈⟦ p between ts ⟧· s₂) →
                 x ∷ xs ∈⟦ p between (t ∷ ts) ⟧· t ∷ s₁ ++ s₂
    ∥ˡ         : ∀ {I i} {R : I → Set} {x s}
                   {p₁ : ParserProg (R i)}
                   {p₂ : ParserProg (∃ R)}
                 (x∈p₁ : x ∈⟦ p₁ ⟧· s) → (-, x) ∈⟦ p₁ ∥ p₂ ⟧· s
    ∥ʳ         : ∀ {I i} {R : I → Set} {x s}
                   {p₁ : ParserProg (R i)}
                   {p₂ : ParserProg (∃ R)}
                 (x∈p₂ : x ∈⟦ p₂ ⟧· s) → x ∈⟦ p₁ ∥ p₂ ⟧· s

  -- The semantics is correct. (Note that this proof only establishes
  -- language equivalence, not parser equivalence; see
  -- TotalParserCombinators.Semantics.)

  private

    drop-[] : ∀ {R s x} {p : Parser NamePart false R} →
              x ∈ p · s ++ [] → x ∈ p · s
    drop-[] = Sem.cast∈ refl refl (proj₂ LM.identity _)

    add-[] : ∀ {R s x} {p : ParserProg R} →
             x ∈⟦ p ⟧· s → x ∈⟦ p ⟧· s ++ []
    add-[] {s = s} x∈p rewrite proj₂ LM.identity s = x∈p

  ⊛-complete : ∀ {s₁ s₂ R₁ R₂ f x}
               (p₁ : ParserProg (R₁ → R₂)) {p₂ : ParserProg R₁} →
               f ∈ ⟦ p₁ ⟧ · s₁ → x ∈ ⟦ p₂ ⟧ · s₂ →
               f x ∈ ⟦ p₁ ⊛ p₂ ⟧ · s₁ ++ s₂
  ⊛-complete _ f∈p₁ x∈p₂ = f∈p₁ !>>= drop-[] (x∈p₂ !>>= return)

  tok-sound : ∀ {t t′ s} →
              t′ ∈ tok t · s →
              t ≡ t′ × s ≡ t′ ∷ []
  tok-sound {t} (_!>>=_ {x = t″} token t′∈) with t ≟ t″
  tok-sound (token !>>= return) | yes t≈t″ = (t≈t″ , refl)
  tok-sound (token !>>= ())     | no  t≉t″

  tok-complete : ∀ {t} → t ∈ tok t · t ∷ []
  tok-complete {t} = token !>>= ok-lemma
    where
    ok-lemma : t ∈ TheToken.ok t t · []
    ok-lemma with t ≟ t
    ... | yes refl = return
    ... | no  t≢t  with t≢t refl
    ...   | ()

  sound : ∀ {R x s} {p : ParserProg R} →
          x ∈⟦ p ⟧· s → x ∈ ⟦ p ⟧ · s
  sound (∣ˡ x∈p₁)                 = ∣ˡ       (sound x∈p₁)
  sound (∣ʳ x∈p₂)                 = ∣ʳ false (sound x∈p₂)
  sound (_⊛_ {p₁ = p₁} f∈p₁ x∈p₂) = ⊛-complete p₁ (sound f∈p₁) (sound x∈p₂)
  sound (<$> x∈p)                 = drop-[] (sound x∈p !>>= return)
  sound (+-[] x∈p)                = drop-[] (sound x∈p !>>= ∣ʳ false return)
  sound (+-∷ x∈p xs∈p)            = sound x∈p !>>= ∣ˡ (drop-[] (sound xs∈p !>>= return))
  sound (∥ˡ x∈p₁)                 = drop-[] (∣ˡ {x = (-, _)} (sound x∈p₁ !>>= return))
  sound (∥ʳ x∈p₂)                 = ∣ʳ false (sound x∈p₂)
  sound between-[]                = tok-complete !>>= return
  sound (between-∷ {s₁ = s₁} {p = p} {ts = _ ∷ _} x∈p xs∈⋯) =
    tok-complete !>>=
    ⊛-complete (_ <$> ♭ p) (drop-[] {s = s₁} (sound x∈p !>>= return)) (sound xs∈⋯)

  complete : ∀ {R x s} (p : ParserProg R) →
             x ∈ ⟦ p ⟧ · s → x ∈⟦ p ⟧· s
  complete fail      ()

  complete (p₁ ∣ p₂) (∣ˡ        x∈p₁) = ∣ˡ (complete p₁ x∈p₁)
  complete (p₁ ∣ p₂) (∣ʳ .false x∈p₂) = ∣ʳ (complete p₂ x∈p₂)

  complete (p₁ ⊛ p₂) (f∈p₁ !>>= (y∈p₂ !>>= return)) =
    complete p₁ f∈p₁ ⊛ add-[] (complete p₂ y∈p₂)

  complete (f <$> p) (x∈p !>>= return) = add-[] (<$> complete p x∈p)

  complete (p +) (x∈p !>>= ∣ˡ (xs∈p+ !>>= return)) = +-∷ (complete p x∈p) (add-[] (complete (p +) xs∈p+))
  complete (p +) (x∈p !>>= ∣ʳ .false return)       = add-[] (+-[] (complete p x∈p))

  complete (p between (t ∷ [])) (t∈ !>>= return) with tok-sound t∈
  ... | (refl , refl) = between-[]
  complete (p between (t ∷ t′ ∷ ts))
           (t∈ !>>= (x∈p !>>= return !>>= (xs∈ !>>= return))) with tok-sound t∈
  ... | (refl , refl) =
    between-∷ (add-[] (complete (♭ p) x∈p))
              (add-[] (complete (p between (t′ ∷ ts)) xs∈))

  complete (p₁ ∥ p₂) (∣ˡ (x∈p₁ !>>= return)) = add-[] (∥ˡ (complete p₁ x∈p₁))
  complete (p₁ ∥ p₂) (∣ʳ .false x∈p₂)        = ∥ʳ (complete p₂ x∈p₂)

------------------------------------------------------------------------
-- A variant of the semantics

-- The alternative semantics defined below may be slightly harder to
-- understand, but it is (language) equivalent to the one above, and
-- it simplifies the proof in Mixfix.Acyclic.Show.

module Semantics-⊕ where

  infix  60 <$>_
  infixl 50 _⊛_
  infix  4  _⊕_∈⟦_⟧·_

  data _⊕_∈⟦_⟧·_ : ∀ {R} →
                   R → List NamePart → ParserProg R → List NamePart → Set1 where
    ∣ˡ         : ∀ {R x s s₁}
                   {p₁ : ParserProg R} {p₂ : ParserProg R}
                 (x∈p₁ : x ⊕ s₁ ∈⟦ p₁ ⟧· s) → x ⊕ s₁ ∈⟦ p₁ ∣ p₂ ⟧· s
    ∣ʳ         : ∀ {R x s s₁}
                   {p₁ : ParserProg R} {p₂ : ParserProg R}
                 (x∈p₂ : x ⊕ s₁ ∈⟦ p₂ ⟧· s) → x ⊕ s₁ ∈⟦ p₁ ∣ p₂ ⟧· s
    _⊛_        : ∀ {s s₁ s₂ R₁ R₂ f x}
                   {p₁ : ParserProg (R₁ → R₂)} {p₂ : ParserProg R₁}
                 (f∈p₁ : f ⊕ s₁ ∈⟦ p₁ ⟧· s) (x∈p₂ : x ⊕ s₂ ∈⟦ p₂ ⟧· s₁) →
                 f x ⊕ s₂ ∈⟦ p₁ ⊛ p₂ ⟧· s
    <$>_       : ∀ {s s′ R₁ R₂ x} {f : R₁ → R₂} {p : ParserProg R₁}
                 (x∈p : x ⊕ s′ ∈⟦ p ⟧· s) → f x ⊕ s′ ∈⟦ f <$> p ⟧· s
    +-[]       : ∀ {R x s s₁} {p : ParserProg R}
                 (x∈p : x ⊕ s₁ ∈⟦ p ⟧· s) → [ x ] ⊕ s₁ ∈⟦ p + ⟧· s
    +-∷        : ∀ {R x s s₁ s₂ xs} {p : ParserProg R}
                 (x∈p : x ⊕ s₁ ∈⟦ p ⟧· s) (xs∈p : xs ⊕ s₂ ∈⟦ p + ⟧· s₁) →
                 x ∷⁺ xs ⊕ s₂ ∈⟦ p + ⟧· s
    between-[] : ∀ {R t s} {p : ∞ (ParserProg R)} →
                 [] ⊕ s ∈⟦ p between (t ∷ []) ⟧· t ∷ s
    between-∷  : ∀ {R n t x xs s s₁ s₂}
                   {p : ∞ (ParserProg R)} {ts : Vec NamePart (suc n)}
                 (x∈p : x ⊕ s₁ ∈⟦ ♭ p ⟧· s)
                 (xs∈⋯ : xs ⊕ s₂ ∈⟦ p between ts ⟧· s₁) →
                 x ∷ xs ⊕ s₂ ∈⟦ p between (t ∷ ts) ⟧· t ∷ s
    ∥ˡ         : ∀ {I i} {R : I → Set} {x s s′}
                   {p₁ : ParserProg (R i)}
                   {p₂ : ParserProg (∃ R)}
                 (x∈p₁ : x ⊕ s′ ∈⟦ p₁ ⟧· s) →
                 (-, x) ⊕ s′ ∈⟦ p₁ ∥ p₂ ⟧· s
    ∥ʳ         : ∀ {I i} {R : I → Set} {s s′ i′} {x : R i′}
                   {p₁ : ParserProg (R i)}
                   {p₂ : ParserProg (∃ R)}
                 (x∈p₂ : (-, x) ⊕ s′ ∈⟦ p₂ ⟧· s) →
                 (-, x) ⊕ s′ ∈⟦ p₁ ∥ p₂ ⟧· s

  -- The semantics is correct.

  ⊛-complete : ∀ {s s₁ s₂ R₁ R₂ f x}
               (p₁ : ParserProg (R₁ → R₂)) {p₂ : ParserProg R₁} →
               f ⊕ s₁ ∈ ⟦ p₁ ⟧ · s → x ⊕ s₂ ∈ ⟦ p₂ ⟧ · s₁ →
               f x ⊕ s₂ ∈ ⟦ p₁ ⊛ p₂ ⟧ · s
  ⊛-complete _ f∈p₁ x∈p₂ = f∈p₁ !>>= (x∈p₂ !>>= return)

  tok-sound : ∀ {t t′ s₁ s} →
              t′ ⊕ s₁ ∈ tok t · s →
              t ≡ t′ × s ≡ t′ ∷ s₁
  tok-sound     ∈ with Sem.⊕-sound′ ∈
  tok-sound     ∈ | (s         , refl , ∈′) with Semantics.tok-sound ∈′
  tok-sound {t} ∈ | (.(t ∷ []) , refl , ∈′) | (refl , refl) = (refl , refl)

  tok-complete : ∀ {t s} → t ⊕ s ∈ tok t · t ∷ s
  tok-complete = Sem.⊕-complete′ (_ , refl , Semantics.tok-complete)

  sound : ∀ {R x s s′} {p : ParserProg R} →
          x ⊕ s′ ∈⟦ p ⟧· s → x ⊕ s′ ∈ ⟦ p ⟧ · s
  sound (∣ˡ x∈p₁)                 = ∣ˡ       (sound x∈p₁)
  sound (∣ʳ x∈p₂)                 = ∣ʳ false (sound x∈p₂)
  sound (_⊛_ {p₁ = p₁} f∈p₁ x∈p₂) = ⊛-complete p₁ (sound f∈p₁) (sound x∈p₂)
  sound (<$> x∈p)                 = sound x∈p !>>= return
  sound (+-[] x∈p)                = sound x∈p !>>= ∣ʳ false return
  sound (+-∷ x∈p xs∈p)            = sound x∈p !>>= ∣ˡ (sound xs∈p !>>= return)
  sound (∥ˡ x∈p₁)                 = ∣ˡ (sound x∈p₁ !>>= return)
  sound (∥ʳ x∈p₂)                 = ∣ʳ false (sound x∈p₂)
  sound between-[]                = tok-complete !>>= return
  sound (between-∷ {p = p} {ts = _ ∷ _} x∈p xs∈⋯) =
    tok-complete !>>=
    ⊛-complete (_ <$> ♭ p) (sound x∈p !>>= return) (sound xs∈⋯)

  complete : ∀ {R x s s′} (p : ParserProg R) →
             x ⊕ s′ ∈ ⟦ p ⟧ · s → x ⊕ s′ ∈⟦ p ⟧· s
  complete fail      ()

  complete (p₁ ∣ p₂) (∣ˡ        x∈p₁) = ∣ˡ (complete p₁ x∈p₁)
  complete (p₁ ∣ p₂) (∣ʳ .false x∈p₂) = ∣ʳ (complete p₂ x∈p₂)

  complete (p₁ ⊛ p₂) (f∈p₁ !>>= (y∈p₂ !>>= return)) =
    complete p₁ f∈p₁ ⊛ complete p₂ y∈p₂

  complete (f <$> p) (x∈p !>>= return) = <$> complete p x∈p

  complete (p +) (x∈p !>>= ∣ˡ (xs∈p+ !>>= return)) = +-∷  (complete p x∈p) (complete (p +) xs∈p+)
  complete (p +) (x∈p !>>= ∣ʳ .false return)       = +-[] (complete p x∈p)

  complete (p between (t ∷ [])) (t∈ !>>= return) with tok-sound t∈
  ... | (refl , refl) = between-[]
  complete (p between (t ∷ t′ ∷ ts))
           (t∈ !>>= (x∈p !>>= return !>>= (xs∈ !>>= return))) with tok-sound t∈
  ... | (refl , refl) =
    between-∷ (complete (♭ p) x∈p) (complete (p between (t′ ∷ ts)) xs∈)

  complete (p₁ ∥ p₂) (∣ˡ (x∈p₁ !>>= return)) = ∥ˡ (complete p₁ x∈p₁)
  complete (p₁ ∥ p₂) (∣ʳ .false x∈p₂)        = ∥ʳ (complete p₂ x∈p₂)

  -- Some lemmas.

  +-∷ʳ : ∀ {R x s s₁ s₂ xs} {p : ParserProg R} →
         xs ⊕ s₁ ∈⟦ p + ⟧· s → x ⊕ s₂ ∈⟦ p ⟧· s₁ →
         xs ⁺∷ʳ x ⊕ s₂ ∈⟦ p + ⟧· s
  +-∷ʳ {xs = _ ∷ ._} (+-[] x∈p)     y∈p = +-∷ x∈p (+-[] y∈p)
  +-∷ʳ {xs = _ ∷ ._} (+-∷ x∈p xs∈p) y∈p = +-∷ x∈p (+-∷ʳ xs∈p y∈p)

  cast∈ : ∀ {R x₁ x₂ s s′} {p : ParserProg R} →
          x₁ ≡ x₂ → x₁ ⊕ s′ ∈⟦ p ⟧· s → x₂ ⊕ s′ ∈⟦ p ⟧· s
  cast∈ refl x∈p = x∈p


------------------------------------------------------------------------
-- A definitional interpreter
------------------------------------------------------------------------

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

module Lambda.Simplified.Partiality-monad.Inductive.Interpreter where

open import Equality.Propositional.Cubical
open import Prelude hiding (⊥)

open import Bijection equality-with-J using (_↔_)
open import Function-universe equality-with-J hiding (id; _∘_)
open import Monad equality-with-J
open import Univalence-axiom equality-with-J
open import Vec.Function equality-with-J

open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Fixpoints
open import Partiality-monad.Inductive.Monad

open import Lambda.Simplified.Syntax

open Closure Tm

------------------------------------------------------------------------
-- One interpreter

module Interpreter₁ where

  -- This interpreter is defined as the least upper bound of a
  -- sequence of increasingly defined interpreters.

  infix 10 _∙_

  mutual

    ⟦_⟧′ : ∀ {n} → Tm n → Env n → ℕ → Value ⊥
    ⟦ var x ⟧′   ρ n = return (ρ x)
    ⟦ ƛ t ⟧′     ρ n = return (ƛ t ρ)
    ⟦ t₁ · t₂ ⟧′ ρ n = ⟦ t₁ ⟧′ ρ n >>= λ v₁ →
                       ⟦ t₂ ⟧′ ρ n >>= λ v₂ →
                       (v₁ ∙ v₂) n

    _∙_ : Value → Value → ℕ → Value ⊥
    (ƛ t₁ ρ ∙ v₂) zero    = never
    (ƛ t₁ ρ ∙ v₂) (suc n) = ⟦ t₁ ⟧′ (cons v₂ ρ) n

  mutual

    ⟦⟧′-increasing :
      ∀ {n} (t : Tm n) ρ n → ⟦ t ⟧′ ρ n ⊑ ⟦ t ⟧′ ρ (suc n)
    ⟦⟧′-increasing (var x)   ρ n = return (ρ x)   ■
    ⟦⟧′-increasing (ƛ t)     ρ n = return (ƛ t ρ) ■
    ⟦⟧′-increasing (t₁ · t₂) ρ n =
      ⟦⟧′-increasing t₁ ρ n >>=-mono λ v₁ →
      ⟦⟧′-increasing t₂ ρ n >>=-mono λ v₂ →
      ∙-increasing v₁ v₂ n

    ∙-increasing : ∀ v₁ v₂ n → (v₁ ∙ v₂) n ⊑ (v₁ ∙ v₂) (suc n)
    ∙-increasing (ƛ t₁ ρ) v₂ (suc n) = ⟦⟧′-increasing t₁ (cons v₂ ρ) n
    ∙-increasing (ƛ t₁ ρ) v₂ zero    =
      never                  ⊑⟨ never⊑ _ ⟩■
      ⟦ t₁ ⟧′ (cons v₂ ρ) 0  ■

  ⟦_⟧ˢ : ∀ {n} → Tm n → Env n → Increasing-sequence Value
  ⟦ t ⟧ˢ ρ = ⟦ t ⟧′ ρ , ⟦⟧′-increasing t ρ

  ⟦_⟧ : ∀ {n} → Tm n → Env n → Value ⊥
  ⟦ t ⟧ ρ = ⨆ (⟦ t ⟧ˢ ρ)

------------------------------------------------------------------------
-- Another interpreter

module Interpreter₂ where

  -- This interpreter is defined using a fixpoint combinator.

  M : Type → Type₁
  M = Partial (∃ λ n → Tm n × Env n) (λ _ → Value)

  infix 10 _∙_

  _∙_ : Value → Value → M Value
  ƛ t₁ ρ ∙ v₂ = rec (_ , t₁ , cons v₂ ρ)

  ⟦_⟧′ : ∀ {n} → Tm n → Env n → M Value
  ⟦ var x ⟧′   ρ = return (ρ x)
  ⟦ ƛ t ⟧′     ρ = return (ƛ t ρ)
  ⟦ t₁ · t₂ ⟧′ ρ = ⟦ t₁ ⟧′ ρ >>= λ v₁ →
                   ⟦ t₂ ⟧′ ρ >>= λ v₂ →
                   v₁ ∙ v₂

  evalP : (∃ λ n → Tm n × Env n) → M Value
  evalP (_ , t , ρ) = ⟦ t ⟧′ ρ

  eval : Trans-⊑ (∃ λ n → Tm n × Env n) (λ _ → Value)
  eval = transformer evalP

  ⟦_⟧ : ∀ {n} → Tm n → Env n → Value ⊥
  ⟦ t ⟧ ρ = fixP evalP (_ , t , ρ)

------------------------------------------------------------------------
-- The two interpreters are pointwise equal

-- Both interpreters' bodies have the form ⨆ s for some sequences s,
-- and element n in the first interpreter's sequence is equal to
-- element 1 + n in the second interpreter's sequence (when the
-- arguments are equal).

interpreters-equal :
  ∀ {n} (t : Tm n) ρ →
  Interpreter₁.⟦ t ⟧ ρ ≡ Interpreter₂.⟦ t ⟧ ρ
interpreters-equal = λ t ρ →
                                                                $⟨ ⟦⟧-lemma t ρ ⟩
  (∀ n → Interpreter₁.⟦ t ⟧′ ρ n ≡
         app→ Interpreter₂.eval (suc n) (_ , t , ρ))            ↝⟨ cong ⨆ ∘ _↔_.to equality-characterisation-increasing ⟩

  ⨆ (Interpreter₁.⟦ t ⟧ˢ ρ) ≡
  ⨆ (tailˢ (at (fix→-sequence Interpreter₂.eval) (_ , t , ρ)))  ↝⟨ flip trans (⨆tail≡⨆ _) ⟩

  ⨆ (Interpreter₁.⟦ t ⟧ˢ ρ) ≡
  ⨆ (at (fix→-sequence Interpreter₂.eval) (_ , t , ρ))          ↝⟨ id ⟩□

  Interpreter₁.⟦ t ⟧ ρ ≡ Interpreter₂.⟦ t ⟧ ρ                   □
  where
  open Partial
  open Trans-⊑

  mutual

    ⟦⟧-lemma :
      ∀ {n} (t : Tm n) ρ n →
      Interpreter₁.⟦ t ⟧′ ρ n ≡
      function (Interpreter₂.⟦ t ⟧′ ρ)
               (app→ Interpreter₂.eval n)
    ⟦⟧-lemma (var x)   ρ n = refl
    ⟦⟧-lemma (ƛ t)     ρ n = refl
    ⟦⟧-lemma (t₁ · t₂) ρ n =
      cong₂ _>>=_ (⟦⟧-lemma t₁ ρ n) $ ⟨ext⟩ λ v₁ →
      cong₂ _>>=_ (⟦⟧-lemma t₂ ρ n) $ ⟨ext⟩ λ v₂ →
      ∙-lemma v₁ v₂ n

    ∙-lemma :
      ∀ v₁ v₂ n →
      (v₁ Interpreter₁.∙ v₂) n ≡
      function (v₁ Interpreter₂.∙ v₂)
               (app→ Interpreter₂.eval n)
    ∙-lemma (ƛ t₁ ρ) v₂ zero    = refl
    ∙-lemma (ƛ t₁ ρ) v₂ (suc n) = ⟦⟧-lemma t₁ (cons v₂ ρ) n

------------------------------------------------------------------------
-- An example

-- The semantics of Ω is the non-terminating computation never.

-- A proof for Interpreter₁.

Ω-loops₁ : Interpreter₁.⟦ Ω ⟧ nil ≡ never
Ω-loops₁ =
  antisymmetry (least-upper-bound _ _ lemma) (never⊑ _)
  where
  open Interpreter₁

  ω-nil = ƛ (var fzero · var fzero) nil

  reduce-twice :
    ∀ n → ⟦ Ω ⟧′ nil n ≡ (ω-nil ∙ ω-nil) n
  reduce-twice n =
    ⟦ Ω ⟧′ nil n                              ≡⟨ now->>= ⟩
    (⟦ ω ⟧′ nil n >>= λ v₂ → (ω-nil ∙ v₂) n)  ≡⟨ now->>= ⟩∎
    (ω-nil ∙ ω-nil) n                         ∎

  lemma : ∀ n → ⟦ Ω ⟧′ nil n ⊑ never
  lemma zero    =
    ⟦ Ω ⟧′ nil zero       ≡⟨ reduce-twice zero ⟩⊑
    (ω-nil ∙ ω-nil) zero  ⊑⟨⟩
    never                 ■
  lemma (suc n) =
    ⟦ Ω ⟧′ nil (suc n)  ≡⟨ reduce-twice (suc n) ⟩⊑
    ⟦ Ω ⟧′ nil n        ⊑⟨ lemma n ⟩■
    never               ■

-- A direct proof for Interpreter₂.

Ω-loops₂ : Interpreter₂.⟦ Ω ⟧ nil ≡ never
Ω-loops₂ = antisymmetry (least-upper-bound _ _ lemma) (never⊑ _)
  module Ω-loops₂ where
  open Interpreter₂
  open Trans-⊑
  open Partial

  ω-nil = ƛ (var fzero · var fzero) nil

  reduce-twice :
    ∀ f →
    function eval f (_ , Ω , nil) ≡
    f (_ , var fzero · var fzero , cons ω-nil nil)
  reduce-twice f =
    function eval f (_ , Ω , nil)                   ≡⟨⟩
    function (⟦ Ω ⟧′ nil) f                         ≡⟨ cong {x = function (⟦ Ω ⟧′ nil)}              (_$ f) (⟨ext⟩ λ _ → now->>=) ⟩
    function (⟦ ω ⟧′ nil >>= λ v₂ → ω-nil ∙ v₂) f   ≡⟨ cong {x = function (⟦ ω ⟧′ nil >>= ω-nil ∙_)} (_$ f) (⟨ext⟩ λ _ → now->>=) ⟩
    function (ω-nil ∙ ω-nil) f                      ≡⟨⟩
    f (_ , var fzero · var fzero , cons ω-nil nil)  ∎

  lemma : ∀ n → app→ eval n (_ , Ω , nil) ⊑ never
  lemma zero       = never⊑ never
  lemma (suc zero) =
    app→ eval 1 (_ , Ω , nil)  ≡⟨ reduce-twice _ ⟩⊑
    app→ eval 0 (_ , Ω , nil)  ⊑⟨⟩
    never                      ■
  lemma (suc (suc n)) =
    app→ eval (suc (suc n)) (_ , Ω , nil)  ≡⟨ reduce-twice _ ⟩⊑
    app→ eval (suc n) (_ , Ω , nil)        ⊑⟨ lemma (suc n) ⟩■
    never                                  ■

-- Another proof for Interpreter₂. This proof uses Scott induction.

Ω-loops₂′ : Interpreter₂.⟦ Ω ⟧ nil ≡ never
Ω-loops₂′ = antisymmetry lemma (never⊑ _)
  where
  open Interpreter₂
  open Trans-⊑
  open Partial

  lemma =
    ⟦ Ω ⟧ nil                                              ⊑⟨⟩

    fixP evalP (_ , Ω , nil)                               ≡⟨ cong (_$ (_ , Ω , nil)) $
                                                                fixP-is-fixpoint-combinator evalP ⟩⊑
    function eval (fixP evalP) (_ , Ω , nil)               ⊑⟨ fixP-induction₁
                                                                (λ f → function eval f (_ , Ω , nil) ⊑ never) (
        function eval (const never) (_ , Ω , nil)                  ≡⟨ Ω-loops₂.reduce-twice _ ⟩⊑
        never                                                      ■)
                                                                (λ s hyp →
        function eval (⨆ ∘ s) (_ , Ω , nil)                        ≡⟨ Ω-loops₂.reduce-twice _ ⟩⊑
        ⨆ (s _)                                                    ⊑⟨ least-upper-bound _ _ (λ n →

            s _ [ n ]                                                   ≡⟨ sym $ Ω-loops₂.reduce-twice _ ⟩⊑
            function eval (λ x → s x [ n ]) (_ , Ω , nil)               ⊑⟨ hyp n ⟩■
            never                                                       ■) ⟩

        never                                                      ■)
                                                                evalP
                                                                (λ g hyp →
        function eval (function eval g) (_ , Ω , nil)              ≡⟨ Ω-loops₂.reduce-twice _ ⟩⊑
        function eval g (_ , Ω , nil)                              ⊑⟨ hyp ⟩■
        never                                                      ■) ⟩■

    never                                                  ■

------------------------------------------------------------------------
-- Setup

-- Let us use Interpreter₂ as the default interpreter.

open Interpreter₂ public


------------------------------------------------------------------------
-- Bag equivalence for lists
------------------------------------------------------------------------

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

open import Equality

module Bag-equivalence
  {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq hiding (trans)

open import Logical-equivalence using (_⇔_)
open import Prelude as P hiding (id; swap)

open import Bijection eq using (_↔_; module _↔_; Σ-≡,≡↔≡)
open import Equality.Decision-procedures eq
open import Fin eq as Finite
open import Function-universe eq as Function-universe
  hiding (_∘_; Kind; module Kind; bijection)
open import H-level eq
open import H-level.Closure eq
open import Injection eq using (_↣_)
open import List eq
open import Monad eq hiding (map)
open import Nat eq hiding (_≟_)

private
  variable
    a ℓ p q                  : Level
    A B                      : Type a
    P Q                      : A → Type p
    x y z                    : A
    xs xs₁ xs₂ ys ys₁ ys₂ zs : List A
    xss yss                  : List (List A)
    k                        : Function-universe.Kind
    m n                      : ℕ

------------------------------------------------------------------------
-- Any

-- Any.

Any : (A → Type p) → List A → Type p
Any P []       = ⊥
Any P (x ∷ xs) = P x ⊎ Any P xs

-- Alternative definition of Any.

data Any′ {A : Type a} (P : A → Type p) : List A → Type (a ⊔ p) where
  here  : ∀ {x xs} → P x       → Any′ P (x ∷ xs)
  there : ∀ {x xs} → Any′ P xs → Any′ P (x ∷ xs)

-- The two definitions of Any are isomorphic.

Any′-[] : Any′ P [] ↔ ⊥ {ℓ = ℓ}
Any′-[] = record
  { surjection = record
    { logical-equivalence = record
      { from = λ ()
      ; to   = λ ()
      }
    ; right-inverse-of = λ ()
    }
  ; left-inverse-of = λ ()
  }

Any′-∷ : Any′ P (x ∷ xs) ↔ P x ⊎ Any′ P xs
Any′-∷ = record
  { surjection = record
    { logical-equivalence = record
      { from = [ here , there ]
      ; to   = λ where
                 (here p)  → inj₁ p
                 (there p) → inj₂ p
        }
    ; right-inverse-of = [ (λ _ → refl _) , (λ _ → refl _) ]
    }
  ; left-inverse-of = λ where
      (here _)  → refl _
      (there _) → refl _
  }

Any↔Any′ : Any P xs ↔ Any′ P xs
Any↔Any′ {P = P} {xs = []} =
  ⊥          ↔⟨ inverse Any′-[] ⟩
  Any′ P []  □
Any↔Any′ {P = P} {xs = x ∷ xs} =
  P x ⊎ Any P xs   ↔⟨ id ⊎-cong Any↔Any′ {P = P} ⟩
  P x ⊎ Any′ P xs  ↔⟨ inverse Any′-∷ ⟩
  Any′ P (x ∷ xs)  □

------------------------------------------------------------------------
-- Lemmas relating Any to some basic list functions

Any-++ : (P : A → Type p) (xs ys : List A) →
         Any P (xs ++ ys) ↔ Any P xs ⊎ Any P ys
Any-++ P [] ys =
  Any P ys      ↔⟨ inverse ⊎-left-identity ⟩
  ⊥ ⊎ Any P ys  □
Any-++ P (x ∷ xs) ys =
  P x ⊎ Any P (xs ++ ys)       ↔⟨ id ⊎-cong Any-++ P xs ys ⟩
  P x ⊎ (Any P xs ⊎ Any P ys)  ↔⟨ ⊎-assoc ⟩
  (P x ⊎ Any P xs) ⊎ Any P ys  □

Any-concat : (P : A → Type p) (xss : List (List A)) →
             Any P (concat xss) ↔ Any (Any P) xss
Any-concat P []         = id
Any-concat P (xs ∷ xss) =
  Any P (xs ++ concat xss)       ↔⟨ Any-++ P xs (concat xss) ⟩
  Any P xs ⊎ Any P (concat xss)  ↔⟨ id ⊎-cong Any-concat P xss ⟩
  Any P xs ⊎ Any (Any P) xss     □

Any-map : (P : B → Type p) (f : A → B) (xs : List A) →
          Any P (map f xs) ↔ Any (P ∘ f) xs
Any-map P f []       = id
Any-map P f (x ∷ xs) =
  P (f x)   ⊎ Any P (map f xs)  ↔⟨ id ⊎-cong Any-map P f xs ⟩
  (P ∘ f) x ⊎ Any (P ∘ f) xs    □

Any->>= : {A B : Type ℓ}
          (P : B → Type p) (xs : List A) (f : A → List B) →
          Any P (xs >>= f) ↔ Any (Any P ∘ f) xs
Any->>= P xs f =
  Any P (concat (map f xs))  ↔⟨ Any-concat P (map f xs) ⟩
  Any (Any P) (map f xs)     ↔⟨ Any-map (Any P) f xs ⟩
  Any (Any P ∘ f) xs         □

Any-filter : (P : A → Type p) (p : A → Bool) (xs : List A) →
             Any P (filter p xs) ↔ Any (λ x → P x × T (p x)) xs
Any-filter P p []       = ⊥ □
Any-filter P p (x ∷ xs) with p x
... | true  =
   P x      ⊎ Any P (filter p xs)           ↔⟨ inverse ×-right-identity ⊎-cong Any-filter P p xs ⟩
  (P x × ⊤) ⊎ Any (λ x → P x × T (p x)) xs  □
... | false =
  Any P (filter p xs)                       ↔⟨ Any-filter P p xs ⟩
              Any (λ x → P x × T (p x)) xs  ↔⟨ inverse ⊎-left-identity ⟩
  ⊥₀        ⊎ Any (λ x → P x × T (p x)) xs  ↔⟨ inverse ×-right-zero ⊎-cong (_ □) ⟩
  (P x × ⊥) ⊎ Any (λ x → P x × T (p x)) xs  □

------------------------------------------------------------------------
-- List membership

infix 4 _∈_

_∈_ : A → List A → Type _
x ∈ xs = Any (λ y → x ≡ y) xs

-- Any can be expressed using _∈_.

Any-∈ : (P : A → Type p) (xs : List A) →
        Any P xs ↔ ∃ λ x → P x × x ∈ xs
Any-∈ P [] =
  ⊥                  ↔⟨ inverse ×-right-zero ⟩
  (∃ λ x → ⊥₀)       ↔⟨ ∃-cong (λ x → inverse ×-right-zero) ⟩
  (∃ λ x → P x × ⊥)  □
Any-∈ P (x ∷ xs) =
  P x                   ⊎ Any P xs                ↔⟨ ∃-intro P x ⊎-cong Any-∈ P xs ⟩
  (∃ λ y → P y × y ≡ x) ⊎ (∃ λ y → P y × y ∈ xs)  ↔⟨ inverse ∃-⊎-distrib-left ⟩
  (∃ λ y → P y × y ≡ x ⊎ P y × y ∈ xs)            ↔⟨ ∃-cong (λ y → inverse ×-⊎-distrib-left) ⟩
  (∃ λ y → P y × (y ≡ x ⊎ y ∈ xs))                □

-- Using this property we can prove that Any and _⊎_ commute.

Any-⊎ : (P : A → Type p) (Q : A → Type q) (xs : List A) →
        Any (λ x → P x ⊎ Q x) xs ↔ Any P xs ⊎ Any Q xs
Any-⊎ P Q xs =
  Any (λ x → P x ⊎ Q x) xs                         ↔⟨ Any-∈ (λ x → P x ⊎ Q x) xs ⟩
  (∃ λ x → (P x ⊎ Q x) × x ∈ xs)                   ↔⟨ ∃-cong (λ x → ×-⊎-distrib-right) ⟩
  (∃ λ x → P x × x ∈ xs ⊎ Q x × x ∈ xs)            ↔⟨ ∃-⊎-distrib-left ⟩
  (∃ λ x → P x × x ∈ xs) ⊎ (∃ λ x → Q x × x ∈ xs)  ↔⟨ inverse $ Any-∈ P xs ⊎-cong Any-∈ Q xs ⟩
  Any P xs ⊎ Any Q xs                              □

------------------------------------------------------------------------
-- Some lemmas related to list membership

-- If f and g are pointwise equal for elements in xs, then map f xs
-- and map g xs are equal.

map-cong-∈ :
  (f g : A → B) (xs : List A) →
  (∀ {x} → x ∈ xs → f x ≡ g x) →
  map f xs ≡ map g xs
map-cong-∈ p q []       p≡q = refl _
map-cong-∈ p q (x ∷ xs) p≡q =
  cong₂ _∷_ (p≡q (inj₁ (refl _))) (map-cong-∈ p q xs (p≡q ∘ inj₂))

-- If p and q are pointwise equal for elements in xs, then filter p xs
-- and filter q xs are equal.

filter-cong-∈ :
  (p q : A → Bool) (xs : List A) →
  (∀ {x} → x ∈ xs → p x ≡ q x) →
  filter p xs ≡ filter q xs
filter-cong-∈ p q []       p≡q = refl _
filter-cong-∈ p q (x ∷ xs) p≡q
  with p x | q x | p≡q (inj₁ (refl _))
     | filter-cong-∈ p q xs (p≡q ∘ inj₂)
... | true  | true  | _   | ih = cong (x ∷_) ih
... | false | false | _   | ih = ih
... | true  | false | t≡f | _  = ⊥-elim $ Bool.true≢false t≡f
... | false | true  | f≡t | _  = ⊥-elim $ Bool.true≢false $ sym f≡t

-- The ordering of natural numbers can be related to list membership
-- and nats-<.

<-↔-∈-nats-< : m < n ↔ m ∈ nats-< n
<-↔-∈-nats-< {m = m} {n = zero} =
  m < zero         ↝⟨ <zero↔ ⟩
  ⊥                ↔⟨⟩
  m ∈ nats-< zero  □
<-↔-∈-nats-< {m = m} {n = suc n} =
  m < suc n             ↔⟨⟩
  suc m ≤ suc n         ↝⟨ suc≤suc↔ ⟩
  m ≤ n                 ↝⟨ ≤↔<⊎≡ ⟩
  m < n ⊎ m ≡ n         ↝⟨ ⊎-comm ⟩
  m ≡ n ⊎ m < n         ↝⟨ Function-universe.id ⊎-cong <-↔-∈-nats-< ⟩
  m ≡ n ⊎ m ∈ nats-< n  ↔⟨⟩
  m ∈ nats-< (suc n)    □

------------------------------------------------------------------------
-- Bag and set equivalence and the subset and subbag orders

-- Various kinds of relatedness.
--
-- NOTE: Perhaps it would be better to define the subbag property in
-- terms of embeddings, rather than injections. The HoTT book (first
-- edition) claims that injectivity "is an ill-behaved notion for
-- non-sets".

open Function-universe public using (Kind) hiding (module Kind)

module Kind where

  open Function-universe public
    using ()
    renaming ( implication         to subset
             ; logical-equivalence to set
             ; injection           to subbag
             ; bijection           to bag
             ; equivalence         to bag-with-equivalence
             ; equivalenceᴱ        to bag-with-equivalenceᴱ
             )

open Kind public

-- A general definition of "relatedness" for lists.

infix 4 _∼[_]_

_∼[_]_ : {A : Type a} → List A → Kind → List A → Type a
xs ∼[ k ] ys = ∀ z → z ∈ xs ↝[ k ] z ∈ ys

-- Bag equivalence.

infix 4 _≈-bag_

_≈-bag_ : {A : Type a} → List A → List A → Type a
xs ≈-bag ys = xs ∼[ bag ] ys

-- Alternative definition of bag equivalence.

infix 4 _≈-bag′_

record _≈-bag′_ {A : Type a} (xs ys : List A) : Type a where
  field
    bijection : Fin (length xs) ↔ Fin (length ys)
    related   : xs And ys Are-related-by bijection

-- Yet another definition of bag equivalence. This definition is taken
-- from Coq's standard library.

infixr 5 _∷_
infix  4 _≈-bag″_

data _≈-bag″_ {A : Type a} : List A → List A → Type a where
  []    : [] ≈-bag″ []
  _∷_   : ∀ x {xs ys} (xs≈ys : xs ≈-bag″ ys) → x ∷ xs ≈-bag″ x ∷ ys
  swap  : ∀ {x y xs} → x ∷ y ∷ xs ≈-bag″ y ∷ x ∷ xs
  trans : ∀ {xs ys zs}
          (xs≈ys : xs ≈-bag″ ys) (ys≈zs : ys ≈-bag″ zs) → xs ≈-bag″ zs

------------------------------------------------------------------------
-- Some congruence lemmas

Any-cong : (∀ x → P x ↝[ k ] Q x) → xs ∼[ k ] ys →
           Any P xs ↝[ k ] Any Q ys
Any-cong {P = P} {Q = Q} {xs = xs} {ys = ys} P↔Q xs≈ys =
  Any P xs                ↔⟨ Any-∈ P xs ⟩
  (∃ λ z → P z × z ∈ xs)  ↝⟨ ∃-cong (λ z → P↔Q z ×-cong xs≈ys z) ⟩
  (∃ λ z → Q z × z ∈ ys)  ↔⟨ inverse (Any-∈ Q ys) ⟩
  Any Q ys                □

++-cong : xs₁ ∼[ k ] ys₁ → xs₂ ∼[ k ] ys₂ →
          xs₁ ++ xs₂ ∼[ k ] ys₁ ++ ys₂
++-cong {xs₁ = xs₁} {ys₁ = ys₁} {xs₂ = xs₂} {ys₂ = ys₂}
        xs₁∼ys₁ xs₂∼ys₂ = λ z →
  z ∈ xs₁ ++ xs₂     ↔⟨ Any-++ _ xs₁ xs₂ ⟩
  z ∈ xs₁ ⊎ z ∈ xs₂  ↝⟨ xs₁∼ys₁ z ⊎-cong xs₂∼ys₂ z ⟩
  z ∈ ys₁ ⊎ z ∈ ys₂  ↔⟨ inverse (Any-++ _ ys₁ ys₂) ⟩
  z ∈ ys₁ ++ ys₂     □

map-cong : (f : A → B) → xs ∼[ k ] ys → map f xs ∼[ k ] map f ys
map-cong {xs = xs} {ys = ys} f xs∼ys = λ z →
  z ∈ map f xs            ↔⟨ Any-map _ f xs ⟩
  Any (λ x → z ≡ f x) xs  ↝⟨ Any-cong (λ x → z ≡ f x □) xs∼ys ⟩
  Any (λ x → z ≡ f x) ys  ↔⟨ inverse (Any-map _ f ys) ⟩
  z ∈ map f ys            □

concat-cong : xss ∼[ k ] yss → concat xss ∼[ k ] concat yss
concat-cong {xss = xss} {yss = yss} xss∼yss = λ z →
  z ∈ concat xss           ↔⟨ Any-concat _ xss ⟩
  Any (λ zs → z ∈ zs) xss  ↝⟨ Any-cong (λ zs → z ∈ zs □) xss∼yss ⟩
  Any (λ zs → z ∈ zs) yss  ↔⟨ inverse (Any-concat _ yss) ⟩
  z ∈ concat yss           □

>>=-cong : {A B : Type ℓ} {xs ys : List A} {f g : A → List B} →
           xs ∼[ k ] ys → (∀ x → f x ∼[ k ] g x) →
           (xs >>= f) ∼[ k ] (ys >>= g)
>>=-cong {xs = xs} {ys = ys} {f = f} {g = g} xs∼ys f∼g = λ z →
  z ∈ xs >>= f            ↔⟨ Any->>= _ xs f ⟩
  Any (λ x → z ∈ f x) xs  ↝⟨ Any-cong (λ x → f∼g x z) xs∼ys ⟩
  Any (λ x → z ∈ g x) ys  ↔⟨ inverse (Any->>= _ ys g) ⟩
  z ∈ ys >>= g            □

filter-cong : (p : A → Bool) (xs ys : List A) →
              xs ∼[ k ] ys → filter p xs ∼[ k ] filter p ys
filter-cong p xs ys xs∼ys = λ z →
  z ∈ filter p xs                 ↔⟨ Any-filter _ p xs ⟩
  Any (λ x → z ≡ x × T (p x)) xs  ↝⟨ Any-cong (λ _ → _ □) xs∼ys ⟩
  Any (λ x → z ≡ x × T (p x)) ys  ↔⟨ inverse (Any-filter _ p ys) ⟩
  z ∈ filter p ys                 □

------------------------------------------------------------------------
-- More properties

-- Any preserves decidability of equality.

module Dec (dec : ∀ {x} → Decidable-equality (P x)) where

  infix 4 _≟_

  _≟_ : Decidable-equality (Any P xs)
  _≟_ {xs = _ ∷ _} = ⊎.Dec._≟_ dec _≟_

-- If the type of x is a set, then equality is decidable for x ∈ xs.

module Dec-∈ (A-set : Is-set A) where

  infix 4 _≟_

  _≟_ : ∀ {x xs} → Decidable-equality (x ∈ xs)
  _≟_ = Dec._≟_ λ _ _ → yes (A-set _ _)

-- Bind distributes from the left over append.

>>=-left-distributive :
  {A B : Type ℓ} (xs : List A) (f g : A → List B) →
  xs >>= (λ x → f x ++ g x) ≈-bag (xs >>= f) ++ (xs >>= g)
>>=-left-distributive xs f g = λ z →
  z ∈ xs >>= (λ x → f x ++ g x)                    ↔⟨ Any->>= (_≡_ z) xs (λ x → f x ++ g x) ⟩
  Any (λ x → z ∈ f x ++ g x) xs                    ↔⟨ Any-cong (λ x → Any-++ (_≡_ z) (f x) (g x)) (λ _ → id) ⟩
  Any (λ x → z ∈ f x ⊎ z ∈ g x) xs                 ↔⟨ Any-⊎ (λ x → z ∈ f x) (λ x → z ∈ g x) xs ⟩
  Any (λ x → z ∈ f x) xs ⊎ Any (λ x → z ∈ g x) xs  ↔⟨ inverse (Any->>= (_≡_ z) xs f ⊎-cong Any->>= (_≡_ z) xs g) ⟩
  z ∈ xs >>= f ⊎ z ∈ xs >>= g                      ↔⟨ inverse (Any-++ (_≡_ z) (xs >>= f) (xs >>= g)) ⟩
  z ∈ (xs >>= f) ++ (xs >>= g)                     □

-- This property does not hold for ordinary list equality.

¬->>=-left-distributive :
  ¬ ({A B : Type} (xs : List A) (f g : A → List B) →
     xs >>= (λ x → f x ++ g x) ≡ (xs >>= f) ++ (xs >>= g))
¬->>=-left-distributive distrib = Bool.true≢false true≡false
  where
  tf = true ∷ false ∷ []
  f  = λ x → x ∷ []
  g  = f

  ttff≡tftf : true ∷ true ∷ false ∷ false ∷ [] ≡
              true ∷ false ∷ true ∷ false ∷ []
  ttff≡tftf = distrib tf f g

  true≡false : true ≡ false
  true≡false = List.cancel-∷-head (List.cancel-∷-tail ttff≡tftf)

-- _++_ is commutative.

++-comm : (xs ys : List A) → xs ++ ys ≈-bag ys ++ xs
++-comm xs ys = λ z →
  z ∈ xs ++ ys     ↔⟨ Any-++ (_≡_ z) xs ys ⟩
  z ∈ xs ⊎ z ∈ ys  ↔⟨ ⊎-comm ⟩
  z ∈ ys ⊎ z ∈ xs  ↔⟨ inverse (Any-++ (_≡_ z) ys xs) ⟩
  z ∈ ys ++ xs     □

-- _++_ is idempotent (when set equivalence is used).

++-idempotent : (xs : List A) → xs ++ xs ∼[ set ] xs
++-idempotent xs = λ z →
  z ∈ xs ++ xs     ↔⟨ Any-++ (_≡_ z) xs xs ⟩
  z ∈ xs ⊎ z ∈ xs  ↝⟨ ⊎-idempotent ⟩
  z ∈ xs           □

-- The so-called "range splitting" property (see, for instance,
-- Hoogendijks "(Relational) Programming Laws in the Boom Hierarchy of
-- Types").

range-splitting : (p : A → Bool) (xs : List A) →
                  filter p xs ++ filter (not ∘ p) xs ≈-bag xs
range-splitting p xs = λ z →
  z ∈ filter p xs ++ filter (not ∘ p) xs                  ↔⟨ Any-++ _ _ (filter (not ∘ p) xs) ⟩
  z ∈ filter p xs ⊎ z ∈ filter (not ∘ p) xs               ↔⟨ Any-filter _ p xs ⊎-cong Any-filter _ (not ∘ p) xs ⟩
  Any (λ x → z ≡ x × T (p x)) xs ⊎
    Any (λ x → z ≡ x × T (not (p x))) xs                  ↔⟨ inverse $ Any-⊎ _ _ xs ⟩
  Any (λ x → z ≡ x × T (p x) ⊎ z ≡ x × T (not (p x))) xs  ↔⟨ Any-cong (λ x → lemma (z ≡ x) (p x)) (λ x → x ∈ xs □) ⟩
  z ∈ xs                                                  □
  where
  lemma : ∀ {a} (A : Type a) (b : Bool) → A × T b ⊎ A × T (not b) ↔ A
  lemma A b =
    A × T b ⊎ A × T (not b)  ↔⟨ ×-comm ⊎-cong ×-comm ⟩
    T b × A ⊎ T (not b) × A  ↔⟨ if-lemma (λ _ → A) id id b ⟩
    A                        □

-- The so-called "range disjunction" property, strengthened to use the
-- subbag preorder instead of set equivalence.

range-disjunction :
  (p q : A → Bool) (xs : List A) →
  filter (λ x → p x ∨ q x) xs ∼[ subbag ]
  filter p xs ++ filter q xs
range-disjunction p q xs = λ z →
  z ∈ filter (λ x → p x ∨ q x) xs                                  ↔⟨ Any-filter _ (λ x → p x ∨ q x) _ ⟩
  Any (λ x → z ≡ x × T (p x ∨ q x)) xs                             ↝⟨ Any-cong (λ x → lemma (z ≡ x) (p x) (q x)) (λ x → x ∈ xs □) ⟩
  Any (λ x → z ≡ x × T (p x) ⊎ z ≡ x × T (q x)) xs                 ↔⟨ Any-⊎ _ _ _ ⟩
  Any (λ x → z ≡ x × T (p x)) xs ⊎ Any (λ x → z ≡ x × T (q x)) xs  ↔⟨ inverse (Any-filter _ p _ ⊎-cong Any-filter _ q _) ⟩
  z ∈ filter p xs ⊎ z ∈ filter q xs                                ↔⟨ inverse $ Any-++ _ _ _ ⟩
  z ∈ filter p xs ++ filter q xs                                   □
  where
  inj : (b₁ b₂ : Bool) → T (b₁ ∨ b₂) ↣ T b₁ ⊎ T b₂
  inj true  true  = record { to = inj₁; injective = λ _ → refl _  }
  inj true  false = record { to = inj₁; injective = ⊎.cancel-inj₁ }
  inj false true  = record { to = inj₂; injective = ⊎.cancel-inj₂ }
  inj false false = record { to = λ (); injective = λ {}          }

  lemma : ∀ {a} (A : Type a) (b₁ b₂ : Bool) →
          A × T (b₁ ∨ b₂) ↣ A × T b₁ ⊎ A × T b₂
  lemma A b₁ b₂ =
    A × T (b₁ ∨ b₂)      ↝⟨ id ×-cong inj b₁ b₂ ⟩
    A × (T b₁ ⊎ T b₂)    ↔⟨ ×-⊎-distrib-left ⟩
    A × T b₁ ⊎ A × T b₂  □

------------------------------------------------------------------------
-- The first two definitions of bag equivalence above are logically
-- equivalent

-- One direction follows from the following lemma, which states that
-- list membership can be expressed as "there is an index which points
-- to the element".
--
-- As an aside, note that the right-hand side is almost
-- index xs ⁻¹ z.

∈-index : (xs : List A) → z ∈ xs ↔ ∃ λ i → z ≡ index xs i
∈-index {z = z} [] =
  ⊥                               ↔⟨ inverse $ ∃-Fin-zero _ ⟩
  (∃ λ (i : ⊥) → z ≡ index [] i)  □
∈-index {z = z} (x ∷ xs) =
  z ≡ x ⊎ z ∈ xs                    ↔⟨ id ⊎-cong ∈-index xs ⟩
  z ≡ x ⊎ (∃ λ i → z ≡ index xs i)  ↔⟨ inverse $ ∃-Fin-suc _ ⟩
  (∃ λ i → z ≡ index (x ∷ xs) i)    □

-- The index which points to the element.

index-of : z ∈ xs → Fin (length xs)
index-of = proj₁ ∘ _↔_.to (∈-index _)

-- For the other direction a sequence of lemmas is used.

-- The first lemma states that ∃ λ z → z ∈ xs is isomorphic to Fin n,
-- where n is the length of xs. Thierry Coquand pointed out that this
-- is a generalisation of singleton-contractible.

Fin-length : (xs : List A) → (∃ λ z → z ∈ xs) ↔ Fin (length xs)
Fin-length xs =
  (∃ λ z → z ∈ xs)                  ↔⟨ ∃-cong (λ _ → ∈-index xs) ⟩
  (∃ λ z → ∃ λ i → z ≡ index xs i)  ↔⟨ ∃-comm ⟩
  (∃ λ i → ∃ λ z → z ≡ index xs i)  ↔⟨⟩
  (∃ λ i → Singleton (index xs i))  ↔⟨ ∃-cong (λ _ → _⇔_.to contractible⇔↔⊤ (singleton-contractible _)) ⟩
  Fin (length xs) × ⊤               ↔⟨ ×-right-identity ⟩
  Fin (length xs)                   □

-- From this lemma we get that lists which are bag equivalent have
-- related lengths.

Fin-length-cong : xs ≈-bag ys → Fin (length xs) ↔ Fin (length ys)
Fin-length-cong {xs = xs} {ys = ys} xs≈ys =
  Fin (length xs)   ↔⟨ inverse $ Fin-length xs ⟩
  ∃ (λ z → z ∈ xs)  ↔⟨ ∃-cong xs≈ys ⟩
  ∃ (λ z → z ∈ ys)  ↔⟨ Fin-length ys ⟩
  Fin (length ys)   □

abstract

  -- In fact, they have equal lengths.

  length-cong : xs ≈-bag ys → length xs ≡ length ys
  length-cong = _⇔_.to Finite.isomorphic-same-size ∘ Fin-length-cong

  -- All that remains (except for some bookkeeping) is to show that
  -- the isomorphism which Fin-length-cong returns relates the two
  -- lists.

  Fin-length-cong-relates :
    {xs ys : List A} (xs≈ys : xs ≈-bag ys) →
    xs And ys Are-related-by Fin-length-cong xs≈ys
  Fin-length-cong-relates {xs = xs} {ys = ys} xs≈ys i =
    index xs i                                ≡⟨ proj₂ $ to (∈-index _) $ to (xs≈ys _) (from (∈-index _) (i , refl _)) ⟩
    index ys (proj₁ $ to (∈-index _) $
              to (xs≈ys _) $
              from (∈-index _) (i , refl _))  ≡⟨⟩
    index ys (to (Fin-length-cong xs≈ys) i)   ∎
    where open _↔_

-- We get that the two definitions of bag equivalence are logically
-- equivalent.

≈⇔≈′ : xs ≈-bag ys ⇔ xs ≈-bag′ ys
≈⇔≈′ = record
  { to   = λ xs≈ys → record
             { bijection = Fin-length-cong xs≈ys
             ; related   = Fin-length-cong-relates xs≈ys
             }
  ; from = from
  }
  where
  equality-lemma : y ≡ z → (x ≡ y) ↔ (x ≡ z)
  equality-lemma = flip-trans-isomorphism

  from : xs ≈-bag′ ys → xs ≈-bag ys
  from {xs = xs} {ys = ys} xs≈ys z =
    z ∈ xs                    ↔⟨ ∈-index xs ⟩
    ∃ (λ i → z ≡ index xs i)  ↔⟨ Σ-cong (_≈-bag′_.bijection xs≈ys)
                                        (λ i → equality-lemma $
                                                 _≈-bag′_.related xs≈ys i) ⟩
    ∃ (λ i → z ≡ index ys i)  ↔⟨ inverse (∈-index ys) ⟩
    z ∈ ys                    □

------------------------------------------------------------------------
-- Left cancellation

-- We have basically already showed that cons is left cancellative for
-- the (first) alternative definition of bag equivalence.

∷-left-cancellative′ : ∀ xs ys → x ∷ xs ≈-bag′ x ∷ ys → xs ≈-bag′ ys
∷-left-cancellative′ {x = x} xs ys x∷xs≈x∷ys = record
  { bijection = Finite.cancel-suc (_≈-bag′_.bijection x∷xs≈x∷ys)
  ; related   = Finite.cancel-suc-preserves-relatedness x xs ys
                  (_≈-bag′_.bijection x∷xs≈x∷ys)
                  (_≈-bag′_.related x∷xs≈x∷ys)
  }

-- By the equivalence above we get the result also for the first
-- definition of bag equivalence, but we can show this directly, with
-- the help of some lemmas.

abstract

  -- The index-of function commutes with applications of certain
  -- inverses. Note that the last three equational reasoning steps do
  -- not need to be written out; I included them in an attempt to make
  -- it easier to understand why the lemma holds.

  index-of-commutes :
    {xs ys : List A} (xs≈ys : xs ≈-bag ys) (p : z ∈ xs) →
    index-of (_↔_.to (xs≈ys z) p) ≡
    _↔_.to (Fin-length-cong xs≈ys) (index-of p)
  index-of-commutes {z = z} {xs = xs} {ys = ys} xs≈ys p =
    index-of $ to (xs≈ys z) p                                     ≡⟨⟩

    index-of $ proj₂ $ Σ-map P.id (λ {x} → to (xs≈ys x)) (z , p)  ≡⟨ cong (index-of ∘ proj₂ ∘ Σ-map P.id (to (xs≈ys _))) $ sym $
                                                                     left-inverse-of (Fin-length xs) (z , p) ⟩
    index-of $ proj₂ $ Σ-map P.id (λ {x} → to (xs≈ys x)) $
    from (Fin-length xs) $ to (Fin-length xs) (z , p)             ≡⟨⟩

    to (Fin-length ys) $ Σ-map P.id (λ {x} → to (xs≈ys x)) $
    from (Fin-length xs) $ index-of p                             ≡⟨⟩

    to (Fin-length-cong xs≈ys) $ index-of p                       ∎
    where
    open _↔_

  -- Bag equivalence isomorphisms preserve index equality. Note that
  -- this means that, even if the underlying equality is proof
  -- relevant, a bag equivalence isomorphism cannot map two distinct
  -- proofs, that point to the same position, to different positions.

  index-equality-preserved :
    {xs ys : List A} {p q : z ∈ xs}
    (xs≈ys : xs ≈-bag ys) →
    index-of p ≡ index-of q →
    index-of (_↔_.to (xs≈ys z) p) ≡ index-of (_↔_.to (xs≈ys z) q)
  index-equality-preserved {z = z} {p = p} {q = q} xs≈ys eq =
    index-of (_↔_.to (xs≈ys z) p)                ≡⟨ index-of-commutes xs≈ys p ⟩
    _↔_.to (Fin-length-cong xs≈ys) (index-of p)  ≡⟨ cong (_↔_.to (Fin-length-cong xs≈ys)) eq ⟩
    _↔_.to (Fin-length-cong xs≈ys) (index-of q)  ≡⟨ sym $ index-of-commutes xs≈ys q ⟩∎
    index-of (_↔_.to (xs≈ys z) q)                ∎

-- If x ∷ xs is bag equivalent to x ∷ ys, then xs and ys are bag
-- equivalent.

∷-left-cancellative : x ∷ xs ≈-bag x ∷ ys → xs ≈-bag ys
∷-left-cancellative {x = x} x∷xs≈x∷ys z =
  ⊎-left-cancellative
    (x∷xs≈x∷ys z)
    (lemma x∷xs≈x∷ys)
    (lemma (inverse ∘ x∷xs≈x∷ys))
  where
  abstract

    -- If the equality type is proof irrelevant (so that p and q are
    -- equal), then this lemma can be proved without the help of
    -- index-equality-preserved.

    lemma : (inv : x ∷ xs ≈-bag x ∷ ys) →
            Well-behaved (_↔_.to (inv z))
    lemma {xs = xs} inv {b = z∈xs} {a = p} {a′ = q} hyp₁ hyp₂ =
      ⊎.inj₁≢inj₂ (
        fzero                                   ≡⟨⟩
        index-of {xs = x ∷ xs} (inj₁ p)         ≡⟨ cong index-of $ sym $ to-from hyp₂ ⟩
        index-of {xs = x ∷ xs} (from (inj₁ q))  ≡⟨ index-equality-preserved (inverse ∘ inv) (refl _) ⟩
        index-of {xs = x ∷ xs} (from (inj₁ p))  ≡⟨ cong index-of $ to-from hyp₁ ⟩
        index-of {xs = x ∷ xs} (inj₂ z∈xs)      ≡⟨⟩
        fsuc (index-of {xs = xs} z∈xs)          ∎)
      where open _↔_ (inv z)

-- Cons is not left cancellative for set equivalence.

∷-not-left-cancellative :
  ¬ (∀ {A : Type} {x : A} {xs ys} →
     x ∷ xs ∼[ set ] x ∷ ys → xs ∼[ set ] ys)
∷-not-left-cancellative cancel =
  _⇔_.to (cancel (++-idempotent (tt ∷ [])) tt) (inj₁ (refl _))

-- _++_ is left and right cancellative (for bag equivalence).

++-left-cancellative :
  ∀ xs → xs ++ ys ≈-bag xs ++ zs → ys ≈-bag zs
++-left-cancellative []       eq = eq
++-left-cancellative (x ∷ xs) eq =
  ++-left-cancellative xs (∷-left-cancellative eq)

++-right-cancellative : xs ++ zs ≈-bag ys ++ zs → xs ≈-bag ys
++-right-cancellative {xs = xs} {zs = zs} {ys = ys} eq =
  ++-left-cancellative zs (λ z →
    z ∈ zs ++ xs  ↔⟨ ++-comm zs xs z ⟩
    z ∈ xs ++ zs  ↔⟨ eq z ⟩
    z ∈ ys ++ zs  ↔⟨ ++-comm ys zs z ⟩
    z ∈ zs ++ ys  □)

------------------------------------------------------------------------
-- The third definition of bag equivalence is sound with respect to
-- the other two

-- _∷_ preserves _∼[ k ]_.

infixr 5 _∷-cong_

_∷-cong_ : x ≡ y → xs ∼[ k ] ys → x ∷ xs ∼[ k ] y ∷ ys
_∷-cong_ {x = x} {y = y} {xs = xs} {ys = ys} x≡y xs≈ys = λ z →
  z ≡ x ⊎ z ∈ xs  ↝⟨ from-bijection (flip-trans-isomorphism x≡y) ⊎-cong xs≈ys z ⟩□
  z ≡ y ⊎ z ∈ ys  □

-- We can swap the first two elements of a list.

swap-first-two : x ∷ y ∷ xs ≈-bag y ∷ x ∷ xs
swap-first-two {x = x} {y = y} {xs = xs} = λ z →
   z ≡ x ⊎ z ≡ y  ⊎ z ∈ xs  ↔⟨ ⊎-assoc ⟩
  (z ≡ x ⊎ z ≡ y) ⊎ z ∈ xs  ↔⟨ ⊎-comm ⊎-cong id ⟩
  (z ≡ y ⊎ z ≡ x) ⊎ z ∈ xs  ↔⟨ inverse ⊎-assoc ⟩
   z ≡ y ⊎ z ≡ x  ⊎ z ∈ xs  □

-- The third definition of bag equivalence is sound with respect to
-- the first one.

≈″⇒≈ : xs ≈-bag″ ys → xs ≈-bag ys
≈″⇒≈ []                  = λ _ → id
≈″⇒≈ (x ∷ xs≈ys)         = refl _ ∷-cong ≈″⇒≈ xs≈ys
≈″⇒≈ swap                = swap-first-two
≈″⇒≈ (trans xs≈ys ys≈zs) = λ z → _ ↔⟨ ≈″⇒≈ xs≈ys z ⟩ ≈″⇒≈ ys≈zs z

-- The other direction should also be provable, but I expect that this
-- requires some work.


-- Basic intuitionistic contextual modal logic, without ∨ or ⊥.
-- Gentzen-style formalisation of syntax with context pairs, after Nanevski-Pfenning-Pientka.
-- Simple terms.

module BasicICML.Syntax.DyadicGentzen where

open import BasicICML.Syntax.Common public

-- Derivations.

-- NOTE: Only var is an instance constructor, which allows the instance argument for mvar to be automatically inferred, in many cases.

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

  infix 3 _⊢⋆_
  data _⊢⋆_ : Cx² Ty Box → Cx Ty → Set where
    instance
      ∙   : ∀ {Γ Δ}     → Γ ⁏ Δ ⊢⋆ ∅
      _,_ : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ ⊢⋆ Ξ → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢⋆ Ξ , A

-- Monotonicity with respect to context inclusion.

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

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

-- Monotonicity with respect to modal context inclusion.

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

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

-- Monotonicity using context pairs.

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

-- Shorthand for variables.

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

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

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

mv₀ : ∀ {Ψ A Γ Δ}
      → {{_ : Γ ⁏ Δ , [ Ψ ] A ⊢⋆ Ψ}}
      → Γ ⁏ Δ , [ Ψ ] A ⊢ A
mv₀ = mvar i₀

mv₁ : ∀ {Ψ Ψ′ A B Γ Δ}
      → {{_ : Γ ⁏ Δ , [ Ψ ] A , [ Ψ′ ] B ⊢⋆ Ψ}}
      → Γ ⁏ Δ , [ Ψ ] A , [ Ψ′ ] B ⊢ A
mv₁ = mvar i₁

mv₂ : ∀ {Ψ Ψ′ Ψ″ A B C Γ Δ}
      → {{_ : Γ ⁏ Δ , [ Ψ ] A , [ Ψ′ ] B , [ Ψ″ ] C ⊢⋆ Ψ}}
      → Γ ⁏ Δ , [ Ψ ] A , [ Ψ′ ] B , [ Ψ″ ] C ⊢ A
mv₂ = mvar i₂

-- Generalised reflexivity.

instance
  refl⊢⋆ : ∀ {Γ Ψ Δ} → {{_ : Ψ ⊆ Γ}} → Γ ⁏ Δ ⊢⋆ Ψ
  refl⊢⋆ {∅}     {{done}}   = ∙
  refl⊢⋆ {Γ , A} {{skip η}} = mono⊢⋆ weak⊆ (refl⊢⋆ {{η}})
  refl⊢⋆ {Γ , A} {{keep η}} = mono⊢⋆ weak⊆ (refl⊢⋆ {{η}}) , v₀

-- Deduction theorem is built-in.

-- Modal deduction theorem.

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

-- Detachment theorems.

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

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

-- Cut and multicut.

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

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

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

-- Contraction.

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

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

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

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

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

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

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

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

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

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

mcomp : ∀ {Ψ Ψ′ Ψ″ A B C Γ Δ}
      → Γ ⁏ Δ , [ Ψ′ ] B ⊢ [ Ψ″ ] C
      → Γ ⁏ Δ , [ Ψ ] A ⊢ [ Ψ′ ] B
      → Γ ⁏ Δ , [ Ψ ] A ⊢ [ Ψ″ ] C
mcomp t u = mdet (app (app ccomp (mlam t)) (mlam u))

-- Useful theorems in functional form.

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

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

down : ∀ {Ψ A Γ Δ}
      → Γ ⁏ Δ ⊢ [ Ψ ] A
      → {{_ : Γ ⁏ Δ , [ Ψ ] A ⊢⋆ Ψ}}
      → Γ ⁏ Δ ⊢ A
down t = unbox t mv₀

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

-- Useful theorems in combinatory form.

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

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

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

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

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

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

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

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

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

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

-- Closure under context concatenation.

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

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

-- Substitution.

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

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

-- Modal substitution.

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

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

-- Convertibility.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  -- TODO: What about commuting conversions for □?

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

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

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

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

-- Examples from the Nanevski-Pfenning-Pientka paper.

-- NOTE: In many cases, the instance argument for mvar can be automatically inferred, but not always.

module Examples where
  e₁ : ∀ {A C D Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ , C ] A ▻
                    [ ∅ , C , D ] A
  e₁ = lam (unbox v₀ (box mv₀))

  e₂ : ∀ {A C Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ , C , C ] A ▻
                    [ ∅ , C ] A
  e₂ = lam (unbox v₀ (box mv₀))

  e₃ : ∀ {A Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ , A ] A
  e₃ = box v₀

  e₄ : ∀ {A B C Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ , A ] B ▻
                    [ ∅ , A ] [ ∅ , B ] C ▻
                    [ ∅ , A ] C
  e₄ = lam (lam (unbox v₁ (unbox v₀ (box
         (unbox mv₀ (mv₀ {{∙ , mv₂}}))))))

  e₅ : ∀ {A Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ ] A ▻ A
  e₅ = lam (unbox v₀ mv₀)

  e₆ : ∀ {A C D Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ , C ] A ▻
                    [ ∅ , D ] [ ∅ , C ] A
  e₆ = lam (unbox v₀ (box (box mv₀)))

  e₇ : ∀ {A B C D Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ , C ] (A ▻ B) ▻
                    [ ∅ , D ] A ▻
                    [ ∅ , C , D ] B
  e₇ = lam (lam (unbox v₁ (unbox v₀ (box
         (app mv₁ mv₀)))))

  e₈ : ∀ {A B C Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ , A ] (A ▻ B) ▻
                    [ ∅ , B ] C ▻
                    [ ∅ , A ] C
  e₈ = lam (lam (unbox v₁ (unbox v₀ (box
         (mv₀ {{∙ , app mv₁ v₀}})))))


{-# OPTIONS --safe --without-K #-}
module Generics.Prelude where

open import Function.Base     public
open import Data.Product      public hiding (map; uncurry; uncurry′; curry′)
open import Level             public using (Setω; Level; _⊔_; Lift; lift)
                                     renaming (zero to lzero; suc to lsuc)

open import Relation.Binary.PropositionalEquality public
  hiding ([_]; Extensionality; ∀-extensionality)
open import Data.Nat.Base        public using (ℕ; zero; suc; _+_)
                                        renaming (_∸_ to _-_)
open import Data.Unit            public using (⊤; tt)
open import Data.Empty           public using (⊥)
open import Data.List            public using (List; []; _∷_)
open import Data.Vec.Base        public using (Vec; []; _∷_; map; lookup)
open import Data.Fin.Base as Fin public using (Fin; zero; suc)
open import Axiom.Extensionality.Propositional public
open import Data.String using (String)

open import Reflection                      public
  hiding (var; return; _>>=_; _>>_; assocˡ; assocʳ; visibility; relevance; module Arg)
import Reflection.Argument
module Arg = Reflection.Argument
open import Reflection.Argument.Information public using (ArgInfo; arg-info; visibility)
                                                   renaming (modality to getModality)
open import Reflection.Argument.Modality    public using (Modality; modality)
open import Reflection.Argument.Relevance   public using (Relevance; relevant; irrelevant)
open import Reflection.Argument.Visibility  public using (Visibility; visible; hidden; instance′)

private variable
  m n   : ℕ
  k     : Fin n
  l l'  : Level
  A B   : Set l

record Irr (A : Set l) : Set l where
  constructor irrv
  field
    .unirr : A
open Irr public

<_>_ : Relevance → Set l → Set l
< relevant   > A = A
< irrelevant > A = Irr A

relevance : ArgInfo → Relevance
relevance = Reflection.Argument.Modality.relevance ∘ getModality

-- withAI : ArgInfo → Term → Term
-- withAI i t with relevance i
-- ... | relevant   = t
-- ... | irrelevant = con (quote irrv) (vArg t ∷ [])
-- macro
--   Π<> : ((n , i) : String × ArgInfo) → Term → Term → Term → TC ⊤
--   Π<> (n , ai) S′ (Term.var k []) =
--     unify (pi (arg ai S′) (abs n (Term.var (suc k) (vArg (withAI ai (Term.var 0 [])) ∷ []))))
--   Π<> (n , ai) S′ _ hole = typeError (strErr "" ∷ [])

-- TODO: do this with reflection, using names
-- TODO: deal with quantities
Π<_> : ((a , i) : String × ArgInfo) (A : Set l) → (< relevance i > A → Set l') → Set (l ⊔ l')
Π< _ , arg-info visible   (modality relevant q)   > A B = (x : A) → B x
Π< _ , arg-info visible   (modality irrelevant q) > A B = .(x : A) → B (irrv x)
Π< _ , arg-info hidden    (modality relevant q)   > A B = {x : A} → B x
Π< _ , arg-info hidden    (modality irrelevant q) > A B = .{x : A} → B (irrv x)
Π< _ , arg-info instance′ (modality relevant q)   > A B = {{x : A}} → B x
Π< _ , arg-info instance′ (modality irrelevant q) > A B = .{{x : A}} → B (irrv x)

_→<_>_ : Set l → String × ArgInfo → Set l' → Set (l ⊔ l')
A →< i > B = Π< i > A λ _ → B

fun<_> : (ai@(a , i) : String × ArgInfo) {A : Set l} {B : < relevance i > A → Set l'}
       → (f : (x : < relevance i > A) → B x) → Π< ai > A B
fun< _ , arg-info visible   (modality relevant q)   > f x     = f x
fun< _ , arg-info visible   (modality irrelevant q) > f x     = f (irrv x)
fun< _ , arg-info hidden    (modality relevant q)   > f {x}   = f x
fun< _ , arg-info hidden    (modality irrelevant q) > f {x}   = f (irrv x)
fun< _ , arg-info instance′ (modality relevant q)   > f {{x}} = f x
fun< _ , arg-info instance′ (modality irrelevant q) > f {{x}} = f (irrv x)

app<_> : (ai@(a , i) : String × ArgInfo) {A : Set l} {B : < relevance i > A → Set l'}
       → (f : Π< ai > A B) → (x : < relevance i > A) → B x
app< _ , arg-info visible   (modality relevant q)   > f x        = f x
app< _ , arg-info visible   (modality irrelevant q) > f (irrv x) = f x
app< _ , arg-info hidden    (modality relevant q)   > f x        = f {x}
app< _ , arg-info hidden    (modality irrelevant q) > f (irrv x) = f {x}
app< _ , arg-info instance′ (modality relevant q)   > f x        = f {{x}}
app< _ , arg-info instance′ (modality irrelevant q) > f (irrv x) = f {{x}}

-- Instead of the definitions from Function.Nary.NonDependent in the
-- standard library, we use a *functional* representation of vectors
-- of levels and types. This makes it much easier to work with
-- operations like lookup and tabulate, at the cost of losing certain
-- eta laws for nil and cons (see the comment for `uncurryₙ` below).

Levels : ℕ → Set
Levels n = Fin n → Level

private variable ls ls' : Levels n

[]l : Levels 0
[]l ()

_∷l_ : Level → Levels n → Levels (suc n)
(l ∷l ls) zero = l
(l ∷l ls) (suc k) = ls k

headl : Levels (suc n) → Level
headl ls = ls zero

taill : Levels (suc n) → Levels n
taill ls = ls ∘ suc

_++l_ : Levels m → Levels n → Levels (m + n)
_++l_ {zero} ls ls' = ls'
_++l_ {suc m} ls ls' zero = headl ls
_++l_ {suc m} ls ls' (suc x) = (taill ls ++l ls') x

⨆ : Levels n → Level
⨆ {zero} ls = lzero
⨆ {suc n} ls = ls zero ⊔ ⨆ (ls ∘ suc)

Sets : (ls : Levels n) → Setω
Sets {n} ls = (k : Fin n) → Set (ls k)

private variable As Bs : Sets ls

[]S : {ls : Levels 0} → Sets ls
[]S ()

_∷S_ : Set (headl ls) → Sets (taill ls) → Sets ls
(A ∷S As) zero    = A
(A ∷S As) (suc k) = As k

headS : Sets ls → Set (headl ls)
headS As = As zero

tailS : Sets ls → Sets (taill ls)
tailS As k = As (suc k)

_++S_ : Sets ls → Sets ls' → Sets (ls ++l ls')
_++S_ {zero}  As Bs = Bs
_++S_ {suc m} As Bs zero = headS As
_++S_ {suc m} As Bs (suc k) = (tailS As ++S Bs) k

Els : (As : Sets ls) → Setω
Els {n} As = (k : Fin n) → As k

private variable xs : Els As

[]El : {As : Sets {zero} ls} → Els As
[]El ()

_∷El_ : headS As → Els (tailS As) → Els As
(x ∷El xs) zero    = x
(x ∷El xs) (suc k) = xs k

headEl : Els As → headS As
headEl xs = xs zero

tailEl : Els As → Els (tailS As)
tailEl xs k = xs (suc k)

_++El_ : Els As → Els Bs → Els (As ++S Bs)
_++El_ {zero} xs ys = ys
_++El_ {suc m} xs ys zero = headEl xs
_++El_ {suc m} xs ys (suc k) = (tailEl xs ++El ys) k

++El-proj₁ : Els (As ++S Bs) → Els As
++El-proj₁ xs zero    = xs zero
++El-proj₁ xs (suc k) = ++El-proj₁ (tailEl xs) k

++El-proj₂ : Els (As ++S Bs) → Els Bs
++El-proj₂ {zero}  xs k = xs k
++El-proj₂ {suc m} xs k = ++El-proj₂ (tailEl xs) k

Pis : (As : Sets ls) (B : Els As → Set l) → Set (⨆ ls ⊔ l)
Pis {zero}  As B = B []El
Pis {suc n} As B = (x : As zero) → Pis (tailS As) (λ xs → B (x ∷El xs))

Arrows : (As : Sets ls) (B : Set l) → Set (⨆ ls ⊔ l)
Arrows As B = Pis As (λ _ → B)

curryₙ : {B : Els As → Set l} → ((xs : Els As) → B xs) → Pis As B
curryₙ {zero}  f = f []El
curryₙ {suc n} f = λ x → curryₙ (λ xs → f (x ∷El xs))

-- It is not possible to define the dependent version of uncurryₙ, as
-- it requires the laws that `xs = []El` for all `xs : Els {zero} As`
-- and `xs = headEl xs ∷El tailEl xs` for all `xs : Els {suc n} As`,
-- which do not hold definitionally and require funExt to prove.
uncurryₙ : Arrows As B → Els As → B
uncurryₙ {zero}  f _  = f
uncurryₙ {suc n} f xs = uncurryₙ (f (headEl xs)) (tailEl xs)

------------------------------------
-- Some utilities to work with Setω

-- TODO: move this somewhere else
-- TODO: consistent naming

record ⊤ω : Setω where
  instance constructor tt

data ⊥ω : Setω where

⊥⇒⊥ω : ⊥ → ⊥ω
⊥⇒⊥ω ()

⊥ω-elimω : {A : Setω} → ⊥ω → A
⊥ω-elimω ()

ttω : ⊤ω
ttω = tt

record Liftω (A : Set l) : Setω where
  constructor liftω
  field lower : A

instance
  liftω-inst : {A : Set l} → ⦃ A ⦄ → Liftω A
  liftω-inst ⦃ x ⦄ = liftω x

record _×ω_ (A B : Setω) : Setω where
  constructor _,_
  field fst : A
        snd : B

_ω,ω_ : {A B : Setω} → A → B → A ×ω B
_ω,ω_ = _,_

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

congω : ∀ {A b} {B : Set b} (f : ∀ x → B)
      → ∀ {x y : A} → x ≡ω y → f x ≡ f y
congω f refl = refl

cong≡ω : {A : Set l} {B : Setω} (f : ∀ x → B)
       → ∀ {x y : A} → x ≡ y → f x ≡ω f y
cong≡ω f refl = refl

cong≡ωω : {A B : Setω} (f : ∀ x → B)
       → ∀ {x y : A} → x ≡ω y → f x ≡ω f y
cong≡ωω f refl = refl

reflω : {A : Setω} {x : A} → x ≡ω x
reflω = refl

transω : {A : Setω} {x y z : A}
       → x ≡ω y → y ≡ω z → x ≡ω z
transω refl refl = refl

symω : {A : Setω} {x y : A} → x ≡ω y → y ≡ω x
symω refl = refl

instance
  ×ω-inst : ∀ {A B} → ⦃ A ⦄ → ⦃ B ⦄ → A ×ω B
  ×ω-inst ⦃ x ⦄ ⦃ y ⦄ = x , y

record Σω {a} (A : Set a) (B : A → Setω) : Setω where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

data Decω (A : Setω) : Setω where
  yesω : A       → Decω A
  noω  : (A → ⊥) → Decω A


open import Agda.Builtin.Reflection
open import Agda.Builtin.Bool
open import Agda.Builtin.String
open import Agda.Builtin.Equality
open import Agda.Builtin.Unit
open import Agda.Builtin.List

_>>=_ = bindTC

`false `true : Term
`false = con (quote false) []
`true  = con (quote true)  []

macro
  macro? : Name → Term → TC ⊤
  macro? x hole =
    isMacro x >>= λ where
      false → unify hole `false
      true  → unify hole `true

test₁ : macro? macro? ≡ true
test₁ = refl

test₂ : macro? test₁ ≡ false
test₂ = refl

test₃ : macro? true ≡ false
test₃ = refl