cleaning up a little bit. i should be able to avoid totally recapitualting the synth argument in ana..

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = _ , _ , ESAsc2 D
    ... | Inr x = _ , _ , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = _ , _ , ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = _ , _ , ESAp2 {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = _ , _ , ESAp3 {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume wt x₁) =  _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e' ⦈[ x ]} (ASubsume (SNEHole wt) x₁)
      with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EANEHole D
    expandability-ana {e = c} (ASubsume SConst x₁) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ())  ESConst x₁
    expandability-ana {e = e ·: x} (ASubsume (SAsc wt) x₂)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' with htype-dec x τ'
    expandability-ana {Γ} {e ·: .x} (ASubsume (SAsc wt) x₂) | d' , Δ' , x , D' | Inl refl = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAsc2 D') x₂
    expandability-ana {Γ} {e ·: x} (ASubsume (SAsc wt) x₂) | d' , Δ' , τ' , D' | Inr x₁ = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAsc1 D' x₁) x₂
    expandability-ana {e = X x} (ASubsume (SVar x₁) x₂) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESVar x₁) x₂
    expandability-ana {e = ·λ x e} (ASubsume () x₁)
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume (SLam x₂ wt) x₃)
      with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EASubsume (λ u → λ ()) (λ e' u → λ ()) (ESLam x₂ D) x₃
    expandability-ana {e = e1 ∘ e2} (ASubsume (SAp wt1 MAHole wt2) x₂)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2 = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAp1 {!!} wt1 {!!} D2) x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume (SAp wt MAArr x₁) x₂) = {!!}
    expandability-ana (ALam x₁ MAHole wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALam x₁ D'

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = d' , Δ' , ESAsc2 D
    ... | Inr x = (< _ > d') , Δ' , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = X n , ∅ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = _ , _ , ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = (d1 ∘ (< {!!} > d2)) , (Δ1 ∪ Δ2) , ESAp2 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = (d1 ∘ d2) , (Δ1 ∪ Δ2) , ESAp3 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume wt x₁) =  _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e' ⦈[ x ]} (ASubsume (SNEHole wt) x₁)
      with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EANEHole D
    expandability-ana {e = c} (ASubsume SConst x₁) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ())  ESConst x₁
    expandability-ana {e = e ·: x} (ASubsume (SAsc wt) x₂)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' with htype-dec x τ'
    expandability-ana {Γ} {e ·: .x} (ASubsume (SAsc wt) x₂) | d' , Δ' , x , D' | Inl refl = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAsc2 D') x₂
    expandability-ana {Γ} {e ·: x} (ASubsume (SAsc wt) x₂) | d' , Δ' , τ' , D' | Inr x₁ = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAsc1 D' x₁) x₂
    expandability-ana {e = X x} (ASubsume (SVar x₁) x₂) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESVar x₁) x₂
    expandability-ana {e = ·λ x e} (ASubsume () x₁)
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume (SLam x₂ wt) x₃)
      with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EASubsume (λ u → λ ()) (λ e' u → λ ()) (ESLam x₂ D) x₃
    expandability-ana {e = e1 ∘ e2} (ASubsume (SAp wt1 MAHole wt2) x₂)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2 = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAp1 {!!} wt1 {!!} D2) x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume (SAp wt MAArr x₁) x₂) = {!!}
    expandability-ana (ALam x₁ MAHole wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALam x₁ D'


Binary.Logical: cleanup

Binary.Logical: cleanup

{-# OPTIONS --universe-polymorphism #-}
module Relation.Binary.Logical where

open import Type hiding (★)
open import Level
open import Algebra.FunctionProperties
open import Data.Product
open import Data.Unit
open import Data.Empty
open import Relation.Nullary
open import Relation.Unary.NP hiding (Decidable)
open import Relation.Binary

⟦★⟧ : ∀ {a₁ a₂} aᵣ (A₁ : ★ a₁) (A₂ : ★ a₂) → ★ _
⟦★⟧ aᵣ A₁ A₂ = A₁ → A₂ → ★ aᵣ

⟦★₀⟧ : ∀ (A₁ A₂ : ★₀) → ★₁
⟦★₀⟧ = ⟦★⟧ zero

⟦★₁⟧ : ∀ (A₁ A₂ : ★₁) → ★₂
⟦★₁⟧ = ⟦★⟧ (suc zero)

-- old name
⟦Set⟧ : ∀ {a₁ a₂} aᵣ (A₁ : ★ a₁) (A₂ : ★ a₂) → ★ _
⟦Set⟧ aᵣ A₁ A₂ = A₁ → A₂ → ★ aᵣ

-- old name
⟦Set₀⟧ : ∀ (A₁ A₂ : Set) → Set₁
⟦Set₀⟧ = ⟦★₀⟧

-- old name
⟦Set₁⟧ : ∀ (A₁ A₂ : Set₁) → Set₂
⟦Set₁⟧ = ⟦★₁⟧

⟦Π⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

infixr 0 ⟦Π⟧
syntax ⟦Π⟧ Aᵣ (λ xᵣ → f) = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

⟦Π⟧e : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧e Aᵣ Bᵣ = λ f₁ f₂ → ∀ x₁ x₂ (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

⟦∀⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : {x : A₁} → B₁ x) (f₂ : {x : A₂} → B₂ x) → ★ _
⟦∀⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ {x₁}) (f₂ {x₂})

infixr 0 ⟦∀⟧
syntax ⟦∀⟧ Aᵣ (λ xᵣ → f) = ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

infixr 1 _⟦→⟧_
_⟦→⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
Aᵣ ⟦→⟧ Bᵣ = ⟦Π⟧ Aᵣ (λ _ → Bᵣ)

infixr 0 _⟦→⟧e_
_⟦→⟧e_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
_⟦→⟧e_ Aᵣ Bᵣ = ⟦Π⟧e Aᵣ (λ _ → Bᵣ)

record ⟦⊤⟧ (x₁ x₂ : ⊤) : ★₀ where
  constructor ⟦tt⟧

data ⟦⊥⟧ (x₁ x₂ : ⊥) : ★₀ where

infix 3 ⟦¬⟧_

⟦¬⟧_ : ∀ {a₁ a₂ aₚ} → (⟦★⟧ {a₁} {a₂} aₚ ⟦→⟧ ⟦★⟧ _) ¬_ ¬_
⟦¬⟧ Aᵣ = Aᵣ ⟦→⟧ ⟦⊥⟧

-- Products ⟦Σ⟧, ⟦∃⟧, ⟦×⟧ are in Data.Product.NP

⟦Pred⟧ : ∀ {p₁ p₂} pᵣ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ _) (Pred p₁) (Pred p₂)
⟦Pred⟧ pᵣ Aᵣ = Aᵣ ⟦→⟧ ⟦★⟧ pᵣ

private
  REL′ : ∀ ℓ {a b} → ★ a → ★ b → ★ (a ⊔ b ⊔ suc ℓ)
  REL′ ℓ A B = A → B → ★ ℓ

  ⟦REL⟧′ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ r₁ r₂} rᵣ →
          (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ {b₁} {b₂} bᵣ ⟦→⟧ ⟦★⟧ _) (REL′ r₁) (REL′ r₂)
  ⟦REL⟧′ rᵣ Aᵣ Bᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦REL⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          {r₁ r₂} rᵣ (∼₁ : REL A₁ B₁ r₁) (∼₂ : REL A₂ B₂ r₂) → ★ _
⟦REL⟧ Aᵣ Bᵣ rᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦Rel⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {r₁ r₂} ℓᵣ (∼₁ : Rel A₁ r₁) (∼₂ : Rel A₂ r₂) → ★ _
⟦Rel⟧ Aᵣ rᵣ = ⟦REL⟧ Aᵣ Aᵣ rᵣ

data ⟦Dec⟧ {ℓ₁ ℓ₂ ℓᵣ} {P₁ : ★ ℓ₁} {P₂ : ★ ℓ₂} (Pᵣ : P₁ → P₂ → ★ ℓᵣ) : ⟦★⟧ (ℓ₁ ⊔ ℓ₂ ⊔ ℓᵣ) (Dec P₁) (Dec P₂) where
  yes : {p₁ : P₁} {p₂ : P₂} (pᵣ : Pᵣ p₁ p₂) → ⟦Dec⟧ Pᵣ (yes p₁) (yes p₂)
  no  : {¬p₁ : ¬ P₁} {¬p₂ : ¬ P₂} (¬pᵣ : (⟦¬⟧ Pᵣ) ¬p₁ ¬p₂) → ⟦Dec⟧ Pᵣ (no ¬p₁) (no ¬p₂)

private
  ⟦Dec⟧' : ∀ {p₁} {p₂} {pᵣ} → ⟦Pred⟧ {p₁} {p₂} _ (⟦★⟧ pᵣ) Dec Dec
  ⟦Dec⟧' = ⟦Dec⟧

⟦Decidable⟧ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ ℓ₁ ℓ₂ ℓᵣ}
              → (∀⟨ Aᵣ ∶ ⟦★⟧ {a₁} {a₂} aᵣ ⟩⟦→⟧
                 ∀⟨ Bᵣ ∶ ⟦★⟧ {b₁} {b₂} bᵣ ⟩⟦→⟧
                   ⟦REL⟧ Aᵣ Bᵣ {ℓ₁} {ℓ₂} ℓᵣ ⟦→⟧ ⟦★⟧ _) Decidable Decidable
⟦Decidable⟧ Aᵣ Bᵣ _∼ᵣ_ = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟨ yᵣ ∶ Bᵣ ⟩⟦→⟧ ⟦Dec⟧ (xᵣ ∼ᵣ yᵣ)

⟦Op₁⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ a) Op₁ Op₁
⟦Op₁⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ

⟦Op₂⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ a) Op₂ Op₂
⟦Op₂⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ

{-# OPTIONS --universe-polymorphism #-}
module Relation.Binary.Logical where

open import Type
open import Level

⟦★⟧ : ∀ {a₁ a₂} aᵣ (A₁ : Set a₁) (A₂ : Set a₂) → Set _
⟦★⟧ aᵣ A₁ A₂ = A₁ → A₂ → Set aᵣ

⟦★₀⟧ : ∀ (A₁ A₂ : ★) → ★₁
⟦★₀⟧ = ⟦★⟧ zero

⟦★₁⟧ : ∀ (A₁ A₂ : ★₁) → ★₂
⟦★₁⟧ = ⟦★⟧ (suc zero)

-- old name
⟦Set⟧ : ∀ {a₁ a₂} aᵣ (A₁ : Set a₁) (A₂ : Set a₂) → Set _
⟦Set⟧ aᵣ A₁ A₂ = A₁ → A₂ → Set aᵣ

-- old name
⟦Set₀⟧ : ∀ (A₁ A₂ : Set) → Set₁
⟦Set₀⟧ = ⟦★₀⟧

-- old name
⟦Set₁⟧ : ∀ (A₁ A₂ : Set₁) → Set₂
⟦Set₁⟧ = ⟦★₁⟧

⟦Π⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → Set bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → Set _
⟦Π⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

infixr 0 ⟦Π⟧
syntax ⟦Π⟧ Aᵣ (λ xᵣ → f) = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

⟦Π⟧e : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → Set bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → Set _
⟦Π⟧e Aᵣ Bᵣ = λ f₁ f₂ → ∀ x₁ x₂ (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

⟦∀⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → Set bᵣ)
         (f₁ : {x : A₁} → B₁ x) (f₂ : {x : A₂} → B₂ x) → Set _
⟦∀⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ {x₁}) (f₂ {x₂})

infixr 0 ⟦∀⟧
syntax ⟦∀⟧ Aᵣ (λ xᵣ → f) = ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

infixr 1 _⟦→⟧_
_⟦→⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
          {b₁ b₂ bᵣ} {B₁ : Set b₁} {B₂ : Set b₂} (Bᵣ : B₁ → B₂ → Set bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → Set _
Aᵣ ⟦→⟧ Bᵣ = ⟦Π⟧ Aᵣ (λ _ → Bᵣ)

infixr 0 _⟦→⟧e_
_⟦→⟧e_ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
          {b₁ b₂ bᵣ} {B₁ : Set b₁} {B₂ : Set b₂} (Bᵣ : B₁ → B₂ → Set bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → Set _
_⟦→⟧e_ Aᵣ Bᵣ = ⟦Π⟧e Aᵣ (λ _ → Bᵣ)

open import Data.Product

open import Data.Unit

record ⟦⊤⟧ (x₁ x₂ : ⊤) : ★ where
  constructor ⟦tt⟧

open import Data.Empty

data ⟦⊥⟧ (x₁ x₂ : ⊥) : ★ where

open import Relation.Nullary

infix 3 ⟦¬⟧_

--⟦¬⟧_ : (⟦★⟧ ⟦→⟧ ⟦★⟧) ¬_ ¬_
⟦¬⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ) → ¬ A₁ → ¬ A₂ → Set _
⟦¬⟧ Aᵣ = Aᵣ ⟦→⟧ ⟦⊥⟧

{-
⟦∃⟧ : {A₁ A₂ : World → ★} (Aᵣ : ∀ {α₁ α₂} → ⟦World⟧ α₁ α₂ → A₁ α₁ → A₂ α₂ → ★)
       (p₁ : ∃ A₁) (f₂ : ∃ A₂) → ★
⟦∃⟧ Aᵣ = λ p₁ p₂ → Σ[ αᵣ ∶ ⟦World⟧ (proj₁ p₁) (proj₁ p₂) ]
                       (Aᵣ αᵣ (proj₂ p₁) (proj₂ p₂))

syntax ⟦∃⟧ (λ αᵣ → f) = ⟦∃⟧[ αᵣ ] f
-}

Pred : ∀ ℓ {a} (A : Set a) → Set (a ⊔ suc ℓ)
Pred ℓ A = A → Set ℓ

⟦Pred⟧ : ∀ {p₁ p₂} pᵣ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ _) (Pred p₁) (Pred p₂)
--⟦Pred⟧ {p₁} {p₂} pᵣ Aᵣ = Aᵣ ⟦→⟧ ⟦★⟧ (p₁ ⊔ p₂ ⊔ pᵣ)
⟦Pred⟧ {p₁} {p₂} pᵣ Aᵣ = λ f₁ f₂ → ∀ {x₁} {x₂} (xᵣ : Aᵣ x₁ x₂) → f₁ x₁ → f₂ x₂ → Set (p₁ ⊔ p₂ ⊔ pᵣ)

open import Relation.Binary

private
  REL′ : ∀ ℓ {a b} → Set a → Set b → Set (a ⊔ b ⊔ suc ℓ)
  REL′ ℓ A B = A → B → Set ℓ

  ⟦REL⟧′ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ ℓ₁ ℓ₂} ℓᵣ →
          (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ {b₁} {b₂} bᵣ ⟦→⟧ ⟦★⟧ _) (REL′ ℓ₁) (REL′ ℓ₂)
  ⟦REL⟧′ ℓᵣ Aᵣ Bᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ ℓᵣ)

⟦REL⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
          {b₁ b₂ bᵣ} {B₁ : Set b₁} {B₂ : Set b₂} (Bᵣ : B₁ → B₂ → Set bᵣ)
          {ℓ₁ ℓ₂} ℓᵣ (∼₁ : REL A₁ B₁ ℓ₁) (∼₂ : REL A₂ B₂ ℓ₂) → Set _
⟦REL⟧ Aᵣ Bᵣ ℓᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ ℓᵣ)

⟦Rel⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
          {ℓ₁ ℓ₂} ℓᵣ (∼₁ : Rel A₁ ℓ₁) (∼₂ : Rel A₂ ℓ₂) → Set _
⟦Rel⟧ Aᵣ ℓᵣ = ⟦REL⟧ Aᵣ Aᵣ ℓᵣ

-- data ⟦Dec⟧ {ℓ₁ ℓ₂ ℓᵣ} {P₁ : Set ℓ₁} {P₂ : Set ℓ₂} (Pᵣ : P₁ → P₂ → Set ℓᵣ) : Dec P₁ → Dec P₂ → Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓᵣ) where
-- data ⟦Dec⟧ {ℓᵣ} : ⟦Pred⟧ (⟦★⟧ ℓᵣ) ℓᵣ Dec Dec where
data ⟦Dec⟧ {ℓ₁ ℓ₂ ℓᵣ} {P₁ : Set ℓ₁} {P₂ : Set ℓ₂} (Pᵣ : P₁ → P₂ → Set ℓᵣ) : ⟦★⟧ (ℓ₁ ⊔ ℓ₂ ⊔ ℓᵣ) (Dec P₁) (Dec P₂) where
  yes : {-∀ {P₁ P₂ Pᵣ}-} {p₁ : P₁} {p₂ : P₂} (pᵣ : Pᵣ p₁ p₂) → ⟦Dec⟧ Pᵣ (yes p₁) (yes p₂)
  no  : {-∀ {P₁ P₂ Pᵣ}-} {¬p₁ : ¬ P₁} {¬p₂ : ¬ P₂} (¬pᵣ : (⟦¬⟧ Pᵣ) ¬p₁ ¬p₂) → ⟦Dec⟧ Pᵣ (no ¬p₁) (no ¬p₂)

--⟦Decidable⟧ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ ℓ₁ ℓ₂ ℓᵣ} → (∀⟨ Aᵣ ∶ ⟦★⟧ {a₁} {a₂} aᵣ ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦★⟧ {b₁ b₂} bᵣ ⟩⟦→⟧ ⟦REL⟧ Aᵣ Bᵣ {ℓ₁} {ℓ₂} ℓᵣ ⟦→⟧ ⟦★⟧ _) Decidable Decidable
⟦Decidable⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
                 {b₁ b₂ bᵣ} {B₁ : Set b₁} {B₂ : Set b₂} (Bᵣ : B₁ → B₂ → Set bᵣ)
                 {ℓ₁ ℓ₂ ℓᵣ} {∼₁ : REL A₁ B₁ ℓ₁} {∼₂ : REL A₂ B₂ ℓ₂} (∼ᵣ : ⟦REL⟧ Aᵣ Bᵣ ℓᵣ ∼₁ ∼₂)
              → Decidable ∼₁ → Decidable ∼₂ → Set _
⟦Decidable⟧ Aᵣ Bᵣ _∼ᵣ_ = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟨ yᵣ ∶ Bᵣ ⟩⟦→⟧ ⟦Dec⟧ (xᵣ ∼ᵣ yᵣ)


Adaptation to minor change in newer Agda

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms (Fig. 1a and 1b).
------------------------------------------------------------------------

-- The syntax of terms depends on the syntax of simple types
-- (because terms are indexed by types in order to rule out
-- ill-typed terms). But we are in the Parametric.* hierarchy, so
-- we don't know the full syntax of types, only how to lift the
-- syntax of base types into the syntax of simple types. This
-- means that we have to be parametric in the syntax of base
-- types, too.
--
-- In such parametric modules that depend on other parametric
-- modules, we first import our dependencies under a more
-- convenient name.

import Parametric.Syntax.Type as Type

-- Then we start the module proper, with parameters for all
-- extension points of our dependencies. Note that here, the
-- "Structure" naming convenion makes some sense, because we can
-- say that we need some "Type.Structure" in order to define the
-- "Term.Structure".

module Parametric.Syntax.Term
    (Base : Type.Structure)
  where

-- Now inside the module, we can open our dependencies with the
-- parameters for their extension points. Again, here the name
-- "Structure" makes some sense, because we can say that we want
-- to access the "Type.Structure" that is induced by Base.

open Type.Structure Base

-- At this point, we have dealt with the extension points of our
-- dependencies, and we have all the definitions about simple
-- types, contexts, variables, and variable sets in scope that we
-- provided in Parametric.Syntax.Type. Now we can proceed to
-- define our own extension point, following the pattern
-- explained in Parametric.Syntax.Type.

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function using (_∘_)
open import Data.Unit
open import Data.Sum

-- Our extension point is a set of primitives, indexed by the
-- types of their arguments and their return type. In general, if
-- you're confused about what an extension point means, you might
-- want to open the corresponding module in the Nehemiah
-- hierarchy to see how it is implemented in the example
-- plugin. In this case, that would be the Nehemiah.Syntax.Term
-- module.

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where

  -- Declarations of Term and Terms to enable mutual recursion.
  --
  -- Note that terms are indexed by contexts and types. In the
  -- paper, we define the abstract syntax of terms in Fig 1a and
  -- then define a type system in Fig 1b. All lemmas and theorems
  -- then explicitly specify that they only hold for well-typed
  -- terms. Here, we use the indices to define a type that can
  -- only hold well-typed terms in the first place.
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  open import Base.Data.DependentList public

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  Terms : Context → Context → Set
  Terms Γ = DependentList (Term Γ)

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    -- constants aka. primitives can only occur fully applied.
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      (args : Terms Γ Σ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Free variables
  FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
  FV-terms : ∀ {Σ Γ} → Terms Γ Σ → Vars Γ

  FV (const ι ts) = FV-terms ts
  FV (var x) = singleton x
  FV (abs t) = tail (FV t)
  FV (app s t) = FV s ∪ FV t

  FV-terms ∅ = none
  FV-terms (t • ts) = FV t ∪ FV-terms ts

  closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ none) ⊎ ⊤
  closed? t = empty? (FV t)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ

  weaken-terms : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

  weaken Γ₁≼Γ₂ (const c ts) = const c (weaken-terms Γ₁≼Γ₂ ts)
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  weaken-terms Γ₁≼Γ₂ ∅ = ∅
  weaken-terms Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weaken-terms Γ₁≼Γ₂ ts

  -- Specialized weakening
  weaken₁ : ∀ {Γ σ τ} →
    Term Γ τ → Term (σ • Γ) τ
  weaken₁ t = weaken (drop _ • ≼-refl) t

  weaken₂ : ∀ {Γ α β τ} →
    Term Γ τ → Term (α • β • Γ) τ
  weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

  weaken₃ : ∀ {Γ α β γ τ} →
    Term Γ τ → Term (α • β • γ • Γ) τ
  weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

  UncurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  UncurriedTermConstructor Γ Σ τ = Terms Γ Σ → Term Γ τ

  uncurriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → UncurriedTermConstructor Γ Σ τ
  uncurriedConst constant = const constant

  CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
  CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

  curryTermConstructor : ∀ {Σ Γ τ} → UncurriedTermConstructor Γ Σ τ → CurriedTermConstructor Γ Σ τ
  curryTermConstructor {∅} k = k ∅
  curryTermConstructor {τ • Σ} k = λ t → curryTermConstructor (λ ts → k (t • ts))

  curriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
  curriedConst constant = curryTermConstructor (uncurriedConst constant)

  -- HOAS-like smart constructors for lambdas, for different arities.

  -- We could also write this:
  module NamespaceForBadAbs₁ where
    abs₁′ :
      ∀ {Γ τ₁ τ} →
        (Term (τ₁ • Γ) τ₁ → Term (τ₁ • Γ) τ) →
        (Term Γ (τ₁ ⇒ τ))
    abs₁′ {Γ} {τ₁} = λ f → abs (f (var this))

  -- However, this is less general, and it is harder to reuse. In particular,
  -- this cannot be used inside abs₂, ..., abs₆.

  -- Now, let's write other variants with a loop!
  open import Data.Vec using (_∷_; []; Vec; foldr; [_]; reverse)
  open import Data.Nat
  module AbsNHelpers where
    open import Function
    hoasArgType : ∀ {n} → Context → Type → Vec Type n → Set
    hoasArgType Γ τres = foldr _ (λ a b → a → b) (Term Γ τres) ∘ Data.Vec.map (Term Γ)
    -- That is,
    --hoasArgType Γ τres [] = Term Γ τres
    --hoasArgType Γ τres (τ₀ ∷ τs) = Term Γ τ₀ → hoasArgType Γ τres τs

    hoasResType : ∀ {n} → Type → Vec Type n → Type
    hoasResType τres = foldr _ _⇒_ τres

    absNType : {n : ℕ} → Vec _ n → Set
    absNType τs = ∀ {Γ τres} →
      (f : ∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → hoasArgType Γ′ τres τs) →
      Term Γ (hoasResType τres τs)

    drop-≼-l : ∀ {Γ Γ′ τ} → (τ • Γ ≼ Γ′) → Γ ≼ Γ′
    drop-≼-l Γ′≼Γ′₁ = ≼-trans (drop _ • ≼-refl) Γ′≼Γ′₁

    absN : {n : ℕ} → (τs : Vec _ n) → absNType τs
    absN []        f = f {Γ≼Γ′ = ≼-refl}
    absN (τ₁ ∷ τs) f =
      abs (absN τs
        (λ {_} {Γ′≼Γ′₁} →
          f
            {Γ≼Γ′ = drop-≼-l Γ′≼Γ′₁}
            (weaken Γ′≼Γ′₁ (var this))))

    -- Using a similar trick, we can declare absV (where V stands for variadic),
    -- which takes the N implicit type arguments individually, collects them and
    -- passes them on to absN. This is inspired by the example in the Agda 2.4.0
    -- release notes about support for varying arity. To collect them, we need
    -- to use an accumulator argument.

    absVType : ∀ n {m} (τs : Vec Type m) → Set
    absVType zero       τs = absNType (reverse τs)
    absVType (suc n) τs = {τ₁ : Type} → absVType n (τ₁ ∷ τs)

    absVAux : ∀ {m} → (τs : Vec Type m) → ∀ n → absVType n τs
    absVAux τs zero    = absN (reverse τs)
    -- (Support for varying arity does not work here, so {τ₁} must be bound in
    -- the right-hand side).
    absVAux τs (suc n) {τ₁} = absVAux (τ₁ ∷ τs) n --λ {τ₁} → absVAux (τ₁ ∷ τs) n

    -- "Initialize" accumulator to the empty list.
    absV = absVAux []
    -- We could maybe define absV directly, without going through absN, by
    -- making hoasArgType and hoasResType also variadic, but I don't see a clear
    -- advantage.

  open AbsNHelpers using (absV) public

  {-
  Example types:
  absV 1:
    {τ₁ : Type} {Γ : Context} {τres : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τres) →
      Term Γ (τ₁ ⇒ τres)

  absV 2:
    {τ₁ : Type} {τ₁ = τ₂ : Type} {Γ : Context} {τres : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} →
       Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τres) →
      Term Γ (τ₁ ⇒ τ₂ ⇒ τres)

  -}

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms (Fig. 1a and 1b).
------------------------------------------------------------------------

-- The syntax of terms depends on the syntax of simple types
-- (because terms are indexed by types in order to rule out
-- ill-typed terms). But we are in the Parametric.* hierarchy, so
-- we don't know the full syntax of types, only how to lift the
-- syntax of base types into the syntax of simple types. This
-- means that we have to be parametric in the syntax of base
-- types, too.
--
-- In such parametric modules that depend on other parametric
-- modules, we first import our dependencies under a more
-- convenient name.

import Parametric.Syntax.Type as Type

-- Then we start the module proper, with parameters for all
-- extension points of our dependencies. Note that here, the
-- "Structure" naming convenion makes some sense, because we can
-- say that we need some "Type.Structure" in order to define the
-- "Term.Structure".

module Parametric.Syntax.Term
    (Base : Type.Structure)
  where

-- Now inside the module, we can open our dependencies with the
-- parameters for their extension points. Again, here the name
-- "Structure" makes some sense, because we can say that we want
-- to access the "Type.Structure" that is induced by Base.

open Type.Structure Base

-- At this point, we have dealt with the extension points of our
-- dependencies, and we have all the definitions about simple
-- types, contexts, variables, and variable sets in scope that we
-- provided in Parametric.Syntax.Type. Now we can proceed to
-- define our own extension point, following the pattern
-- explained in Parametric.Syntax.Type.

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function using (_∘_)
open import Data.Unit
open import Data.Sum

-- Our extension point is a set of primitives, indexed by the
-- types of their arguments and their return type. In general, if
-- you're confused about what an extension point means, you might
-- want to open the corresponding module in the Nehemiah
-- hierarchy to see how it is implemented in the example
-- plugin. In this case, that would be the Nehemiah.Syntax.Term
-- module.

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where

  -- Declarations of Term and Terms to enable mutual recursion.
  --
  -- Note that terms are indexed by contexts and types. In the
  -- paper, we define the abstract syntax of terms in Fig 1a and
  -- then define a type system in Fig 1b. All lemmas and theorems
  -- then explicitly specify that they only hold for well-typed
  -- terms. Here, we use the indices to define a type that can
  -- only hold well-typed terms in the first place.
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  open import Base.Data.DependentList public

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  Terms : Context → Context → Set
  Terms Γ = DependentList (Term Γ)

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    -- constants aka. primitives can only occur fully applied.
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      (args : Terms Γ Σ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Free variables
  FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
  FV-terms : ∀ {Σ Γ} → Terms Γ Σ → Vars Γ

  FV (const ι ts) = FV-terms ts
  FV (var x) = singleton x
  FV (abs t) = tail (FV t)
  FV (app s t) = FV s ∪ FV t

  FV-terms ∅ = none
  FV-terms (t • ts) = FV t ∪ FV-terms ts

  closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ none) ⊎ ⊤
  closed? t = empty? (FV t)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ

  weaken-terms : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

  weaken Γ₁≼Γ₂ (const c ts) = const c (weaken-terms Γ₁≼Γ₂ ts)
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  weaken-terms Γ₁≼Γ₂ ∅ = ∅
  weaken-terms Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weaken-terms Γ₁≼Γ₂ ts

  -- Specialized weakening
  weaken₁ : ∀ {Γ σ τ} →
    Term Γ τ → Term (σ • Γ) τ
  weaken₁ t = weaken (drop _ • ≼-refl) t

  weaken₂ : ∀ {Γ α β τ} →
    Term Γ τ → Term (α • β • Γ) τ
  weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

  weaken₃ : ∀ {Γ α β γ τ} →
    Term Γ τ → Term (α • β • γ • Γ) τ
  weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

  UncurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  UncurriedTermConstructor Γ Σ τ = Terms Γ Σ → Term Γ τ

  uncurriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → UncurriedTermConstructor Γ Σ τ
  uncurriedConst constant = const constant

  CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
  CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

  curryTermConstructor : ∀ {Σ Γ τ} → UncurriedTermConstructor Γ Σ τ → CurriedTermConstructor Γ Σ τ
  curryTermConstructor {∅} k = k ∅
  curryTermConstructor {τ • Σ} k = λ t → curryTermConstructor (λ ts → k (t • ts))

  curriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
  curriedConst constant = curryTermConstructor (uncurriedConst constant)

  -- HOAS-like smart constructors for lambdas, for different arities.

  -- We could also write this:
  module NamespaceForBadAbs₁ where
    abs₁′ :
      ∀ {Γ τ₁ τ} →
        (Term (τ₁ • Γ) τ₁ → Term (τ₁ • Γ) τ) →
        (Term Γ (τ₁ ⇒ τ))
    abs₁′ {Γ} {τ₁} = λ f → abs (f (var this))

  -- However, this is less general, and it is harder to reuse. In particular,
  -- this cannot be used inside abs₂, ..., abs₆.

  -- Now, let's write other variants with a loop!
  open import Data.Vec using (_∷_; []; Vec; foldr; [_]; reverse)
  open import Data.Nat
  module AbsNHelpers where
    open import Function
    hoasArgType : ∀ {n} → Context → Type → Vec Type n → Set
    hoasArgType Γ τres = foldr _ (λ a b → a → b) (Term Γ τres) ∘ Data.Vec.map (Term Γ)
    -- That is,
    --hoasArgType Γ τres [] = Term Γ τres
    --hoasArgType Γ τres (τ₀ ∷ τs) = Term Γ τ₀ → hoasArgType Γ τres τs

    hoasResType : ∀ {n} → Type → Vec Type n → Type
    hoasResType τres = foldr _ _⇒_ τres

    absNType : {n : ℕ} → Vec _ n → Set
    absNType τs = ∀ {Γ τres} →
      (f : ∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → hoasArgType Γ′ τres τs) →
      Term Γ (hoasResType τres τs)

    drop-≼-l : ∀ {Γ Γ′ τ} → (τ • Γ ≼ Γ′) → Γ ≼ Γ′
    drop-≼-l Γ′≼Γ′₁ = ≼-trans (drop _ • ≼-refl) Γ′≼Γ′₁

    absN : {n : ℕ} → (τs : Vec _ n) → absNType τs
    absN []        f = f {Γ≼Γ′ = ≼-refl}
    absN (τ₁ ∷ τs) f =
      abs (absN τs
        (λ {_} {Γ′≼Γ′₁} →
          f
            {Γ≼Γ′ = drop-≼-l Γ′≼Γ′₁}
            (weaken Γ′≼Γ′₁ (var this))))

    -- Using a similar trick, we can declare absV (where V stands for variadic),
    -- which takes the N implicit type arguments individually, collects them and
    -- passes them on to absN. This is inspired by the example in the Agda 2.4.0
    -- release notes about support for varying arity. To collect them, we need
    -- to use an accumulator argument.

    absVType : ∀ n {m} (τs : Vec Type m) → Set
    absVType zero       τs = absNType (reverse τs)
    absVType (suc n) τs = {τ₁ : Type} → absVType n (τ₁ ∷ τs)

    absVAux : ∀ {m} → (τs : Vec Type m) → ∀ n → absVType n τs
    absVAux τs zero    = absN (reverse τs)
    -- (Support for varying arity does not work here, so {τ₁} must be bound in
    -- the right-hand side).
    absVAux τs (suc n) = λ {τ₁} → absVAux (τ₁ ∷ τs) n

    -- "Initialize" accumulator to the empty list.
    absV = absVAux []
    -- We could maybe define absV directly, without going through absN, by
    -- making hoasArgType and hoasResType also variadic, but I don't see a clear
    -- advantage.

  open AbsNHelpers using (absV) public

  {-
  Example types:
  absV 1:
    {τ₁ : Type} {Γ : Context} {τres : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τres) →
      Term Γ (τ₁ ⇒ τres)

  absV 2:
    {τ₁ : Type} {τ₁ = τ₂ : Type} {Γ : Context} {τres : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} →
       Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τres) →
      Term Γ (τ₁ ⇒ τ₂ ⇒ τres)

  -}


Add commented out attempt at eval-strengthen

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- But to betray the eventual goal, I can also relate integer values with a
-- change in the relation witness. That was a completely local change. But that
-- might also be because we only have few primitives.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

-- CHEATS:
-- "Fuctional big-step semantics" requires an external termination proof for the
-- semantics. There it is also mechanized, here it isn't. Worse, the same
-- termination problem affects some lemmas about the semantics.

module Thesis.FunBigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value.

-- WARNING: ISAC's big-step semantics produces a step count as "output". But
-- that would not help Agda establish termination. That's only a problem for a
-- functional big-step semantics, not for a relational semantics.
--
-- So, instead, I tried to use a sort of writer monad: the interpreter gets fuel
-- and returns the remaining fuel. That's the same trick as in "functional
-- big-step semantics". That *makes* the function terminating, even though Agda
-- cannot see this because it does not know that the returned fuel is no bigger.

-- Since we focus for now on STLC, unlike that
-- paper, we could avoid error values because we keep types.
--
-- One could drop types and add error values instead.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → ErrVal τ
  Error : ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v) n

{-# TERMINATING #-}
eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
eval (app s t) ρ (suc n) = (eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)) n

eval-const-dec : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 →  n1 ≤ n0
eval-const-dec (lit v) n0 .n0 refl = ≤-refl

{-# TERMINATING #-}
eval-dec : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → n1 ≤ n0
eval-dec (const c) ρ v n0 n1 eq = eval-const-dec c n0 n1 eq
eval-dec (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = ≤-refl
eval-dec (abs t) ρ .(closure t ρ) n0 .n0 refl = ≤-refl
eval-dec (app s t) ρ v zero n1 ()
eval-dec (app s t) ρ v (suc n0) n3 eq  with eval s ρ n0 | inspect (eval s ρ) n0
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv sn1 | [ seq ] with eval t ρ sn1 | inspect (eval t ρ) sn1
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv@(closure st sρ) sn1 | [ seq ] | (Done tv tn2) | [ teq ] = ≤-step (≤-trans (≤-trans (eval-dec st _ _ _ _ eq) (eval-dec t _ _ _ _ teq)) (eval-dec s _ _ _ _ seq))
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | Error | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | TimeOut | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Error | [ seq ]
eval-dec (app s t) ρ v (suc n0) n3 () | TimeOut | [ seq ]

eval-const-mono : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 → evalConst c (suc n0) ≡ Done v (suc n1)
eval-const-mono (lit v) n0 .n0 refl = refl

-- ARGH
{-# TERMINATING #-}
eval-mono : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (suc n0) ≡ Done v (suc n1)
eval-mono (const c) ρ v n0 n1 eq = eval-const-mono c n0 n1 eq
eval-mono (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
eval-mono (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
eval-mono (app s t) ρ v zero n1 ()
eval-mono (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
eval-mono (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
eval-mono (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-mono t₁ (tv • ρ₁) v n2 n3 eq
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ]
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ]
eval-mono (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
eval-mono (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]

eval-adjust-plus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (d + n0) ≡ Done v (d + n1)
eval-adjust-plus zero t ρ v n0 n1 eq = eq
eval-adjust-plus (suc d) t ρ v n0 n1 eq = eval-mono t ρ v (d + n0) (d + n1) (eval-adjust-plus d t ρ v n0 n1 eq)

eval-const-strengthen : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c (suc n0) ≡ Done v (suc n1) → evalConst c n0 ≡ Done v n1
eval-const-strengthen (lit v) n0 .n0 refl = refl

-- I started trying to prove eval-strengthen, which I appeal to informally
-- below, but I gave up. I still guess the lemma is true but proving it looks
-- too painful to bother.

-- Without this lemma, I can't fully prove that this logical relation is
-- equivalent to the original one.
-- But this one works (well, at least up to the fundamental theorem, haven't
-- attempted other lemmas), so it should be good enough.

-- eval-mono-err : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ n → eval t ρ n ≡ Error → eval t ρ (suc n) ≡ Error
-- eval-mono-err (const (lit x)) ρ zero eq = {!!}
-- eval-mono-err (const (lit x)) ρ (suc n) eq = {!!}
-- eval-mono-err (var x) ρ n eq = {!!}
-- eval-mono-err (app t t₁) ρ n eq = {!!}
-- eval-mono-err (abs t) ρ n eq = {!!}

-- -- eval t ρ (suc n0) ≡ Done v (suc n1) → eval t ρ n0 ≡ Done v n
-- eval-aux : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ n → (Σ[ res0 ∈ ErrVal τ ] eval t ρ n ≡ res0) × (Σ[ resS ∈ ErrVal τ ] eval t ρ n ≡ resS)
-- eval-aux t ρ n with
--   eval t ρ n | inspect (eval t ρ) n |
--   eval t ρ (suc n) | inspect (eval t ρ) (suc n)
-- eval-aux t ρ n | res0 | [ eq0 ] | (Done v1 n1) | [ eq1 ] = {!!}
-- eval-aux t ρ n | res0 | [ eq0 ] | Error | [ eq1 ] = {!!}
-- eval-aux t ρ n | Done v n1 | [ eq0 ] | TimeOut | [ eq1 ] = {!!}
-- eval-aux t ρ n | Error | [ eq0 ] | TimeOut | [ eq1 ] = {!!}
-- eval-aux t ρ n | TimeOut | [ eq0 ] | TimeOut | [ eq1 ] = (TimeOut , refl) , (TimeOut , refl)

-- {-# TERMINATING #-}
-- eval-strengthen : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ (suc n0) ≡ Done v (suc n1) → eval t ρ n0 ≡ Done v n1
-- eval-strengthen (const c) ρ v n0 n1 eq = eval-const-strengthen c n0 n1 eq
-- eval-strengthen (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
-- eval-strengthen (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
-- eval-strengthen (app s t) ρ v zero n1 eq with eval s ρ 0 | inspect (eval s ρ) 0
-- eval-strengthen (app s t) ρ v zero n1 eq | Done sv sn1 | [ seq ] with eval-dec s ρ sv 0 sn1 seq
-- eval-strengthen (app s t) ρ v zero n1 eq | Done sv .0 | [ seq ] | z≤n with eval t ρ 0 | inspect (eval t ρ) 0
-- eval-strengthen (app s t) ρ v zero n1 eq | Done sv _ | [ seq ] | z≤n | Done tv tn1 | [ teq ]  with eval-dec t ρ tv 0 tn1 teq
-- eval-strengthen (app s t) ρ v zero n1 eq | Done (closure st sρ) _ | [ seq ] | z≤n | (Done tv .0) | [ teq ] | z≤n with eval-dec st _ v 0 (suc n1) eq
-- eval-strengthen (app s t) ρ v zero n1 eq | Done (closure st sρ) _ | [ seq ] | z≤n | (Done tv _) | [ teq ] | z≤n | ()
-- eval-strengthen (app s t) ρ v zero n1 () | Done sv _ | [ seq ] | z≤n | Error | [ teq ]
-- eval-strengthen (app s t) ρ v zero n1 () | Done sv _ | [ seq ] | z≤n | TimeOut | [ teq ]
-- eval-strengthen (app s t) ρ v zero n1 () | Error | [ seq ]
-- eval-strengthen (app s t) ρ v zero n1 () | TimeOut | [ seq ]
-- -- eval-dec s ρ
-- --  {!eval-dec s ρ ? (suc zero) (suc n1) !}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ (suc n0) | inspect (eval s ρ) (suc n0)
-- -- eval-strengthen (app s t) ρ v₁ (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ n0 = {!eval-strengthen s ρ v n0 n1 seq !}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-strengthen t₁ (tv • ρ₁) v n2 n3 eq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | Error | [ seq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | TimeOut | [ seq ] = {!!}

-- eval-adjust-minus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ {ρ v} n0 n1 → eval t ρ (d + n0) ≡ Done v (d + n1) → eval t ρ n0 ≡ Done v n1
-- eval-adjust-minus zero t n0 n1 eq = eq
-- eval-adjust-minus (suc d) t n0 n1 eq = eval-adjust-minus d t n0 n1 (eval-strengthen t _ _ (d + n0) (d + n1) eq)

import Data.Integer as I
open I using (ℤ)
mutual
  -- This is not the same definition of relT, but it is equivalent.
  relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
  -- This equation is a lemma in the original definition.
  relT {τ} t1 t2 ρ1 ρ2 zero = ⊤
  -- To compare this definition, note that the original k is suc n here.
  relT {τ} t1 t2 ρ1 ρ2 (suc n) =
    (v1 : Val τ) →
    -- Originally we have 0 ≤ j < k, so j < suc n, so k - j = suc n - j.
    -- It follows that 0 < k - j ≤ k, hence suc n - j ≤ suc n, or n - j ≤ n.
    -- Here, instead of binding j we bind n-j = n - j, require n - j ≤ n, and
    -- use suc n-j instead of k - j.
    ∀ n-j (n-j≤n : n-j ≤ n) →
    -- The next assumption is important. This still says that evaluation consumes j steps.
    -- Since j ≤ n, it is OK to start evaluation with n steps.
    -- Starting with (suc n) and getting suc n-j is equivalent, per eval-mono
    -- and eval-strengthen. But in practice this version is easier to use.
    (eq : eval t1 ρ1 n ≡ Done v1 n-j) →
    Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] eval t2 ρ2 n2 ≡ Done v2 0 × relV τ v1 v2 (suc n-j)
    -- Here, computing t2 is allowed to take an unbounded number of steps. Having to write a number at all is annoying.

  relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
  -- Show the proof still goes through if we relate clearly different values by
  -- inserting changes in the relation.
  -- There's no syntax to produce such changes, but you can add changes to the
  -- environment.
  relV nat (intV v1) (intV v2) n = Σ[ dv ∈ ℤ ] dv I.+ (I.+ v1) ≡ (I.+ v2)
  relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) n =
    ∀ (k : ℕ) (k≤n : k < n) v1 v2 →
    relV σ v1 v2 k →
    relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
  -- Above, in the conclusion, I'm not relating app (closure t1 ρ1) v1 with app
  -- (closure t2 ρ2) v2 (or some encoding of that that actually works), but the
  -- result of taking a step from that configuration. That is important, because
  -- both Pitts' "Step-Indexed Biorthogonality: a Tutorial Example" and
  -- "Imperative Self-Adjusting Computation" do the same thing (and point out it's
  -- important).

  -- Relate λ x → 0 and λ x → 1 at any step count.
  example1 : ∀ n → relV (nat ⇒ nat) (closure (const (lit 0)) ∅) (closure (const (lit 1)) ∅) n
  example1 n zero k≤n v1 v2 x = tt
  example1 n (suc k) k≤n v1 v2 x .(intV 0) .k n-j≤n refl = intV 1 , 0 , refl , (I.+ 1 , refl)

  -- Relate λ x → 0 and λ x → x at any step count.
  example2 : ∀ n → relV (nat ⇒ nat) (closure (const (lit 0)) ∅) (closure (var this) ∅) n
  example2 n zero k≤n v1 v2 x = tt
  example2 n (suc k) k≤n (intV v1) (intV v2) x .(intV 0) .k n-j≤n refl = intV v2 , 0 , refl , (I.+ v2 , cong I.+_ (+-right-identity v2))

relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono m n m≤n nat (intV v1) (intV v2) vv = vv
relV-mono m n m≤n (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) ff k k≤m = ff k (≤-trans k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero ρ1 ρ2 ρρ = tt
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 .n n-j≤n refl =  v2 , zero , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

-- relV-apply : ∀ {σ τ Γ} (s : Term Γ (σ ⇒ τ)) t v1 ρ2 n-j
--   n1 sv1 sv2
--   (svv : relV (σ ⇒ τ) sv1 sv2 n1)
--   n2 tv1 tv2
--   (tvv : relV σ tv1 tv2 (suc (suc n2)))
--   (eq : apply sv1 tv1 n2 ≡ Done v1 n-j) →
--   -- (tvv)
--   -- (eqv1)
--   Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] Σ[ n3 ∈ ℕ ] eval (app s t) ρ2 n2 ≡ Done v2 n3 × relV τ v1 v2 (suc n-j)
-- relV-apply s t v1 ρ n-j n1 (closure st ρ1) (closure st2 ρ2) svv n2 tv1 tv2 tvv eq = {! !}
-- -- relV-apply s t v1 ρ2 n-j _ _ sv2 svv _ tv1 tv2 tvv eq

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ = tt
fundamental (var x) (suc n) ρ1 ρ2 ρρ = fundamentalV x (suc n) ρ1 ρ2 ρρ
fundamental (const (lit v)) (suc n) ρ1 ρ2 ρρ .(intV v) .n n-j≤n refl = intV v , zero , refl , I.+ zero , refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ .(closure t ρ1) .n n-j≤n refl =  closure t ρ2 , zero , refl , (λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k (suc n) (lt1 k≤n) _ _ _ ρρ))
fundamental (app s t) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq with eval s ρ1 n | inspect (eval s ρ1) n
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done sv1 n1 | [ s1eq ] with eval-dec s _ _ n n1 s1eq | eval t ρ1 n1 | inspect (eval t ρ1) n1
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done (closure st1 sρ1) n1 | [ s1eq ] | n1≤n | Done tv1 n2 | [ t1eq ] with eval-dec t _ _ n1 n2 t1eq
... | n2≤n1 with fundamental s (suc (suc n)) ρ1 ρ2 ρρ (closure st1 sρ1) (suc n1) (s≤s n1≤n) (eval-mono s ρ1 (closure st1 sρ1) n n1 s1eq)
  | fundamental t (suc (suc n1)) ρ1 ρ2 (relρ-mono (suc (suc n1)) (suc (suc n)) (s≤s (s≤s n1≤n)) _ _ _ ρρ) tv1 (suc n2) (s≤s n2≤n1) (eval-mono t ρ1 tv1 n1 n2 t1eq)
... | sv2@(closure st2 sρ2) , sn3 , s2eq , svv | tv2 , tn3 , t2eq , tvv with svv (suc n2) (s≤s (s≤s n2≤n1)) tv1 tv2 (relV-mono _ _ (s≤s (n≤1+n n2)) _ _ _ tvv ) v1 n-j (eval-dec st1 _ _ _ _ eq) eq
... | v2 , n3 , eq2 , vv = v2 , suc (sn3 + (tn3 + n3)) , comp , vv
  where
    s2eq-adj : eval s ρ2 (sn3 + (tn3 + n3)) ≡ Done (closure st2 sρ2) (tn3 + n3)
    s2eq-adj rewrite +-comm sn3 (tn3 + n3)| cong (Done (closure st2 sρ2)) (sym (+-right-identity (tn3 + n3))) = eval-adjust-plus (tn3 + n3) s _ sv2 _ _ s2eq
    t2eq-adj : eval t ρ2 (tn3 + n3) ≡ Done tv2 n3
    t2eq-adj rewrite +-comm tn3 n3 | cong (Done tv2) (sym (+-right-identity n3)) = eval-adjust-plus n3 t _ tv2 _ _ t2eq

    comp : (eval s ρ2 >>= (λ sv → eval t ρ2 >>= apply sv))
      (sn3 + (tn3 + n3))
      ≡ Done v2 0
    comp rewrite s2eq-adj | t2eq-adj = eq2

fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | Error | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | TimeOut | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Error | [ s1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | TimeOut | [ s1eq ]

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- But to betray the eventual goal, I can also relate integer values with a
-- change in the relation witness. That was a completely local change. But that
-- might also be because we only have few primitives.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

-- CHEATS:
-- "Fuctional big-step semantics" requires an external termination proof for the
-- semantics. There it is also mechanized, here it isn't. Worse, the same
-- termination problem affects some lemmas about the semantics.

module Thesis.FunBigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value.

-- WARNING: ISAC's big-step semantics produces a step count as "output". But
-- that would not help Agda establish termination. That's only a problem for a
-- functional big-step semantics, not for a relational semantics.
--
-- So, instead, I tried to use a sort of writer monad: the interpreter gets fuel
-- and returns the remaining fuel. That's the same trick as in "functional
-- big-step semantics". That *makes* the function terminating, even though Agda
-- cannot see this because it does not know that the returned fuel is no bigger.

-- Since we focus for now on STLC, unlike that
-- paper, we could avoid error values because we keep types.
--
-- One could drop types and add error values instead.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → ErrVal τ
  Error : ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v) n

{-# TERMINATING #-}
eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
eval (app s t) ρ (suc n) = (eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)) n

eval-const-dec : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 →  n1 ≤ n0
eval-const-dec (lit v) n0 .n0 refl = ≤-refl

{-# TERMINATING #-}
eval-dec : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → n1 ≤ n0
eval-dec (const c) ρ v n0 n1 eq = eval-const-dec c n0 n1 eq
eval-dec (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = ≤-refl
eval-dec (abs t) ρ .(closure t ρ) n0 .n0 refl = ≤-refl
eval-dec (app s t) ρ v zero n1 ()
eval-dec (app s t) ρ v (suc n0) n3 eq  with eval s ρ n0 | inspect (eval s ρ) n0
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv sn1 | [ seq ] with eval t ρ sn1 | inspect (eval t ρ) sn1
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv@(closure st sρ) sn1 | [ seq ] | (Done tv tn2) | [ teq ] = ≤-step (≤-trans (≤-trans (eval-dec st _ _ _ _ eq) (eval-dec t _ _ _ _ teq)) (eval-dec s _ _ _ _ seq))
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | Error | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | TimeOut | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Error | [ seq ]
eval-dec (app s t) ρ v (suc n0) n3 () | TimeOut | [ seq ]

eval-const-mono : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 → evalConst c (suc n0) ≡ Done v (suc n1)
eval-const-mono (lit v) n0 .n0 refl = refl

-- ARGH
{-# TERMINATING #-}
eval-mono : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (suc n0) ≡ Done v (suc n1)
eval-mono (const c) ρ v n0 n1 eq = eval-const-mono c n0 n1 eq
eval-mono (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
eval-mono (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
eval-mono (app s t) ρ v zero n1 ()
eval-mono (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
eval-mono (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
eval-mono (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-mono t₁ (tv • ρ₁) v n2 n3 eq
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ]
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ]
eval-mono (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
eval-mono (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]

eval-adjust-plus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (d + n0) ≡ Done v (d + n1)
eval-adjust-plus zero t ρ v n0 n1 eq = eq
eval-adjust-plus (suc d) t ρ v n0 n1 eq = eval-mono t ρ v (d + n0) (d + n1) (eval-adjust-plus d t ρ v n0 n1 eq)

eval-const-strengthen : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c (suc n0) ≡ Done v (suc n1) → evalConst c n0 ≡ Done v n1
eval-const-strengthen (lit v) n0 .n0 refl = refl

-- {-# TERMINATING #-}
-- eval-strengthen : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ (suc n0) ≡ Done v (suc n1) → eval t ρ n0 ≡ Done v n1
-- eval-strengthen (const c) ρ v n0 n1 eq = eval-const-strengthen c n0 n1 eq
-- eval-strengthen (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
-- eval-strengthen (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
-- eval-strengthen (app s t) ρ v zero n1 eq = {!!}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ (suc n0) | inspect (eval s ρ) (suc n0)
-- -- eval-strengthen (app s t) ρ v₁ (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ n0 = {!eval-strengthen s ρ v n0 n1 seq !}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-strengthen t₁ (tv • ρ₁) v n2 n3 eq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | Error | [ seq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | TimeOut | [ seq ] = {!!}

-- eval-adjust-minus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ {ρ v} n0 n1 → eval t ρ (d + n0) ≡ Done v (d + n1) → eval t ρ n0 ≡ Done v n1
-- eval-adjust-minus zero t n0 n1 eq = eq
-- eval-adjust-minus (suc d) t n0 n1 eq = eval-adjust-minus d t n0 n1 (eval-strengthen t _ _ (d + n0) (d + n1) eq)

import Data.Integer as I
open I using (ℤ)
mutual
  -- This is not the same definition of relT, but it is equivalent.
  relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
  -- This equation is a lemma in the original definition.
  relT {τ} t1 t2 ρ1 ρ2 zero = ⊤
  -- To compare this definition, note that the original k is suc n here.
  relT {τ} t1 t2 ρ1 ρ2 (suc n) =
    (v1 : Val τ) →
    -- Originally we have 0 ≤ j < k, so j < suc n, so k - j = suc n - j.
    -- It follows that 0 < k - j ≤ k, hence suc n - j ≤ suc n, or n - j ≤ n.
    -- Here, instead of binding j we bind n-j = n - j, require n - j ≤ n, and
    -- use suc n-j instead of k - j.
    ∀ n-j (n-j≤n : n-j ≤ n) →
    -- The next assumption is important. This still says that evaluation consumes j steps.
    -- Since j ≤ n, it is OK to start evaluation with n steps.
    -- Starting with (suc n) and getting suc n-j is equivalent, per eval-mono
    -- and eval-strengthen. But in practice this version is easier to use.
    (eq : eval t1 ρ1 n ≡ Done v1 n-j) →
    Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] eval t2 ρ2 n2 ≡ Done v2 0 × relV τ v1 v2 (suc n-j)
    -- Here, computing t2 is allowed to take an unbounded number of steps. Having to write a number at all is annoying.

  relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
  -- Show the proof still goes through if we relate clearly different values by
  -- inserting changes in the relation.
  -- There's no syntax to produce such changes, but you can add changes to the
  -- environment.
  relV nat (intV v1) (intV v2) n = Σ[ dv ∈ ℤ ] dv I.+ (I.+ v1) ≡ (I.+ v2)
  relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) n =
    ∀ (k : ℕ) (k≤n : k < n) v1 v2 →
    relV σ v1 v2 k →
    relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
  -- Above, in the conclusion, I'm not relating app (closure t1 ρ1) v1 with app
  -- (closure t2 ρ2) v2 (or some encoding of that that actually works), but the
  -- result of taking a step from that configuration. That is important, because
  -- both Pitts' "Step-Indexed Biorthogonality: a Tutorial Example" and
  -- "Imperative Self-Adjusting Computation" do the same thing (and point out it's
  -- important).

  -- Relate λ x → 0 and λ x → 1 at any step count.
  example1 : ∀ n → relV (nat ⇒ nat) (closure (const (lit 0)) ∅) (closure (const (lit 1)) ∅) n
  example1 n zero k≤n v1 v2 x = tt
  example1 n (suc k) k≤n v1 v2 x .(intV 0) .k n-j≤n refl = intV 1 , 0 , refl , (I.+ 1 , refl)

  -- Relate λ x → 0 and λ x → x at any step count.
  example2 : ∀ n → relV (nat ⇒ nat) (closure (const (lit 0)) ∅) (closure (var this) ∅) n
  example2 n zero k≤n v1 v2 x = tt
  example2 n (suc k) k≤n (intV v1) (intV v2) x .(intV 0) .k n-j≤n refl = intV v2 , 0 , refl , (I.+ v2 , cong I.+_ (+-right-identity v2))

relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono m n m≤n nat (intV v1) (intV v2) vv = vv
relV-mono m n m≤n (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) ff k k≤m = ff k (≤-trans k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero ρ1 ρ2 ρρ = tt
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 .n n-j≤n refl =  v2 , zero , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

-- relV-apply : ∀ {σ τ Γ} (s : Term Γ (σ ⇒ τ)) t v1 ρ2 n-j
--   n1 sv1 sv2
--   (svv : relV (σ ⇒ τ) sv1 sv2 n1)
--   n2 tv1 tv2
--   (tvv : relV σ tv1 tv2 (suc (suc n2)))
--   (eq : apply sv1 tv1 n2 ≡ Done v1 n-j) →
--   -- (tvv)
--   -- (eqv1)
--   Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] Σ[ n3 ∈ ℕ ] eval (app s t) ρ2 n2 ≡ Done v2 n3 × relV τ v1 v2 (suc n-j)
-- relV-apply s t v1 ρ n-j n1 (closure st ρ1) (closure st2 ρ2) svv n2 tv1 tv2 tvv eq = {! !}
-- -- relV-apply s t v1 ρ2 n-j _ _ sv2 svv _ tv1 tv2 tvv eq

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ = tt
fundamental (var x) (suc n) ρ1 ρ2 ρρ = fundamentalV x (suc n) ρ1 ρ2 ρρ
fundamental (const (lit v)) (suc n) ρ1 ρ2 ρρ .(intV v) .n n-j≤n refl = intV v , zero , refl , I.+ zero , refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ .(closure t ρ1) .n n-j≤n refl =  closure t ρ2 , zero , refl , (λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k (suc n) (lt1 k≤n) _ _ _ ρρ))
fundamental (app s t) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq with eval s ρ1 n | inspect (eval s ρ1) n
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done sv1 n1 | [ s1eq ] with eval-dec s _ _ n n1 s1eq | eval t ρ1 n1 | inspect (eval t ρ1) n1
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done (closure st1 sρ1) n1 | [ s1eq ] | n1≤n | Done tv1 n2 | [ t1eq ] with eval-dec t _ _ n1 n2 t1eq
... | n2≤n1 with fundamental s (suc (suc n)) ρ1 ρ2 ρρ (closure st1 sρ1) (suc n1) (s≤s n1≤n) (eval-mono s ρ1 (closure st1 sρ1) n n1 s1eq)
  | fundamental t (suc (suc n1)) ρ1 ρ2 (relρ-mono (suc (suc n1)) (suc (suc n)) (s≤s (s≤s n1≤n)) _ _ _ ρρ) tv1 (suc n2) (s≤s n2≤n1) (eval-mono t ρ1 tv1 n1 n2 t1eq)
... | sv2@(closure st2 sρ2) , sn3 , s2eq , svv | tv2 , tn3 , t2eq , tvv with svv (suc n2) (s≤s (s≤s n2≤n1)) tv1 tv2 (relV-mono _ _ (s≤s (n≤1+n n2)) _ _ _ tvv ) v1 n-j (eval-dec st1 _ _ _ _ eq) eq
... | v2 , n3 , eq2 , vv = v2 , suc (sn3 + (tn3 + n3)) , comp , vv
  where
    s2eq-adj : eval s ρ2 (sn3 + (tn3 + n3)) ≡ Done (closure st2 sρ2) (tn3 + n3)
    s2eq-adj rewrite +-comm sn3 (tn3 + n3)| cong (Done (closure st2 sρ2)) (sym (+-right-identity (tn3 + n3))) = eval-adjust-plus (tn3 + n3) s _ sv2 _ _ s2eq
    t2eq-adj : eval t ρ2 (tn3 + n3) ≡ Done tv2 n3
    t2eq-adj rewrite +-comm tn3 n3 | cong (Done tv2) (sym (+-right-identity n3)) = eval-adjust-plus n3 t _ tv2 _ _ t2eq

    comp : (eval s ρ2 >>= (λ sv → eval t ρ2 >>= apply sv))
      (sn3 + (tn3 + n3))
      ≡ Done v2 0
    comp rewrite s2eq-adj | t2eq-adj = eq2

fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | Error | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | TimeOut | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Error | [ s1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | TimeOut | [ s1eq ]


Sequence: combining and splitting >>= processes

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Data.Product.NP using (Σ; _×_; _,_; first) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Two hiding (_≟_)
open import Data.Nat hiding (_⊔_)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _∙_; refl; ap; coe; coe!; !_) renaming (subst to tr)
open import Function.Extensionality
open import HoTT
open Equivalences

open import Control.Protocol.Core

module Control.Protocol.Sequence where

infixl 1 _>>=_ _>>_

_>>=_ : (P : Proto) → (Log P → Proto) → Proto
end     >>= Q = Q _
com q P >>= Q = com q λ m → P m >>= λ ms → Q (m , ms)

_>>_ : Proto → Proto → Proto
P >> Q = P >>= λ _ → Q

>>=-fst : ∀ P {Q} → ⟦ P >>= Q ⟧ → ⟦ P ⟧
>>=-fst end q = end
>>=-fst (recv P) pq = λ m → >>=-fst (P m) (pq m)
>>=-fst (send P) (m , pq) = m , >>=-fst (P m) pq

>>=-snd : ∀ P {Q}(pq : ⟦ P >>= Q ⟧)(p : ⟦ P ⊥⟧) → ⟦ Q (telecom P (>>=-fst P pq) p) ⟧
>>=-snd end      q        end     = q
>>=-snd (recv P) pq       (m , p) = >>=-snd (P m) (pq m) p
>>=-snd (send P) (m , pq) p       = >>=-snd (P m) pq (p m)

[_]_>>>=_ : ∀ P {Q} → ⟦ P ⟧ → ((log : Log P) → ⟦ Q log ⟧) → ⟦ P >>= Q ⟧
[ end    ] p       >>>= q = q _
[ recv P ] p       >>>= q = λ m → [ P m ] p m >>>= λ log → q (m , log)
[ send P ] (m , p) >>>= q = m , [ P m ] p >>>= λ log → q (m , log)

[_]_>>>_ : ∀ P {Q} → ⟦ P ⟧ → ⟦ Q ⟧ → ⟦ P >> Q ⟧
[ P ] p >>> q = [ P ] p >>>= λ _ → q

module _ {{_ : FunExt}} where
    >>=-fst-inv : ∀ P {Q}(p : ⟦ P ⟧)(q : ((log : Log P) → ⟦ Q log ⟧)) → >>=-fst P {Q} ([ P ] p >>>= q) ≡ p
    >>=-fst-inv end      end     q = refl
    >>=-fst-inv (recv P) p       q = λ= λ m → >>=-fst-inv (P m) (p m) λ log → q (m , log)
    >>=-fst-inv (send P) (m , p) q = snd= (>>=-fst-inv (P m) p λ log → q (m , log))

    >>=-snd-inv : ∀ P {Q}(p : ⟦ P ⟧)(q : ((log : Log P) → ⟦ Q log ⟧))(p' : ⟦ P ⊥⟧)
                  → tr (λ x → ⟦ Q (telecom P x p') ⟧) (>>=-fst-inv P p q)
                       (>>=-snd P {Q} ([ P ] p >>>= q) p') ≡ q (telecom P p p')
    >>=-snd-inv end          end     q p' = refl
    >>=-snd-inv (recv P) {Q} p       q (m , p') = ap (flip _$_ (>>=-snd (P m) ([ P m ] p m >>>= (λ log → q (m , log))) p'))
                                                     (tr-λ= (λ z → ⟦ Q (m , telecom (P m) z p') ⟧)
                                                               (λ m → >>=-fst-inv (P m) (p m) (q ∘ _,_ m)))
                                                ∙ >>=-snd-inv (P m) {Q ∘ _,_ m} (p m) (λ log → q (m , log)) p'
    >>=-snd-inv (send P) {Q} (m , p) q p' = tr-snd= (λ { (m , p) → ⟦ Q (m , telecom (P m) p (p' m)) ⟧ })
                                                    (>>=-fst-inv (P m) p (q ∘ _,_ m))
                                                    (>>=-snd (P m) {Q ∘ _,_ m} ([ P m ] p >>>= (q ∘ _,_ m)) (p' m))
                                          ∙ >>=-snd-inv (P m) {Q ∘ _,_ m} p (λ log → q (m , log)) (p' m)

    {- hmmm...
    >>=-uniq : ∀ P {Q} (pq : ⟦ P >>= Q ⟧)(p' : ⟦ P ⊥⟧) → pq ≡ [ P ] (>>=-fst P {Q} pq) >>>= (λ log → {!>>=-snd P {Q} pq p'!})
    >>=-uniq = {!!}
    -}

replicateᴾ : ℕ → Proto → Proto
replicateᴾ 0       P = end
replicateᴾ (suc n) P = P >> replicateᴾ n P

replicate-proc : ∀ n P → ⟦ P ⟧ → ⟦ replicateᴾ n P ⟧
replicate-proc zero    P p = end
replicate-proc (suc n) P p = [ P ] p >>> replicate-proc n P p

module _ {{_ : FunExt}}{{_ : UA}} where
  Log->>=-Σ : ∀ (P : Proto){Q} → Log (P >>= Q) ≡ Σ (Log P) (Log ∘ Q)
  Log->>=-Σ end       = ! (×= End-uniq refl ∙ 𝟙×-snd)
  Log->>=-Σ (com _ P) = Σ=′ _ (λ m → Log->>=-Σ (P m)) ∙ Σ-assoc

  Log->>-× : ∀ (P : Proto){Q} → Log (P >> Q) ≡ (Log P × Log Q)
  Log->>-× P = Log->>=-Σ P

  ++Log' : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
  ++Log' P p q = coe! (Log->>=-Σ P) (p , q)

-- Same as ++Log' but computes better
++Log : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
++Log end       _        ys = ys
++Log (com q P) (x , xs) ys = x , ++Log (P x) xs ys

module _ {{_ : FunExt}}{{_ : UA}} where

module _ {{_ : FunExt}} where
    >>-right-unit : ∀ P → (P >> end) ≡ P
    >>-right-unit end       = refl
    >>-right-unit (com q P) = com= refl refl λ m → >>-right-unit (P m)

    >>=-assoc : ∀ (P : Proto)(Q : Log P → Proto)(R : Log (P >>= Q) → Proto)
                → (P >>= (λ x → Q x >>= (λ y → R (++Log P x y)))) ≡ ((P >>= Q) >>= R)
    >>=-assoc end       Q R = refl
    >>=-assoc (com q P) Q R = com= refl refl λ m → >>=-assoc (P m) (λ ms → Q (m , ms)) (λ ms → R (m , ms))

    ap->>= : ∀ P {Q₀ Q₁} → (∀ {log} → ⟦ Q₀ log ⟧ ≡ ⟦ Q₁ log ⟧) → ⟦ P >>= Q₀ ⟧ ≡ ⟦ P >>= Q₁ ⟧
    ap->>= end      Q= = Q=
    ap->>= (send P) Q= = Σ=′ _ λ m → ap->>= (P m) Q=
    ap->>= (recv P) Q= = Π=′ _ λ m → ap->>= (P m) Q=

    dual->> : ∀ P Q → dual (P >> Q) ≡ (dual P >> dual Q)
    dual->> end        Q = refl
    dual->> (com io P) Q = com= refl refl λ m → dual->> (P m) Q

    {- My coe-ap-fu is lacking...
    dual->>= : ∀ P (Q : Log P → Proto) → dual (P >>= Q) ≡ dual P >>= (dual ∘ Q ∘ coe (dual-Log P))
    dual->>= end Q = refl
    dual->>= (com io P) Q = com= refl refl λ m → dual->>= (P m) (Q ∘ _,_ m) ∙ ap (_>>=_ (dual (P m))) (λ= λ ms → ap (λ x → dual (Q x)) (pair= {!!} {!!}))
    -}

    dual-replicateᴾ : ∀ n P → dual (replicateᴾ n P) ≡ replicateᴾ n (dual P)
    dual-replicateᴾ zero    P = refl
    dual-replicateᴾ (suc n) P = dual->> P (replicateᴾ n P) ∙ ap (_>>_ (dual P)) (dual-replicateᴾ n P)

{- An incremental telecom function which makes processes communicate
   during a matching initial protocol. -}
>>=-telecom : (P : Proto){Q : Log P → Proto}{R : Log P → Proto}
            → ⟦ P >>= Q  ⟧
            → ⟦ P >>= R ⊥⟧
            → Σ (Log P) (λ t → ⟦ Q t ⟧ × ⟦ R t ⊥⟧)
>>=-telecom end      p0       p1       = _ , p0 , p1
>>=-telecom (send P) (m , p0) p1       = first (_,_ m) (>>=-telecom (P m) p0 (p1 m))
>>=-telecom (recv P) p0       (m , p1) = first (_,_ m) (>>=-telecom (P m) (p0 m) p1)

>>-telecom : (P : Proto){Q R : Proto}
           → ⟦ P >> Q  ⟧
           → ⟦ P >> R ⊥⟧
           → Log P × ⟦ Q ⟧ × ⟦ R ⊥⟧
>>-telecom P p q = >>=-telecom P p q

{-# OPTIONS --without-K #-}
open import Function.NP
open import Data.Product.NP using (Σ; _×_; _,_; first)
open import Data.Two hiding (_≟_)
open import Data.Nat hiding (_⊔_)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _∙_; refl; ap)
open import Function.Extensionality
open import HoTT
open Equivalences

open import Control.Protocol.Core

module Control.Protocol.Sequence where

_>>=_ : (P : Proto) → (Log P → Proto) → Proto
end     >>= Q = Q _
com q P >>= Q = com q λ m → P m >>= λ ms → Q (m , ms)

_>>_ : Proto → Proto → Proto
P >> Q = P >>= λ _ → Q

replicateᴾ : ℕ → Proto → Proto
replicateᴾ 0       P = end
replicateᴾ (suc n) P = P >> replicateᴾ n P

++Log : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
++Log end       _        ys = ys
++Log (com q P) (x , xs) ys = x , ++Log (P x) xs ys

module _ {{_ : FunExt}} where
    >>=-right-unit : ∀ P → (P >> end) ≡ P
    >>=-right-unit end       = refl
    >>=-right-unit (com q P) = com= refl refl λ m → >>=-right-unit (P m)

    >>=-assoc : ∀ (P : Proto)(Q : Log P → Proto)(R : Log (P >>= Q) → Proto)
                → P >>= (λ x → Q x >>= (λ y → R (++Log P x y))) ≡ ((P >>= Q) >>= R)
    >>=-assoc end       Q R = refl
    >>=-assoc (com q P) Q R = com= refl refl λ m → >>=-assoc (P m) (λ ms → Q (m , ms)) (λ ms → R (m , ms))

    ap->>= : ∀ P {Q₀ Q₁} → (∀ {log} → ⟦ Q₀ log ⟧ ≡ ⟦ Q₁ log ⟧) → ⟦ P >>= Q₀ ⟧ ≡ ⟦ P >>= Q₁ ⟧
    ap->>= end      Q= = Q=
    ap->>= (send P) Q= = Σ=′ _ λ m → ap->>= (P m) Q=
    ap->>= (recv P) Q= = Π=′ _ λ m → ap->>= (P m) Q=

    dual->> : ∀ P Q → dual (P >> Q) ≡ dual P >> dual Q
    dual->> end        Q = refl
    dual->> (com io P) Q = com= refl refl λ m → dual->> (P m) Q

    {- My coe-ap-fu is lacking...
    dual->>= : ∀ P (Q : Log P → Proto) → dual (P >>= Q) ≡ dual P >>= (dual ∘ Q ∘ coe (dual-Log P))
    dual->>= end Q = refl
    dual->>= (com io P) Q = com= refl refl λ m → dual->>= (P m) (Q ∘ _,_ m) ∙ ap (_>>=_ (dual (P m))) (λ= λ ms → ap (λ x → dual (Q x)) (pair= {!!} {!!}))
    -}

    dual-replicateᴾ : ∀ n P → dual (replicateᴾ n P) ≡ replicateᴾ n (dual P)
    dual-replicateᴾ zero    P = refl
    dual-replicateᴾ (suc n) P = dual->> P (replicateᴾ n P) ∙ ap (_>>_ (dual P)) (dual-replicateᴾ n P)

{- An incremental telecom function which makes processes communicate
   during a matching initial protocol. -}
>>=-telecom : (P : Proto){Q : Log P → Proto}{R : Log P → Proto}
            → ⟦ P >>= Q  ⟧
            → ⟦ P >>= R ⊥⟧
            → Σ (Log P) (λ t → ⟦ Q t ⟧ × ⟦ R t ⊥⟧)
>>=-telecom end      p0       p1       = _ , p0 , p1
>>=-telecom (send P) (m , p0) p1       = first (_,_ m) (>>=-telecom (P m) p0 (p1 m))
>>=-telecom (recv P) p0       (m , p1) = first (_,_ m) (>>=-telecom (P m) (p0 m) p1)

>>-telecom : (P : Proto){Q R : Proto}
           → ⟦ P >> Q  ⟧
           → ⟦ P >> R ⊥⟧
           → Log P × ⟦ Q ⟧ × ⟦ R ⊥⟧
>>-telecom P p q = >>=-telecom P p q


Missing change in the last patch.

Missing change in the last patch.

Ignore-this: 3211beabafe1322efb98fa955570a8c1

darcs-hash:20110725165551-3bd4e-e1faddbbf8a037a1388aefb01f6ebe11ac35575b.gz


Continue playing around with Smyth in Agda.

module Text.Greek.Smyth where

open import Data.Char
open import Data.Maybe
open import Relation.Nullary using (¬_)

-- Smyth §1
data Letter : Set where
  α β γ δ ε ζ η θ ι κ λ′ μ ν ξ ο π ρ σ τ υ φ χ ψ ω : Letter

data LetterCase : Set where
  capital small : LetterCase

form : Letter → LetterCase → Char
form α capital = 'Α'
form α small = 'α'
form β capital = 'Β'
form β small = 'β'
form γ capital = 'Γ'
form γ small = 'γ'
form δ capital = 'Δ'
form δ small = 'δ'
form ε capital = 'Ε'
form ε small = 'ε'
form ζ capital = 'Ζ'
form ζ small = 'ζ'
form η capital = 'Η'
form η small = 'η'
form θ capital = 'Θ'
form θ small = 'θ'
form ι capital = 'Ι'
form ι small = 'ι'
form κ capital = 'Κ'
form κ small = 'κ'
form λ′ capital = 'Λ'
form λ′ small = 'λ'
form μ capital = 'Μ'
form μ small = 'μ'
form ν capital = 'Ν'
form ν small = 'ν'
form ξ capital = 'Ξ'
form ξ small = 'ξ'
form ο capital = 'Ο'
form ο small = 'ο'
form π capital = 'Π'
form π small = 'π'
form ρ capital = 'Ρ'
form ρ small = 'ρ'
form σ capital = 'Σ'
form σ small = 'σ'
form τ capital = 'Τ'
form τ small = 'τ'
form υ capital = 'Υ'
form υ small = 'υ'
form φ capital = 'Φ'
form φ small = 'φ'
form χ capital = 'Χ'
form χ small = 'χ'
form ψ capital = 'Ψ'
form ψ small = 'ψ'
form ω capital = 'Ω'
form ω small = 'ω'

-- Smyth §1 a
data PositionInWord : Set where
  start-of-word : PositionInWord
  middle-of-word : PositionInWord
  end-of-word : PositionInWord

data FinalForm : Set where
  final-form not-final-form : FinalForm

get-final-form : Letter → LetterCase → PositionInWord → FinalForm
get-final-form σ′ small end-of-word = final-form
get-final-form _ _ _ = not-final-form

-- Smyth §3
data OlderLetter : Set where
  Ϝ′ : OlderLetter
  Ϙ′ : OlderLetter
  ϡ′ : OlderLetter

-- Smyth §4
data Vowel : Letter → Set where
  α : Vowel α
  ε : Vowel ε
  η : Vowel η
  ι : Vowel ι
  ο : Vowel ο
  υ : Vowel υ
  ω : Vowel ω

data AlwaysShort : Letter → Set where
  ε : AlwaysShort ε
  ο : AlwaysShort ο

data AlwaysLong : Letter → Set where
  η : AlwaysLong η
  ω : AlwaysLong ω

data VowelLength : Set where
  short long : VowelLength

data VowelWithLength : ∀ {v} → Vowel v → VowelLength → Set where
  always-short : ∀ {ℓ} → (v : Vowel ℓ) → AlwaysShort ℓ → VowelWithLength v short
  always-long : ∀ {ℓ} → (v : Vowel ℓ) → AlwaysLong ℓ → VowelWithLength v long
  α-with-length : (vl : VowelLength) → VowelWithLength α vl
  ι-with-length : (vl : VowelLength) → VowelWithLength ι vl
  υ-with-length : (vl : VowelLength) → VowelWithLength υ vl

alwaysShort-Vowel : ∀ {ℓ} → AlwaysShort ℓ → Vowel ℓ
alwaysShort-Vowel ε = ε
alwaysShort-Vowel ο = ο

alwaysLong-Vowel : ∀ {ℓ} → AlwaysLong ℓ → Vowel ℓ
alwaysLong-Vowel η = η
alwaysLong-Vowel ω = ω

-- Smyth §5
data Diphthong : Letter → Letter → Set where
  αι : Diphthong α ι
  ει : Diphthong ε ι
  οι : Diphthong ο ι
  ᾱͅ : Diphthong α ι
  ῃ : Diphthong η ι
  ῳ : Diphthong ω ι
  αυ : Diphthong α υ
  ευ : Diphthong ε υ
  ου : Diphthong ο υ
  ηυ : Diphthong η υ
  υι : Diphthong υ ι

-- Smyth §6
data SpuriousDiphthong : ∀ {v₁ v₂} → Diphthong v₁ v₂ → Set where
  ει-sp : SpuriousDiphthong ει
  ου-sp : SpuriousDiphthong ου

-- Smyth §7
data TonguePosition : Set where
  closed closed-medium open-medium open′ closing opening : TonguePosition

tongue-position-vowel : ∀ {ℓ} → Vowel ℓ → TonguePosition
tongue-position-vowel α = open′
tongue-position-vowel ε = closed-medium
tongue-position-vowel η = open-medium
tongue-position-vowel ι = closed
tongue-position-vowel ο = closed-medium
tongue-position-vowel υ = closed
tongue-position-vowel ω = open-medium

tongue-position-diphthong : ∀ {ℓ₁ ℓ₂} → Diphthong ℓ₁ ℓ₂ → TonguePosition
tongue-position-diphthong d = closing

data RoundedLips : Set where
  rounded-lips not-rounded-lips : RoundedLips

rounded-lips-vowel : ∀ {ℓ} → Vowel ℓ → RoundedLips
rounded-lips-vowel ο = rounded-lips
rounded-lips-vowel υ = rounded-lips
rounded-lips-vowel ω = rounded-lips
rounded-lips-vowel _ = not-rounded-lips

rounded-lips-diphthong : ∀ {ℓ₁ ℓ₂} → Diphthong ℓ₁ ℓ₂ → RoundedLips
rounded-lips-diphthong ου = rounded-lips
rounded-lips-diphthong _ = not-rounded-lips

-- Smyth §9
data Breathing : Set where
  ῾ ᾿ : Breathing

-- Smyth §15
data Consonant : Letter → Set where
  β : Consonant β
  γ : Consonant γ
  δ : Consonant δ
  ζ : Consonant ζ
  θ : Consonant θ
  κ : Consonant κ
  λ′ : Consonant λ′
  μ : Consonant μ
  ν : Consonant ν
  ξ : Consonant ξ
  π : Consonant π
  ρ : Consonant ρ
  σ : Consonant σ
  τ : Consonant τ
  φ : Consonant φ
  χ : Consonant χ
  ψ : Consonant ψ

data LetterCategory : Letter → Set where
  vowel : ∀ {ℓ} → Vowel ℓ → LetterCategory ℓ
  consonant : ∀ {ℓ} → Consonant ℓ → LetterCategory ℓ

Letter-to-LetterCategory : (ℓ : Letter) → LetterCategory ℓ
Letter-to-LetterCategory α = vowel α
Letter-to-LetterCategory β = consonant β
Letter-to-LetterCategory γ = consonant γ
Letter-to-LetterCategory δ = consonant δ
Letter-to-LetterCategory ε = vowel ε
Letter-to-LetterCategory ζ = consonant ζ
Letter-to-LetterCategory η = vowel η
Letter-to-LetterCategory θ = consonant θ
Letter-to-LetterCategory ι = vowel ι
Letter-to-LetterCategory κ = consonant κ
Letter-to-LetterCategory λ′ = consonant λ′
Letter-to-LetterCategory μ = consonant μ
Letter-to-LetterCategory ν = consonant ν
Letter-to-LetterCategory ξ = consonant ξ
Letter-to-LetterCategory ο = vowel ο
Letter-to-LetterCategory π = consonant π
Letter-to-LetterCategory ρ = consonant ρ
Letter-to-LetterCategory σ = consonant σ
Letter-to-LetterCategory τ = consonant τ
Letter-to-LetterCategory υ = vowel υ
Letter-to-LetterCategory φ = consonant φ
Letter-to-LetterCategory χ = consonant χ
Letter-to-LetterCategory ψ = consonant ψ
Letter-to-LetterCategory ω = vowel ω

LetterCategory-to-Letter : ∀ {ℓ} → LetterCategory ℓ → Letter
LetterCategory-to-Letter {ℓ} _ = ℓ

data ConsonantSound : Letter → Set where
  β : ConsonantSound β
  γ : ConsonantSound γ
  δ : ConsonantSound δ
  ζ : ConsonantSound ζ
  θ : ConsonantSound θ
  κ : ConsonantSound κ
  λ′ : ConsonantSound λ′
  μ : ConsonantSound μ
  ν : ConsonantSound ν
  ξ : ConsonantSound ξ
  π : ConsonantSound π
  ρ : ConsonantSound ρ
  σ : ConsonantSound σ
  τ : ConsonantSound τ
  φ : ConsonantSound φ
  χ : ConsonantSound χ
  ψ : ConsonantSound ψ
  γ-nasal : ConsonantSound γ
  ῥ : ConsonantSound ρ

data VocalChords : Set where
  voiced voiceless : VocalChords

-- Smyth §15 a
data Voiced : ∀ {ℓ} → ConsonantSound ℓ → Set where
  β : Voiced β
  δ : Voiced δ
  γ : Voiced γ
  λ′ : Voiced λ′
  ρ : Voiced ρ
  μ : Voiced μ
  ν : Voiced ν
  γ-nasal : Voiced γ-nasal
  ζ : Voiced ζ

-- Smyth §15 a, b
data Voiceless : ∀ {ℓ} → ConsonantSound ℓ → Set where
  ῥ : Voiceless ῥ
  π : Voiceless π
  τ : Voiceless τ
  κ : Voiceless κ
  φ : Voiceless φ
  θ : Voiceless θ
  χ : Voiceless χ
  σ : Voiceless σ
  ψ : Voiceless ψ
  ξ : Voiceless ξ

-- TODO (needs a unified model)

-- Accent
-- Smyth §4 All vowels with the circumflex (149) are long.

-- Diaeresis
-- Smyth §8 Diaeresis.—A double dot, the mark of diaeresis, may be written over ι or υ when these do not form a diphthong with the preceding vowel

-- Breathing
-- Smyth §9. Every initial vowel or diphthong has either the rough (῾) or the smooth (᾿) breathing.
-- Smyth §10. Initial υ (ῠ and ῡ) always has the rough breathing.
-- Smyth §11. Diphthongs take the breathing, as the accent (152), over the second vowel: αἱρέω hairéo I seize, αἴρω aíro I lift.
-- Smyth §11. But ᾳ, ῃ, ῳ take both the breathing and the accent on the first vowel, even when ι is written in the line (5): ᾄδω = Ἄιδω I sing… The writing ἀίδηλος (Ἀίδηλος) destroying shows that αι does not here form a diphthong
-- Smyth §12. In compound words (as in προορᾶν to foresee, from πρό + ὁρᾶν) the rough breathing is not written, though it must often have been pronounced
-- Smyth §13. Every initial ρ has the rough breathing
-- Smyth §13. Medial ρρ is written ῤῥ in some texts

-- Consonants
-- Smyth §15 c. ι̯ υ̯

module Text.Greek.Smyth where

open import Data.Char
open import Data.Maybe

-- Smyth §1
data Letter : Set where
  α′ β′ γ′ δ′ ε′ ζ′ η′ θ′ ι′ κ′ λ′ μ′ ν′ ξ′ ο′ π′ ρ′ σ′ τ′ υ′ φ′ χ′ ψ′ ω′ : Letter

data LetterCase : Set where
  capital small : LetterCase

form : Letter → LetterCase → Char
form α′ capital = 'Α'
form α′ small = 'α'
form β′ capital = 'Β'
form β′ small = 'β'
form γ′ capital = 'Γ'
form γ′ small = 'γ'
form δ′ capital = 'Δ'
form δ′ small = 'δ'
form ε′ capital = 'Ε'
form ε′ small = 'ε'
form ζ′ capital = 'Ζ'
form ζ′ small = 'ζ'
form η′ capital = 'Η'
form η′ small = 'η'
form θ′ capital = 'Θ'
form θ′ small = 'θ'
form ι′ capital = 'Ι'
form ι′ small = 'ι'
form κ′ capital = 'Κ'
form κ′ small = 'κ'
form λ′ capital = 'Λ'
form λ′ small = 'λ'
form μ′ capital = 'Μ'
form μ′ small = 'μ'
form ν′ capital = 'Ν'
form ν′ small = 'ν'
form ξ′ capital = 'Ξ'
form ξ′ small = 'ξ'
form ο′ capital = 'Ο'
form ο′ small = 'ο'
form π′ capital = 'Π'
form π′ small = 'π'
form ρ′ capital = 'Ρ'
form ρ′ small = 'ρ'
form σ′ capital = 'Σ'
form σ′ small = 'σ'
form τ′ capital = 'Τ'
form τ′ small = 'τ'
form υ′ capital = 'Υ'
form υ′ small = 'υ'
form φ′ capital = 'Φ'
form φ′ small = 'φ'
form χ′ capital = 'Χ'
form χ′ small = 'χ'
form ψ′ capital = 'Ψ'
form ψ′ small = 'ψ'
form ω′ capital = 'Ω'
form ω′ small = 'ω'

-- Smyth §1 a
data PositionInWord : Set where
  not-end : PositionInWord
  end-of-word : PositionInWord

form-in-word : Letter → LetterCase → PositionInWord → Char
form-in-word σ′ small end-of-word = 'ς'
form-in-word ℓ c _ = form ℓ c

-- Smyth §3
data OlderLetter : Set where
  Ϝ′ : OlderLetter
  Ϙ′ : OlderLetter
  ϡ′ : OlderLetter

-- Smyth §4
data Vowel : Letter → Set where
  α-vowel : Vowel α′
  ε-vowel : Vowel ε′
  η-vowel : Vowel η′
  ι-vowel : Vowel ι′
  ο-vowel : Vowel ο′
  υ-vowel : Vowel υ′
  ω-vowel : Vowel ω′

data AlwaysShort : Letter → Set where
  ε-always-short : Vowel ε′ → AlwaysShort ε′
  ο-always-short : Vowel ο′ → AlwaysShort ο′

data AlwaysLong : Letter → Set where
  η-always-long : Vowel η′ → AlwaysLong η′
  ω-always-long : Vowel ω′ → AlwaysLong ω′

-- Smyth §4 All vowels with the circumflex (149) are long

-- Smyth §149
data Accent : Set where
  acute circumflex grave : Accent