Add Mu eliminator to operational semantics.

module Spire.Operational where

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

data Level : Set where
  zero : Level
  suc : Level → Level

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

data Context : Set
data Type (Γ : Context) : Set
data Value (Γ : Context) : Type Γ → Set
data Neutral (Γ : Context) : Type Γ → Set

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

data Context where
  ∅ : Context
  _,_ : (Γ : Context) → Type Γ → Context

data Type Γ where
  `⊥ `⊤ `Bool : Type Γ
  `Desc `Type : (ℓ : Level) → Type Γ
  `Π `Σ : (A : Type Γ) (B : Type (Γ , A)) → Type Γ
  `μ : ∀{ℓ} → Value Γ (`Desc ℓ) → Type Γ
  `⟦_⟧ : ∀{ℓ} → Neutral Γ (`Type ℓ) → Type Γ
  `⟦_⟧ᵈ : ∀{ℓ} → Neutral Γ (`Desc ℓ) → Type Γ → Type Γ

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

⟦_⟧ : ∀{Γ ℓ} → Value Γ (`Type ℓ) →  Type Γ
⟦_⟧ᵈ : ∀{Γ ℓ} → Value Γ (`Desc ℓ) → Type Γ →  Type Γ

postulate
  wknT : ∀{Γ A} → Type Γ → Type (Γ , A)
  subT : ∀{Γ A} → Type (Γ , A) → Value Γ A → Type Γ
  subV : ∀{Γ A B} → Value (Γ , A) B → (x : Value Γ A) → Value Γ (subT B x)

data Var : (Γ : Context) (A : Type Γ) → Set where
  here : ∀{Γ A} → Var (Γ , A) (wknT A)
  there : ∀{Γ A B} → Var Γ A → Var (Γ , B) (wknT A)

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

data Value Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Desc `Type : ∀{ℓ} → Value Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Value Γ (`Type ℓ)) (B : Value (Γ , ⟦ A ⟧) (`Type ℓ)) → Value Γ (`Type ℓ)
  `μ : ∀{ℓ} → Value Γ (`Desc ℓ) → Value Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Value Γ (`Type ℓ) → Value Γ (`Type (suc ℓ))
  `⟦_⟧ᵈ : ∀{ℓ} → Value Γ (`Desc ℓ) → Value Γ (`Type ℓ) → Value Γ (`Type ℓ)

  {- Desc introduction -}
  `⊤ᵈ `Xᵈ : ∀{ℓ} → Value Γ (`Desc ℓ)
  `Πᵈ `Σᵈ : ∀{ℓ}
    (A : Value Γ (`Type ℓ))
    (B : Value (Γ , ⟦ A ⟧) (`Desc (suc ℓ)))
    → Value Γ (`Desc (suc ℓ))

  {- Value introduction -}
  `tt : Value Γ `⊤
  `true `false : Value Γ `Bool
  _`,_ : ∀{A B} (a : Value Γ A) (b : Value Γ (subT B a)) → Value Γ (`Σ A B)
  `λ : ∀{A B} → Value (Γ , A) B → Value Γ (`Π A B)
  `con : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Value Γ (⟦ D ⟧ᵈ (`μ D)) → Value Γ (`μ D)
  `neut : ∀{A} → Neutral Γ A → Value Γ A

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

data Neutral Γ where
  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Neutral Γ A
  `if_`then_`else_ : ∀{C} (b : Neutral Γ `Bool) (c₁ c₂ : Value Γ C) → Neutral Γ C
  `elim⊥ : ∀{A} → Neutral Γ `⊥ → Neutral Γ A
  `elimBool : ∀{ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
    (pt : Value Γ (subT ⟦ P ⟧ `true))
    (pf : Value Γ (subT ⟦ P ⟧ `false))
    (b : Neutral Γ `Bool) → Neutral Γ (subT ⟦ P ⟧ (`neut b))
  `proj₁ : ∀{A B} → Neutral Γ (`Σ A B) → Neutral Γ A
  `proj₂ : ∀{A B} (ab : Neutral Γ (`Σ A B)) → Neutral Γ (subT B (`neut (`proj₁ ab)))
  _`$_ : ∀{A B} (f : Neutral Γ (`Π A B)) (a : Value Γ A) → Neutral Γ (subT B a)
  `des : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Neutral Γ (`μ D) → Neutral Γ (⟦ D ⟧ᵈ (`μ D))

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

⟦ `Π A B ⟧ = `Π ⟦ A ⟧ ⟦ B ⟧
⟦ `Σ A B ⟧ = `Σ ⟦ A ⟧ ⟦ B ⟧
⟦ `⊥ ⟧ = `⊥
⟦ `⊤ ⟧ = `⊤
⟦ `Bool ⟧ = `Bool
⟦ `μ D ⟧ = `μ D
⟦ `Type {zero} ⟧ = `⊥
⟦ `Type {suc ℓ} ⟧ = `Type ℓ
⟦ `⟦ A ⟧ ⟧ = ⟦ A ⟧
⟦ `Desc {ℓ} ⟧ = `Desc ℓ
⟦ `⟦ D ⟧ᵈ X ⟧ = ⟦ D ⟧ᵈ ⟦ X ⟧
⟦ `neut A ⟧ = `⟦ A ⟧

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

⟦ `⊤ᵈ ⟧ᵈ X = `⊤
⟦ `Xᵈ ⟧ᵈ X = X
⟦ `Πᵈ A D ⟧ᵈ X = `Π ⟦ A ⟧ (⟦ D ⟧ᵈ (wknT X))
⟦ `Σᵈ A D ⟧ᵈ X = `Σ ⟦ A ⟧ (⟦ D ⟧ᵈ (wknT X))
⟦ `neut D ⟧ᵈ X = `⟦ D ⟧ᵈ X

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

elim⊥ : ∀{Γ A} → Value Γ `⊥ → Value Γ A
elim⊥ (`neut bot) = `neut (`elim⊥ bot)

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

if_then_else_ : ∀{Γ C} (b : Value Γ `Bool) (c₁ c₂ : Value Γ C) → Value Γ C
if `true then c₁ else c₂ = c₁
if `false then c₁ else c₂ = c₂
if `neut b then c₁ else c₂ = `neut (`if b `then c₁ `else c₂)

elimBool : ∀{Γ ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
  (pt : Value Γ (subT ⟦ P ⟧ `true))
  (pf : Value Γ (subT ⟦ P ⟧ `false))
  (b : Value Γ `Bool)
  → Value Γ (subT ⟦ P ⟧ b)
elimBool P pt pf `true = pt
elimBool P pt pf `false = pf
elimBool P pt pf (`neut b) = `neut (`elimBool P pt pf b)

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

proj₁ : ∀{Γ A B} → Value Γ (`Σ A B) → Value Γ A
proj₁ (a `, b) = a
proj₁ (`neut ab) = `neut (`proj₁ ab)

proj₂ : ∀{Γ A B} (ab : Value Γ (`Σ A B)) → Value Γ (subT B (proj₁ ab))
proj₂ (a `, b) = b
proj₂ (`neut ab) = `neut (`proj₂ ab)

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

des : ∀{Γ ℓ} {D : Value Γ (`Desc ℓ)} → Value Γ (`μ D) → Value Γ (⟦ D ⟧ᵈ (`μ D))
des (`con x) = x
des (`neut x) = `neut (`des x)

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

_$_ : ∀{Γ A B} → Value Γ (`Π A B) → (a : Value Γ A) → Value Γ (subT B a)
`λ b $ a = subV b a
`neut f $ a = `neut (f `$ a)

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

data Term (Γ : Context) : Type Γ → Set
eval : ∀{Γ A} → Term Γ A → Value Γ A

data Term Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Type : ∀{ℓ} → Term Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Term Γ (`Type ℓ)) (B : Term (Γ , ⟦ eval A ⟧) (`Type ℓ)) → Term Γ (`Type ℓ)
  `μ : ∀{ℓ} → Term Γ (`Desc ℓ) → Term Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Term Γ (`Type ℓ) → Term Γ (`Type (suc ℓ))
  `⟦_⟧ᵈ : ∀{ℓ} → Term Γ (`Desc ℓ) → Term Γ (`Type ℓ) → Term Γ (`Type ℓ)

  {- Desc introduction -}
  `⊤ᵈ `Xᵈ : ∀{ℓ} → Term Γ (`Desc ℓ)
  `Πᵈ `Σᵈ : ∀{ℓ}
    (A : Term Γ (`Type ℓ))
    (D : Term (Γ , ⟦ eval A ⟧) (`Desc (suc ℓ)))
    → Term Γ (`Desc (suc ℓ))

  {- Value introduction -}
  `tt : Term Γ `⊤
  `true `false : Term Γ `Bool
  _`,_ : ∀{A B}
    (a : Term Γ A) (b : Term Γ (subT B (eval a)))
    → Term Γ (`Σ A B)
  `λ : ∀{A B}
    (b : Term (Γ , A) B)
    → Term Γ (`Π A B)
  `con : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Term Γ (⟦ D ⟧ᵈ (`μ D)) → Term Γ (`μ D)

  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Term Γ A
  `if_`then_`else_ : ∀{C}
    (b : Term Γ `Bool)
    (c₁ c₂ : Term Γ C)
    → Term Γ C
  _`$_ : ∀{A B} (f : Term Γ (`Π A B)) (a : Term Γ A) → Term Γ (subT B (eval a))
  `proj₁ : ∀{A B} → Term Γ (`Σ A B) → Term Γ A
  `proj₂ : ∀{A B} (ab : Term Γ (`Σ A B)) → Term Γ (subT B (proj₁ (eval ab)))
  `elim⊥ : ∀{A} → Term Γ `⊥ → Term Γ A
  `elimBool : ∀{ℓ} (P : Term (Γ , `Bool) (`Type ℓ))
    (pt : Term Γ (subT ⟦ eval P ⟧ `true))
    (pf : Term Γ (subT ⟦ eval P ⟧ `false))
    (b : Term Γ `Bool)
    → Term Γ (subT ⟦ eval P ⟧ (eval b))
  `des : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Term Γ (`μ D) → Term Γ (⟦ D ⟧ᵈ (`μ D))

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

{- Type introduction -}
eval `⊥ = `⊥
eval `⊤ = `⊤
eval `Bool = `Bool
eval `Type = `Type
eval (`Π A B) = `Π (eval A) (eval B)
eval (`Σ A B) = `Σ (eval A) (eval B)
eval (`μ D) = `μ (eval D)
eval `⟦ A ⟧ = `⟦ eval A ⟧
eval (`⟦ D ⟧ᵈ X) = `⟦ eval D ⟧ᵈ (eval X)

{- Desc introduction -}
eval `⊤ᵈ = `⊤ᵈ
eval `Xᵈ = `Xᵈ
eval (`Πᵈ A D) = `Πᵈ (eval A) (eval D)
eval (`Σᵈ A D) = `Σᵈ (eval A) (eval D)

{- Value introduction -}
eval `tt = `tt
eval `true = `true
eval `false = `false
eval (a `, b) = eval a `, eval b
eval (`λ b) = `λ (eval b)
eval (`con x) = `con (eval x)

{- Value elimination -}
eval (`var i) = `neut (`var i)
eval (`if b `then c₁ `else c₂) = if eval b then eval c₁ else eval c₂
eval (f `$ a) = eval f $ eval a
eval (`proj₁ ab) = proj₁ (eval ab)
eval (`proj₂ ab) = proj₂ (eval ab)
eval (`elim⊥ bot) = elim⊥ (eval bot)
eval (`elimBool P pt pf b) = elimBool (eval P) (eval pt) (eval pf) (eval b)
eval (`des x) = des (eval x)

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

module Spire.Operational where

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

data Level : Set where
  zero : Level
  suc : Level → Level

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

data Context : Set
data Type (Γ : Context) : Set
data Value (Γ : Context) : Type Γ → Set
data Neutral (Γ : Context) : Type Γ → Set

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

data Context where
  ∅ : Context
  _,_ : (Γ : Context) → Type Γ → Context

data Type Γ where
  `⊥ `⊤ `Bool : Type Γ
  `Desc `Type : (ℓ : Level) → Type Γ
  `Π `Σ : (A : Type Γ) (B : Type (Γ , A)) → Type Γ
  `μ : ∀{ℓ} → Value Γ (`Desc ℓ) → Type Γ
  `⟦_⟧ : ∀{ℓ} → Neutral Γ (`Type ℓ) → Type Γ
  `⟦_⟧ᵈ : ∀{ℓ} → Neutral Γ (`Desc ℓ) → Type Γ → Type Γ

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

⟦_⟧ : ∀{Γ ℓ} → Value Γ (`Type ℓ) →  Type Γ
⟦_⟧ᵈ : ∀{Γ ℓ} → Value Γ (`Desc ℓ) → Type Γ →  Type Γ

postulate
  wknT : ∀{Γ A} → Type Γ → Type (Γ , A)
  subT : ∀{Γ A} → Type (Γ , A) → Value Γ A → Type Γ
  subV : ∀{Γ A B} → Value (Γ , A) B → (x : Value Γ A) → Value Γ (subT B x)

data Var : (Γ : Context) (A : Type Γ) → Set where
  here : ∀{Γ A} → Var (Γ , A) (wknT A)
  there : ∀{Γ A B} → Var Γ A → Var (Γ , B) (wknT A)

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

data Value Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Desc `Type : ∀{ℓ} → Value Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Value Γ (`Type ℓ)) (B : Value (Γ , ⟦ A ⟧) (`Type ℓ)) → Value Γ (`Type ℓ)
  `μ : ∀{ℓ} → Value Γ (`Desc ℓ) → Value Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Value Γ (`Type ℓ) → Value Γ (`Type (suc ℓ))
  `⟦_⟧ᵈ : ∀{ℓ} → Value Γ (`Desc ℓ) → Value Γ (`Type ℓ) → Value Γ (`Type ℓ)

  {- Desc introduction -}
  `⊤ᵈ `Xᵈ : ∀{ℓ} → Value Γ (`Desc ℓ)
  `Πᵈ `Σᵈ : ∀{ℓ}
    (A : Value Γ (`Type ℓ))
    (B : Value (Γ , ⟦ A ⟧) (`Desc (suc ℓ)))
    → Value Γ (`Desc (suc ℓ))

  {- Value introduction -}
  `tt : Value Γ `⊤
  `true `false : Value Γ `Bool
  _`,_ : ∀{A B} (a : Value Γ A) (b : Value Γ (subT B a)) → Value Γ (`Σ A B)
  `λ : ∀{A B} → Value (Γ , A) B → Value Γ (`Π A B)
  `con : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Value Γ (⟦ D ⟧ᵈ (`μ D)) → Value Γ (`μ D)
  `neut : ∀{A} → Neutral Γ A → Value Γ A

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

data Neutral Γ where
  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Neutral Γ A
  `if_`then_`else_ : ∀{C} (b : Neutral Γ `Bool) (c₁ c₂ : Value Γ C) → Neutral Γ C
  `elim⊥ : ∀{A} → Neutral Γ `⊥ → Neutral Γ A
  `elimBool : ∀{ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
    (pt : Value Γ (subT ⟦ P ⟧ `true))
    (pf : Value Γ (subT ⟦ P ⟧ `false))
    (b : Neutral Γ `Bool) → Neutral Γ (subT ⟦ P ⟧ (`neut b))
  `proj₁ : ∀{A B} → Neutral Γ (`Σ A B) → Neutral Γ A
  `proj₂ : ∀{A B} (ab : Neutral Γ (`Σ A B)) → Neutral Γ (subT B (`neut (`proj₁ ab)))
  _`$_ : ∀{A B} (f : Neutral Γ (`Π A B)) (a : Value Γ A) → Neutral Γ (subT B a)

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

⟦ `Π A B ⟧ = `Π ⟦ A ⟧ ⟦ B ⟧
⟦ `Σ A B ⟧ = `Σ ⟦ A ⟧ ⟦ B ⟧
⟦ `⊥ ⟧ = `⊥
⟦ `⊤ ⟧ = `⊤
⟦ `Bool ⟧ = `Bool
⟦ `μ D ⟧ = `μ D
⟦ `Type {zero} ⟧ = `⊥
⟦ `Type {suc ℓ} ⟧ = `Type ℓ
⟦ `⟦ A ⟧ ⟧ = ⟦ A ⟧
⟦ `Desc {ℓ} ⟧ = `Desc ℓ
⟦ `⟦ D ⟧ᵈ X ⟧ = ⟦ D ⟧ᵈ ⟦ X ⟧
⟦ `neut A ⟧ = `⟦ A ⟧

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

⟦ `⊤ᵈ ⟧ᵈ X = `⊤
⟦ `Xᵈ ⟧ᵈ X = X
⟦ `Πᵈ A D ⟧ᵈ X = `Π ⟦ A ⟧ (⟦ D ⟧ᵈ (wknT X))
⟦ `Σᵈ A D ⟧ᵈ X = `Σ ⟦ A ⟧ (⟦ D ⟧ᵈ (wknT X))
⟦ `neut D ⟧ᵈ X = `⟦ D ⟧ᵈ X

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

elim⊥ : ∀{Γ A} → Value Γ `⊥ → Value Γ A
elim⊥ (`neut bot) = `neut (`elim⊥ bot)

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

if_then_else_ : ∀{Γ C} (b : Value Γ `Bool) (c₁ c₂ : Value Γ C) → Value Γ C
if `true then c₁ else c₂ = c₁
if `false then c₁ else c₂ = c₂
if `neut b then c₁ else c₂ = `neut (`if b `then c₁ `else c₂)

elimBool : ∀{Γ ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
  (pt : Value Γ (subT ⟦ P ⟧ `true))
  (pf : Value Γ (subT ⟦ P ⟧ `false))
  (b : Value Γ `Bool)
  → Value Γ (subT ⟦ P ⟧ b)
elimBool P pt pf `true = pt
elimBool P pt pf `false = pf
elimBool P pt pf (`neut b) = `neut (`elimBool P pt pf b)

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

proj₁ : ∀{Γ A B} → Value Γ (`Σ A B) → Value Γ A
proj₁ (a `, b) = a
proj₁ (`neut ab) = `neut (`proj₁ ab)

proj₂ : ∀{Γ A B} (ab : Value Γ (`Σ A B)) → Value Γ (subT B (proj₁ ab))
proj₂ (a `, b) = b
proj₂ (`neut ab) = `neut (`proj₂ ab)

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

_$_ : ∀{Γ A B} → Value Γ (`Π A B) → (a : Value Γ A) → Value Γ (subT B a)
`λ b $ a = subV b a
`neut f $ a = `neut (f `$ a)

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

data Term (Γ : Context) : Type Γ → Set
eval : ∀{Γ A} → Term Γ A → Value Γ A

data Term Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Type : ∀{ℓ} → Term Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Term Γ (`Type ℓ)) (B : Term (Γ , ⟦ eval A ⟧) (`Type ℓ)) → Term Γ (`Type ℓ)
  `μ : ∀{ℓ} → Term Γ (`Desc ℓ) → Term Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Term Γ (`Type ℓ) → Term Γ (`Type (suc ℓ))
  `⟦_⟧ᵈ : ∀{ℓ} → Term Γ (`Desc ℓ) → Term Γ (`Type ℓ) → Term Γ (`Type ℓ)

  {- Desc introduction -}
  `⊤ᵈ `Xᵈ : ∀{ℓ} → Term Γ (`Desc ℓ)
  `Πᵈ `Σᵈ : ∀{ℓ}
    (A : Term Γ (`Type ℓ))
    (D : Term (Γ , ⟦ eval A ⟧) (`Desc (suc ℓ)))
    → Term Γ (`Desc (suc ℓ))

  {- Value introduction -}
  `tt : Term Γ `⊤
  `true `false : Term Γ `Bool
  _`,_ : ∀{A B}
    (a : Term Γ A) (b : Term Γ (subT B (eval a)))
    → Term Γ (`Σ A B)
  `λ : ∀{A B}
    (b : Term (Γ , A) B)
    → Term Γ (`Π A B)
  `con : ∀{ℓ} {D : Value Γ (`Desc ℓ)} → Term Γ (⟦ D ⟧ᵈ (`μ D)) → Term Γ (`μ D)

  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Term Γ A
  `if_`then_`else_ : ∀{C}
    (b : Term Γ `Bool)
    (c₁ c₂ : Term Γ C)
    → Term Γ C
  _`$_ : ∀{A B} (f : Term Γ (`Π A B)) (a : Term Γ A) → Term Γ (subT B (eval a))
  `proj₁ : ∀{A B} → Term Γ (`Σ A B) → Term Γ A
  `proj₂ : ∀{A B} (ab : Term Γ (`Σ A B)) → Term Γ (subT B (proj₁ (eval ab)))
  `elim⊥ : ∀{A} → Term Γ `⊥ → Term Γ A
  `elimBool : ∀{ℓ} (P : Term (Γ , `Bool) (`Type ℓ))
    (pt : Term Γ (subT ⟦ eval P ⟧ `true))
    (pf : Term Γ (subT ⟦ eval P ⟧ `false))
    (b : Term Γ `Bool)
    → Term Γ (subT ⟦ eval P ⟧ (eval b))

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

{- Type introduction -}
eval `⊥ = `⊥
eval `⊤ = `⊤
eval `Bool = `Bool
eval `Type = `Type
eval (`Π A B) = `Π (eval A) (eval B)
eval (`Σ A B) = `Σ (eval A) (eval B)
eval (`μ D) = `μ (eval D)
eval `⟦ A ⟧ = `⟦ eval A ⟧
eval (`⟦ D ⟧ᵈ X) = `⟦ eval D ⟧ᵈ (eval X)

{- Desc introduction -}
eval `⊤ᵈ = `⊤ᵈ
eval `Xᵈ = `Xᵈ
eval (`Πᵈ A D) = `Πᵈ (eval A) (eval D)
eval (`Σᵈ A D) = `Σᵈ (eval A) (eval D)

{- Value introduction -}
eval `tt = `tt
eval `true = `true
eval `false = `false
eval (a `, b) = eval a `, eval b
eval (`λ b) = `λ (eval b)
eval (`con x) = `con (eval x)

{- Value elimination -}
eval (`var i) = `neut (`var i)
eval (`if b `then c₁ `else c₂) = if eval b then eval c₁ else eval c₂
eval (f `$ a) = eval f $ eval a
eval (`proj₁ ab) = proj₁ (eval ab)
eval (`proj₂ ab) = proj₂ (eval ab)
eval (`elim⊥ bot) = elim⊥ (eval bot)
eval (`elimBool P pt pf b) = elimBool (eval P) (eval pt) (eval pf) (eval b)

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


lecture rough

lecture rough


Added missing ATP pragma.

Added missing ATP pragma.

Ignore-this: 35750d7ab3f49bf9ac17e50181c7427f

darcs-hash:20120430141705-3bd4e-97325bb46e704d3caa042733380b7157713d800a.gz

------------------------------------------------------------------------------
-- Non-intuitionistic logic theorems
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOL.NonIntuitionistic.TheoremsATP where

-- The ATPs work in classical logic, therefore we also can prove some
-- non-intuitionistic logic theorems.

open import FOL.Base hiding ( pem )

------------------------------------------------------------------------------
-- The principle of the excluded middle.
postulate pem : ∀ {A} → A ∨ ¬ A
{-# ATP prove pem #-}

-- The principle of indirect proof (proof by contradiction).
postulate ¬-elim : ∀ {A} → (¬ A → ⊥) → A
{-# ATP prove ¬-elim #-}

-- Double negation elimination.
postulate ¬¬-elim : ∀ {A} → ¬ ¬ A → A
{-# ATP prove ¬¬-elim #-}

-- The reductio ab absurdum rule. (Some authors uses this name for the
-- principle of indirect proof).
postulate raa : ∀ {A} → (¬ A → A) → A
{-# ATP prove raa #-}

-- ∃ in terms of ∀ and ¬.
postulate ¬∃¬→∀ : {A : D → Set} → ¬ (∃[ x ] ¬ A x) → ∀ {x} → A x
{-# ATP prove ¬∃¬→∀ #-}


Typos.

Typos.

Ignore-this: 7034a047e46c9c8ca3be2cfedf871eda

darcs-hash:20110719140945-3bd4e-31a13a583b7c766e5b96868fcd29d5d4f47d7234.gz

------------------------------------------------------------------------------
-- The map-iterate property: A property using coinduction
------------------------------------------------------------------------------

-- The map-iterate property [1]:
-- map f (iterate f x) = iterate f (f · x)

-- [1] Jeremy Gibbons and Graham Hutton. Proof methods for corecursive
-- programs. Fundamenta Informaticae, XX:1–14, 2005.

module FOTC.Program.MapIterate.MapIterateATP where

open import FOTC.Base

open import FOTC.Data.List
open import FOTC.Relation.Binary.Bisimilarity

------------------------------------------------------------------------------
-- The map-iterate property.

≈-map-iterate : (f x : D) → map f (iterate f x) ≈ iterate f (f · x)
≈-map-iterate f x = ≈-gfp₂ R (λ {xs} {ys} → helper xs ys) (x , refl , refl)
  where
  -- The relation R was based on the relation used by Eduardo Giménez
  -- and Pierre Castéran. A Tutorial on [Co-]Inductive Types in
  -- Coq. May 1998 -- August 17, 2007.
  R : D → D → Set
  R xs ys = ∃ (λ y → xs ≡ map f (iterate f y) ∧ ys ≡ iterate f (f · y))

  helper : ∀ xs ys → R xs ys → ∃ (λ x' → ∃ (λ xs' → ∃ (λ ys' →
             R xs' ys' ∧
             xs ≡ x' ∷ xs' ∧
             ys ≡ x' ∷ ys')))
  helper xs ys h = (f · y)
                   , (map f (iterate f (f · y)))
                   , (iterate f (f · (f · y)))
                   , ((f · y) , refl , refl)
                   , (trans xs≡map unfoldMap)
                   , trans ys≡iterate unfoldIterate
    where
    y : D
    y = ∃-proj₁ h

    xs≡map : xs ≡ map f (iterate f y)
    xs≡map = ∧-proj₁ (∃-proj₂ h)

    ys≡iterate : ys ≡ iterate f (f · y)
    ys≡iterate = ∧-proj₂ (∃-proj₂ h)

    postulate
      unfoldMap : map f (iterate f y) ≡ f · y ∷ map f (iterate f (f · y))
      unfoldIterate : iterate f (f · y) ≡ f · y ∷ iterate f (f · (f · y))
    {-# ATP prove unfoldMap #-}
    {-# ATP prove unfoldIterate #-}

------------------------------------------------------------------------------
-- The map-iterate property: A property using coinduction
------------------------------------------------------------------------------

-- The map-iterate property [1]:
-- map f (iterate f x) ≡ iterate f (f · x)

-- [1] Jeremy Gibbons and Graham Hutton. Proof methods for corecursive
-- programs. Fundamenta Informaticae, XX:1–14, 2005.

module FOTC.Program.MapIterate.MapIterateATP where

open import FOTC.Base

open import FOTC.Data.List
open import FOTC.Relation.Binary.Bisimilarity

------------------------------------------------------------------------------
-- The map-iterate property.

≈-map-iterate : (f x : D) → map f (iterate f x) ≈ iterate f (f · x)
≈-map-iterate f x = ≈-gfp₂ R (λ {xs} {ys} → helper xs ys) (x , refl , refl)
  where
  -- The relation R was based on the relation used by Eduardo Giménez
  -- Pierre Castéran. A Tutorial on [Co-]Inductive Types in Coq May
  -- 1998 -- August 17, 2007.
  R : D → D → Set
  R xs ys = ∃ (λ y → xs ≡ map f (iterate f y) ∧ ys ≡ iterate f (f · y))

  helper : ∀ xs ys → R xs ys → ∃ (λ x' → ∃ (λ xs' → ∃ (λ ys' →
             R xs' ys' ∧
             xs ≡ x' ∷ xs' ∧
             ys ≡ x' ∷ ys')))
  helper xs ys h = (f · y)
                   , (map f (iterate f (f · y)))
                   , (iterate f (f · (f · y)))
                   , ((f · y) , refl , refl)
                   , (trans xs≡map unfoldMap)
                   , trans ys≡iterate unfoldIterate
    where
    y : D
    y = ∃-proj₁ h

    xs≡map : xs ≡ map f (iterate f y)
    xs≡map = ∧-proj₁ (∃-proj₂ h)

    ys≡iterate : ys ≡ iterate f (f · y)
    ys≡iterate = ∧-proj₂ (∃-proj₂ h)

    postulate
      unfoldMap : map f (iterate f y) ≡ f · y ∷ map f (iterate f (f · y))
      unfoldIterate : iterate f (f · y) ≡ f · y ∷ iterate f (f · (f · y))
    {-# ATP prove unfoldMap #-}
    {-# ATP prove unfoldIterate #-}


Learn we can't prove change composition correct in this setting

--
-- In this module we conclude our proof: we have shown that t, derive-dterm t
-- and produce related values (in the sense of the fundamental property,
-- rfundamental3), and for related values v1, dv and v2 we have v1 ⊕ dv ≡
-- v2 (because ⊕ agrees with validity, rrelV3→⊕).
--
-- We now put these facts together via derive-correct-si and derive-correct.
-- This is immediate, even though I spend so much code on it:
-- Indeed, all theorems are immediate corollaries of what we established (as
-- explained above); only the statements are longer, especially because I bother
-- expanding them.

module Thesis.SIRelBigStep.DeriveCorrect where

open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Thesis.SIRelBigStep.IlcSILR
open import Thesis.SIRelBigStep.FundamentalProperty

-- Theorem statement. This theorem still mentions step-indexes explicitly.
derive-correct-si-type =
  ∀ {τ Γ k} (t : Term Γ τ) ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3-skeleton (λ v1 dv v2 _ → v1 ⊕ dv ≡ v2) t (derive-dterm t) t ρ1 dρ ρ2 k

-- A verified expansion of the theorem statement.
derive-correct-si-type-means :
  derive-correct-si-type ≡
  ∀ {τ Γ k} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  (v1 v2 : Val τ) →
  ∀ j (j<k : j < k) →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct-si-type-means = refl

derive-correct-si : derive-correct-si-type
derive-correct-si t ρ1 dρ ρ2 ρρ = rrelT3→⊕ t (derive-dterm t) t ρ1 dρ ρ2 (rfundamental3 _ t ρ1 dρ ρ2 ρρ)

-- Infinitely related environments:
rrelρ3-inf : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3-inf Γ ρ1 dρ ρ2 = ∀ k → rrelρ3 Γ ρ1 dρ ρ2 k

-- A theorem statement for infinitely-related environments. On paper, if we informally
-- omit the arbitrary derivation step-index as usual, we get a statement without
-- step-indexes.
derive-correct :
  ∀ {τ Γ} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3-inf Γ ρ1 dρ ρ2) →
  (v1 v2 : Val τ) →
  ∀ j →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct t ρ1 dρ ρ2 ρρ v1 v2 j = derive-correct-si t ρ1 dρ ρ2 (ρρ (suc j)) v1 v2 j ≤-refl

open import Data.Unit

nilρ : ∀ {Γ n} (ρ : ⟦ Γ ⟧Context) → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ dρ ρ n
nilV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n
nilV (closure t ρ) = let dρ , ρρ = nilρ ρ in dclosure (derive-dterm t) ρ dρ , rfundamental3svv _ (abs t) ρ dρ ρ ρρ
nilV (natV n₁) = dnatV zero , refl
nilV (pairV a b) = let 0a , aa = nilV a; 0b , bb = nilV b in dpairV 0a 0b , aa , bb

nilρ ∅ = ∅ , tt
nilρ (v • ρ) = let dv , vv = nilV v ; dρ , ρρ = nilρ ρ in dv • dρ , vv , ρρ

-- Try to prove to define validity-preserving change composition.
-- Sadly, if we don't store proofs that environment changes in closures are valid, we can't finish the proof for the closure case :-(.
-- Moreover, the proof is annoying to do unless we build a datatype to invert
-- validity proofs (as suggested by Ezyang in
-- http://blog.ezyang.com/2013/09/induction-and-logical-relations/).

-- ocomposeρ : ∀ {Γ} n ρ1 dρ1 ρ2 dρ2 ρ3 → rrelρ3 Γ ρ1 dρ1 ρ2 n → rrelρ3 Γ ρ2 dρ2 ρ3 n → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ1 dρ ρ3 n

-- ocomposev : ∀ {τ} n v1 dv1 v2 dv2 v3 → rrelV3 τ v1 dv1 v2 n → rrelV3 τ v2 dv2 v3 n → Σ[ dv ∈ DVal τ ] rrelV3 τ v1 dv v3 n
-- ocomposev n v1 dv1 v2 (bang v3) .v3 vv1 refl = bang v3 , refl
-- ocomposev n v1 (bang x) v2 (dclosure dt ρ dρ) v3 vv1 vv2 = {!!}
-- ocomposev n (closure t ρ) (dclosure .(derive-dterm t) .ρ dρ1) (closure .t .(ρ ⊕ρ dρ1)) (dclosure .(derive-dterm t) .(ρ ⊕ρ dρ1) dρ2) (closure .t .((ρ ⊕ρ dρ1) ⊕ρ dρ2)) ((refl , refl) , refl , refl , refl , refl , p5) ((refl , refl) , refl , refl , refl , refl , p5q) =
--   let dρ , ρρ = ocomposeρ n ρ dρ1 (ρ ⊕ρ dρ1) dρ2 ((ρ ⊕ρ dρ1) ⊕ρ dρ2) {!!} {!!}
--   in dclosure (derive-dterm t) ρ dρ , (refl , refl) , refl , {!!} , refl , refl ,
--     λ { k (s≤s k<n) v1 dv v2 vv →
--       rfundamental3 k t (v1 • ρ) (dv • dρ) (v2 • ((ρ ⊕ρ dρ1) ⊕ρ dρ2)) (vv , rrelρ3-mono k n (≤-step k<n) _ ρ dρ ((ρ ⊕ρ dρ1) ⊕ρ dρ2) ρρ)}
-- -- p1 , p2 , p3 , p4 , p5
-- ocomposev n v1 dv1 v2 (dnatV n₁) v3 vv1 vv2 = {!!}
-- ocomposev n v1 dv1 v2 (dpairV dv2 dv3) v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (bang v2) .v2 dv2 v3 refl vv2 = bang (v2 ⊕ dv2) , rrelV3→⊕ v2 dv2 v3 vv2
-- -- ocomposev n v1 (dclosure dt ρ dρ) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dnatV n₁) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dpairV dv1 dv2) v2 dv3 v3 vv1 vv2 = {!!}
-- -- ocomposeV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n

-- ocomposeρ {∅} n ∅ dρ1 ρ2 dρ2 ∅ ρρ1 ρρ2 = ∅ , tt
-- ocomposeρ {τ • Γ} n (v1 • ρ1) (dv1 • dρ1) (v2 • ρ2) (dv2 • dρ2) (v3 • ρ3) (vv1 , ρρ1) (vv2 , ρρ2) =
--   let dv , vv = ocomposev n v1 dv1 v2 dv2 v3 vv1 vv2
--       dρ , ρρ = ocomposeρ n ρ1 dρ1 ρ2 dρ2 ρ3 ρρ1 ρρ2
--   in  dv • dρ , vv , ρρ

-- But we sort of know how to store environments validity proofs in closures, you just need to use well-founded inductions, even if you're using types. Sad, yes, that's insanely tedious. Let's leave that to Coq.
-- What is also interesting: if that were fixed, could we prove correct
-- composition for change *terms* and rrelT3? And for *open expressions*? The
-- last is the main problem Ahmed run into.


proved that indets arent errors #14

proved that indets arent errors #14

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- boxed values and indeterminates are disjoint
  vi : ∀{d} → d boxedval → d indet → ⊥
  vi (BVVal VConst) ()
  vi (BVVal VLam) ()
  vi (BVArrCast x bv) (ICastArr x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastGroundHole x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = vi bv ind

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter (CECong eps er)) = {!!}
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong x₁ er) = {!!}
  ve (BVVal x) (CECong x₁ er) = ve (lem-valfill x x₁) er
    where
    lem-valfill : ∀{ε d d'} → d val → d == ε ⟦ d' ⟧ → d' boxedval
    lem-valfill VConst FHOuter = BVVal VConst
    lem-valfill VLam FHOuter = BVVal VLam

  -- boxed values and expressions that step are disjoint
  vs : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  vs (BVVal VConst) (d' , Step FHOuter () x₃)
  vs (BVVal VLam) (d' , Step FHOuter () x₃)
  vs (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  vs (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)
  vs (BVHoleCast x bv) (d' , Step FHOuter x₂ FHOuter) = {!x₂!} -- cyrus
  vs (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- todo: there's something going on with these lemmas here that's
    -- repetative and i don't quite understand how to make it more compact

    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err
    ie (INEHole x) (CECong FHOuter err) = fe x (lem err)
      where
      lem : ∀{d u σ} → ⦇ d ⦈⟨ u , σ ⟩ casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHNEHole x₁) ce) = CECong x₁ ce
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err)
      with lem err
      where
      lem : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
      lem (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)
    ... | Inl d1err = ie indet d1err
    ... | Inr d2err = fe x₁ d2err
      where
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
      lem (CECastFail x₁ x₂ () x₄)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = ie indet (lem err x)
      where
      lem : ∀{d τ} → (d ⟨ ⦇⦈ ⇒ τ ⟩) casterr → ((d' : dhexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇⦈ ⟩)) → d casterr
      lem (CECastFail x₂ x₃ x₄ x₅) f = abort (f _ _ refl)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₂) ce) _ = CECong x₂ ce
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    fe : ∀{d} → d final → d casterr → ⊥
    fe (FBoxed x) err = ve x err
    fe (FIndet x) err = ie x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = vi x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole x ind) stp = {!!}
  lem2 (ICastHoleGround x ind x₁) stp = {!!}

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁) = {!!} -- cyrus

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 x FHOuter = x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    is : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    is IEHole (d' , Step FHOuter () FHOuter)
    is (INEHole x) (d' , Step FHOuter () FHOuter)
    is (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    is (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    is (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    is (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = is ind (_ , Step x₂ x₃ x₄)
    is (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = fs f (_ , Step x₃ x₄ x₆)
    is (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    is (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FBoxed x)) FHOuter) = vi x ind
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FIndet x)) FHOuter) = {!!} -- cyrus
    is (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    is (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    is (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)

    fs : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    fs (FBoxed x) stp = vs x stp
    fs (FIndet x) stp = is x stp

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  es er stp = {!!}

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- boxed values and indeterminates are disjoint
  vi : ∀{d} → d boxedval → d indet → ⊥
  vi (BVVal VConst) ()
  vi (BVVal VLam) ()
  vi (BVArrCast x bv) (ICastArr x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastGroundHole x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = vi bv ind

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter (CECong eps er)) = {!!}
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong x₁ er) = {!!}
  ve (BVVal x) (CECong x₁ er) = ve (lem-valfill x x₁) er
    where
    lem-valfill : ∀{ε d d'} → d val → d == ε ⟦ d' ⟧ → d' boxedval
    lem-valfill VConst FHOuter = BVVal VConst
    lem-valfill VLam FHOuter = BVVal VLam

  -- boxed values and expressions that step are disjoint
  vs : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  vs (BVVal VConst) (d' , Step FHOuter () x₃)
  vs (BVVal VLam) (d' , Step FHOuter () x₃)
  vs (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  vs (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)
  vs (BVHoleCast x bv) (d' , Step FHOuter x₂ FHOuter) = {!x₂!} -- cyrus
  vs (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- todo: there's something going on with these lemmas here that's
    -- repetative and i don't quite understand how to make it more compact

    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err
    ie (INEHole x) (CECong FHOuter err) = fe x (lem err)
      where
      lem : ∀{d u σ} → ⦇ d ⦈⟨ u , σ ⟩ casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHNEHole x₁) ce) = CECong x₁ ce
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err)
      with lem err
      where
      lem : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
      lem (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)
    ... | Inl d1err = ie indet d1err
    ... | Inr d2err = fe x₁ d2err
      where
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
      lem (CECastFail x₁ x₂ () x₄)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ} → (d ⟨ ⦇⦈ ⇒ τ ⟩) casterr → d casterr
      lem (CECastFail x₂ x₃ x₄ x₅) = {!!}
      lem (CECong x₂ ce) = {!!}
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    fe : ∀{d} → d final → d casterr → ⊥
    fe (FBoxed x) err = ve x err
    fe (FIndet x) err = ie x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = vi x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole x ind) stp = {!!}
  lem2 (ICastHoleGround x ind x₁) stp = {!!}

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁) = {!!} -- cyrus

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 x FHOuter = x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    is : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    is IEHole (d' , Step FHOuter () FHOuter)
    is (INEHole x) (d' , Step FHOuter () FHOuter)
    is (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    is (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    is (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    is (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = is ind (_ , Step x₂ x₃ x₄)
    is (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = fs f (_ , Step x₃ x₄ x₆)
    is (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    is (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FBoxed x)) FHOuter) = vi x ind
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround (FIndet x)) FHOuter) = {!!} -- cyrus
    is (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    is (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    is (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)

    fs : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    fs (FBoxed x) stp = vs x stp
    fs (FIndet x) stp = is x stp

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  es er stp = {!!}


Added indDom.

Added indDom.

Ignore-this: 4caeff32954b707404a01a96a0c95c86

darcs-hash:20110405194626-3bd4e-f1bde760aba5296a166fe70f48370dd068760c5f.gz

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- Inductive principle associated to the domain predicate.
indDom : (P : D → Set) →
         P zero →
         (∀ {d} → Dom d → P d → Dom (nest d) → P (nest d) → P (succ d)) →
         ∀ {d} → Dom d → P d
indDom P P0 ih dom0           = P0
indDom P P0 ih (domS d h₁ h₂) = ih h₁ (indDom P P0 ih h₁) h₂ (indDom P P0 ih h₂)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 zN      = nest-0
nest-x≡0 (sN {n} Nn) =
  begin
    nest (succ n)
      ≡⟨ nest-S n ⟩
    nest (nest n)
      ≡⟨ subst (λ t → nest (nest n) ≡ nest t)
               (nest-x≡0 Nn)  -- IH.
               refl
      ⟩
    nest zero
      ≡⟨ nest-0 ⟩
    zero
  ∎

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-DN : ∀ {d} → Dom d → N (nest d)
nest-DN dom0           = subst N (sym nest-0) zN
nest-DN (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-DN h₂)

-- The nest function is total.
nest-N : ∀ {n} → N n → N (nest n)
nest-N Nn = subst N (sym (nest-x≡0 Nn)) zN

nest-≤ : ∀ {n} → Dom n → LE (nest n) n
nest-≤ dom0 =
  begin
    nest zero ≤ zero
      ≡⟨ subst (λ t → nest zero ≤ zero ≡ t ≤ zero)
               nest-0
               refl
      ⟩
    zero ≤ zero
      ≡⟨ x≤x zN ⟩
    true
  ∎

nest-≤ (domS n h₁ h₂) =
  ≤-trans (nest-N (sN (dom-N n h₁))) (nest-N (dom-N n h₁)) (sN Nn) prf₁ prf₂
    where
      Nn : N n
      Nn = dom-N n h₁

      prf₁ : LE (nest (succ n)) (nest n)
      prf₁ =
        begin
          nest (succ n) ≤ nest n
            ≡⟨ subst (λ t → nest (succ n) ≤ nest n ≡ t ≤ nest n)
                     (nest-S n)
                     refl
            ⟩
          nest (nest n) ≤ nest n
            ≡⟨ nest-≤ h₂ ⟩
          true
          ∎

      prf₂ : LE (nest n) (succ n)
      prf₂ = ≤-trans (nest-N (dom-N n h₁)) Nn (sN Nn) (nest-≤ h₁) (x≤Sx Nn)

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h =
      domS x dn-x (h (nest-N Nx ) (x≤y→x<Sy (nest-N Nx) Nx (nest-≤ dn-x)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 zN      = nest-0
nest-x≡0 (sN {n} Nn) =
  begin
    nest (succ n)
      ≡⟨ nest-S n ⟩
    nest (nest n)
      ≡⟨ subst (λ t → nest (nest n) ≡ nest t)
               (nest-x≡0 Nn)  -- IH.
               refl
      ⟩
    nest zero
      ≡⟨ nest-0 ⟩
    zero
  ∎

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-DN : ∀ {d} → Dom d → N (nest d)
nest-DN dom0           = subst N (sym nest-0) zN
nest-DN (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-DN h₂)

-- The nest function is total.
nest-N : ∀ {n} → N n → N (nest n)
nest-N Nn = subst N (sym (nest-x≡0 Nn)) zN

nest-≤ : ∀ {n} → Dom n → LE (nest n) n
nest-≤ dom0 =
  begin
    nest zero ≤ zero
      ≡⟨ subst (λ t → nest zero ≤ zero ≡ t ≤ zero)
               nest-0
               refl
      ⟩
    zero ≤ zero
      ≡⟨ x≤x zN ⟩
    true
  ∎

nest-≤ (domS n h₁ h₂) =
  ≤-trans (nest-N (sN (dom-N n h₁))) (nest-N (dom-N n h₁)) (sN Nn) prf₁ prf₂
    where
      Nn : N n
      Nn = dom-N n h₁

      prf₁ : LE (nest (succ n)) (nest n)
      prf₁ =
        begin
          nest (succ n) ≤ nest n
            ≡⟨ subst (λ t → nest (succ n) ≤ nest n ≡ t ≤ nest n)
                     (nest-S n)
                     refl
            ⟩
          nest (nest n) ≤ nest n
            ≡⟨ nest-≤ h₂ ⟩
          true
          ∎

      prf₂ : LE (nest n) (succ n)
      prf₂ = ≤-trans (nest-N (dom-N n h₁)) Nn (sN Nn) (nest-≤ h₁) (x≤Sx Nn)

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h =
      domS x dn-x (h (nest-N Nx ) (x≤y→x<Sy (nest-N Nx) Nx (nest-≤ dn-x)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)


Fixed issue #5 (in Agda).

Fixed issue #5 (in Agda).

------------------------------------------------------------------------------
-- ABP lemma 2
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2ATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.List
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for the ABP lemma 2

module Helper where
  -- We have these definitions outside the where clause to keep them
  -- simple for the ATPs.

  ds⁵ : D → D → D
  ds⁵ cs' os₁⁵ = corrupt · os₁⁵ · cs'
  {-# ATP definition ds⁵ #-}

  as⁵ : D → D → D → D → D → D
  as⁵ b i' is' cs' os₁⁵ = await b i' is' (ds⁵ cs' os₁⁵)
  {-# ATP definition as⁵ #-}

  bs⁵ : D → D → D → D → D → D → D
  bs⁵ b i' is' cs' os₀⁵ os₁⁵ = corrupt · os₀⁵ · as⁵ b i' is' cs' os₁⁵
  {-# ATP definition bs⁵ #-}

  cs⁵ : D → D → D → D → D → D → D
  cs⁵ b i' is' cs' os₀⁵ os₁⁵ = ack · not b · bs⁵ b i' is' cs' os₀⁵ os₁⁵
  {-# ATP definition cs⁵ #-}

  os₀⁵ : D → D
  os₀⁵ os₀' = tail₁ os₀'
  {-# ATP definition os₀⁵ #-}

  os₁⁵ : D → D → D
  os₁⁵ ft₁ os₁'' = ft₁ ++ os₁''
  {-# ATP definition os₁⁵ #-}

  helper : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
           Bit b →
           Fair os₀' →
           ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
           ∃[ ft₁ ] ∃[ os₁'' ] F*T ft₁ ∧ Fair os₁'' ∧ os₁' ≡ ft₁ ++ os₁'' →
           ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₀''
           ∧ Fair os₁''
           ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
  helper {b} {i'} {is'} {js' = js'} Bb Fos₀' abp'
         (.(T ∷ []) , os₁'' , f*tnil , Fos₁'' , os₁'-eq) = prf
    where
    postulate
      prf : ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
            Fair os₀''
            ∧ Fair os₁''
            ∧ as'' ≡ send · not b · is' · ds''
            ∧ bs'' ≡ corrupt · os₀'' · as''
            ∧ cs'' ≡ ack · not b · bs''
            ∧ ds'' ≡ corrupt · os₁'' · cs''
            ∧ js'  ≡ out · not b · bs''
    {-# ATP prove prf #-}

  helper {b} {i'} {is'} {os₀'} {os₁'} {as'} {bs'} {cs'} {ds'} {js'}
         Bb Fos₀' abp'
         (.(F ∷ ft₁) , os₁'' , f*tcons {ft₁} FTft₁ , Fos₁'' , os₁'-eq)
         = helper Bb (tail-Fair Fos₀') ABP'IH (ft₁ , os₁'' , FTft₁ , Fos₁'' , refl)
    where
    postulate os₁'-eq-helper : os₁' ≡ F ∷ os₁⁵ ft₁ os₁''
    {-# ATP prove os₁'-eq-helper #-}

    postulate ds'-eq : ds' ≡ error ∷ ds⁵ cs' (os₁⁵ ft₁ os₁'')
    {-# ATP prove ds'-eq os₁'-eq-helper #-}

    postulate as'-eq : as' ≡ < i' , b > ∷ as⁵ b i' is' cs' (os₁⁵ ft₁ os₁'')
    {-# ATP prove as'-eq #-}

    postulate
      bs'-eq-helper₁ : os₀' ≡ T ∷ tail₁ os₀' →
                       bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove bs'-eq-helper₁ as'-eq #-}

    postulate
      bs'-eq-helper₂ : os₀' ≡ F ∷ tail₁ os₀' →
                       bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove bs'-eq-helper₂ as'-eq #-}

    bs'-eq : bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
             ∨ bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    bs'-eq = case (λ h → inj₁ (bs'-eq-helper₁ h))
                  (λ h → inj₂ (bs'-eq-helper₂ h))
                  (head-tail-Fair Fos₀')

    postulate
      cs'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       cs' ≡ b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove cs'-eq-helper₁ not-x≢x not-involutive #-}

    postulate
      cs'-eq-helper₂ : bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       cs' ≡ b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove cs'-eq-helper₂ not-involutive #-}

    cs'-eq : cs' ≡ b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

    postulate
      js'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       js' ≡ out · not b
                                 · bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove js'-eq-helper₁ not-x≢x #-}

    postulate
      js'-eq-helper₂ : bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       js' ≡ out · not b
                                 · bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove js'-eq-helper₂ #-}

    js'-eq : js' ≡ out · not b · bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    js'-eq = case js'-eq-helper₁ js'-eq-helper₂ bs'-eq

    postulate ds⁵-eq : ds⁵ cs' (os₁⁵ ft₁ os₁'') ≡
                       corrupt · (os₁⁵ ft₁ os₁'')
                               · (b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁''))

    ABP'IH : ABP' b i' is'
                  (os₀⁵ os₀')
                  (os₁⁵ ft₁ os₁'')
                  (as⁵ b i' is' cs' (os₁⁵ ft₁ os₁''))
                  (bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁''))
                  (cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁''))
                  (ds⁵ cs' (os₁⁵ ft₁ os₁''))
                  js'
    ABP'IH = ds⁵-eq , refl , refl , refl , js'-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈
-- Fair, and hence by unfolding Fair we conclude that there are ft₁ :
-- F*T and os₁'' : Fair, such that os₁' = ft₁ ++ os₁''.
--
-- We proceed by induction on ft₁ : F*T using helper.

open Helper
lemma₂ : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₀' →
         Fair os₁' →
         ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
         ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
         Fair os₀''
         ∧ Fair os₁''
         ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
lemma₂ Bb Fos₀' Fos₁' abp' = helper Bb Fos₀' abp' (Fair-unf Fos₁')

------------------------------------------------------------------------------
-- ABP lemma 2
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2ATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.List
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for the ABP lemma 2

module Helper where
  -- We have these definitions outside the where clause to keep them
  -- simple for the ATPs.

  ds⁵ : D → D → D
  ds⁵ cs' os₁⁵ = corrupt · os₁⁵ · cs'
  {-# ATP definition ds⁵ #-}

  as⁵ : D → D → D → D → D → D
  as⁵ b i' is' cs' os₁⁵ = await b i' is' (ds⁵ cs' os₁⁵)
  {-# ATP definition as⁵ #-}

  bs⁵ : D → D → D → D → D → D → D
  bs⁵ b i' is' cs' os₀⁵ os₁⁵ = corrupt · os₀⁵ · as⁵ b i' is' cs' os₁⁵
  {-# ATP definition bs⁵ #-}

  cs⁵ : D → D → D → D → D → D → D
  cs⁵ b i' is' cs' os₀⁵ os₁⁵ = ack · not b · bs⁵ b i' is' cs' os₀⁵ os₁⁵
  {-# ATP definition cs⁵ #-}

  os₀⁵ : D → D
  os₀⁵ os₀' = tail₁ os₀'
  {-# ATP definition os₀⁵ #-}

  os₁⁵ : D → D → D
  os₁⁵ ft₁ os₁'' = ft₁ ++ os₁''
  {-# ATP definition os₁⁵ #-}

  helper : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
           Bit b →
           Fair os₀' →
           ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
           ∃[ ft₁ ] ∃[ os₁'' ] F*T ft₁ ∧ Fair os₁'' ∧ os₁' ≡ ft₁ ++ os₁'' →
           ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₀''
           ∧ Fair os₁''
           ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
  helper {b} {i'} {is'} {js' = js'} Bb Fos₀' abp'
         (.(T ∷ []) , os₁'' , f*tnil , Fos₁'' , os₁'-eq) = prf
    where
    postulate
      prf : ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
            Fair os₀''
            ∧ Fair os₁''
            ∧ as'' ≡ send · not b · is' · ds''
            ∧ bs'' ≡ corrupt · os₀'' · as''
            ∧ cs'' ≡ ack · not b · bs''
            ∧ ds'' ≡ corrupt · os₁'' · cs''
            ∧ js'  ≡ out · not b · bs''
    {-# ATP prove prf #-}

  helper {b} {i'} {is'} {os₀'} {os₁'} {as'} {bs'} {cs'} {ds'} {js'}
         Bb Fos₀' abp'
         (.(F ∷ ft₁) , os₁'' , f*tcons {ft₁} FTft₁ , Fos₁'' , os₁'-eq)
         = helper Bb (tail-Fair Fos₀') ABP'IH (ft₁ , os₁'' , FTft₁ , Fos₁'' , refl)
    where
    postulate os₁'-eq-helper : os₁' ≡ F ∷ os₁⁵ ft₁ os₁''
    {-# ATP prove os₁'-eq-helper #-}

    postulate ds'-eq : ds' ≡ error ∷ ds⁵ cs' (os₁⁵ ft₁ os₁'')
    {-# ATP prove ds'-eq os₁'-eq-helper #-}

    postulate as'-eq : as' ≡ < i' , b > ∷ as⁵ b i' is' cs' (os₁⁵ ft₁ os₁'')
    {-# ATP prove as'-eq #-}

    postulate
      bs'-eq-helper₁ : os₀' ≡ T ∷ tail₁ os₀' →
                       bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove bs'-eq-helper₁ as'-eq #-}

    postulate
      bs'-eq-helper₂ : os₀' ≡ F ∷ tail₁ os₀' →
                       bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove bs'-eq-helper₁ as'-eq #-}

    bs'-eq : bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
             ∨ bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    bs'-eq = case (λ h → inj₁ (bs'-eq-helper₁ h))
                  (λ h → inj₂ (bs'-eq-helper₂ h))
                  (head-tail-Fair Fos₀')

    postulate
      cs'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       cs' ≡ b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove cs'-eq-helper₁ not-x≢x not-involutive #-}

    postulate
      cs'-eq-helper₂ : bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       cs' ≡ b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove cs'-eq-helper₂ not-involutive #-}

    cs'-eq : cs' ≡ b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

    postulate
      js'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       js' ≡ out · not b
                                 · bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove js'-eq-helper₁ not-x≢x #-}

    postulate
      js'-eq-helper₂ : bs' ≡ error ∷ bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'') →
                       js' ≡ out · not b
                                 · bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    {-# ATP prove js'-eq-helper₂ #-}

    js'-eq : js' ≡ out · not b · bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁'')
    js'-eq = case js'-eq-helper₁ js'-eq-helper₂ bs'-eq

    postulate ds⁵-eq : ds⁵ cs' (os₁⁵ ft₁ os₁'') ≡
                       corrupt · (os₁⁵ ft₁ os₁'')
                               · (b ∷ cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁''))

    ABP'IH : ABP' b i' is'
                  (os₀⁵ os₀')
                  (os₁⁵ ft₁ os₁'')
                  (as⁵ b i' is' cs' (os₁⁵ ft₁ os₁''))
                  (bs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁''))
                  (cs⁵ b i' is' cs' (os₀⁵ os₀') (os₁⁵ ft₁ os₁''))
                  (ds⁵ cs' (os₁⁵ ft₁ os₁''))
                  js'
    ABP'IH = ds⁵-eq , refl , refl , refl , js'-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈
-- Fair, and hence by unfolding Fair we conclude that there are ft₁ :
-- F*T and os₁'' : Fair, such that os₁' = ft₁ ++ os₁''.
--
-- We proceed by induction on ft₁ : F*T using helper.

open Helper
lemma₂ : ∀ {b i' is' os₀' os₁' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₀' →
         Fair os₁' →
         ABP' b i' is' os₀' os₁' as' bs' cs' ds' js' →
         ∃[ os₀'' ] ∃[ os₁'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
         Fair os₀''
         ∧ Fair os₁''
         ∧ ABP (not b) is' os₀'' os₁'' as'' bs'' cs'' ds'' js'
lemma₂ Bb Fos₀' Fos₁' abp' = helper Bb Fos₀' abp' (Fair-unf Fos₁')