-- Andreas, 2011-04-07

module IrrelevantTelescopeRecord where

record Wrap .(A : Set) : Set where
  field
    out : A
-- cannot use A, because it is declared irrelevant


-- Basic intuitionistic logic of proofs, without ∨, ⊥, or +.
-- Gentzen-style formalisation of syntax with context pairs.
-- Simple terms.

module BasicILP.Syntax.DyadicGentzen where

open import BasicILP.Syntax.Common public

-- Types, or propositions.
-- [ Ψ ⁏ Ω ⊢ t ] A means t is a proof of the fact that the type A is inhabited given assumptions in the context Ψ and the modal context Ω.

mutual
  syntax □ Π A t = [ Π ⊢ t ] A

  infixr 10 □
  infixl 9 _∧_
  infixr 7 _▻_
  data Ty : Set where
    α_  : Atom → Ty
    _▻_ : Ty → Ty → Ty
    □   : (Π : Cx² Ty Box) → (A : Ty) → Π ⊢ A → Ty
    _∧_ : Ty → Ty → Ty
    ⊤  : Ty

  -- Context/modal context/type/term quadruples.

  record Box : Set where
    inductive
    constructor □
    field
      Π : Cx² Ty Box
      A : Ty
      x : Π ⊢ A

  -- Derivations.

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

  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 x Γ Δ}   → [ Ψ ⁏ Ω ⊢ x ] A ∈ Δ
                              → {{_ : Γ ⁏ Δ ⊢⋆ Ψ}}
                              → {{_ : Γ ⁏ Δ ⊢⍟ Ω}}
                              → Γ ⁏ Δ ⊢ A

    box   : ∀ {Ψ Ω A Γ Δ}     → (x : Ψ ⁏ Ω ⊢ A)
                              → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ x ] A

    unbox : ∀ {Ψ Ω A C x Γ Δ} → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ x ] A
                              → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] 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

  infix 3 _⊢⍟_
  data _⊢⍟_ : Cx² Ty Box → Cx Box → Set where
    instance
      ∙   : ∀ {Γ Δ}           → Γ ⁏ Δ ⊢⍟ ∅
      _,_ : ∀ {Ξ Ψ Ω A x Γ Δ} → Γ ⁏ Δ ⊢⍟ Ξ
                              → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ x ] A
                              → Γ ⁏ Δ ⊢⍟ Ξ , [ Ψ ⁏ Ω ⊢ x ] 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}} {{us}}) = mvar i {{mono⊢⋆ η ts}} {{mono⊢⍟ η us}}
  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

  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}} {{us}}) = mvar (mono∈ θ i) {{mmono⊢⋆ θ ts}} {{mmono⊢⍟ θ us}}
  mmono⊢ θ (box t)                = box 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

  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 x Γ Δ}
      → {{_ : Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢⋆ Ψ}}
      → {{_ : Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢⍟ Ω}}
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢ A
mv₀ = mvar i₀

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

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

-- Generalised reflexivity.

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

  mrefl⊢⍟ : ∀ {Δ Ω Γ} → {{_ : Ω ⊆ Δ}} → Γ ⁏ Δ ⊢⍟ Ω
  mrefl⊢⍟ {∅}                     {{done}}   = ∙
  mrefl⊢⍟ {Δ , [ Ψ ⁏ Ω ⊢ x ] A } {{skip θ}} = mmono⊢⍟ weak⊆ (mrefl⊢⍟ {{θ}})
  mrefl⊢⍟ {Δ , [ Ψ ⁏ Ω ⊢ x ] A } {{keep θ}} = mmono⊢⍟ weak⊆ (mrefl⊢⍟ {{θ}}) , box x

-- Deduction theorem is built-in.

-- Modal deduction theorem.

mlam : ∀ {Ψ Ω A B x Γ Δ}
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢ B
      → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ x ] 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₀

-- FIXME: Is this correct?
mdet : ∀ {Ψ Ω A B x Γ Δ}
      → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ x ] A ▻ B
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢ B
mdet {x = x} t = app (mmono⊢ weak⊆ t) (box x)

-- Cut and multicut.

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

mcut : ∀ {Ψ Ω A B x Γ Δ}
      → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ x ] A
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] 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 x Γ Δ}
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A , [ Ψ ⁏ Ω ⊢ x ] A ⊢ B
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] 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 x y Γ Δ}
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A , [ Ψ′ ⁏ Ω′ ⊢ y ] B ⊢ C
      → Γ ⁏ Δ , [ Ψ′ ⁏ Ω′ ⊢ y ] B , [ Ψ ⁏ Ω ⊢ x ] 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 x y z Γ Δ}
      → Γ ⁏ Δ , [ Ψ′ ⁏ Ω′ ⊢ y ] B ⊢ [ Ψ″ ⁏ Ω″ ⊢ z ] C
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢ [ Ψ′ ⁏ Ω′ ⊢ y ] B
      → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ x ] A ⊢ [ Ψ″ ⁏ Ω″ ⊢ z ] C
mcomp t u = mdet (app (app ccomp (mlam t)) (mlam u))

-- Useful theorems in functional form.

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

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

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

-- 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 t u Γ Δ}
      → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ t ] (A ▻ B) ▻
                  [ Ψ ⁏ Ω ⊢ u ] A ▻
                  [ Ψ ⁏ Ω , [ Ψ ⁏ Ω ⊢ t ] (A ▻ B) , [ Ψ ⁏ Ω ⊢ u ] A ⊢ app mv₁ mv₀ ] B
cdist = lam (lam (dist v₁ v₀))

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

cunbox : ∀ {Ψ Ω A C t Γ Δ} → Γ ⁏ Δ ⊢ [ Ψ ⁏ Ω ⊢ t ] A ▻ ([ Ψ ⁏ Ω ⊢ t ] 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 t Γ Δ} Δ′ → Γ ⁏ Δ , [ Ψ ⁏ Ω ⊢ t ] A ⊢ B → Γ ⁏ Δ′ ⊢ [ Ψ ⁏ Ω ⊢ t ] 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}} {{us}} = mvar j {{[ i ≔ s ]⋆ ts}} {{[ i ≔ s ]⍟ us}}
  [ 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

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

-- Modal substitution.

mutual
  m[_≔_]_ : ∀ {Ψ Ω A C t Γ Δ} → (i : [ Ψ ⁏ Ω ⊢ t ] 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}} {{us}} with i ≟∈ j
  m[ i ≔ s ] mvar .i {{ts}} {{us}} | same   = multicut (m[ i ≔ s ]⋆ ts) s
  m[ i ≔ s ] mvar ._ {{ts}} {{us}} | diff j = mvar j {{m[ i ≔ s ]⋆ ts}} {{m[ i ≔ s ]⍟ us}}
  m[ i ≔ s ] box t                 = box 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 t Γ Δ} → (i : [ Ψ ⁏ Ω ⊢ t ] A ∈ Δ) → Ψ ⁏ Δ ∖ i ⊢ A → Γ ⁏ Δ ⊢⋆ Ξ → Γ ⁏ Δ ∖ i ⊢⋆ Ξ
  m[_≔_]⋆_ i s ∙        = ∙
  m[_≔_]⋆_ i s (ts , t) = m[ i ≔ s ]⋆ ts , m[ i ≔ s ] t

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

-- TODO: Convertibility.

-- 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 Γ Δ t}
        → Γ ⁏ Δ ⊢ [ ∅ , C ⁏ Δ ⊢ t ] A ▻
                    [ ∅ , C , D ⁏ Δ , [ ∅ , C ⁏ Δ ⊢ t ] A ⊢ mv₀ ] A
  e₁ = lam (unbox v₀ (box mv₀))

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

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

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

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

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

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

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

-- Examples from the Alt-Artemov paper.

module Examples₂ where
  e₁ : ∀ {A Γ Δ t}
        → Γ ⁏ Δ ⊢ [ ∅ ⁏ Δ ⊢ lam (down v₀) ]
                      ([ ∅ ⁏ Δ ⊢ t ] A ▻ A)
  e₁ = box (lam (down v₀))

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

  e₃ : ∀ {A B Γ Δ}
        → Γ ⁏ Δ ⊢ [ ∅ ⁏ Δ ⊢ box (lam (lam (pair v₁ v₀))) ]
                      [ ∅ ⁏ Δ ⊢ lam (lam (pair v₁ v₀)) ]
                        (A ▻ B ▻ A ∧ B)
  e₃ = box (box (lam (lam (pair v₁ v₀))))

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


open import Agda.Builtin.List
open import Agda.Builtin.Reflection
open import Agda.Builtin.Sigma
open import Agda.Builtin.Unit

@0 m : Name → TC ⊤
m F = defineFun F
  (clause
     (( "A"
      , arg (arg-info visible (modality relevant quantity-0))
          (agda-sort (lit 0))) ∷
      [])
     (arg (arg-info visible (modality relevant quantity-0)) (var 0) ∷
      [])
     (var 0 []) ∷
   [])

F : @0 Set → Set
unquoteDef F = m F


open import Prelude hiding (id; erase)

module Implicits.WellTyped where

open import Data.Fin.Substitution
open import Data.Vec hiding ([_])
open import Data.List as List hiding ([_]; map)

open import Implicits.Syntax.Type
open import Implicits.Syntax.Term
open import Implicits.Syntax.Context
open import Implicits.Substitutions

module TypingRules (_⊢ᵣ_ : ∀ {ν} → ICtx ν → Type ν → Set) where
  infixl 4 _⊢_∈_

  -----------------------------------------------------------------------------
  -- typings

  data _⊢_∈_ {ν n} (K : Ktx ν n) : Term ν n → Type ν → Set where
    var : (x : Fin n) → K ⊢ var x ∈ (lookup x (proj₁ K))
    λ' : ∀ {t b} a → a ∷Γ K ⊢ t ∈ b → K ⊢ λ' a t ∈ simpl (a →' b)
    Λ : ∀ {t} {a : Type (suc ν)} → ktx-weaken K ⊢ t ∈ a → K ⊢ Λ t ∈ ∀' a
    _[_] : ∀ {t} {a : Type (suc ν)} →
           K ⊢ t ∈ ∀' a → (b : Type ν) → K ⊢ t [ b ] ∈ a tp[/tp b ]
    _·_  : ∀ {f t a b} → K ⊢ f ∈ simpl (a →' b) → K ⊢ t ∈ a → K ⊢ f · t ∈ b

    -- implicit abstract/application
    ρ : ∀ {t b a} → [] ⊢unamb a → a ∷K K ⊢ t ∈ b → K ⊢ ρ a t ∈ (a ⇒ b)
    _⟨_⟩ : ∀ {a b f} → K ⊢ f ∈ a ⇒ b → (proj₂ K) ⊢ᵣ a → K ⊢ f ⟨⟩ ∈ b
    _with'_ : ∀ {r e a b} → K ⊢ r ∈ a ⇒ b → K ⊢ e ∈ a → K ⊢ r with' e ∈ b

  _⊢_∉_ : ∀ {ν n} → (K : Ktx ν n) → Term ν n → Type ν → Set
  _⊢_∉_ K t τ = ¬ K ⊢ t ∈ τ

  -----------------------------------------------------------------------------
  -- syntactic sugar

  let'_in'_ : ∀ {ν n} {e₁ : Term ν n} {e₂ : Term ν (suc n)} {a b} {K} →
              K ⊢ e₁ ∈ a → a ∷Γ K ⊢ e₂ ∈ b → K ⊢ (let' e₁ ∶ a in' e₂) ∈ b
  let' e₁ in' e₂ = (λ' _ e₂) · e₁

  implicit'_∶_in'_ : ∀ {ν n} {e₁ : Term ν n} {e₂ : Term ν (suc n)} {a b} {K} →
              K ⊢ e₁ ∈ a → [] ⊢unamb a → a ∷K K ⊢ e₂ ∈ b → K ⊢ (implicit e₁ ∶ a in' e₂) ∈ b
  implicit' e₁ ∶ a in' e₂ = (ρ a e₂) with' e₁

  wt-¿ : ∀ {ν n} {r : Type ν} {K : Ktx ν n} → [] ⊢unamb r → (proj₂ K) ⊢ᵣ r → K ⊢ (¿ r) ∈ r
  wt-¿ r x = (ρ r (var zero)) ⟨ x ⟩

  -----------------------------------------------------------------------------
  -- utilities

  erase : ∀ {ν n} {K : Ktx ν n} {t a} → K ⊢ t ∈ a → Term ν n
  erase {t = t} _ = t

  -- Collections of typing derivations for well-typed terms.
  data _⊢ⁿ_∈_ {m n} (Γ : Ktx n m) : ∀ {k} → Vec (Term n m) k → Vec (Type n) k → Set where
    []  : Γ ⊢ⁿ [] ∈ []
    _∷_ : ∀ {t a k} {ts : Vec (Term n m) k} {as : Vec (Type n) k} →
        Γ ⊢ t ∈ a → Γ ⊢ⁿ ts ∈ as → Γ ⊢ⁿ t ∷ ts ∈ (a ∷ as)

  -- Lookup a well-typed term in a collection thereof.
  lookup-⊢ : ∀ {m n k} {Γ : Ktx n m} {ts : Vec (Term n m) k} {as : Vec (Type n) k} →
              (x : Fin k) → Γ ⊢ⁿ ts ∈ as → Γ ⊢ lookup x ts ∈ lookup x as
  lookup-⊢ zero  (⊢t ∷ ⊢ts) = ⊢t
  lookup-⊢ (suc x) (⊢t ∷ ⊢ts) = lookup-⊢ x ⊢ts


record R : Set₁ where
  field
    A : Set

open R ⦃ … ⦄

-- The inferred type of A is ⦃ r : R ⦄ → Set. However, the following
-- code is rejected:

X : R → Set
X r = A ⦃ r = r ⦄

-- WAS: Function does not accept argument ⦃ r = r ⦄
-- when checking that ⦃ r = r ⦄ is a valid argument to a function of
-- type ⦃ r = r₁ : R ⦄ → Set

-- SHOULD: succeed


-- WARNING: This file was generated automatically by Vehicle
-- and should not be modified manually!
-- Metadata
--  - Agda version: 2.6.2
--  - AISEC version: 0.1.0.1
--  - Time generated: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Vehicle.Data.Tensor
open import Data.Product
open import Data.Sum
open import Data.Integer as ℤ using (ℤ)
open import Data.Rational as ℚ using (ℚ)
open import Data.Fin as Fin using (Fin; #_)
open import Data.List
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

module acasXu-temp-output where

InputVector : Set
InputVector = Tensor ℚ (5 ∷ [])

distanceToIntruder : ∀ {_x0 : Set} {{_x1 : HasNatLits _x0}} → _x0
distanceToIntruder = 0

angleToIntruder : ∀ {_x4 : Set} {{_x5 : HasNatLits _x4}} → _x4
angleToIntruder = 1

intruderHeading : ∀ {_x8 : Set} {{_x9 : HasNatLits _x8}} → _x8
intruderHeading = 2

speed : ∀ {_x12 : Set} {{_x13 : HasNatLits _x12}} → _x12
speed = 3

intruderSpeed : ∀ {_x16 : Set} {{_x17 : HasNatLits _x16}} → _x16
intruderSpeed = 4

OutputVector : Set
OutputVector = Tensor ℚ (5 ∷ [])

clearOfConflict : ∀ {_x20 : Set} {{_x21 : HasNatLits _x20}} → _x20
clearOfConflict = 0

weakLeft : ∀ {_x24 : Set} {{_x25 : HasNatLits _x24}} → _x24
weakLeft = 1

weakRight : ∀ {_x28 : Set} {{_x29 : HasNatLits _x28}} → _x28
weakRight = 2

strongLeft : ∀ {_x32 : Set} {{_x33 : HasNatLits _x32}} → _x32
strongLeft = 3

strongRight : ∀ {_x36 : Set} {{_x37 : HasNatLits _x36}} → _x36
strongRight = 4

postulate acasXu : InputVector → OutputVector

pi : ℚ
pi = ℤ.+ 392699 ℚ./ 125000

Advises : Fin 5 → (InputVector → Set)
Advises i x = ∀ (j : Fin 5) → i ≢ j → acasXu x i ℚ.< acasXu x j

IntruderDistantAndSlower : InputVector → Set
IntruderDistantAndSlower x = x distanceToIntruder ℚ.≥ ℤ.+ 55947691 ℚ./ 1000 × (x speed ℚ.≥ ℤ.+ 1145 ℚ./ 1 × x intruderSpeed ℚ.≤ ℤ.+ 60 ℚ./ 1)

abstract
  property1 : ∀ (x : Tensor ℚ (5 ∷ [])) → IntruderDistantAndSlower x → acasXu x clearOfConflict ℚ.≤ ℤ.+ 1500 ℚ./ 1
  property1 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

abstract
  property2 : ∀ (x : Tensor ℚ (5 ∷ [])) → IntruderDistantAndSlower x → ∃ λ (j : Fin 5) → acasXu x j ℚ.> acasXu x clearOfConflict
  property2 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

DirectlyAhead : InputVector → Set
DirectlyAhead x = (ℤ.+ 1500 ℚ./ 1 ℚ.≤ x distanceToIntruder × x distanceToIntruder ℚ.≤ ℤ.+ 1800 ℚ./ 1) × (ℚ.- (ℤ.+ 3 ℚ./ 50) ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ ℤ.+ 3 ℚ./ 50)

MovingTowards : InputVector → Set
MovingTowards x = x intruderHeading ℚ.≥ ℤ.+ 31 ℚ./ 10 × (x speed ℚ.≥ ℤ.+ 980 ℚ./ 1 × x intruderSpeed ℚ.≥ ℤ.+ 960 ℚ./ 1)

abstract
  property3 : ∀ (x : Tensor ℚ (5 ∷ [])) → DirectlyAhead x × MovingTowards x → ¬ Advises clearOfConflict x
  property3 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

MovingAway : InputVector → Set
MovingAway x = x intruderHeading ≡ ℤ.+ 0 ℚ./ 1 × (ℤ.+ 1000 ℚ./ 1 ℚ.≤ x speed × (ℤ.+ 700 ℚ./ 1 ℚ.≤ x intruderSpeed × x intruderSpeed ℚ.≤ ℤ.+ 800 ℚ./ 1))

abstract
  property4 : ∀ (x : Tensor ℚ (5 ∷ [])) → DirectlyAhead x × MovingAway x → ¬ Advises clearOfConflict x
  property4 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

NearAndApproachingFromLeft : InputVector → Set
NearAndApproachingFromLeft x = (ℤ.+ 250 ℚ./ 1 ℚ.≤ x distanceToIntruder × x distanceToIntruder ℚ.≤ ℤ.+ 400 ℚ./ 1) × ((ℤ.+ 1 ℚ./ 5 ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ ℤ.+ 2 ℚ./ 5) × ((ℚ.- pi ℚ.≤ x intruderHeading × x intruderHeading ℚ.≤ ℚ.- pi ℚ.+ ℤ.+ 1 ℚ./ 200) × ((ℤ.+ 100 ℚ./ 1 ℚ.≤ x speed × x speed ℚ.≤ ℤ.+ 400 ℚ./ 1) × (ℤ.+ 0 ℚ./ 1 ℚ.≤ x intruderSpeed × x intruderSpeed ℚ.≤ ℤ.+ 400 ℚ./ 1))))

abstract
  property5 : ∀ (x : Tensor ℚ (5 ∷ [])) → NearAndApproachingFromLeft x → Advises strongRight x
  property5 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

IntruderFarAway : InputVector → Set
IntruderFarAway x = (ℤ.+ 12000 ℚ./ 1 ℚ.≤ x distanceToIntruder × x distanceToIntruder ℚ.≤ ℤ.+ 62000 ℚ./ 1) × ((ℚ.- pi ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ ℚ.- (ℤ.+ 7 ℚ./ 10) ⊎ ℤ.+ 7 ℚ./ 10 ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ pi) × ((ℚ.- pi ℚ.≤ x intruderHeading × x intruderHeading ℚ.≤ ℚ.- pi ℚ.+ ℤ.+ 1 ℚ./ 200) × ((ℤ.+ 100 ℚ./ 1 ℚ.≤ x speed × x speed ℚ.≤ ℤ.+ 1200 ℚ./ 1) × (ℤ.+ 0 ℚ./ 1 ℚ.≤ x intruderSpeed × x intruderSpeed ℚ.≤ ℤ.+ 1200 ℚ./ 1))))

abstract
  property6 : ∀ (x : Tensor ℚ (5 ∷ [])) → IntruderFarAway x → Advises clearOfConflict x
  property6 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

LargeVerticalSeparation : InputVector → Set
LargeVerticalSeparation x = (ℤ.+ 0 ℚ./ 1 ℚ.≤ x distanceToIntruder × x distanceToIntruder ℚ.≤ ℤ.+ 60760 ℚ./ 1) × ((ℚ.- pi ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ pi) × ((ℚ.- pi ℚ.≤ x intruderHeading × x intruderHeading ℚ.≤ pi) × ((ℤ.+ 100 ℚ./ 1 ℚ.≤ x speed × x speed ℚ.≤ ℤ.+ 1200 ℚ./ 1) × (ℤ.+ 0 ℚ./ 1 ℚ.≤ x intruderSpeed × x intruderSpeed ℚ.≤ ℤ.+ 1200 ℚ./ 1))))

abstract
  property7 : ∀ (x : Tensor ℚ (5 ∷ [])) → LargeVerticalSeparation x → ¬ Advises strongLeft x × ¬ Advises strongRight x
  property7 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

LargeVerticalSeparationAndPreviousWeakLeft : InputVector → Set
LargeVerticalSeparationAndPreviousWeakLeft x = (ℤ.+ 0 ℚ./ 1 ℚ.≤ x distanceToIntruder × x distanceToIntruder ℚ.≤ ℤ.+ 60760 ℚ./ 1) × ((ℚ.- pi ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ ℚ.- (ℤ.+ 3 ℚ./ 4) ℚ.* pi) × ((ℚ.- (ℤ.+ 1 ℚ./ 10) ℚ.≤ x intruderHeading × x intruderHeading ℚ.≤ ℤ.+ 1 ℚ./ 10) × ((ℤ.+ 600 ℚ./ 1 ℚ.≤ x speed × x speed ℚ.≤ ℤ.+ 1200 ℚ./ 1) × (ℤ.+ 600 ℚ./ 1 ℚ.≤ x intruderSpeed × x intruderSpeed ℚ.≤ ℤ.+ 1200 ℚ./ 1))))

abstract
  property8 : ∀ (x : Tensor ℚ (5 ∷ [])) → LargeVerticalSeparationAndPreviousWeakLeft x → Advises clearOfConflict x ⊎ Advises weakLeft x
  property8 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

PreviousWeakRightAndNearbyIntruder : InputVector → Set
PreviousWeakRightAndNearbyIntruder x = (ℤ.+ 2000 ℚ./ 1 ℚ.≤ x distanceToIntruder × x distanceToIntruder ℚ.≤ ℤ.+ 7000 ℚ./ 1) × ((ℚ.- (ℤ.+ 2 ℚ./ 5) ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ ℚ.- (ℤ.+ 7 ℚ./ 50)) × ((ℚ.- pi ℚ.≤ x intruderHeading × x intruderHeading ℚ.≤ ℚ.- pi ℚ.+ ℤ.+ 1 ℚ./ 100) × ((ℤ.+ 100 ℚ./ 1 ℚ.≤ x speed × x speed ℚ.≤ ℤ.+ 150 ℚ./ 1) × (ℤ.+ 0 ℚ./ 1 ℚ.≤ x intruderSpeed × x intruderSpeed ℚ.≤ ℤ.+ 150 ℚ./ 1))))

abstract
  property9 : ∀ (x : Tensor ℚ (5 ∷ [])) → PreviousWeakRightAndNearbyIntruder x → Advises strongLeft x
  property9 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

IntruderFarAway2 : InputVector → Set
IntruderFarAway2 x = (ℤ.+ 36000 ℚ./ 1 ℚ.≤ x distanceToIntruder × x distanceToIntruder ℚ.≤ ℤ.+ 60760 ℚ./ 1) × ((ℤ.+ 7 ℚ./ 10 ℚ.≤ x angleToIntruder × x angleToIntruder ℚ.≤ pi) × ((ℚ.- pi ℚ.≤ x intruderHeading × x intruderHeading ℚ.≤ ℚ.- pi ℚ.+ ℤ.+ 1 ℚ./ 100) × ((ℤ.+ 900 ℚ./ 1 ℚ.≤ x speed × x speed ℚ.≤ ℤ.+ 1200 ℚ./ 1) × (ℤ.+ 600 ℚ./ 1 ℚ.≤ x intruderSpeed × x intruderSpeed ℚ.≤ ℤ.+ 1200 ℚ./ 1))))

abstract
  property10 : ∀ (x : Tensor ℚ (5 ∷ [])) → IntruderFarAway2 x → Advises clearOfConflict x
  property10 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }


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

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties

open import Tools.Product

-- Valid types are reducible.
reducibleᵛ : ∀ {A Γ l}
             ([Γ] : ⊩ᵛ Γ)
           → Γ ⊩ᵛ⟨ l ⟩ A / [Γ]
           → Γ ⊩⟨ l ⟩ A
reducibleᵛ [Γ] [A] =
  let ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevance′ (subst-id _) (proj₁ ([A] ⊢Γ [id]))

-- Valid type equality is reducible.
reducibleEqᵛ : ∀ {A B Γ l}
               ([Γ] : ⊩ᵛ Γ)
               ([A] : Γ ⊩ᵛ⟨ l ⟩ A / [Γ])
             → Γ ⊩ᵛ⟨ l ⟩ A ≡ B / [Γ] / [A]
             → Γ ⊩⟨ l ⟩ A ≡ B / reducibleᵛ [Γ] [A]
reducibleEqᵛ {A = A} [Γ] [A] [A≡B] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceEq″ (subst-id _) (subst-id _)
                      (proj₁ ([A] ⊢Γ [id])) [σA] ([A≡B] ⊢Γ [id])

-- Valid terms are reducible.
reducibleTermᵛ : ∀ {t A Γ l}
                 ([Γ] : ⊩ᵛ Γ)
                 ([A] : Γ ⊩ᵛ⟨ l ⟩ A / [Γ])
               → Γ ⊩ᵛ⟨ l ⟩ t ∷ A / [Γ] / [A]
               → Γ ⊩⟨ l ⟩ t ∷ A / reducibleᵛ [Γ] [A]
reducibleTermᵛ {A = A} [Γ] [A] [t] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceTerm″ (subst-id _) (subst-id _)
                        (proj₁ ([A] ⊢Γ [id])) [σA] (proj₁ ([t] ⊢Γ [id]))

-- Valid term equality is reducible.
reducibleEqTermᵛ : ∀ {t u A Γ l}
                   ([Γ] : ⊩ᵛ Γ)
                   ([A] : Γ ⊩ᵛ⟨ l ⟩ A / [Γ])
                 → Γ ⊩ᵛ⟨ l ⟩ t ≡ u ∷ A / [Γ] / [A]
                 → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / reducibleᵛ [Γ] [A]
reducibleEqTermᵛ {A = A} [Γ] [A] [t≡u] =
  let [σA] = reducibleᵛ {A = A} [Γ] [A]
      ⊢Γ = soundContext [Γ]
      [id] = idSubstS [Γ]
  in  irrelevanceEqTerm″ (subst-id _) (subst-id _) (subst-id _)
                          (proj₁ ([A] ⊢Γ [id])) [σA] ([t≡u] ⊢Γ [id])


{-# OPTIONS --guardedness-preserving-type-constructors #-}

open import Agda.Builtin.Coinduction
open import Agda.Builtin.IO
open import Agda.Builtin.Unit

data Rec (A : ∞ Set) : Set where
  fold : ♭ A → Rec A

D : Set
D = Rec (♯ (∞ D))

d : D
d = fold (♯ d)

postulate
  seq    : {A B : Set} → A → B → B
  return : {A : Set} → A → IO A

{-# COMPILE GHC return = \_   -> return #-}
{-# COMPILE GHC seq    = \_ _ -> seq    #-}

main : IO ⊤
main = seq d (return tt)


module InstanceArgs where

data UnitMonoid : Set where
  u : UnitMonoid
  p : UnitMonoid → UnitMonoid → UnitMonoid

record Plus (A : Set) : Set where
  infixl 6 _+_
  field
    _+_ : A → A → A

open Plus {{...}}

instance
  plus-unitMonoid : Plus UnitMonoid
  plus-unitMonoid = record { _+_ = p }

bigValue : UnitMonoid
bigValue =
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u +
  u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u + u


-- Record constructors are not allowed in patterns.

module RecordConstructorPatternMatching where

record R : Set₁ where
  constructor con
  field
    {A}         : Set
    f           : A → A
    {B C} D {E} : Set
    g           : B → C → E

id : R → R
id (con f D g) = con f D g


-- Issue 3536 reported by Malin Altenmüller

-- The problem was that the Treeless compiler reruns the clause
-- compiler, but without the split tree from the coverage
-- checker. However, the split tree is necessary to direct the clause
-- compiler.

data Unit : Set where
 true : Unit

record R : Set where
 coinductive
 field
   f1 : R
   f2 : R
open R public

foo : Unit -> R
f1 (foo true) = foo true
f2 (foo b) = foo b


-- Andreas, 2018-05-28, issue #3095, fail on attempt to make hidden parent variable visible

data Nat : Set where
  suc : {n : Nat} → Nat

data IsSuc : Nat → Set where
  isSuc : ∀{n} → IsSuc (suc {n})

test : ∀{m} → IsSuc m → Set
test p = aux p
  where
  aux : ∀{n} → IsSuc n → Set
  aux isSuc = {!.m!}  -- Split on .m here

-- Context:
-- p  : IsSuc .m
-- .m : Nat
-- .n : Nat

-- Expected error:
-- Cannot split on module parameter .m
-- when checking that the expression ? has type Set


{-
  This is the readme of the Agda mechanization accompanying our
  POPL 2018 paper:

    "Intrinsically-Typed Interpreters for Imperative Languages"

  The repository is hosted here:
  - https://github.com/metaborg/mj.agda

  A rendered and linked version of this readme can be found here:
  - https://metaborg.github.io/mj.agda/

  This development has been tested against Agda 2.6.1.1 (see CHANGELOG for previous versions).
  If you have this installed, you should simply be able to run
  `make` in the project root. This will checkout the two dependencies in
  `./lib/` first and then build this `./Readme.agda` which serves as the main
  entrypoint to the development.

  Alternatively you can run `make docs` to build the html version of
  the development which is useful if you want to navigate the code
  (starting e.g. in `docs/index.html`) without having an editor setup
  for it. The html docs are syntax-highlighted and you can click
  references to navigate to their definitions.

  There are some minor differences between the Agda code used in the
  paper and this mechanization.  One general (but minor) discrepancy
  is that the definitions in the paper are typed in a manner that is
  not universe polymorphic.  However, the development makes extensive
  use of universe polymorphism, by explicitly quantifying over
  universe levels (e.g., `i` in `{i} → Set i`).

  Other discrepancies are summarized below in this readme.
-}

module Readme where

{-
  * Section 2 *

  We develop a monadic, well-typed interpreter for STLC and interpret
  a few example programs.

  Unlike the interpreter summarized in the paper, the STLC semantics
  in the development makes use of integers and integer operations.
-}
open import STLC.Semantics
open import STLC.Examples

{-
  * Section 3.1 - 3.3 *

  We demonstrate how naively extending the approach to cover
  imperative state is possible, but requires explicit weakening of
  bound values in the interpreter.
-}

open import STLCRef.SemanticsLB

{-
  * Section 3.4 : dependent passing style *

  We can improve the semantics with a form of monadic strength to get
  rid of explicit weakening.
-}
open import STLCRef.Semantics
open import STLCRef.Examples

{-
  * Section 4 until 4.3 *

  We implement the scopes and frames approach in the following small
  Agda library.
-}

open import ScopesFrames.ScopesFrames

{-
  * Section 4.4 *

  We demonstrate the basic usage of this library on an interpreter for
  STLC using scopes and frames.
-}
open import STLCSF.Semantics

{-
  * Section 5 *

  We show how our techniques scale by defining an intrinsically-typed
  interpreter for Middleweight Java (MJ), a language with:

  - Imperative objects
  - Sub-typing
  - Mutable, block-scoped environments
  - Early returns

  The only discrepancy between the code in this development and the
  code shown in the paper is the following:

  - Pattern matching lambdas are not useful for pattern matching
    against.  Instead of using `All` types with pattern matching
    lambdas (Section 5.3 and 5.4), we use tagging predicates in
    `MJSF.Syntax`.

  Then there are some notable differences between the original
  presentation of MJ and our development:

  - Original MJ distinguishes promotable expressions (method
    invocation and object creation) and all other expressions. We
    admit arbitrary expressions to be promoted. This does not change
    the semantics in any significant way. The expressions that we
    allow to be promoted are side-effect free.

  - returns are implemented by modeling non-void methods as having an
    expression as its last statement (technically, this is enforced by
    the type rules of Original MJ; in our development it is
    syntactically enforced).

  - MJ only has equality comparison expressions that can be used as
    conditional expressions.  We allow arbitrary expressions, and use
    if-zero (`ifz`) for conditionals.  This does not correspond to MJ
    or Java, but it would be straightforward to add Booleans and use a
    more conventional `if` statement instead.

  - If-zero statements have ordinary statements as their
    sub-statements.  These can either be block statements or any other
    statement which does not allocate a new frame.  In Original MJ, if
    statements must be blocks.

  - We include integers and integer operations, which are not in
    Original MJ.

  - Our MJ syntax admits fields typed by `void`, which Original MJ
    does not.

  - Our MJ syntax incorporates a dedicated `this` expression for
    referencing the "self" of an object.

-}

open import MJSF.Syntax
open import MJSF.Values
open import MJSF.Monad
open import MJSF.Semantics

{-
  We demonstrate that our interpreter is executable:
-}
open import MJSF.Examples.Integer
open import MJSF.Examples.DynamicDispatch

{-
  * Appendix A *

  The following code artifacts *are not* described in the paper, but
  are used as a comparison point to evaluate the impact on the
  interpreter of using the scopes and frames model of binding.

  This is an intrinsically-typed interpreter for MJ without the use of
  scope-and-frames. Instead it describes a language-*dependent*
  classtable construction to deal with object dot-access binding and
  typing contexts and environments to deal with lexical binding
  respectively.
-}
open import MJ.Syntax.Typed

-- lexical contexts
open import MJ.LexicalScope

-- class table
open import MJ.Classtable.Core
open import MJ.Classtable.Membership
open import MJ.Classtable.Code

-- semantics
open import MJ.Semantics.Values
open import MJ.Semantics.Environments
open import MJ.Semantics.Objects
open import MJ.Semantics.Objects.Flat
open import MJ.Semantics.Monadic

-- examples
open import MJ.Examples.Integer
open import MJ.Examples.Exceptions
open import MJ.Examples.While
open import MJ.Examples.DynDispatch

{-
  * Appendix B *

  Additionally we demonstrate briefly how Agda's typeclass mechanism
  is not sufficiently strong to infer store extension facts for
  weakening. (Notably Idris rejects an equivalent program as well
  because the two instances are overlapping)
-}
open import Experiments.Infer

{-
  * Appendix C *

  Our interpreters make use of the operator `_^_` operator, defined
  as:

  (1) `_^_ : ∀ {Σ Γ}{p q : List Type → Set} ⦃ w : Weakenable q ⦄ →
             M Γ p Σ → q Σ → M Γ (p ⊗ q) Σ`

  This operator is strikingly similar to the strength operator that is
  characteristic of strong monads:

  (2)  `_^_ : ∀ {p q} → M p → q → M (p ⊗ q)`

  Here, `p` and `q` are objects in a category ℂ, and M is a monad for
  ℂ.

  In the following development we show how to define a monad that is
  morally equivalent to ours.  The monad in the development below is
  defined over the category of monotone predicates.  In this category,
  the store-passing monad is a strong monad, with the usual notion of
  monadic strength, i.e., (2) above.

  We also show how, in this category, we can write an interpreter
  without explicit weakening, by writing the interpreter in a
  point-free style.
-}

open import Experiments.Category
open import Experiments.StrongMonad
open import Experiments.STLCRefPointfree

{-
  We briefly outline how these experiments relate to our paper.

  The interpreters in our paper are defined in terms of ordinary Agda
  functions and indexed types.  Agda functions and indexed types are
  not guaranteed to be weakenable, and Agda does not have built-in
  support for automatically weakening types across monadic binds.  In
  our paper, we address the weakening problem by making explicit use
  in our interpreters of the `_^_` operator, which is morally
  equivalent to the monadic strength operator for monotone predicates
  over store types, defined in the categorical development above.  Our
  `_^_` operator explicitly requires `q` to be weakenable, which is a
  fairly minimal requirement for convincing Agda's type checker that
  carrying types over monadic binds is safe.

  The categorical model enjoys a cleaner treatment of weakening, but
  it is more cumbersome to write interpreters in Agda using this
  model, because of the additional level of encoding imposed by
  constructing and working with objects and morphisms in a category,
  as encoded in Agda.  However, we imagine that the categorical
  development is a good target model for a future specification
  language for dynamic semantics.
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Binary.Pointwise.Inductive directly.
------------------------------------------------------------------------

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

module Data.Vec.Relation.Pointwise.Inductive where

open import Data.Vec.Relation.Binary.Pointwise.Inductive public

{-# WARNING_ON_IMPORT
"Data.Vec.Relation.Pointwise.Inductive was deprecated in v1.0.
Use Data.Vec.Relation.Binary.Pointwise.Inductive instead."
#-}


-- Strict A is a datatype isomorphic to A, with constructor ! : A → Strict A
-- Semantically it has no impact, but its constructor is strict, so it can be
-- used to force evaluation of a term to whnf by pattern-matching.

open import Data.Strict.Primitive using ()

module Data.Strict where

open Data.Strict.Primitive public using ( Strict ; ! )


open import Data.Nat hiding (_^_ ; _+_)
open import Data.List as List hiding (null)
open import Data.List.Membership.Propositional
open import Data.List.Relation.Unary.Any
open import Data.List.Relation.Unary.All as All
open import Data.List.All.Properties.Extra
open import Data.Integer
open import Data.Unit
open import Data.Empty
open import Data.Product hiding (map)
open import Relation.Binary.PropositionalEquality hiding ([_])
open ≡-Reasoning
open import Function
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Star hiding (return ; _>>=_ ; map)

module MJSF.Semantics (k : ℕ) where

open import MJSF.Syntax k
open import MJSF.Values k
open import MJSF.Monad k
open import ScopesFrames.ScopesFrames k Ty
open import Common.Weakening

-- This file contains the definitional interpreter for MJ using scopes
-- and frames, described in Section 5 of the paper.

module Semantics (g : Graph) where

  open SyntaxG g
  open ValuesG g
  open MonadG g
  open UsesVal Valᵗ valᵗ-weaken renaming (getFrame to getFrame') public

  -----------------
  -- AUXILIARIES --
  -----------------

  -- The interpreter relies on a number of auxiliary function.  We
  -- briefly summarize each.

  -- In Java (and MJ), each field member of an object is initialized
  -- to have a default value.  The `default` function defines a
  -- default value for each value type in MJ.

  default : {Σ : List Scope} → (t : VTy) → Val t Σ
  default int     = num (+ 0)
  default (ref s) = null
  default void    = void

  -- An alias for mapping `default` over a list of well-typed values:

  defaults : ∀ {fs : List Ty}{Σ} → All (#v (λ _ → ⊤)) fs → Slots fs Σ
  defaults fs = All.map (λ{ (#v' {t} _) → vᵗ (default t) }) fs

  -- `override` overrides methods in parent objects by overwriting
  -- method slots in super class frames by overriding child methods.
  --
  -- This notion of overriding does not straightforwardly scale to
  -- deal with `super`, but `super` is not a part of MJ.  See the
  -- paper or the MJ semantics in the appendix of this artifact for
  -- discussion and inspiration for how to represent class methods
  -- separately from object representations.

  override : ∀ {s Σ oms} →
             All (#m (λ ts t → (s ↦ (mᵗ ts t)) × Meth s ts t)) oms →
             M s (λ _ → ⊤) Σ
  override [] =
    return tt
  override (#m' (p , m) ∷ oms) =
    getFrame >>= λ f →
    setv p (mᵗ f m) >>= λ _ →
    override oms

  -- `init-obj` takes as input a class definition and a witness that
  -- the class has a finite inheritance chain.  The function is
  -- structurally recursive over the inheritance chain finity witness.
  --
  -- Each object is initialized by using the `initι` function, which
  -- allows us to refer to the "self" frame and store it in method
  -- definitions (i.e., the `fc` passed to the method value
  -- constructor `mᵗ` in `map-all` below).
  --
  -- Method slots are initialized using the method members in the
  -- class definition.  Field slots are initialized using `defaults`
  -- defined above.
  --
  -- After frame initialization, overrides are applied by using
  -- `override` defined above.
  --
  -- `init-obj` is assumed to be invoked in the context of the root
  -- frame, which all objects are linked to (because all scopes have
  -- an edge to the root scope).

  init-obj : ∀ {sʳ s s' Σ} → Class sʳ s → Inherits s s' → M sʳ (Frame s) Σ
  init-obj (class0 ms fs oms) (obj _)
    = getFrame >>= λ f →
      initι _ (λ fc → (All.map (λ{ (#m' m) → mᵗ fc m }) ms) ++-all (defaults fs)) (f ∷ []) >>= λ f' →
      (usingFrame f' (override oms) ^ f') >>= λ{ (_ , f') →
      return f' }
  init-obj (class0 ⦃ shape ⦄ _ _ _) (super ⦃ shape' ⦄ _)
    with (trans (sym shape) shape')
  ...  | () -- absurd case: the scope shapes of `class0` and `super` do not match
  init-obj (class1 p ⦃ shape ⦄ ms fs oms) (super ⦃ shape' ⦄ x)
    with (trans (sym shape) shape')
  ...  | refl =
    getv p >>= λ{ (cᵗ class' ic f') →
    (usingFrame f' (init-obj class' x) ^ f') >>= λ{ (f , f') →
    initι _ ⦃ shape ⦄ (λ fc → (All.map (λ{ (#m' m) → mᵗ fc m }) ms) ++-all (defaults fs)) (f' ∷ f ∷ []) >>= λ f'' →
    (usingFrame f'' (override oms) ^ f'') >>= λ{ (_ , f'') →
    return f'' }}}
  init-obj (class1 _ ⦃ shape ⦄ _ _ _) (obj _ ⦃ shape' ⦄)
    with (trans (sym shape) shape')
  ...  | () -- absurd case: the scope shapes of `class1` and `obj` do not match

  -------------------------
  -- EARLY RETURNS MONAD --
  -------------------------

  -- In order to deal with early returns, we define a specialized bind
  -- which stops evaluation and returns the yielded value.

  _>>=ᶜ_     :  ∀ {s s' s'' r Σ} →
               M s (λ Σ → Val r Σ ⊎ Frame s' Σ) Σ →
               (∀ {Σ'} → Frame s' Σ' → M s (λ Σ → Val r Σ ⊎ Frame s'' Σ) Σ') →
               M s (λ Σ → Val r Σ ⊎ Frame s'' Σ) Σ
  (m >>=ᶜ f) = m >>= λ{
      (inj₁ v) → return (inj₁ v) ;
      (inj₂ fr) → f fr
    }

  -- Continue is used to indicate that evaluation should continue.

  continue : ∀ {s r Σ} → M s (λ Σ → Val r Σ ⊎ Frame s Σ) Σ
  continue = fmap inj₂ getFrame

  mutual

    ---------------------------
    -- EXPRESSION EVALUATION --
    ---------------------------

    eval    :  ℕ → ∀ {t s Σ} → Expr s t → M s (Val t) Σ
    eval zero _ =
      timeoutᴹ
    eval (suc k) (upcast σ e) =
      eval k e >>= λ v →
      return (upcastRef σ v)
    eval (suc k) (num x) =
      return (num x)
    eval (suc k) (iop x l r) =
      eval k l >>= λ{ (num il) →
      eval k r >>= λ{ (num ir) →
      return (num (il + ir)) }}
    eval (suc k) null =
      return null
    eval (suc k) (var x) =
      getv x >>= λ{ (vᵗ v) →
      return v }
    eval (suc k) (new x) =
      getv x >>= λ{ (cᵗ class ic f) →
      usingFrame f (init-obj class ic) >>= λ{ f' →
      return (ref [] f') }}
    eval (suc k) (get e p) =
      eval k e >>= λ{
        null → raise ;
        (ref p' f) →
          usingFrame f (getv (prepend p' p)) >>= λ{ (vᵗ v) →
          return v }}
    eval (suc k) (call e p args) =
      eval k e >>= λ {
        null → raise ;
        (ref p' f) →
          usingFrame f (getv (prepend p' p)) >>= λ{ (mᵗ f' (meth s b)) →  -- f' is the "self"
          (eval-args k args ^ f') >>= λ{ (slots , f') →
          init s slots (f' ∷ []) >>= λ f'' →  -- f' is the static link of the method call frame
          usingFrame f'' (eval-body k b) }}}
    eval (suc k) (this p e) =
      getf p >>= λ f →
      usingFrame f (getl e) >>= λ f' →
      return (ref [] f')

    eval-args : ℕ → ∀ {s ts Σ} → All (Expr s) ts → M s (Slots (List.map vᵗ ts)) Σ
    eval-args zero _ = timeoutᴹ
    eval-args (suc k) [] = return []
    eval-args (suc k) (e ∷ es) =
      eval k e >>= λ v →
      (eval-args k es ^ v) >>= λ{ (slots , v) →
      return (vᵗ v ∷ slots) }

    --------------------------
    -- STATEMENT EVALUATION --
    --------------------------

    -- The following functions use the early returns monadic bind and
    -- `continue` operation defined above.

    eval-stmt : ℕ → ∀ {s s' r Σ} → Stmt s r s' → M s (λ Σ → Val r Σ ⊎ Frame s' Σ) Σ
    eval-stmt zero _ = timeoutᴹ
    eval-stmt (suc k) (run e) =
      eval k e >>= λ _ →
      continue
    eval-stmt (suc k) (ifz c t e) =
      eval k c >>= λ{
        (num (+ zero)) → eval-stmt k t
      ; (num i) → eval-stmt k e }
    eval-stmt (suc k) (set e p e') =
      eval k e >>= λ{
        null → raise ;
        (ref p' f) →
          (eval k e' ^ f) >>= λ{ (v , f) →
          usingFrame f (setv (prepend p' p) (vᵗ v)) >>= λ _ → continue }}
    eval-stmt (suc k) (loc s t) =
      getFrame >>= λ f →
      fmap inj₂ (init s (vᵗ (default t) ∷ []) (f ∷ [])) -- initializes a new local variable frame
    eval-stmt (suc k) (asgn x e) =
      eval k e >>= λ{ v →
      setv x (vᵗ v) >>= λ _ →
      continue }
    eval-stmt (suc k) (block stmts) =
      eval-stmts k stmts >>= λ{ _ →
      continue }
    eval-stmt (suc k) (ret e) =
      eval k e >>= λ{ v →
      return (inj₁ v) }

    eval-stmts : ℕ → ∀ {s r s' Σ} → Stmts s r s' → M s (λ Σ → Val r Σ ⊎ Frame s' Σ) Σ
    eval-stmts zero _ =
      timeoutᴹ
    eval-stmts (suc k) ε =
      continue
    eval-stmts (suc k) (stmt ◅ stmts) =
      eval-stmt k stmt >>=ᶜ λ f' →
      usingFrame f' (eval-stmts k stmts)

    ---------------------
    -- BODY EVALUATION --
    ---------------------

    -- Defined in terms of statement evaluation; handles early returns:

    eval-body : ℕ → ∀ {s t Σ} → Body s t → M s (Val t) Σ
    eval-body zero _ =
      timeoutᴹ
    eval-body (suc k) (body stmts e) =
      eval-stmts k stmts >>= λ{
        (inj₁ v)  → return v
      ; (inj₂ fr) → usingFrame fr (eval k e) }
    eval-body (suc k) (body-void stmts) =
      eval-stmts k stmts >>= λ _ →
      return void

  ------------------------
  -- PROGRAM EVALUATION --
  ------------------------

  -- Program evaluation first initializes the root frame to store all
  -- class definitions, and subsequently evaluates the program main
  -- function in the context of this root scope.
  --
  -- We use `initι` to initialize the root frame since class
  -- definition values (`cᵗ`) store a pointer to the root frame, i.e.,
  -- slots in the root frame are self-referential.

  eval-program : ℕ → ∀ {sʳ t} → Program sʳ t → Res (∃ λ Σ' → (Heap Σ' × Val t Σ'))
  eval-program k (program _ cs b) =
    let (f₀ , h₀) = initFrameι _ (λ f → All.map (λ{ (#c' (c , _ , ic)) → cᵗ c ic f }) cs) [] []
    in case (eval-body k b f₀ h₀) of λ{
         (ok (Σ' , h' , v , _)) → ok (Σ' , h' , v)
       ; timeout → timeout
       ; nullpointer → nullpointer }

  -- For the purpose of running the interpreter on test programs, we
  -- introduce some short-hand notation:

  -- The program will terminate succesfully in a state where p holds
  _⇓⟨_⟩_ : ∀ {sʳ a} → Program sʳ a → ℕ → (p : ∀ {Σ} → Val a Σ → Set) → Set
  p ⇓⟨ k ⟩ P with eval-program k p
  ... | nullpointer = ⊥
  ... | timeout = ⊥
  ... | ok (_ , _ , v) = P v

  -- The program will raise an exception in a state where p holds
  _⇓⟨_⟩!_ : ∀ {sʳ a} → Program sʳ a → ℕ → (p : ∀ {Σ} → Val a Σ → Set) → Set
  p ⇓⟨ k ⟩! P with eval-program k p
  ... | nullpointer = ⊤
  ... | timeout = ⊥
  ... | ok (_ , _ , v) = ⊥


------------------------------------------------------------------------
-- The Agda standard library
--
-- Notation for adding an additional point to any set
------------------------------------------------------------------------

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

module Relation.Nullary.Construct.Add.Point where

open import Data.Maybe.Base using ()
  renaming (Maybe to Pointed; nothing to ∙; just to [_])
  public


open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit
open import Agda.Builtin.String
open import Agda.Builtin.Nat
open import Agda.Builtin.List

infixl 5 _>>=_
_>>=_ = bindTC
pure = returnTC

defToTerm : Name → Definition → List (Arg Term) → Term
defToTerm _ (function cs) as = pat-lam cs as
defToTerm _ (data-cons d) as = con d as
defToTerm _ _ _ = unknown

derefImmediate : Term → TC Term
derefImmediate (def f args) = getDefinition f >>= λ f' → pure (defToTerm f f' args)
derefImmediate x = pure x

macro
  reflect : ∀ {ℓ} {t : Set ℓ} → t → Type → TC ⊤
  reflect {_} {t} x ty = quoteTC x >>= derefImmediate >>= λ x' → quoteTC t >>= checkType x' >>= quoteTC >>= unify ty
  -- reflect {_} {t} x ty = quoteTC x >>= derefImmediate >>= quoteTC >>= unify ty

data Maybe {ℓ} (t : Set ℓ) : Set ℓ where
  just : t → Maybe t
  nothing : Maybe t

listToMaybe : ∀ {ℓ} {t : Set ℓ} → List t → Maybe t
listToMaybe [] = nothing
listToMaybe (x ∷ _) = just x

record Show {ℓ} (t : Set ℓ) : Set ℓ where
  field
     show : t → String

open Show {{...}}

instance
  showN : Show Nat
  showN = record { show = λ _ → "nat" }

  mShow : ∀ {ℓ} {t : Set ℓ} → {{_ : Show t}} → Show (Maybe t)
  mShow = record {
      show = λ { (just x) → show x ;
                 _ → "nothing" }
    }

prog : String
prog =
  let
    x : List Nat
    x = 3 ∷ []
  in
  show (listToMaybe x)

example : Term
example = reflect prog


-------------------------------------------
-- This file contains basic definitions. --
-------------------------------------------
module Basics where

  open import Level

  data ⊥-poly {l : Level} : Set l where

  ⊥-poly-elim : ∀ {l w} {Whatever : Set w} → ⊥-poly {l} → Whatever
  ⊥-poly-elim ()


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

module Mixfix.Acyclic.Example where

open import Codata.Musical.Notation
open import Data.Vec using ([]; _∷_; [_])
open import Data.List as List
  using (List; []; _∷_) renaming ([_] to L[_])
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Relation.Unary.Any using (here; there)
import Codata.Musical.Colist as Colist
open import Data.Product using (∃₂; -,_)
open import Data.Unit.Polymorphic using (⊤)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Nat using (zero; suc)
open import Data.Fin using (#_)
import Data.List.Relation.Binary.Pointwise as ListEq
import Data.String as String
open String using (String; _++_)
import Data.String.Properties as String
open import Relation.Binary
open DecSetoid (ListEq.decSetoid String.≡-decSetoid) using (_≟_)
open import Function using (_∘_; _$_)
open import Data.Bool using (Bool; if_then_else_)
import Data.Bool.Show as Bool
open import Relation.Nullary.Decidable using (⌊_⌋)
import Relation.Binary.PropositionalEquality as P
open import IO
import Level

open import Mixfix.Fixity hiding (_≟_)
open import Mixfix.Operator
open import Mixfix.Expr
open import Mixfix.Acyclic.PrecedenceGraph
import Mixfix.Acyclic.Grammar as Grammar
import Mixfix.Acyclic.Show as Show
import StructurallyRecursiveDescentParsing.Simplified as Simplified
open Simplified using (Parser)
import StructurallyRecursiveDescentParsing.DepthFirst as DepthFirst
import TotalParserCombinators.BreadthFirst as BreadthFirst

------------------------------------------------------------------------
-- Operators

atom : Operator closed 0
atom = record { nameParts = "•" ∷ [] }

plus : Operator (infx left) 0
plus = record { nameParts = "+" ∷ [] }

ifThen : Operator prefx 1
ifThen = record { nameParts = "i" ∷ "t" ∷ [] }

ifThenElse : Operator prefx 2
ifThenElse = record { nameParts = "i" ∷ "t" ∷ "e" ∷ [] }

comma : Operator (infx left) 0
comma = record { nameParts = "," ∷ [] }

wellTyped : Operator postfx 1
wellTyped = record { nameParts = "⊢" ∷ "∶" ∷ [] }

------------------------------------------------------------------------
-- Precedence graph

prec : List (∃₂ Operator) → List Precedence → Precedence
prec ops = precedence (λ fix → List.mapMaybe (hasFixity fix) ops)

mutual

  a  = prec ((-, -, atom) ∷ [])                        []
  pl = prec ((-, -, plus) ∷ [])                        (a ∷ [])
  ii = prec ((-, -, ifThen) ∷ (-, -, ifThenElse) ∷ []) (pl ∷ a ∷ [])
  c  = prec ((-, -, comma) ∷ [])                       (ii ∷ pl ∷ a ∷ [])
  wt = prec ((-, -, wellTyped) ∷ [])                   (c ∷ a ∷ [])

g : PrecedenceGraph
g = wt ∷ c ∷ ii ∷ pl ∷ a ∷ []

------------------------------------------------------------------------
-- Expressions

open PrecedenceCorrect acyclic g

• : ExprIn a non
• = ⟪ here P.refl ∙ [] ⟫

_+_ : Outer pl left → Expr (a ∷ []) → ExprIn pl left
e₁ + e₂ = e₁ ⟨ here P.refl ∙ [] ⟩ˡ e₂

i_t_ : Expr g → Outer ii right → ExprIn ii right
i e₁ t e₂ = ⟪ here P.refl ∙ e₁ ∷ [] ⟩ e₂

i_t_e_ : Expr g → Expr g → Outer ii right → ExprIn ii right
i e₁ t e₂ e e₃ = ⟪ there (here P.refl) ∙ e₁ ∷ e₂ ∷ [] ⟩ e₃

_,_ : Outer c left → Expr (ii ∷ pl ∷ a ∷ []) → ExprIn c left
e₁ , e₂ = e₁ ⟨ here P.refl ∙ [] ⟩ˡ e₂

_⊢_∶ : Outer wt left → Expr g → Expr g
e₁ ⊢ e₂ ∶ = here P.refl ∙ (e₁ ⟨ here P.refl ∙ [ e₂ ] ⟫)

------------------------------------------------------------------------
-- Some tests

open Show g

fromNameParts : List NamePart → String
fromNameParts = List.foldr _++_ ""

toNameParts : String → List NamePart
toNameParts = List.map (String.fromList ∘ L[_]) ∘ String.toList

data Backend : Set where
  depthFirst   : Backend
  breadthFirst : Backend

parse : ∀ {Tok e R} → Backend → Parser Tok e R → List Tok → List R
parse depthFirst   p = DepthFirst.parseComplete p
parse breadthFirst p = BreadthFirst.parse (Simplified.⟦_⟧ p)

parseExpr : Backend → String → List String
parseExpr backend = List.map (fromNameParts ∘ show) ∘
                    parse backend (Grammar.expression g) ∘
                    toNameParts

-- The breadth-first backend is considerably slower than the
-- depth-first one on these examples.
backend = depthFirst

runTest : String → List String → IO (⊤ {ℓ = Level.zero})
runTest s₁ s₂ = do
  putStrLn ("Testing: " ++ s₁)
  Colist.mapM′ putStrLn (Colist.fromList p₁)
  putStrLn (if ⌊ p₁ ≟ s₂ ⌋ then "Passed" else "Failed")
  where p₁ = parseExpr backend s₁

main = run do
  runTest "•+•⊢•∶"      []
  runTest "•,•⊢∶"       []
  runTest "•⊢•∶"        L[ "•⊢•∶" ]
  runTest "•,i•t•+•⊢•∶" L[ "•,i•t•+•⊢•∶" ]
  runTest "i•ti•t•e•"   ("i•ti•t•e•" ∷ "i•ti•t•e•" ∷ [])


-- Interface to standard library.

module Library where

open import Function public
  hiding (_∋_)

open import Level public
  using (Level) renaming (zero to lzero; suc to lsuc)

open import Size public

open import Category.Monad public
  using (RawMonad; module RawMonad)

open import Data.Empty public
  using (⊥; ⊥-elim)

open import Data.List public
  using (List; []; _∷_; map)

open import Data.Maybe public
  using (Maybe; just; nothing) renaming (map to fmap)

open import Data.Nat public
  using (ℕ; zero; suc; _+_; _≟_)

open import Data.Product public
  using (∃; _×_; _,_) renaming (proj₁ to fst; proj₂ to snd)
--infixr 1 _,_

open import Data.Sum public
  using (_⊎_; [_,_]′) renaming (inj₁ to inl; inj₂ to inr)

open import Data.Unit  public
  using (⊤)

open import Function public
  using (_∘_; flip; case_of_)
  renaming (id to idf)

open import Relation.Nullary public
  using (Dec; yes; no)

open import Relation.Binary public
  using (Setoid; module Setoid)

import Relation.Binary.PreorderReasoning
module Pre = Relation.Binary.PreorderReasoning

open import Relation.Binary.PropositionalEquality public
  using ( _≡_; refl; sym; trans; cong; cong₂; subst; module ≡-Reasoning
        ; inspect; [_])

--open ≡-Reasoning renaming (begin_ to proof_) public

open import Relation.Binary.HeterogeneousEquality public
  using (_≅_; refl; ≡-to-≅; module ≅-Reasoning)
  renaming (sym to hsym; trans to htrans; cong to hcong;
            cong₂ to hcong₂; subst to hsubst)
{-
hcong₃ : {A : Set}
         {B : A → Set}
         {C : ∀ a → B a → Set}
         {D : ∀ a b → C a b → Set}
         (f : ∀ a b c → D a b c)
         {a a' : A} → a ≅ a' →
         {b : B a}{b' : B a'} → b ≅ b' →
         {c : C a b}{c' : C a' b'} → c ≅ c' →
         f a b c ≅ f a' b' c'
hcong₃ f refl refl refl = refl

≅-to-≡ : ∀ {a} {A : Set a} {x y : A} → x ≅ y → x ≡ y
≅-to-≡ refl = refl

record Cat : Set1 where
  field Obj  : Set
        Hom  : Obj → Obj → Set
        iden : ∀{X} → Hom X X
        comp : ∀{X Y Z} → Hom Y Z → Hom X Y → Hom X Z
        idl  : ∀{X Y}{f : Hom X Y} → comp iden f ≅ f
        idr  : ∀{X Y}{f : Hom X Y} → comp f iden ≅ f
        ass  : ∀{W X Y Z}{f : Hom Y Z}{g : Hom X Y}{h : Hom W X} →
               comp (comp f g) h ≅ comp f (comp g h)
open Cat public

record Fun (C D : Cat) : Set where
  open Cat
  field OMap  : Obj C → Obj D
        HMap  : ∀{X Y} → Hom C X Y → Hom D (OMap X) (OMap Y)
        fid   : ∀{X} → HMap (iden C {X}) ≅ iden D {OMap X}
        fcomp : ∀{X Y Z}{f : Hom C Y Z}{g : Hom C X Y} →
                HMap (comp C f g) ≅ comp D (HMap f) (HMap g)

open Fun public

postulate ext : {A : Set}{B B' : A → Set}{f : ∀ a → B a}{g : ∀ a → B' a} →
                (∀ a → f a ≅ g a) → f ≅ g

postulate iext : {A : Set}{B B' : A → Set}
                 {f : ∀ {a} → B a}{g : ∀{a} → B' a} →
                 (∀ a → f {a} ≅ g {a}) →
                 _≅_ {_}{ {a : A} → B a} f { {a : A} → B' a} g
-}


-- Andreas, 2016-10-30, issue #2286 reported by carlostome

-- {-# OPTIONS -v interaction.give:40 #-}
-- {-# OPTIONS -v tc.term.expr:40 #-}
-- {-# OPTIONS -v tc.meta:40 #-}
-- {-# OPTIONS -v 10 #-}

data Nat : Set where
  zero : Nat
  succ : Nat → Nat

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

f : Nat -> Nat
f x = {! f x !}  -- giving  f x  here used to loop, as termination checking was not redone

p1 : (n : Nat) -> f n == n
p1 n = refl  -- This unsolved constraint triggered the loop.


-- 2014-07-27 Andreas, issue reported by phadei

module _ where

-- trait A { type T <: A }
record A (self : Set) (T : Set) : Set₁ where
  inductive
  field
    T⊂A : T → A T self

-- trait C extends A with B { type T <: C }
record C (self : Set) (T : Set) : Set₁ where
  inductive
  field
    a : A T self
    T⊂C : T → C T self

-- A with B { type T <: A with B { type T <: ... } }
record AB (self : Set) (T : Set) : Set₁ where
  field
    c : C T self

postulate
  Nat Bool : Set

-- Let's give Nat a A∧B trait, with T = Bool
Nat-AB : AB Nat Bool
Nat-AB = {!!}

-- WAS: Non-termination of type-checker (eta-expansion).

-- SHOULD BE: an unsolved meta.


module spaceShipCell where

open import Unit
open import Data.List.Base hiding ([])
open import Data.Bool.Base
open import Data.Integer
open import Data.Product hiding (map)
open import NativeIO

open import SizedIO.Object
open import SizedIO.IOObject
open import StateSizedIO.GUI.WxBindingsFFI
open import StateSizedIO.GUI.WxGraphicsLib
open import StateSized.GUI.ShipBitMap
open import SizedIO.Base
open import StateSizedIO.GUI.BaseStateDependent
open import StateSizedIO.GUI.VariableList
open import Sized.SimpleCell hiding (main; program)

VarType  = Object (cellI ℤ)

cellℤC : (z : ℤ ) → VarType
objectMethod (cellℤC z) get       = (  z  ,  cellℤC z   )
objectMethod (cellℤC z) (put z')  = (  _  ,  cellℤC z'  )

varInit : VarType
varInit = cellℤC (+ 150)

onPaint : ∀{i} → VarType → DC → Rect → IO GuiLev1Interface i VarType
onPaint c dc rect =
  let (z , c₁) = objectMethod c get                in
  do  (drawBitmap dc ship (z , (+ 150)) true)  λ _ →
  return c₁

moveSpaceShip  : ∀{i} → Frame → VarType → IO GuiLev1Interface i VarType
moveSpaceShip fra c =
  let  (z  ,  c₁)  =  objectMethod c   get
       (_  ,  c₂)  =  objectMethod c₁  (put (z + + 20))
  in   return c₂

callRepaint    : ∀{i} → Frame → VarType → IO GuiLev1Interface i VarType
callRepaint fra c = do (repaint fra) λ _ →  return c

buttonHandler : ∀{i} → Frame → List (VarType  → IO GuiLev1Interface i VarType)
buttonHandler fra = moveSpaceShip fra ∷ [ callRepaint fra ]

program : ∀{i} → IOˢ GuiLev2Interface i (λ _ → Unit) []
program =  doˢ (level1C makeFrame)           λ fra →
           doˢ (level1C (makeButton fra))    λ bt →
           doˢ (level1C (addButton fra bt))  λ _ →
           doˢ (createVar varInit)           λ _ →
           doˢ (setButtonHandler bt (buttonHandler fra)) λ _ →
           doˢ (setOnPaint       fra [ onPaint  ])
           returnˢ

main : NativeIO Unit
main = start (translateLev2 program)


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

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

open import Relation.Unary using (_∈_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
import Relation.Binary.HeterogeneousEquality as Het

open import Common

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

open import SessionType message
open import Trace message

data Transition : SessionType -> Action -> SessionType -> Set where
  inp : ∀{f x}                 -> Transition (inp f) (I x) (f x .force)
  out : ∀{f x} (!x : x ∈ dom f) -> Transition (out f) (O x) (f x .force)

data Transitions : SessionType -> Trace -> SessionType -> Set where
  refl : ∀{T} -> Transitions T [] T
  step : ∀{T α T' φ T''} (t : Transition T α T') (tr : Transitions T' φ T'') -> Transitions T (α ∷ φ) T''

transition->defined : ∀{T a S} -> Transition T a S -> Defined T
transition->defined inp     = inp
transition->defined (out _) = out

output-transition->defined : ∀{T x S} -> Transition T (O x) S -> Defined S
output-transition->defined (out !x) = !x

output-transitions->defined : ∀{T φ x S} -> Transitions T (φ ∷ʳ O x) S -> Defined S
output-transitions->defined {_} {[]} (step (out fx) refl) = fx
output-transitions->defined {_} {_ ∷ _} (step _ tr) = output-transitions->defined tr

unsnoc-transitions : ∀{T φ α S} -> Transitions T (φ ∷ʳ α) S -> ∃[ R ] (Transitions T φ R × Transition R α S)
unsnoc-transitions {_} {[]} (step t refl) = _ , refl , t
unsnoc-transitions {_} {x ∷ φ} (step t tr) with unsnoc-transitions tr
... | _ , sr , s = _ , step t sr , s

transitions+defined->defined : ∀{T as S} -> Transitions T as S -> Defined S -> Defined T
transitions+defined->defined refl def = def
transitions+defined->defined (step t _) _ = transition->defined t

transitions-eq : ∀{T T' T'' φ} (tr : Transitions T φ T') (sr : Transitions T φ T'') ->
  T' ≡ T'' × tr Het.≅ sr
transitions-eq refl refl = refl , Het.refl
transitions-eq (step inp tr) (step inp sr) with transitions-eq tr sr
... | refl , Het.refl = refl , Het.refl
transitions-eq (step (out fx) tr) (step (out gx) sr) with Defined-eq fx gx | transitions-eq tr sr
... | refl | refl , Het.refl = refl , Het.refl

win-reduces-⊥ : ∀{S S' α} → Win S → Transition S α S' → ⊥
win-reduces-⊥ (out e) (out !x) = e _ !x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pointwise lifting of relations to lists
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Pointwise where

open import Function
open import Function.Inverse using (Inverse)
open import Data.Product hiding (map)
open import Data.List.Base as List hiding (map; head; tail)
open import Data.List.Properties using (≡-dec)
open import Data.Fin using (Fin) renaming (zero to fzero; suc to fsuc)
open import Data.Nat using (ℕ; zero; suc)
open import Level
open import Relation.Nullary
open import Relation.Nullary.Negation using (contradiction)
import Relation.Nullary.Decidable as Dec using (map′)
open import Relation.Unary as U using (Pred)
open import Relation.Binary renaming (Rel to Rel₂)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

infixr 5 _∷_

data Pointwise {a b ℓ} {A : Set a} {B : Set b}
         (_∼_ : REL A B ℓ) : List A → List B → Set (a ⊔ b ⊔ ℓ) where
  []  : Pointwise _∼_ [] []
  _∷_ : ∀ {x xs y ys} (x∼y : x ∼ y) (xs∼ys : Pointwise _∼_ xs ys) →
        Pointwise _∼_ (x ∷ xs) (y ∷ ys)

------------------------------------------------------------------------
-- Operations

module _ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} where

  head : ∀ {x y xs ys} → Pointwise _∼_ (x ∷ xs) (y ∷ ys) → x ∼ y
  head (x∼y ∷ xs∼ys) = x∼y

  tail : ∀ {x y xs ys} → Pointwise _∼_ (x ∷ xs) (y ∷ ys) →
         Pointwise _∼_ xs ys
  tail (x∼y ∷ xs∼ys) = xs∼ys

  rec : ∀ {c} (P : ∀ {xs ys} → Pointwise _∼_ xs ys → Set c) →
        (∀ {x y xs ys} {xs∼ys : Pointwise _∼_ xs ys} →
          (x∼y : x ∼ y) → P xs∼ys → P (x∼y ∷ xs∼ys)) →
        P [] →
        ∀ {xs ys} (xs∼ys : Pointwise _∼_ xs ys) → P xs∼ys
  rec P c n []            = n
  rec P c n (x∼y ∷ xs∼ys) = c x∼y (rec P c n xs∼ys)

  map : ∀ {ℓ₂} {_≈_ : REL A B ℓ₂} →
        _≈_ ⇒ _∼_ → Pointwise _≈_ ⇒ Pointwise _∼_
  map ≈⇒∼ []            = []
  map ≈⇒∼ (x≈y ∷ xs≈ys) = ≈⇒∼ x≈y ∷ map ≈⇒∼ xs≈ys

------------------------------------------------------------------------
-- Relational properties

reflexive : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
            {_≈_ : REL A B ℓ₁} {_∼_ : REL A B ℓ₂} →
            _≈_ ⇒ _∼_ → Pointwise _≈_ ⇒ Pointwise _∼_
reflexive ≈⇒∼ []            = []
reflexive ≈⇒∼ (x≈y ∷ xs≈ys) = ≈⇒∼ x≈y ∷ reflexive ≈⇒∼ xs≈ys

refl : ∀ {a ℓ} {A : Set a} {_∼_ : Rel₂ A ℓ} →
       Reflexive _∼_ → Reflexive (Pointwise _∼_)
refl rfl {[]}     = []
refl rfl {x ∷ xs} = rfl ∷ refl rfl

symmetric : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
            {_≈_ : REL A B ℓ₁} {_∼_ : REL B A ℓ₂} →
            Sym _≈_ _∼_ → Sym (Pointwise _≈_) (Pointwise _∼_)
symmetric sym []            = []
symmetric sym (x∼y ∷ xs∼ys) = sym x∼y ∷ symmetric sym xs∼ys

transitive : ∀ {a b c ℓ₁ ℓ₂ ℓ₃}
             {A : Set a} {B : Set b} {C : Set c}
             {_≋_ : REL A B ℓ₁} {_≈_ : REL B C ℓ₂} {_∼_ : REL A C ℓ₃} →
             Trans _≋_ _≈_ _∼_ →
             Trans (Pointwise _≋_) (Pointwise _≈_) (Pointwise _∼_)
transitive trans []            []            = []
transitive trans (x∼y ∷ xs∼ys) (y∼z ∷ ys∼zs) =
  trans x∼y y∼z ∷ transitive trans xs∼ys ys∼zs

antisymmetric : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b}
                {_≤_ : REL A B ℓ₁} {_≤′_ : REL B A ℓ₂} {_≈_ : REL A B ℓ₃} →
                Antisym _≤_ _≤′_ _≈_ →
                Antisym (Pointwise _≤_) (Pointwise _≤′_) (Pointwise _≈_)
antisymmetric antisym []            []            = []
antisymmetric antisym (x∼y ∷ xs∼ys) (y∼x ∷ ys∼xs) =
  antisym x∼y y∼x ∷ antisymmetric antisym xs∼ys ys∼xs

respects₂ : ∀ {a ℓ₁ ℓ₂} {A : Set a}
            {_≈_ : Rel₂ A ℓ₁} {_∼_ : Rel₂ A ℓ₂} →
            _∼_ Respects₂ _≈_ →
            (Pointwise _∼_) Respects₂ (Pointwise _≈_)
respects₂ {_≈_ = _≈_} {_∼_} resp = resp¹ , resp²
  where
  resp¹ : ∀ {xs} → (Pointwise _∼_ xs) Respects (Pointwise _≈_)
  resp¹ []            []            = []
  resp¹ (x≈y ∷ xs≈ys) (z∼x ∷ zs∼xs) =
    proj₁ resp x≈y z∼x ∷ resp¹ xs≈ys zs∼xs

  resp² : ∀ {ys} → (flip (Pointwise _∼_) ys) Respects (Pointwise _≈_)
  resp² []            []            = []
  resp² (x≈y ∷ xs≈ys) (x∼z ∷ xs∼zs) =
    proj₂ resp x≈y x∼z ∷ resp² xs≈ys xs∼zs

decidable : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} →
            Decidable _∼_ → Decidable (Pointwise _∼_)
decidable dec []       []       = yes []
decidable dec []       (y ∷ ys) = no (λ ())
decidable dec (x ∷ xs) []       = no (λ ())
decidable dec (x ∷ xs) (y ∷ ys) with dec x y
... | no ¬x∼y = no (¬x∼y ∘ head)
... | yes x∼y with decidable dec xs ys
...   | no ¬xs∼ys = no (¬xs∼ys ∘ tail)
...   | yes xs∼ys = yes (x∼y ∷ xs∼ys)

isEquivalence : ∀ {a ℓ} {A : Set a} {_≈_ : Rel₂ A ℓ} →
                IsEquivalence _≈_ → IsEquivalence (Pointwise _≈_)
isEquivalence eq = record
  { refl  = refl       Eq.refl
  ; sym   = symmetric  Eq.sym
  ; trans = transitive Eq.trans
  } where module Eq = IsEquivalence eq

isPreorder : ∀ {a ℓ₁ ℓ₂} {A : Set a}
             {_≈_ : Rel₂ A ℓ₁} {_∼_ : Rel₂ A ℓ₂} →
             IsPreorder _≈_ _∼_ → IsPreorder (Pointwise _≈_) (Pointwise _∼_)
isPreorder pre = record
  { isEquivalence = isEquivalence Pre.isEquivalence
  ; reflexive     = reflexive     Pre.reflexive
  ; trans         = transitive    Pre.trans
  } where module Pre = IsPreorder pre

isPartialOrder : ∀ {a ℓ₁ ℓ₂} {A : Set a}
                 {_≈_ : Rel₂ A ℓ₁} {_≤_ : Rel₂ A ℓ₂} →
                 IsPartialOrder _≈_ _≤_ →
                 IsPartialOrder (Pointwise _≈_) (Pointwise _≤_)
isPartialOrder po = record
  { isPreorder = isPreorder    PO.isPreorder
  ; antisym    = antisymmetric PO.antisym
  } where module PO = IsPartialOrder po

isDecEquivalence : ∀ {a ℓ} {A : Set a} {_≈_ : Rel₂ A ℓ} →
                   IsDecEquivalence _≈_ →
                   IsDecEquivalence (Pointwise _≈_)
isDecEquivalence eq = record
  { isEquivalence = isEquivalence DE.isEquivalence
  ; _≟_           = decidable     DE._≟_
  } where module DE = IsDecEquivalence eq

preorder : ∀ {p₁ p₂ p₃} → Preorder p₁ p₂ p₃ → Preorder _ _ _
preorder p = record
  { isPreorder = isPreorder (Preorder.isPreorder p)
  }

poset : ∀ {c ℓ₁ ℓ₂} → Poset c ℓ₁ ℓ₂ → Poset _ _ _
poset p = record
  { isPartialOrder = isPartialOrder (Poset.isPartialOrder p)
  }

setoid : ∀ {c ℓ} → Setoid c ℓ → Setoid _ _
setoid s = record
  { isEquivalence = isEquivalence (Setoid.isEquivalence s)
  }

decSetoid : ∀ {c ℓ} → DecSetoid c ℓ → DecSetoid _ _
decSetoid d = record
  { isDecEquivalence = isDecEquivalence (DecSetoid.isDecEquivalence d)
  }

------------------------------------------------------------------------
-- tabulate

module _ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} where

  tabulate⁺ : ∀ {n} {f : Fin n → A} {g : Fin n → B} →
              (∀ i → f i ∼ g i) → Pointwise _∼_ (tabulate f) (tabulate g)
  tabulate⁺ {zero}  f∼g = []
  tabulate⁺ {suc n} f∼g = f∼g fzero ∷ tabulate⁺ (f∼g ∘ fsuc)

  tabulate⁻ : ∀ {n} {f : Fin n → A} {g : Fin n → B} →
              Pointwise _∼_ (tabulate f) (tabulate g) → (∀ i → f i ∼ g i)
  tabulate⁻ {zero}  []            ()
  tabulate⁻ {suc n} (x∼y ∷ xs∼ys) fzero    = x∼y
  tabulate⁻ {suc n} (x∼y ∷ xs∼ys) (fsuc i) = tabulate⁻ xs∼ys i

------------------------------------------------------------------------
-- _++_

module _ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} where

  ++⁺ : ∀ {ws xs ys zs} → Pointwise _∼_ ws xs → Pointwise _∼_ ys zs →
        Pointwise _∼_ (ws ++ ys) (xs ++ zs)
  ++⁺ []            ys∼zs = ys∼zs
  ++⁺ (w∼x ∷ ws∼xs) ys∼zs = w∼x ∷ ++⁺ ws∼xs ys∼zs

------------------------------------------------------------------------
-- concat

module _ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} where

  concat⁺ : ∀ {xss yss} → Pointwise (Pointwise _∼_) xss yss →
            Pointwise _∼_ (concat xss) (concat yss)
  concat⁺ []                = []
  concat⁺ (xs∼ys ∷ xss∼yss) = ++⁺ xs∼ys (concat⁺ xss∼yss)

------------------------------------------------------------------------
-- length

module _ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} where

  Pointwise-length : ∀ {xs ys} → Pointwise _∼_ xs ys →
                     length xs ≡ length ys
  Pointwise-length []            = P.refl
  Pointwise-length (x∼y ∷ xs∼ys) = P.cong ℕ.suc (Pointwise-length xs∼ys)

------------------------------------------------------------------------
-- reverse

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  reverseAcc⁺ : ∀ {as bs as′ bs′} → Pointwise R as′ bs′ → Pointwise R as bs →
                Pointwise R (reverseAcc as′ as) (reverseAcc bs′ bs)
  reverseAcc⁺ rs′ []       = rs′
  reverseAcc⁺ rs′ (r ∷ rs) = reverseAcc⁺ (r ∷ rs′) rs

  reverse⁺ : ∀ {as bs} → Pointwise R as bs → Pointwise R (reverse as) (reverse bs)
  reverse⁺ = reverseAcc⁺ []

------------------------------------------------------------------------
-- map

module _ {a b c d r} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
         {R : REL C D r} where

  map⁺ : ∀ {as bs} (f : A → C) (g : B → D) →
         Pointwise (λ a b → R (f a) (g b)) as bs →
         Pointwise R (List.map f as) (List.map g bs)
  map⁺ f g []       = []
  map⁺ f g (r ∷ rs) = r ∷ map⁺ f g rs

  map⁻ : ∀ {as bs} (f : A → C) (g : B → D) →
         Pointwise R (List.map f as) (List.map g bs) →
         Pointwise (λ a b → R (f a) (g b)) as bs
  map⁻ {[]} {[]} f g [] = []
  map⁻ {[]} {b ∷ bs} f g rs with Pointwise-length rs
  ... | ()
  map⁻ {a ∷ as} {[]} f g rs with Pointwise-length rs
  ... | ()
  map⁻ {a ∷ as} {b ∷ bs} f g (r ∷ rs) = r ∷ map⁻ f g rs

------------------------------------------------------------------------
-- filter

module _ {a b r p q} {A : Set a} {B : Set b} {R : REL A B r}
         {P : Pred A p} {Q : Pred B q} (P? : U.Decidable P) (Q? : U.Decidable Q)
         (P⇒Q : ∀ {a b} → R a b → P a → Q b) (Q⇒P : ∀ {a b} → R a b → Q b → P a)
         where

  filter⁺ : ∀ {as bs} → Pointwise R as bs → Pointwise R (filter P? as) (filter Q? bs)
  filter⁺ []       = []
  filter⁺ {a ∷ _} {b ∷ _} (r ∷ rs) with P? a | Q? b
  ... | yes p | yes q = r ∷ filter⁺ rs
  ... | yes p | no ¬q = contradiction (P⇒Q r p) ¬q
  ... | no ¬p | yes q = contradiction (Q⇒P r q) ¬p
  ... | no ¬p | no ¬q = filter⁺ rs

------------------------------------------------------------------------
-- replicate

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  replicate⁺ : ∀ {a b} → R a b → ∀ n → Pointwise R (replicate n a) (replicate n b)
  replicate⁺ r 0       = []
  replicate⁺ r (suc n) = r ∷ replicate⁺ r n

------------------------------------------------------------------------
-- Irrelevance

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  irrelevant : Irrelevant R → Irrelevant (Pointwise R)
  irrelevant R-irr [] [] = P.refl
  irrelevant R-irr (r ∷ rs) (r₁ ∷ rs₁) =
    P.cong₂ _∷_ (R-irr r r₁) (irrelevant R-irr rs rs₁)

------------------------------------------------------------------------
-- Properties of propositional pointwise

module _ {a} {A : Set a} where

  Pointwise-≡⇒≡ : Pointwise {A = A} _≡_ ⇒ _≡_
  Pointwise-≡⇒≡ []               = P.refl
  Pointwise-≡⇒≡ (P.refl ∷ xs∼ys) with Pointwise-≡⇒≡ xs∼ys
  ... | P.refl = P.refl

  ≡⇒Pointwise-≡ :  _≡_ ⇒ Pointwise {A = A} _≡_
  ≡⇒Pointwise-≡ P.refl = refl P.refl

  Pointwise-≡↔≡ : Inverse (setoid (P.setoid A)) (P.setoid (List A))
  Pointwise-≡↔≡ = record
    { to         = record { _⟨$⟩_ = id; cong = Pointwise-≡⇒≡ }
    ; from       = record { _⟨$⟩_ = id; cong = ≡⇒Pointwise-≡ }
    ; inverse-of = record
      { left-inverse-of  = λ _ → refl P.refl
      ; right-inverse-of = λ _ → P.refl
      }
    }

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

Rel    = Pointwise
{-# WARNING_ON_USAGE Rel
"Warning: Rel was deprecated in v0.15.
Please use Pointwise instead."
#-}
Rel≡⇒≡ = Pointwise-≡⇒≡
{-# WARNING_ON_USAGE Rel≡⇒≡
"Warning: Rel≡⇒≡ was deprecated in v0.15.
Please use Pointwise-≡⇒≡ instead."
#-}
≡⇒Rel≡ = ≡⇒Pointwise-≡
{-# WARNING_ON_USAGE ≡⇒Rel≡
"Warning: ≡⇒Rel≡ was deprecated in v0.15.
Please use ≡⇒Pointwise-≡ instead."
#-}
Rel↔≡  = Pointwise-≡↔≡
{-# WARNING_ON_USAGE Rel↔≡
"Warning: Rel↔≡ was deprecated in v0.15.
Please use Pointwise-≡↔≡ instead."
#-}

-- Version 1.0

decidable-≡ = ≡-dec
{-# WARNING_ON_USAGE decidable-≡
"Warning: decidable-≡ was deprecated in v1.0.
Please use ≡-dec from `Data.List.Properties` instead."
#-}


{-# OPTIONS -v scope.import:10 #-}

import Common.Level
import Common.Level


-- Andreas, 2016-12-31, re issue #1976
-- Allow projection pattern disambiguation by parameters

{-# OPTIONS --allow-unsolved-metas #-}

postulate
  A B : Set

module M (_ : Set) where

  record R : Set₂ where
    field
      F : Set₁

  open R public

module Succeeds where
  open M _
  open M B

  test : M.R B
  F test = Set

module ShouldFail where
  open M A
  open M _

  test : M.R B
  F test = Set  -- should fail

module Fails where
  open M _
  open M A

  test : M.R B
  F test = Set


module Highlighting where

Set-one : Set₂
Set-one = Set₁

record R (A : Set) : Set-one where
  constructor con

  field X : Set

  F : Set → Set → Set
  F A B = B

  field P : F A X → Set

  -- highlighting of non-terminating definition
  Q : F A X → Set
  Q = Q

postulate P : _

open import Highlighting.M

data D (A : Set) : Set-one where
  d : let X = D in X A

postulate _+_ _×_ : Set → Set → Set

infixl 4 _×_ _+_
  -- Issue #2140: the operators should be highlighted also in the
  -- fixity declaration.


module ModuleArityMismatch where

 module M (A : Set) where

 postulate
   A : Set

 module M′ = M A A


open import Data.Product using ( _,_ ; proj₁ ; proj₂ )
open import Data.Sum using ( inj₁ ; inj₂ )
open import Relation.Unary using ( _⊆_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong )
open import Web.Semantic.DL.ABox using ( ε ; _,_ ; _∼_ ; _∈₁_ ; _∈₂_ ; ⟨ABox⟩ ; Assertions )
open import Web.Semantic.DL.ABox.Interp using ( ⌊_⌋ ; ind )
open import Web.Semantic.DL.ABox.Model using ( ⊨a-impl-⊨b ; ⟨ABox⟩-Assertions )
open import Web.Semantic.DL.Category.Composition using ( _∙_ )
open import Web.Semantic.DL.Category.Object using ( Object ; _,_ ; IN ; fin ; iface )
open import Web.Semantic.DL.Category.Morphism using ( _⇒_ ; _⊑_ ; _≣_ ; _,_ )
open import Web.Semantic.DL.Category.Properties.Composition.RespectsEquiv using ( compose-resp-≣ )
open import Web.Semantic.DL.Category.Properties.Composition.RespectsWiring using ( compose-resp-wiring )
open import Web.Semantic.DL.Category.Properties.Equivalence using ( ≣-refl ; ≣-sym ; ≣-trans )
open import Web.Semantic.DL.Category.Properties.Tensor.RespectsEquiv using ( tensor-resp-≣ )
open import Web.Semantic.DL.Category.Properties.Tensor.RespectsWiring using ( tensor-resp-wiring )
open import Web.Semantic.DL.Category.Tensor using ( _⊗_ ; _⟨⊗⟩_ )
open import Web.Semantic.DL.Category.Unit using ( I )
open import Web.Semantic.DL.Category.Wiring using
  ( wiring ; wires ; wires-≈ ; wires-≈⁻¹
  ; identity ; symm ; assoc ; assoc⁻¹ ; unit₁ ; unit₁⁻¹ ; unit₂ ; unit₂⁻¹
  ; id✓ ; ⊎-swap✓ ; ⊎-assoc✓ ; ⊎-assoc⁻¹✓ ; inj₁✓ ; inj₂✓ ; ⊎-unit₁✓ ; ⊎-unit₂✓ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox )
open import Web.Semantic.DL.TBox.Interp using ( ≈-refl′ ; ≈-trans )
open import Web.Semantic.Util using
  ( id ; _∘_ ; inode ; _⟨⊎⟩_ ; ⊎-swap ; ⊎-assoc ; ⊎-assoc⁻¹ ; ⊎-unit₁ ; ⊎-unit₂ )

module Web.Semantic.DL.Category.Properties.Wiring
  {Σ : Signature} {S T : TBox Σ} where

wiring-⊑-refl : ∀ (A B : Object S T) (f g : IN B → IN A)
  (f✓ : Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A))
    (g✓ : Assertions (⟨ABox⟩ g (iface B)) ⊆ Assertions (iface A)) →
      (∀ x → f x ≡ g x) → (wiring A B f f✓ ⊑ wiring A B g g✓)
wiring-⊑-refl A B f g f✓ g✓ f≡g I I⊨STA I⊨F =
  ⊨a-impl-⊨b I (wires g (proj₁ (fin B)))
    (wires-≈⁻¹ g
      (λ x → ≈-trans ⌊ I ⌋
        (≈-refl′ ⌊ I ⌋ (cong (ind I ∘ inode) (sym (f≡g x))))
        (wires-≈ f (proj₂ (fin B) x) I⊨F))
      (proj₁ (fin B)))

wiring-≣-refl : ∀ (A B : Object S T) (f g : IN B → IN A)
  (f✓ : Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A))
    (g✓ : Assertions (⟨ABox⟩ g (iface B)) ⊆ Assertions (iface A)) →
      (∀ x → f x ≡ g x) → (wiring A B f f✓ ≣ wiring A B g g✓)
wiring-≣-refl A B f g f✓ g✓ f≡g =
  ( wiring-⊑-refl A B f g f✓ g✓ f≡g
  , wiring-⊑-refl A B g f g✓ f✓ (λ x → sym (f≡g x)) )

∘✓ :  (A B C : Object S T) →
  (f : IN B → IN A) → (g : IN C → IN B) →
  (Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A)) →
  (Assertions (⟨ABox⟩ g (iface C)) ⊆ Assertions (iface B)) →
  (Assertions (⟨ABox⟩ (f ∘ g) (iface C)) ⊆ Assertions (iface A))
∘✓ A B (X , X∈Fin , ε) f g f✓ g✓ ()
∘✓ A B (X , X∈Fin , C₁ , C₂) f g f✓ g✓ (inj₁ a∈C₁) = ∘✓ A B (X , X∈Fin , C₁) f g f✓ (g✓ ∘ inj₁) a∈C₁
∘✓ A B (X , X∈Fin , C₁ , C₂) f g f✓ g✓ (inj₂ a∈C₂) = ∘✓ A B (X , X∈Fin , C₂) f g f✓ (g✓ ∘ inj₂) a∈C₂
∘✓ A B (X , X∈Fin , x ∼ y) f g f✓ g✓ refl = f✓ (⟨ABox⟩-Assertions f (iface B) (g✓ refl))
∘✓ A B (X , X∈Fin , x ∈₁ c) f g f✓ g✓ refl = f✓ (⟨ABox⟩-Assertions f (iface B) (g✓ refl))
∘✓ A B (X , X∈Fin , (x , y) ∈₂ r) f g f✓ g✓ refl = f✓ (⟨ABox⟩-Assertions f (iface B) (g✓ refl))

⟨⊎⟩✓ : (A₁ A₂ B₁ B₂ : Object S T) →
  (f₁ : IN B₁ → IN A₁) → (f₂ : IN B₂ → IN A₂) →
  (Assertions (⟨ABox⟩ f₁ (iface B₁)) ⊆ Assertions (iface A₁)) →
  (Assertions (⟨ABox⟩ f₂ (iface B₂)) ⊆ Assertions (iface A₂)) →
  (Assertions (⟨ABox⟩ (f₁ ⟨⊎⟩ f₂) (iface (B₁ ⊗ B₂))) ⊆ Assertions (iface (A₁ ⊗ A₂)))
⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , ε) B₂ f₁ f₂ f₁✓ f₂✓ (inj₁ ())
⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , B₁₁ , B₁₂) B₂ f₁ f₂ f₁✓ f₂✓ (inj₁ (inj₁ b∈B₁₁)) =
  ⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , B₁₁) B₂ f₁ f₂ (f₁✓ ∘ inj₁) f₂✓ (inj₁ b∈B₁₁)
⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , B₁₁ , B₁₂) B₂ f₁ f₂ f₁✓ f₂✓ (inj₁ (inj₂ b∈B₁₂)) =
  ⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , B₁₂) B₂ f₁ f₂ (f₁✓ ∘ inj₂) f₂✓ (inj₁ b∈B₁₂)
⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , x ∼ y) B₂ f₁ f₂ f₁✓ f₂✓ (inj₁ refl) =
  inj₁ (⟨ABox⟩-Assertions inj₁ (iface A₁) (f₁✓ refl))
⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , x ∈₁ c) B₂ f₁ f₂ f₁✓ f₂✓ (inj₁ refl) =
  inj₁ (⟨ABox⟩-Assertions inj₁ (iface A₁) (f₁✓ refl))
⟨⊎⟩✓ A₁ A₂ (X₁ , X₁∈Fin , (x , y) ∈₂ r) B₂ f₁ f₂ f₁✓ f₂✓ (inj₁ refl) =
  inj₁ (⟨ABox⟩-Assertions inj₁ (iface A₁) (f₁✓ refl))
⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , ε) f₁ f₂ f₁✓ f₂✓ (inj₂ ())
⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , B₂₁ , B₂₂) f₁ f₂ f₁✓ f₂✓ (inj₂ (inj₁ b∈B₂₁)) =
  ⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , B₂₁) f₁ f₂ f₁✓ (f₂✓ ∘ inj₁) (inj₂ b∈B₂₁)
⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , B₂₁ , B₂₂) f₁ f₂ f₁✓ f₂✓ (inj₂ (inj₂ b∈B₂₂)) =
  ⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , B₂₂) f₁ f₂ f₁✓ (f₂✓ ∘ inj₂) (inj₂ b∈B₂₂)
⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , x ∼ y) f₁ f₂ f₁✓ f₂✓ (inj₂ refl) =
  inj₂ (⟨ABox⟩-Assertions inj₂ (iface A₂) (f₂✓ refl))
⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , x ∈₁ c) f₁ f₂ f₁✓ f₂✓ (inj₂ refl) =
  inj₂ (⟨ABox⟩-Assertions inj₂ (iface A₂) (f₂✓ refl))
⟨⊎⟩✓ A₁ A₂ B₁ (X₂ , X₂∈Fin , (x , y) ∈₂ r) f₁ f₂ f₁✓ f₂✓ (inj₂ refl) =
  inj₂ (⟨ABox⟩-Assertions inj₂ (iface A₂) (f₂✓ refl))

data Rewrite : (A B : Object S T) (F : A ⇒ B) (f : IN B → IN A) →
  (Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A)) → Set₁ where
    rewrite-wiring : ∀ A B f (f✓ : Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A)) →
      Rewrite A B (wiring A B f f✓) f f✓
    rewrite-compose : ∀ {A B C F G f g}
      {f✓ : Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A)}
        {g✓ : Assertions (⟨ABox⟩ g (iface C)) ⊆ Assertions (iface B)} →
      Rewrite A B F f f✓ → Rewrite B C G g g✓ → Rewrite A C (F ∙ G) (f ∘ g) (∘✓ A B C f g f✓ g✓)
    rewrite-tensor : ∀ {A₁ A₂ B₁ B₂ F₁ F₂ f₁ f₂}
      {f₁✓ : Assertions (⟨ABox⟩ f₁ (iface B₁)) ⊆ Assertions (iface A₁)}
        {f₂✓ : Assertions (⟨ABox⟩ f₂ (iface B₂)) ⊆ Assertions (iface A₂)} →
          Rewrite A₁ B₁ F₁ f₁ f₁✓ → Rewrite A₂ B₂ F₂ f₂ f₂✓ →
            Rewrite (A₁ ⊗ A₂) (B₁ ⊗ B₂) (F₁ ⟨⊗⟩ F₂) (f₁ ⟨⊎⟩ f₂) (⟨⊎⟩✓ A₁ A₂ B₁ B₂ f₁ f₂ f₁✓ f₂✓)

rewrite-identity : ∀ A → Rewrite A A (identity A) id (id✓ A)
rewrite-identity A = rewrite-wiring A A id (id✓ A)

rewrite-symm : ∀ A B → Rewrite (A ⊗ B) (B ⊗ A) (symm A B) ⊎-swap (⊎-swap✓ A B)
rewrite-symm A B = rewrite-wiring (A ⊗ B) (B ⊗ A) ⊎-swap (⊎-swap✓ A B)

rewrite-assoc : ∀ A B C → Rewrite ((A ⊗ B) ⊗ C) (A ⊗ (B ⊗ C)) (assoc A B C) ⊎-assoc⁻¹ (⊎-assoc⁻¹✓ A B C)
rewrite-assoc A B C = rewrite-wiring ((A ⊗ B) ⊗ C) (A ⊗ (B ⊗ C)) ⊎-assoc⁻¹ (⊎-assoc⁻¹✓ A B C)

rewrite-assoc⁻¹ : ∀ A B C → Rewrite (A ⊗ (B ⊗ C)) ((A ⊗ B) ⊗ C) (assoc⁻¹ A B C) ⊎-assoc (⊎-assoc✓ A B C)
rewrite-assoc⁻¹ A B C = rewrite-wiring (A ⊗ (B ⊗ C)) ((A ⊗ B) ⊗ C) ⊎-assoc (⊎-assoc✓ A B C)

rewrite-unit₁ : ∀ A → Rewrite (I ⊗ A) A (unit₁ A) inj₂ (inj₂✓ A)
rewrite-unit₁ A = rewrite-wiring (I ⊗ A) A inj₂ (inj₂✓ A)

rewrite-unit₁⁻¹ : ∀ A → Rewrite A (I ⊗ A) (unit₁⁻¹ A) ⊎-unit₁ (⊎-unit₁✓ A)
rewrite-unit₁⁻¹ A = rewrite-wiring A (I ⊗ A) ⊎-unit₁ (⊎-unit₁✓ A)

rewrite-unit₂ : ∀ A → Rewrite (A ⊗ I) A (unit₂ A) inj₁ (inj₁✓ A)
rewrite-unit₂ A = rewrite-wiring (A ⊗ I) A inj₁ (inj₁✓ A)

rewrite-unit₂⁻¹ : ∀ A → Rewrite A (A ⊗ I) (unit₂⁻¹ A) ⊎-unit₂ (⊎-unit₂✓ A)
rewrite-unit₂⁻¹ A = rewrite-wiring A (A ⊗ I) ⊎-unit₂ (⊎-unit₂✓ A)

rewriting : ∀ {A B F G f g}
  {f✓ : Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A)}
    {g✓ : Assertions (⟨ABox⟩ g (iface B)) ⊆ Assertions (iface A)} →
      (Rewrite A B F f f✓) → (∀ x → f x ≡ g x) → (Rewrite A B G g g✓) →
        (F ≣ G)
rewriting {A} {B} {F} {G} {f} {g} {f✓} {g✓} F⇓f f≡g G⇓g =
  ≣-trans (lemma F⇓f)
    (≣-trans (wiring-≣-refl A B f g f✓ g✓ f≡g)
      (≣-sym (lemma G⇓g))) where

  lemma :  ∀ {A B F f}
    {f✓ : Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A)} →
      (Rewrite A B F f f✓) →
        (F ≣ wiring A B f f✓)
  lemma (rewrite-wiring A B f f✓) = ≣-refl (wiring A B f f✓)
  lemma (rewrite-compose {A} {B} {C} {F} {G} {f} {g} {f✓} {g✓} F⇓f G⇓g) =
    ≣-trans (compose-resp-≣ (lemma F⇓f) (lemma G⇓g))
      (compose-resp-wiring A B C f f✓ g g✓ (f ∘ g)
        (∘✓ A B C f g f✓ g✓) (λ x → refl))
  lemma (rewrite-tensor {A₁} {A₂} {B₁} {B₂} {F₁} {F₂} {f₁} {f₂} {f₁✓} {f₂✓} F₁⇓f₁ F₂⇓f₂) =
    ≣-trans (tensor-resp-≣ (lemma F₁⇓f₁) (lemma F₂⇓f₂))
      (tensor-resp-wiring A₁ A₂ B₁ B₂ f₁ f₁✓ f₂ f₂✓ (f₁ ⟨⊎⟩ f₂)
        (⟨⊎⟩✓ A₁ A₂ B₁ B₂ f₁ f₂ f₁✓ f₂✓) (λ x → refl) (λ x → refl))