Remove spurious imports

Remove spurious imports

Old-commit-hash: fc57d2d6ee3ff6f548c16e7073aeb6ae12646d85

import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Context.Context {Type.Type B} → Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Syntax.Context.Plotkin B

-- Declarations of Term and Terms to enable mutual recursion
data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

-- (Term Γ τ) represents a term of type τ
-- with free variables bound in Γ.
data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

-- (Terms Γ Σ) represents a list of terms with types from Σ
-- with free variables bound in Γ.
data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

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

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

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

weakenAll Γ₁≼Γ₂ ∅ = ∅
weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ 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 : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → 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 : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
curriedConst constant = curryTermConstructor (uncurriedConst constant)

import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Context.Context {Type.Type B} → Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Denotation.Environment Type
open import Syntax.Context.Plotkin B

-- Declarations of Term and Terms to enable mutual recursion
data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

-- (Term Γ τ) represents a term of type τ
-- with free variables bound in Γ.
data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

-- (Terms Γ Σ) represents a list of terms with types from Σ
-- with free variables bound in Γ.
data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

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

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

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

weakenAll Γ₁≼Γ₂ ∅ = ∅
weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ 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 : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → 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 : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
curriedConst constant = curryTermConstructor (uncurriedConst constant)


Prototype proof that static caching is type-correct

See comments for extra info.

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Standard evaluation (Def. 3.3 and Fig. 4i)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value

module Parametric.Denotation.Evaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality
open import Theorem.CongApp
open import Postulate.Extensionality

-- Extension Point: Evaluation of fully applied constants.
Structure : Set
Structure = ∀ {Σ τ} → Const Σ τ → ⟦ Σ ⟧ → ⟦ τ ⟧

module Structure (⟦_⟧Const : Structure) where
  ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧

  ⟦_⟧Terms : ∀ {Γ Σ} → Terms Γ Σ → ⟦ Γ ⟧ → ⟦ Σ ⟧

  -- We provide: Evaluation of arbitrary terms.
  ⟦ const c args ⟧Term ρ = ⟦ c ⟧Const (⟦ args ⟧Terms ρ)
  ⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
  ⟦ app s t ⟧Term ρ = (⟦ s ⟧Term ρ) (⟦ t ⟧Term ρ)
  ⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)

  -- this is what we'd like to write.
  -- unfortunately termination checker complains.
  --
  --   ⟦ terms ⟧Terms ρ = map (λ t → ⟦ t ⟧Term ρ) terms
  --
  -- so we do explicit pattern matching instead.
  ⟦ ∅ ⟧Terms ρ = ∅
  ⟦ s • terms ⟧Terms ρ = ⟦ s ⟧Term ρ • ⟦ terms ⟧Terms ρ

  meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
  meaningOfTerm = meaning ⟦_⟧Term

  weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
    (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken Γ₁≼Γ₂ t ⟧ ρ ≡ ⟦ t ⟧ (⟦ Γ₁≼Γ₂ ⟧ ρ)

  weaken-terms-sound : ∀ {Γ₁ Γ₂ Σ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
    (terms : Terms Γ₁ Σ) (ρ : ⟦ Γ₂ ⟧) →
    ⟦ weaken-terms Γ₁≼Γ₂ terms ⟧Terms ρ ≡ ⟦ terms ⟧Terms (⟦ Γ₁≼Γ₂ ⟧ ρ)

  weaken-terms-sound ∅ ρ = refl
  weaken-terms-sound (t • terms) ρ =
    cong₂ _•_ (weaken-sound t ρ) (weaken-terms-sound terms ρ)

  weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weaken-var-sound Γ₁≼Γ₂ x ρ
  weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
  weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
  weaken-sound {Γ₁} {Γ₂} {Γ₁≼Γ₂ = Γ₁≼Γ₂} (const {Σ} {τ} c args) ρ =
    cong ⟦ c ⟧Const (weaken-terms-sound args ρ)

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but instead of producing object language terms, we
  -- produce host language terms to take advantage of the richer type system of
  -- the host language (in particular, here we need the unit type, product types
  -- and *existentials*).
  -}
  open import Data.Product hiding (map)
  open import Data.Unit

  -- A semantics for empty caching semantics
  ⟦_⟧Type2 : (τ : Type) → Set
  ⟦ base ι ⟧Type2 = ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧Type2 = ⟦ σ ⟧Type → (⟦ τ ⟧Type × ⊤)

  open import Level

  {-
  -- Hidden cache semantics, try 1.
  --
  -- Wrong: even the inputs should be extended.
  -- It's just that extension on base values does nothing interesting.

  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache =  ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )
  -- This type would be cooler, but it also places "excessive" requirements on
  -- the object language compared to what we formalize - e.g., unit types.
  --
  --⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Type ] ⟦ τ ⟧Type × ⟦ τ₁ ⟧Type )

  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache
  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → ⊤ , (extend (v x) , tt)

  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v x)))

  -- Wrong type signature:
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = {!!}
  -- Oh. We don't even know what to return without matching on the type. That's
  -- also true in our term transformation: we need to eta-expand also
  -- non-primitives (higher-order arguments) for everything to possibly work.
  -- Hm... or we need to have extended values in the environment - where the extension is again just for functions.
  ⟦_⟧TermCache (var x) ρ = extend (⟦ var x ⟧ ρ)
  -- XXX: this delegates to standard evaluation, I'm not sure whether we should do that.
  -- In fact, we should use our evaluation and select from the result.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧Term ρ)))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache (x • ρ) , tt)

  -- Wrong type definitions: functions get argument of transformed types.
  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = {!!}
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (dropCache (⟦ t ⟧TermCache2 ρ))))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache2 (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache2 ((extend x) • ρ) , tt)
  -}

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → ⊤ , (extend (v (dropCache x)) , tt)

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (⟦ t ⟧TermCache2 ρ)))
  -- Provide an empty cache!
  ⟦_⟧TermCache2 (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache2 (x • ρ) , tt)


Fix Preorder-Reasoning and Setoid-Reasoning

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

open import Level
open import Relation.Binary public
import Relation.Binary.PropositionalEquality as PropEq

-- could this be moved in place of Trans is Relation.Binary.Core
Trans' : ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c} →
        REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _
Trans' P Q R = ∀ {i j k} (x : P i j) (xs : Q j k) → R i k

substitutive-to-reflexive : ∀ {a ℓ ℓ'} {A : Set a} {≈ : Rel A ℓ} {≡ : Rel A ℓ'}
                            → Substitutive ≡ ℓ → Reflexive ≈ → ≡ ⇒ ≈
substitutive-to-reflexive {≈ = ≈} ≡-subst ≈-refl xᵣ = ≡-subst (≈ _) xᵣ ≈-refl

substitutive⇒≡ : ∀ {a ℓ} {A : Set a} {≡ : Rel A ℓ} → Substitutive ≡ a → ≡ ⇒ PropEq._≡_
substitutive⇒≡ subst = substitutive-to-reflexive {≈ = PropEq._≡_} subst PropEq.refl

record Equality {a ℓ} {A : Set a} (_≡_ : Rel A ℓ) : Set (suc a ⊔ ℓ) where
  field
    isEquivalence : IsEquivalence _≡_
    subst : Substitutive _≡_ a

  open IsEquivalence isEquivalence public

  to-reflexive : ∀ {≈} → Reflexive ≈ → _≡_ ⇒ ≈
  to-reflexive = substitutive-to-reflexive subst

  to-propositional : _≡_ ⇒ PropEq._≡_
  to-propositional = substitutive⇒≡ subst

-- Equational reasoning combinators.

module Trans-Reasoning {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) (trans : Transitive _≈_) where

  infix  2 finally
  infixr 2 _≈⟨_⟩_

  _≈⟨_⟩_ : ∀ x {y z : A} → x ≈ y → y ≈ z → x ≈ z
  _ ≈⟨ x≈y ⟩ y≈z = trans x≈y y≈z

  -- When there is no reflexivty available this
  -- combinator can be used to end the reasoning.
  finally : ∀ (x y : A) → x ≈ y → x ≈ y
  finally _ _ x≈y = x≈y

  syntax finally x y x≈y = x ≈⟨ x≈y ⟩∎ y ∎

module Equivalence-Reasoning
         {a ℓ} {A : Set a} {_≈_ : Rel A ℓ}
         (E : IsEquivalence _≈_) where
  open IsEquivalence E
  open Trans-Reasoning _≈_ trans public hiding (finally)

  infix  2 _∎

  _∎ : ∀ x → x ≈ x
  _ ∎ = refl

module Preorder-Reasoning
         {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where
  open Preorder P
  open Trans-Reasoning _∼_ trans public hiding (finally) renaming (_≈⟨_⟩_ to _∼⟨_⟩_)
  open Equivalence-Reasoning isEquivalence public renaming (_∎ to _☐)

  infix  2 _∎

  _∎ : ∀ x → x ∼ x
  _ ∎ = refl

module Setoid-Reasoning {a ℓ} (s : Setoid a ℓ) where
  open Equivalence-Reasoning (Setoid.isEquivalence s) public

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

open import Level
open import Relation.Binary public
import Relation.Binary.PropositionalEquality as PropEq

-- could this be moved in place of Trans is Relation.Binary.Core
Trans' : ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c} →
        REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _
Trans' P Q R = ∀ {i j k} (x : P i j) (xs : Q j k) → R i k

substitutive-to-reflexive : ∀ {a ℓ ℓ'} {A : Set a} {≈ : Rel A ℓ} {≡ : Rel A ℓ'}
                            → Substitutive ≡ ℓ → Reflexive ≈ → ≡ ⇒ ≈
substitutive-to-reflexive {≈ = ≈} ≡-subst ≈-refl xᵣ = ≡-subst (≈ _) xᵣ ≈-refl

substitutive⇒≡ : ∀ {a ℓ} {A : Set a} {≡ : Rel A ℓ} → Substitutive ≡ a → ≡ ⇒ PropEq._≡_
substitutive⇒≡ subst = substitutive-to-reflexive {≈ = PropEq._≡_} subst PropEq.refl

record Equality {a ℓ} {A : Set a} (_≡_ : Rel A ℓ) : Set (suc a ⊔ ℓ) where
  field
    isEquivalence : IsEquivalence _≡_
    subst : Substitutive _≡_ a

  open IsEquivalence isEquivalence public

  to-reflexive : ∀ {≈} → Reflexive ≈ → _≡_ ⇒ ≈
  to-reflexive = substitutive-to-reflexive subst

  to-propositional : _≡_ ⇒ PropEq._≡_
  to-propositional = substitutive⇒≡ subst

-- Equational reasoning combinators.

module Trans-Reasoning {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) (trans : Transitive _≈_) where

  infix  2 finally
  infixr 2 _≈⟨_⟩_

  _≈⟨_⟩_ : ∀ x {y z : A} → x ≈ y → y ≈ z → x ≈ z
  _ ≈⟨ x≈y ⟩ y≈z = trans x≈y y≈z

  -- When there is no reflexivty available this
  -- combinator can be used to end the reasoning.
  finally : ∀ (x y : A) → x ≈ y → x ≈ y
  finally _ _ x≈y = x≈y

  syntax finally x y x≈y = x ≈⟨ x≈y ⟩∎ y ∎

module Equivalence-Reasoning
         {a ℓ} {A : Set a} {_≈_ : Rel A ℓ}
         (E : IsEquivalence _≈_) where
  open IsEquivalence E
  open Trans-Reasoning _≈_ trans public hiding (finally)

  infix  2 _∎

  _∎ : ∀ x → x ≈ x
  _ ∎ = refl

module Preorder-Reasoning
         {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where
  open Preorder P
  open Equivalence-Reasoning isEquivalence public renaming (_≈⟨_⟩_ to _∼⟨_⟩_)

module Setoid-Reasoning {a ℓ} (s : Setoid a ℓ) where
  open Preorder-Reasoning (Setoid.preorder s) public renaming (_∼⟨_⟩_ to _≈⟨_⟩_)


rephrasing lemma to match paper text per  #43

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import progress
open import htype-decidable

module complete-progress where

  data okc : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → okc d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → okc d Δ

  -- no term is both complete and indeterminate
  lem-ind-comp : ∀{d} → d dcomplete → d indet → ⊥
  lem-ind-comp DCVar ()
  lem-ind-comp DCConst ()
  lem-ind-comp (DCLam comp x₁) ()
  lem-ind-comp (DCAp comp comp₁) (IAp x ind x₁) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastArr x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastGroundHole x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastHoleGround x₂ ind x₃) = lem-ind-comp comp ind

  -- if an arrow is disequal, it disagrees in the first or second argument
  ne-factor : ∀{τ1 τ2 τ3 τ4} → (τ1 ==> τ2) ≠ (τ3 ==> τ4) → (τ1 ≠ τ3) + (τ2 ≠ τ4)
  ne-factor {τ1} {τ2} {τ3} {τ4} ne with htype-dec τ1 τ3 | htype-dec τ2 τ4
  ne-factor ne | Inl refl | Inl refl = Inl (λ x → ne refl)
  ne-factor ne | Inl x | Inr x₁ = Inr x₁
  ne-factor ne | Inr x | Inl x₁ = Inl x
  ne-factor ne | Inr x | Inr x₁ = Inl x

  -- complete types that are consistent are equal
  eq-complete-consist : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → τ1 ~ τ2 → τ1 == τ2
  eq-complete-consist TCBase TCBase consis = refl
  eq-complete-consist TCBase (TCArr tc2 tc3) ()
  eq-complete-consist (TCArr tc1 tc2) TCBase ()
  eq-complete-consist (TCArr tc1 tc2) (TCArr tc3 tc4) TCRefl = refl
  eq-complete-consist (TCArr tc1 tc2) (TCArr tc3 tc4) (TCArr consis1 consis2)
    with eq-complete-consist tc1 tc3 consis1
  ... | refl with eq-complete-consist tc2 tc4 consis2
  ... | refl = refl

  complete-progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
                       Δ , ∅ ⊢ d :: τ →
                       d dcomplete →
                       okc d Δ
  complete-progress wt comp with progress wt
  complete-progress wt comp | I x = abort (lem-ind-comp comp x)
  complete-progress wt comp | S x = S x
  complete-progress wt comp | BV (BVVal x) = V x
  complete-progress wt (DCCast comp x₂ ()) | BV (BVHoleCast x x₁)
  complete-progress (TACast wt x) (DCCast comp x₃ x₄) | BV (BVArrCast x₁ x₂) = abort (x₁ (eq-complete-consist x₃ x₄ x))

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import progress
open import htype-decidable

module complete-progress where

  data okc : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → okc d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → okc d Δ

  -- no term is both complete and indeterminate
  lem-ind-comp : ∀{d} → d dcomplete → d indet → ⊥
  lem-ind-comp DCVar ()
  lem-ind-comp DCConst ()
  lem-ind-comp (DCLam comp x₁) ()
  lem-ind-comp (DCAp comp comp₁) (IAp x ind x₁) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastArr x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastGroundHole x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastHoleGround x₂ ind x₃) = lem-ind-comp comp ind

  -- if an arrow is disequal, it disagrees in the first or second argument
  ne-factor : ∀{τ1 τ2 τ3 τ4} → (τ1 ==> τ2) ≠ (τ3 ==> τ4) → (τ1 ≠ τ3) + (τ2 ≠ τ4)
  ne-factor {τ1} {τ2} {τ3} {τ4} ne with htype-dec τ1 τ3 | htype-dec τ2 τ4
  ne-factor ne | Inl refl | Inl refl = Inl (λ x → ne refl)
  ne-factor ne | Inl x | Inr x₁ = Inr x₁
  ne-factor ne | Inr x | Inl x₁ = Inl x
  ne-factor ne | Inr x | Inr x₁ = Inl x

  -- disequal complete types are not consistent
  eq-com-con : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → τ1 ≠ τ2 → τ1 ~ τ2 → ⊥
  eq-com-con tc1 tc2 ne TCRefl = ne refl
  eq-com-con tc1 () ne TCHole1
  eq-com-con () tc2 ne TCHole2
  eq-com-con (TCArr tc1 tc2) (TCArr tc3 tc4) ne (TCArr con con₁) with ne-factor ne
  eq-com-con (TCArr tc1 tc2) (TCArr tc3 tc4) ne (TCArr con con₁) | Inl x = eq-com-con tc1 tc3 x con
  eq-com-con (TCArr tc1 tc2) (TCArr tc3 tc4) ne (TCArr con con₁) | Inr x = eq-com-con tc2 tc4 x con₁

  complete-progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
                       Δ , ∅ ⊢ d :: τ →
                       d dcomplete →
                       okc d Δ
  complete-progress wt comp with progress wt
  complete-progress wt comp | I x = abort (lem-ind-comp comp x)
  complete-progress wt comp | S x = S x
  complete-progress wt comp | BV (BVVal x) = V x
  complete-progress wt (DCCast comp x₂ ()) | BV (BVHoleCast x x₁)
  complete-progress (TACast wt x) (DCCast comp x₃ x₄) | BV (BVArrCast x₁ x₂) = abort (eq-com-con x₃ x₄ x₁ x)


Working dependent evaluator, but need to remove explicit weakening.

module Spire.DependentEvaluator where

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

data Con : Set
data Type : Con → Set
data NType : Con → Set
data Val : (Γ : Con) → Type Γ → Set
data NVal : (Γ : Con) → Type Γ → Set
data Var : (Γ : Con) → Type Γ → Set
strC : ∀{Γ A} → Var Γ A → Con
strT : ∀{Γ A} (i : Var Γ A) → Type (strC i)
Sub : ∀{Γ A} → Var Γ A → Set
subC : ∀{Γ A} (i : Var Γ A) → Sub i → Con
subT : ∀{Γ A} → Type Γ → (i : Var Γ A) (x : Sub i) → Type (subC i x)
subNT : ∀{Γ A} → NType Γ → (i : Var Γ A) (x : Sub i) → Type (subC i x)
subV : ∀{Γ A B} → Val Γ B → (i : Var Γ A) (x : Sub i) → Val (subC i x) (subT B i x)
subNV : ∀{Γ A B} → NVal Γ B → (i : Var Γ A) (x : Sub i) → Val (subC i x) (subT B i x)

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

infixl 3 _,_
data Con where
  ∅ : Con
  _,_ : (Γ : Con) (A : Type Γ) → Con

data Type where
  `wkn : ∀{Γ A} → Type Γ → Type (Γ , A)
  `⊤ `Bool : ∀{Γ} → Type Γ
  `neutral : ∀{Γ} → NType Γ → Type Γ

data NType where
  `if_then_else_ : ∀{Γ} → NVal Γ `Bool
    → Type Γ → Type Γ → NType Γ

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

data Val where
  `wkn : ∀{Γ A B} → Val Γ A → Val (Γ , B) (`wkn A)
  `tt : ∀{Γ} → Val Γ `⊤
  `true `false : ∀{Γ} → Val Γ `Bool
  `neutral : ∀{Γ A} → NVal Γ A → Val Γ A

data NVal where
  `var : ∀{Γ A} → Var Γ A → NVal Γ A
  `not : ∀{Γ} → NVal Γ `Bool → NVal Γ `Bool

data Var where
  here : ∀{Γ A} → Var (Γ , A) (`wkn A)
  there : ∀{Γ A B} (i : Var Γ A) → Var (Γ , B) (`wkn A)

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

if_then_else_ : ∀{Γ} → Val Γ `Bool → Type Γ → Type Γ → Type Γ
if `true then A else B = A
if `false then A else B = B
if `neutral b then A else B = `neutral (`if b then A else B)

not : ∀{Γ} → Val Γ `Bool → Val Γ `Bool
not `true = `false
not `false = `true
not (`neutral b) = `neutral (`not b)

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

strC (here {Γ}) = Γ
strC (there i) = strC i
strT (here {Γ} {A}) = A
strT (there i) = strT i
Sub i = Val (strC i) (strT i)
subC (here {Γ}) x = Γ
subC (there {Γ} {A} {B} i) x = subC i x , subT B i x
subT (`wkn A) here x = A
subT (`wkn A) (there i) x = `wkn (subT A i x)
subT `⊤ i x = `⊤
subT `Bool i x = `Bool
subT (`neutral n) i x = subNT n i x
subNT (`if b then A else B) i x = if (subNV b i x) then subT A i x else subT B i x
subV (`wkn a) here x = a
subV (`wkn a) (there i) x = `wkn (subV a i x)
subV `tt i x = `tt
subV `true i x = `true
subV `false i x = `false
subV (`neutral n) i x = subNV n i x
subNV (`var here) here x = x
subNV (`var here) (there i) x = `neutral (`var here)
subNV (`var (there j)) here x = `neutral (`var j)
subNV (`var (there j)) (there i) x = `wkn (subNV (`var j) i x)
subNV (`not b) i x = not (subNV b i x)

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

data Term : (Γ : Con) → Type Γ → Set where
  `var : ∀{Γ A} (i : Var Γ A) → Term Γ A
  `tt : ∀{Γ} → Term Γ `⊤
  `true `false : ∀{Γ} → Term Γ `Bool
  `not : ∀{Γ} (b : Term Γ `Bool) → Term Γ `Bool

data TermType : (Γ : Con) → Set where
  `⊤ `Bool : ∀{Γ} → TermType Γ
  `if_then_else_ : ∀{Γ}
    → Term Γ `Bool
    → TermType Γ → TermType Γ
    → TermType Γ

eval : ∀{Γ A} → Term Γ A → Val Γ A
eval (`var i) = `neutral (`var i)
eval `tt = `tt
eval `true = `true
eval `false = `false
eval (`not b) = not (eval b)

evalType : ∀{Γ} → TermType Γ → Type Γ
evalType `⊤ = `⊤
evalType `Bool = `Bool
evalType (`if b then A else B) = if eval b then evalType A else evalType B

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

module Spire.DependentEvaluator where

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

data Context : Set
data Type : Context → Set
data NType : Context → Set
data Val : (Γ : Context) → Type Γ → Set
data NVal : (Γ : Context) → Type Γ → Set
data Var : (Γ : Context) → Type Γ → Set

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

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

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

data Type where
  `wkn : ∀{Γ A} → Type Γ → Type (Γ , A)
  `⊤ `Bool : ∀{Γ} → Type Γ
  `neutral : ∀{Γ} → NType Γ → Type Γ

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

data NType where
  `if_then_else_ : ∀{Γ} → NVal Γ `Bool
    → Type Γ → Type Γ → NType Γ

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

data Val where
  `tt : ∀{Γ} → Val Γ `⊤
  `true `false : ∀{Γ} → Val Γ `Bool
  `neutral : ∀{Γ A} → NVal Γ A → Val Γ A

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

data NVal where
  `var : ∀{Γ A} → Var Γ A → NVal Γ A
  `not : ∀{Γ} → NVal Γ `Bool → NVal Γ `Bool

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

data Var where
  here : ∀{Γ A} → Var (Γ , A) (`wkn A)
  there : ∀{Γ A B} → Var Γ A → Var (Γ , B) (`wkn A)

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

strC : ∀{Γ A} → Var Γ A → Context
strC (here {Γ}) = Γ
strC (there i) = strC i

strT : ∀{Γ A} (i : Var Γ A) → Type (strC i)
strT (here {Γ} {A}) = A
strT (there i) = strT i

Sub : ∀{Γ A} → Var Γ A → Set
Sub i = Val (strC i) (strT i)

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

if_then_else_ : ∀{Γ} → Val Γ `Bool → Type Γ → Type Γ → Type Γ
if `true then A else B = A
if `false then A else B = B
if `neutral b then A else B = `neutral (`if b then A else B)

not : ∀{Γ} → Val Γ `Bool → Val Γ `Bool
not `true = `false
not `false = `true
not (`neutral b) = `neutral (`not b)

subC : ∀{Γ A} (i : Var Γ A) → Sub i → Context
subT : ∀{Γ A} → Type Γ → (i : Var Γ A) (x : Sub i) → Type (subC i x)
subNT : ∀{Γ A} → NType Γ → (i : Var Γ A) (x : Sub i) → Type (subC i x)
subV : ∀{Γ A B} → Val Γ B → (i : Var Γ A) (x : Sub i) → Val (subC i x) (subT B i x)
subNV : ∀{Γ A B} → NVal Γ B → (i : Var Γ A) (x : Sub i) → Val (subC i x) (subT B i x)

subC (here {Γ}) x = Γ
subC (there {Γ} {A} {B} i) x = subC i x , subT B i x

subT (`wkn B) i x = {!!}
subT `⊤ i x = `⊤
subT `Bool i x = `Bool
subT (`neutral n) i x = subNT n i x

postulate
  wknVal : ∀{Γ A} (i : Var Γ A) (x : Sub i) → Val (subC i x) (subT A i x)

wknVar : ∀{Γ A B} (i : Var Γ A) (x : Sub i) → Var (subC i x) (subT B i x) → Var Γ B
wknVar i x j = {!!}

data Compare {Γ} {A : Type Γ} (i : Var Γ A) : {B : Type Γ} → Var Γ B → Sub i → Set where
  equal : (x : Val (strC i) (strT i)) → Compare i i x
  diff : ∀{B}
    (x : Val (strC i) (strT i))
    (j : Var (subC i x) (subT B i x))
    → Compare i {B = B} (wknVar i x j) x

postulate
  compare : ∀{Γ A B} (i : Var Γ A) (j : Var Γ B) (x : Sub i) → Compare i j x

subNT (`if b then A else B) i x = if (subNV b i x) then subT A i x else subT B i x

subV `tt i x = `tt
subV `true i x = `true
subV `false i x = `false
subV (`neutral n) i x = subNV n i x

subNV (`var j) i x = {!!}
-- with compare i j x
-- subNV (`var .i) i .x | equal x = wknVal i x
-- subNV (`var .(wknVar i x j)) i .x | diff x j = `neutral (`var j)
subNV (`not b) i x = not (subNV b i x)

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


Helios: setup the intermediate games

Helios: setup the intermediate games

open import Type
open import Function
open import Data.List
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
{-
open import Data.Zero
open import Data.One
-}
open import Data.Two
open import Data.Nat.NP hiding (_==_; _<_)
open import Control.Strategy

module Helios
  (VoterId : ★)
  (PublicKey : ★)
  (SecretKey : ★)
  (NIZKSecretKey : PublicKey → ★)
  (Vote   : ★)
  (Ballot : ★)
  (Decryption-share : ★)
  (PublicInfo : ★)
  (R-setup : ★)
  (R-vote : ★)
  (vote : PublicKey → R-vote → VoterId → Vote → Ballot)
  (let Ballots = List (VoterId × Ballot)
       Decryption-shares = List Decryption-share
  )
  (validate-ballots : PublicKey → Ballots → 𝟚)
  (Tally : ★) -- could be a valid tally or a special symbol ⊥
  (fake-decrytion-share : Tally → Ballots → Decryption-share)
  (R-adversary : ★)
  where

record KeyPair : ★ where
  constructor mk
  field
    pk : PublicKey
    sk : SecretKey
    zk : NIZKSecretKey pk

record BB : ★ where
  constructor <_,,_,,_,,_>
  field
    Y-pk              : PublicKey
    π-pk              : NIZKSecretKey Y-pk
    ballots           : Ballots
    decryption-shares : Decryption-shares
open BB public

Make-decryption-shares = KeyPair → Ballots → Decryption-shares
Simulate-decryption-shares = (bs₀ : Ballots) → Make-decryption-shares

validate : PublicKey → Ballots → VoterId × Ballot → 𝟚
validate pk bs vb = validate-ballots pk (vb ∷ bs)

data Q : ★ where
  ask-vote   : (v_ : Vote ²) → Q
  ask-ballot : (b  : Ballot) → Q

VotingPhase = List (Ballots → VoterId × Q)

module Tallying
  (decryption-shares : Make-decryption-shares)
  (result : BB → Tally)
  where

  tally-bb : KeyPair → Ballots → BB
  tally-bb (mk Y sk zk) bs = < Y ,, zk ,, bs ,, decryption-shares (mk Y sk zk) bs >

  tally : KeyPair → Ballots → Tally
  tally kp bs = result (tally-bb kp bs)

module Run-common
           (pk : PublicKey)
           (r-votes : VoterId → R-vote ²) where
    run-vote-query¹ : R-vote → VoterId → Vote → Ballots → Ballots
    run-vote-query¹ r-vote vid v bs = case validate pk bs (vid , b)
                                        0: bs
                                        1: ((vid , b) ∷ bs)
      where
        b : Ballot
        b = vote pk r-vote vid v

    run-vote-query : (hack-run-vote-query : 𝟚 → 𝟚) → VoterId → Vote ² → Ballots ² → Ballots ²
    run-vote-query hack-run-vote-query vid v_ bs_ i = run-vote-query¹ (r-votes vid i) vid (v_ (hack-run-vote-query i)) (bs_ i)

    run-ballot-query : (β : 𝟚) → VoterId → Ballot → Ballots ² → Ballots ²
    run-ballot-query β vid b bs_ i =
        case validate pk (bs_ β) (vid , b)
          0: bs_ i
          1: case validate pk (bs_ (not β)) (vid , b)
               0: case i
                    0: ((vid , b) ∷ bs_ 0₂)
                    1: bs_ 1₂
               1: ((vid , b) ∷ bs_ i)

Hack-run-vote-query = ℕ → 𝟚 → 𝟚

module Run (β : 𝟚)
           (hack-run-vote-query : Hack-run-vote-query)
           (pk : PublicKey)
           (r-votes : VoterId → R-vote ²) where
    open Run-common pk r-votes

    run-query : (hack-run-vote-query : 𝟚 → 𝟚) → VoterId → Q → Ballots ² → Ballots ²
    run-query hack-run-vote-query vid (ask-vote v_)  = run-vote-query hack-run-vote-query vid v_
    run-query hack-run-vote-query vid (ask-ballot b) = run-ballot-query β vid b

    run-voting-phase : VotingPhase → Ballots ² → Ballots ²
    run-voting-phase []       bs_ = bs_
    run-voting-phase (q ∷ qs) bs_ = run-voting-phase qs (uncurry (run-query (hack-run-vote-query (length qs))) (q (bs_ β)) bs_)

module _ where
  Adversary = R-adversary →
              PublicKey →
              VotingPhase ×
              (BB →
              𝟚)

  module CommonChallenger
              (setup : R-setup → KeyPair)
              (r-setup : R-setup)
              (r-adversary : R-adversary)
              (A : Adversary)
              where
    kp = setup r-setup
    open KeyPair kp public

    A-setup = A r-adversary pk

    A-voting-phase : VotingPhase
    A-voting-phase = fst A-setup

  -- The real challenger (has access to β)
  module Game (setup : R-setup → KeyPair)
              (decryption-shares : Make-decryption-shares)
              (hack-run-vote-query : Hack-run-vote-query)

              (r-setup : R-setup)
              (r-adversary : R-adversary)
              (A : Adversary)
              (r-votes : VoterId → R-vote ²)
              (simulate-decryption-shares : Simulate-decryption-shares)
              (β : 𝟚)
              where
    open CommonChallenger setup r-setup r-adversary A public

    open Run β hack-run-vote-query pk r-votes

    bs_ : Ballots ²
    bs_ = run-voting-phase A-voting-phase (const [])

    decryption-shares-β =
      (case β
         0: decryption-shares
         1: simulate-decryption-shares (bs_ 0₂))
      kp (bs_ β)

    bb : BB
    bb = record { Y-pk = pk ; π-pk = zk ; ballots = bs_ β ; decryption-shares = decryption-shares-β }

    exp : 𝟚
    exp = snd A-setup bb

    game = exp == β

  module Unused-simulate-decryption-shares
              (decryption-shares : Make-decryption-shares)
              (result : BB → Tally)
              (kp  : KeyPair)
              (bs_ : Ballots ²)
           where
    open KeyPair kp
    open Tallying decryption-shares result
    simulated-decryption-shares : Decryption-shares
    simulated-decryption-shares = fake-decrytion-share (tally kp (bs_ 0₂)) (bs_ 1₂) ∷ []

    {-
  module Simulated-Challenger
              (r-setup : R-setup)
              (r-votes : VoterId → R-vote ²)
              (r-adversary : R-adversary)
              (A : Adversary)
            where
    open CommonChallenger r-setup r-adversary A public
-}
  module Proof (setup : R-setup → KeyPair)
               (result : BB → Tally)
               (decryption-shares  decryption-sharesₐ : Make-decryption-shares)
               (r-setup : R-setup)
               (r-adversary : R-adversary)
               (A : Adversary)
               (r-votes : VoterId → R-vote ²)
               (simulate-decryption-shares : Simulate-decryption-shares)
               (simulate-zksecret : (pk : PublicKey) → NIZKSecretKey pk)
               where
     hack-no-queries : Hack-run-vote-query
     hack-no-queries = const id
     module EXP = Game setup decryption-shares hack-no-queries r-setup r-adversary A r-votes simulate-decryption-shares
     G₀ = EXP.exp 0₂
     G₁ = EXP.exp 1₂

     setupₐ : R-setup → KeyPair
     setupₐ r-setup = record (setup r-setup) { zk = simulate-zksecret _ }

     module EXPₐ = Game setupₐ decryption-sharesₐ hack-no-queries r-setup r-adversary A r-votes simulate-decryption-shares 0₂

     Gₐ = EXPₐ.exp

     simulate-decryption-shares-B : Make-decryption-shares
     simulate-decryption-shares-B kp bs = fake-decrytion-share t bs ∷ []
       where
         open Tallying decryption-sharesₐ result
         t  = tally kp bs

     module EXP-B = Game setupₐ simulate-decryption-shares-B hack-no-queries r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂

     G-B = EXP-B.exp

     hack-all-queries : Hack-run-vote-query
     hack-all-queries = const not

     Seq : ★ → ★
     Seq A = ℕ → A

     _<_ : ℕ → ℕ → 𝟚
     x < y = suc x <= y

     replicateSeq : {A : ★} → ℕ → A → A → Seq A
     replicateSeq n x y i = case (i < n) 0: x 1: y

     hack-queries-up-to : ℕ → Hack-run-vote-query
     hack-queries-up-to n i = replicateSeq (n id not i

     module EXP-C-up-to (n : ℕ) = Game setupₐ simulate-decryption-shares-B (hack-queries-up-to n) r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂

     module EXP-C = Game setupₐ simulate-decryption-shares-B hack-all-queries r-setup r-adversary A r-votes (λ _ _ _ → {- unused -} []) 0₂

     G-C = EXP-C.exp

     {- EXP-C-up-to zero -}

     -- G₀∼Gₐ
-- -}
-- -}
-- -}
-- -}
-- -}

open import Type
open import Data.List
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
{-
open import Data.Zero
open import Data.One
open import Data.Nat
-}
open import Data.Two
open import Control.Strategy

module Helios
  (VoterId : ★)
  (PublicKey : ★)
  (SecretKey : ★)
  (Vote   : ★)
  (Ballot : ★)
  (Decryption-share : ★)
  (PublicInfo : ★)
  where

Ballots = List (VoterId × Ballot)
Decryption-shares = List Decryption-share

record BB : ★ where
  constructor <_,,_,,_>
  field
    Y-pk              : PublicKey
    ballots           : Ballots
    decryption-shares : Decryption-shares
open BB public

module Nested
  (R-setup : ★)
  (setup : R-setup → PublicKey × {-List-} SecretKey)
  (R-vote : ★)

  (vote : PublicKey → R-vote → VoterId → Vote → Ballot)
  (validate : BB → VoterId × Ballot → 𝟚)

  (Tally : ★) -- could be a valid tally or a special symbol ⊥
  (dec-shares : PublicKey → Ballots → {-List-} SecretKey → Decryption-shares)
  (result : BB → Tally)

  (R-adversary : ★)
  where

  tally : BB → {-List-} SecretKey → BB
  tally < Y ,, bs ,, ds > sks = < Y ,, bs ,, dec-shares Y bs sks >

  data Q : ★ where
    ask-vote   : (v_ : Vote ²) → Q
    ask-ballot : (b  : Ballot) → Q

  VotingPhase = List (BB → VoterId × Q)

  add-ballot : VoterId → Ballot → BB → BB
  add-ballot vid b bb = record bb { ballots = (vid , b) ∷ ballots bb }

  module Run (β : 𝟚)
             (pk : PublicKey)
             (r-votes : VoterId → R-vote ²)
           where

    run-query : VoterId → Q → BB ² → BB ²
    run-query vid (ask-vote v_)  bb_ i = case validate (bb_ i) (vid , b)
                                          0: bb_ i
                                          1: add-ballot vid b (bb_ i)
      where
        b : Ballot
        b = vote pk (r-votes vid i) vid (v i)

    run-query vid (ask-ballot b) bb_ i =
        case validate (bb_ β) (vid , b)
          0: bb_ i
          1: case validate (bb_ (not β)) (vid , b)
               0: case i
                    0: add-ballot vid b (bb_ 0₂)
                    1: bb_ 1₂
               1: add-ballot vid b (bb_ i)

    run-voting-phase : VotingPhase → BB ² → BB ²
    run-voting-phase []       bb_ = bb_
    run-voting-phase (q ∷ qs) bb_ = run-voting-phase qs (uncurry run-query (q (bb_ β)) bb_)

  Adversary = R-adversary →
              PublicKey →
              VotingPhase ×
              (BB →
              𝟚)

  module Game (β : 𝟚)
              (r-setup : R-setup)
              (r-votes : VoterId → R-vote ²)
              (r-adversary : R-adversary)
              (A : Adversary)
              where
    pksk = setup r-setup
    pk = fst pksk
    sk = snd pksk

    BB-setup : BB
    BB-setup = < pk ,, [] ,, [] >

    BB²-setup : BB ²
    BB²-setup _ = BB-setup

    A-setup = A r-adversary pk

    A-voting-phase : VotingPhase
    A-voting-phase = fst A-setup

    open Run β pk r-votes

    exp : 𝟚
    exp = snd A-setup (run-voting-phase A-voting-phase BB²-setup β)

    game = exp == β
-- -}
-- -}
-- -}
-- -}
-- -}


Added doc related to projection-like functions.

Ignore-this: 1691c2b03146dd4bef59f0eb004fe936

darcs-hash:20110919213152-3bd4e-9c46d3f7c4ca039d9b04c80d6bf54f98d2cf3dee.gz

------------------------------------------------------------------------------
-- The translation of projection-like functions is not implemented

-- 2011-09-19: Maybe the information in the issue 465 (Missing
-- patterns in funClauses) is useful.

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

module Test.Fail.ProjectionLikeFunction where

-- Error: The translation of projection-like functions Test.Fail.ProjectionLikeFunction._.P is not implemented.

postulate
  D    : Set
  _≡_  : D → D → Set
  N    : D → Set

foo : ∀ {n} → N n → D
foo {n} Nn = n
  where
  P : D → Set
  P i = i ≡ i
  {-# ATP definition P #-}

  postulate bar : P n
  {-# ATP prove bar #-}

------------------------------------------------------------------------------
-- The translation of projection-like functions is not implemented
------------------------------------------------------------------------------

module Test.Fail.ProjectionLikeFunction where

-- Error: The translation of projection-like functions Test.Fail.ProjectionLikeFunction._.P is not implemented.

postulate
  D    : Set
  _≡_  : D → D → Set
  N    : D → Set

foo : ∀ {n} → N n → D
foo {n} Nn = n
  where
  P : D → Set
  P i = i ≡ i
  {-# ATP definition P #-}

  postulate bar : P n
  {-# ATP prove bar #-}


Minor changes.

Minor changes.

Ignore-this: 80b6d52ceb4e05f8daca0c4feaf390e6

darcs-hash:20110518144052-3bd4e-876879e98b56ce1879cc4bae32deec0b8c804064.gz

------------------------------------------------------------------------------
-- Example of a nested recursive function using the Bove-Capretta
-- method
------------------------------------------------------------------------------

-- Tested with the development version of the standard library on
-- 18 May 2011.

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

module NestBC where

open import Data.Nat
open import Data.Nat.Properties

open import Induction
open import Induction.Nat

open import Relation.Binary

module NDTO = DecTotalOrder decTotalOrder

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

≤′-trans : Transitive _≤′_
≤′-trans i≤′j j≤′k = ≤⇒≤′ (NDTO.trans (≤′⇒≤ i≤′j) (≤′⇒≤ j≤′k))

mutual
  -- The domain predicate of the nest function.
  data NestDom : ℕ → Set where
    nestDom0 : NestDom 0
    nestDomS : ∀ {n} → (h₁ : NestDom n) →
               (h₂ : NestDom (nestD n h₁)) →
               NestDom (suc n)

  -- The nest function by structural recursion on the domain predicate.
  nestD : ∀ n → NestDom n → ℕ
  nestD .0       nestDom0             = 0
  nestD .(suc n) (nestDomS {n} h₁ h₂) = nestD (nestD n h₁) h₂

nestD-≤′ : ∀ n → (h : NestDom n) → nestD n h ≤′ n
nestD-≤′ .0       nestDom0             = ≤′-refl
nestD-≤′ .(suc n) (nestDomS {n} h₁ h₂) =
  ≤′-trans (≤′-trans (nestD-≤′ (nestD n h₁) h₂) (nestD-≤′ n h₁))
           (≤′-step ≤′-refl)

-- The nest function is total.
allNestDom : ∀ n → NestDom n
allNestDom = build <-rec-builder P ih
  where
    P : ℕ → Set
    P = NestDom

    ih : ∀ y → <-Rec P y → P y
    ih zero    rec = nestDom0
    ih (suc y) rec = nestDomS nd-y (rec (nestD y nd-y) (s≤′s (nestD-≤′ y nd-y)))
        where
          helper : ∀ x → x <′ y → P x
          helper x Sx≤′y = rec x (≤′-step Sx≤′y)

          nd-y : NestDom y
          nd-y = ih y helper

-- The nest function.
nest : ℕ → ℕ
nest n = nestD n (allNestDom n)

------------------------------------------------------------------------------
-- Example of a nested recursive function using the Bove-Capretta
-- method
------------------------------------------------------------------------------

-- Tested with the development version of the standard library on 04
-- April 2011.

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

module NestBC where

open import Data.Nat
open import Data.Nat.Properties

open import Induction.Nat
open import Induction

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

≤′-trans : ∀ {m n o} → m ≤′ n → n ≤′ o → m ≤′ o
≤′-trans ≤′-refl            n≤′o                = n≤′o
≤′-trans (≤′-step {n} m≤′n) ≤′-refl             = ≤′-step m≤′n
≤′-trans (≤′-step {n} m≤′n) (≤′-step {o} Sn≤′o) =
  ≤′-step (≤′-trans m≤′n (≤′-trans (≤′-step ≤′-refl) Sn≤′o))

mutual
  -- The domain predicate of the nest function.
  data DomNest : ℕ → Set where
    dom0 : DomNest 0
    domS : ∀ {n} → (h₁ : DomNest n) →
                   (h₂ : DomNest (nestD n h₁)) →
                   DomNest (suc n)

  -- The nest function by structural recursion on the domain predicate.
  nestD : ∀ n → DomNest n → ℕ
  nestD .0       dom0             = 0
  nestD .(suc n) (domS {n} h₁ h₂) = nestD (nestD n h₁) h₂

nestD-≤′ : ∀ n → (h : DomNest n) → nestD n h ≤′ n
nestD-≤′ .0       dom0             = ≤′-refl
nestD-≤′ .(suc n) (domS {n} h₁ h₂) =
  ≤′-trans (≤′-trans (nestD-≤′ (nestD n h₁) h₂) (nestD-≤′ n h₁))
           (≤′-step ≤′-refl)

-- The nest function is total.
allDomNest : ∀ n → DomNest n
allDomNest = build <-rec-builder P ih
  where
    P : ℕ → Set
    P = DomNest

    ih : ∀ y → <-Rec P y → P y
    ih zero    rec = dom0
    ih (suc y) rec = domS dn-y (rec (nestD y dn-y) (s≤′s (nestD-≤′ y dn-y)))
        where
          helper : (x : ℕ) → x <′ y → P x
          helper x Sx≤′y = rec x (≤′-step Sx≤′y)

          dn-y : DomNest y
          dn-y = ih y helper

-- The nest function.
nest : ℕ → ℕ
nest n = nestD n (allDomNest n)


Added x<x+Sy (by Ana Bove).

Added x<x+Sy (by Ana Bove).

Ignore-this: 1b7829d941cd8b1cf318d5579418b1a0

darcs-hash:20110210163141-3bd4e-05b6623c2d6425ca20325ece755c6603f568ee14.gz

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Data.Nat.Inequalities.PropertiesATP where

open import LTC.Base
open import LTC.Base.Properties using ( x≡y→Sx≡Sy )

open import Common.Function using ( _$_ )

open import LTC.Data.Nat
  using ( _+_ ; _∸_ ; ∸-SS
        ; N ; sN ; zN  -- The LTC natural numbers type
        )
open import LTC.Data.Nat.Inequalities
  using ( <-00 ; <-0S ; <-S0 ; <-SS
        ; GE ; GT ; LE ; LT ; NGT ; NLE ; NLT
        ; LT₂
        )
open import LTC.Data.Nat.PropertiesATP
  using ( +-N ; ∸-N
        ; +-comm
        ; +-rightIdentity
        )

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

0<0-elim : LT zero zero → ⊥
0<0-elim 0<0 = true≠false $ trans (sym 0<0) <-00

S<0-elim : {d : D} → LT (succ d) zero → ⊥
S<0-elim {d} Sd<0 = true≠false $ trans (sym Sd<0) (<-S0 d)

x≥0 : ∀ {n} → N n → GE n zero
x≥0 zN          = <-0S zero
x≥0 (sN {n} Nn) = <-0S $ succ n

0≤x : ∀ {n} → N n → LE zero n
0≤x Nn = x≥0 Nn

¬x<0 : ∀ {n} → N n → ¬ (LT n zero)
¬x<0 zN      0<0  = 0<0-elim 0<0
¬x<0 (sN Nn) Sn<0 = S<0-elim Sn<0

0≯x : ∀ {n} → N n → NGT zero n
0≯x zN          = <-00
0≯x (sN {n} Nn) = <-S0 n

postulate
  ¬0>x : ∀ {n} → N n → ¬ (GT zero n)
{-# ATP prove ¬0>x 0≯x #-}

x≰x : ∀ {n} → N n → NLT n n
x≰x zN          = <-00
x≰x (sN {n} Nn) = trans (<-SS n n) (x≰x Nn)

S≰0 : ∀ {n} → N n → NLE (succ n) zero
S≰0 zN          = x≰x (sN zN)
S≰0 (sN {n} Nn) = trans (<-SS (succ n) zero) (<-S0 n)

¬S≤0 : ∀ {n} → N n → ¬ (LE (succ n) zero)
¬S≤0 {d} Nn Sn≤0 = true≠false $ trans (sym Sn≤0) (S≰0 Nn)

¬0≥S : ∀ {n} → N n → ¬ (GE zero (succ n))
¬0≥S Nn 0≥Sn = ¬S≤0 Nn 0≥Sn

x<Sx : ∀ {n} → N n → LT n (succ n)
x<Sx zN          = <-0S zero
x<Sx (sN {n} Nn) = trans (<-SS n (succ n)) (x<Sx Nn)

postulate
  x<y→Sx<Sy : ∀ {m n} → LT m n → LT (succ m) (succ n)
{-# ATP prove x<y→Sx<Sy #-}

postulate
  Sx<Sy→x<y : ∀ {m n} → LT (succ m) (succ n) → LT m n
{-# ATP prove Sx<Sy→x<y #-}

¬x<x : ∀ {n} → N n → ¬ (LT n n)
¬x<x zN           0<0  = 0<0-elim 0<0
¬x<x (sN {n} Nn) Sn<Sn = ⊥-elim $ ¬x<x Nn (trans (sym $ <-SS n n) Sn<Sn)

¬x>x : ∀ {n} → N n → ¬ (GT n n)
¬x>x Nn = ¬x<x Nn

x≤x : ∀ {n} → N n → LE n n
x≤x zN          = <-0S zero
x≤x (sN {n} Nn) = trans (<-SS n (succ n)) (x≤x Nn)

x≤y→Sx≤Sy : ∀ {m n} → LE m n → LE (succ m) (succ n)
x≤y→Sx≤Sy {m} {n} m≤n = trans (<-SS m (succ n)) m≤n

postulate
  Sx≤Sy→x≤y : ∀ {m n} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≰y→Sx≰Sy : ∀ m n → NLE m n → NLE (succ m) (succ n)
x≰y→Sx≰Sy m n m≰n = trans (<-SS m (succ n)) m≰n

x>y→y<x : ∀ {m n} → N m → N n → GT m n → LT n m
x>y→y<x zN          Nn          0>n   = ⊥-elim $ ¬0>x Nn 0>n
x>y→y<x (sN {m} Nm) zN          _     = <-0S m
x>y→y<x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  trans (<-SS n m) (x>y→y<x Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x≥y→x≮y : ∀ {m n} → N m → N n → GE m n → NLT m n
x≥y→x≮y zN          zN          _     = x≰x zN
x≥y→x≮y zN          (sN Nn)     0≥Sn  = ⊥-elim $ ¬0≥S Nn 0≥Sn
x≥y→x≮y (sN {m} Nm) zN          _     = <-S0 m
x≥y→x≮y (sN {m} Nm) (sN {n} Nn) Sm≥Sn =
  trans (<-SS m n) (x≥y→x≮y Nm Nn (trans (sym $ <-SS n (succ m)) Sm≥Sn))

x>y→x≰y : ∀ {m n} → N m → N n → GT m n → NLE m n
x>y→x≰y zN          Nn          0>m   = ⊥-elim $ ¬0>x Nn 0>m
x>y→x≰y (sN Nm)     zN          _     = S≰0 Nm
x>y→x≰y (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  x≰y→Sx≰Sy m n (x>y→x≰y Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x>y∨x≤y : ∀ {m n} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ <-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m>n → inj₁ (trans (<-SS n m) m>n))
  , (λ m≤n → inj₂ (x≤y→Sx≤Sy m≤n))
  ] (x>y∨x≤y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → LT m n ∨ GE m n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x≤y∨x≰y : ∀ {m n} → N m → N n → LE m n ∨ NLE m n
x≤y∨x≰y zN Nn = inj₁ (0≤x Nn)
x≤y∨x≰y (sN Nm) zN = inj₂ (S≰0 Nm)
x≤y∨x≰y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m≤n → inj₁ (x≤y→Sx≤Sy m≤n))
  , (λ m≰n → inj₂ (x≰y→Sx≰Sy m n m≰n))
  ] (x≤y∨x≰y Nm Nn)

x≡y→x≤y : ∀ {m n} {Nm : N m} {Nn : N n} → m ≡ n → LE m n
x≡y→x≤y {Nm = Nm} refl = x≤x Nm

x<y→x≤y : ∀ {m n} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim $ ¬x<0 Nm m<0
x<y→x≤y zN (sN {n} Nn)          _     = <-0S $ succ n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<y→Sx≤y : ∀ {m n} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm          zN          m<0   = ⊥-elim $ ¬x<0 Nm m<0
x<y→Sx≤y zN          (sN Nn)     0<Sn  = x≤y→Sx≤Sy (0≤x Nn)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = trans (<-SS (succ m) (succ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim $ ¬S≤0 Nm Sm≤0
Sx≤y→x<y zN          (sN {n} Nn) _      = <-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

<-trans : ∀ {m n o} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN          _           0<0   _     = ⊥-elim $ 0<0-elim 0<0
<-trans zN          (sN Nn)     zN          _     Sn<0  = ⊥-elim $ S<0-elim Sn<0
<-trans zN          (sN Nn)     (sN {o} No) _     _     = <-0S o
<-trans (sN Nm)     Nn          zN          _     n<0   = ⊥-elim $ ¬x<0 Nn n<0
<-trans (sN Nm)     zN          (sN No)     Sm<0  _     = ⊥-elim $ S<0-elim Sm<0
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy $ <-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So)

≤-trans : ∀ {m n o} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim $ ¬S≤0 Nm Sm≤0
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim $ ¬S≤0 Nn Sn≤0
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

x≤x+y : ∀ {m n} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf $ x≤x+y Nm Nn
  where
    postulate prf : LE m (m + n) →  -- IH.
                    LE (succ m) (succ m + n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf #-}

x<x+Sy : ∀ {m n} → N m → N n → LT m (m + succ n)
x<x+Sy {n = n} zN Nn = prf0
  where
    postulate prf0 : LT zero (zero + succ n)
    {-# ATP prove prf0 #-}
x<x+Sy {n = n} (sN {m} Nm) Nn = prfS (x<x+Sy Nm Nn)
  where
    postulate prfS : LT m (m + succ n) → LT (succ m) (succ m + succ n)
    {-# ATP prove prfS #-}

x-y<Sx : ∀ {m n} → N m → N n → LT (m ∸ n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m ∸ zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero ∸ succ n) (succ zero)
    {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf $ x-y<Sx Nm Nn
  where
    postulate prf : LT (m ∸ n) (succ m) →  -- IH.
                    LT (succ m ∸ succ n) (succ (succ m))
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf <-trans ∸-N x<Sx #-}  -- Use the hint sN.

postulate
  Sx-Sy<Sx : ∀ {m n} → N m → N n → LT (succ m ∸ succ n) (succ m)
{-# ATP prove Sx-Sy<Sx ∸-SS x-y<Sx #-}

x>y→x-y+y≡x : ∀ {m n} → N m → N n → GT m n → (m ∸ n) + n ≡ m
x>y→x-y+y≡x zN          Nn 0>n  = ⊥-elim $ ¬0>x Nn 0>n
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m ∸ zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf $ x>y→x-y+y≡x Nm Nn m>n
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m ∸ n) + n ≡ m →  -- IH.
                    (succ m ∸ succ n) + succ n ≡ succ m
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x≤y→y-x+x≡y : ∀ {m n} → N m → N n → LE m n → (n ∸ m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n ∸ zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim $ ¬S≤0 Nm Sm≤0

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf $ x≤y→y-x+x≡y Nm Nn m≤n
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n ∸ m) + m ≡ n →  -- IH.
                    (succ n ∸ succ m) + succ m ≡ succ n
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x<y→x<Sy : ∀ {m n} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim $ ¬x<0 Nm m<0
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = <-0S $ succ n
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (<-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim $ ¬x<0 Nm (trans (sym $ <-SS m zero) Sm<S0)
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (<-SS m n) m<n))
  , (λ m≡n → inj₂ (x≡y→Sx≡Sy m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT m n ∨ m ≡ n
    m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym $ <-SS m (succ n)) Sm<SSn)

postulate
  x<y→y≡z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : ∀ {m n o} → N m → N n → N o → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

x≥y→y>0→x-y<x : ∀ {m n} → N m → N n → GE m n → GT n zero → LT (m ∸ n) m
x≥y→y>0→x-y<x Nm          zN          _     0>0  = ⊥-elim $ ¬x>x zN 0>0
x≥y→y>0→x-y<x zN          (sN Nn)     0≥Sn  _    = ⊥-elim $ ¬S≤0 Nn 0≥Sn
x≥y→y>0→x-y<x (sN {m} Nm) (sN {n} Nn) Sm≥Sn Sn>0 = prf
  where
    postulate prf : LT (succ m ∸ succ n) (succ m)
    {-# ATP prove prf x-y<Sx #-}

x<y→y≤z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → LE n o → LT m o
x<y→y≤z→x<z Nm Nn No m<n n≤o =
  [ (λ n<o → <-trans Nm Nn No m<n n<o)
  , (λ n≡o → aux m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)
  where
    aux : ∀ {a b c} → LT a b → b ≡ c → LT a c
    aux a<b refl = a<b

x≤y+x-y : ∀ {m n} → N m → N n → LE m (n + (m ∸ n))
x≤y+x-y {n = n} zN Nn = prf0
  where postulate prf0 : LE zero (n + (zero ∸ n))
        {-# ATP prove prf0 0≤x +-N  #-}
x≤y+x-y (sN {m} Nm) zN = prfx0
  where postulate prfx0 : LE (succ m) (zero + (succ m ∸ zero))
        {-# ATP prove prfx0 x<Sx #-}
x≤y+x-y (sN {m} Nm) (sN {n} Nn) = prfSS (x≤y+x-y Nm Nn)
  where postulate prfSS : LE m (n + (m ∸ n)) →  -- IH.
                          LE (succ m) (succ n + (succ m ∸ succ n))
        {-# ATP prove prfSS x≤y→Sx≤Sy ≤-trans +-N ∸-N #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  ¬xy<00 : ∀ {m n} → N m → N n → ¬ (LT₂ m n zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove ¬xy<00 ¬x<0 #-}

postulate
  ¬Sxy₁<0y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove ¬Sxy₁<0y₂ ¬x<0 #-}  -- Use the hint sN.

postulate
  ¬0Sx<00 : ∀ {m} → N m → ¬ (LT₂ zero (succ m) zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove ¬0Sx<00 ¬x<0 #-}  -- Use the hint sN.

postulate
  x₁y<x₂0→x₁<x₂ : ∀ {m₁ n m₂} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove x₁y<x₂0→x₁<x₂ ¬x<0 #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ ¬x<0 #-}

[Sx-Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x-y<Sx #-}  -- Use the hint sN.

[Sx,Sy-Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x-y<Sx #-}  -- Use the hint sN.

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Data.Nat.Inequalities.PropertiesATP where

open import LTC.Base
open import LTC.Base.Properties using ( x≡y→Sx≡Sy )

open import Common.Function using ( _$_ )

open import LTC.Data.Nat
  using ( _+_ ; _∸_ ; ∸-SS
        ; N ; sN ; zN  -- The LTC natural numbers type
        )
open import LTC.Data.Nat.Inequalities
  using ( <-00 ; <-0S ; <-S0 ; <-SS
        ; GE ; GT ; LE ; LT ; NGT ; NLE ; NLT
        ; LT₂
        )
open import LTC.Data.Nat.PropertiesATP
  using ( +-N ; ∸-N
        ; +-comm
        ; +-rightIdentity
        )

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

0<0-elim : LT zero zero → ⊥
0<0-elim 0<0 = true≠false $ trans (sym 0<0) <-00

S<0-elim : {d : D} → LT (succ d) zero → ⊥
S<0-elim {d} Sd<0 = true≠false $ trans (sym Sd<0) (<-S0 d)

x≥0 : ∀ {n} → N n → GE n zero
x≥0 zN          = <-0S zero
x≥0 (sN {n} Nn) = <-0S $ succ n

0≤x : ∀ {n} → N n → LE zero n
0≤x Nn = x≥0 Nn

¬x<0 : ∀ {n} → N n → ¬ (LT n zero)
¬x<0 zN      0<0  = 0<0-elim 0<0
¬x<0 (sN Nn) Sn<0 = S<0-elim Sn<0

0≯x : ∀ {n} → N n → NGT zero n
0≯x zN          = <-00
0≯x (sN {n} Nn) = <-S0 n

postulate
  ¬0>x : ∀ {n} → N n → ¬ (GT zero n)
{-# ATP prove ¬0>x 0≯x #-}

x≰x : ∀ {n} → N n → NLT n n
x≰x zN          = <-00
x≰x (sN {n} Nn) = trans (<-SS n n) (x≰x Nn)

S≰0 : ∀ {n} → N n → NLE (succ n) zero
S≰0 zN          = x≰x (sN zN)
S≰0 (sN {n} Nn) = trans (<-SS (succ n) zero) (<-S0 n)

¬S≤0 : ∀ {n} → N n → ¬ (LE (succ n) zero)
¬S≤0 {d} Nn Sn≤0 = true≠false $ trans (sym Sn≤0) (S≰0 Nn)

¬0≥S : ∀ {n} → N n → ¬ (GE zero (succ n))
¬0≥S Nn 0≥Sn = ¬S≤0 Nn 0≥Sn

x<Sx : ∀ {n} → N n → LT n (succ n)
x<Sx zN          = <-0S zero
x<Sx (sN {n} Nn) = trans (<-SS n (succ n)) (x<Sx Nn)

postulate
  x<y→Sx<Sy : ∀ {m n} → LT m n → LT (succ m) (succ n)
{-# ATP prove x<y→Sx<Sy #-}

postulate
  Sx<Sy→x<y : ∀ {m n} → LT (succ m) (succ n) → LT m n
{-# ATP prove Sx<Sy→x<y #-}

¬x<x : ∀ {n} → N n → ¬ (LT n n)
¬x<x zN           0<0  = 0<0-elim 0<0
¬x<x (sN {n} Nn) Sn<Sn = ⊥-elim $ ¬x<x Nn (trans (sym $ <-SS n n) Sn<Sn)

¬x>x : ∀ {n} → N n → ¬ (GT n n)
¬x>x Nn = ¬x<x Nn

x≤x : ∀ {n} → N n → LE n n
x≤x zN          = <-0S zero
x≤x (sN {n} Nn) = trans (<-SS n (succ n)) (x≤x Nn)

x≤y→Sx≤Sy : ∀ {m n} → LE m n → LE (succ m) (succ n)
x≤y→Sx≤Sy {m} {n} m≤n = trans (<-SS m (succ n)) m≤n

postulate
  Sx≤Sy→x≤y : ∀ {m n} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≰y→Sx≰Sy : ∀ m n → NLE m n → NLE (succ m) (succ n)
x≰y→Sx≰Sy m n m≰n = trans (<-SS m (succ n)) m≰n

x>y→y<x : ∀ {m n} → N m → N n → GT m n → LT n m
x>y→y<x zN          Nn          0>n   = ⊥-elim $ ¬0>x Nn 0>n
x>y→y<x (sN {m} Nm) zN          _     = <-0S m
x>y→y<x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  trans (<-SS n m) (x>y→y<x Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x≥y→x≮y : ∀ {m n} → N m → N n → GE m n → NLT m n
x≥y→x≮y zN          zN          _     = x≰x zN
x≥y→x≮y zN          (sN Nn)     0≥Sn  = ⊥-elim $ ¬0≥S Nn 0≥Sn
x≥y→x≮y (sN {m} Nm) zN          _     = <-S0 m
x≥y→x≮y (sN {m} Nm) (sN {n} Nn) Sm≥Sn =
  trans (<-SS m n) (x≥y→x≮y Nm Nn (trans (sym $ <-SS n (succ m)) Sm≥Sn))

x>y→x≰y : ∀ {m n} → N m → N n → GT m n → NLE m n
x>y→x≰y zN          Nn          0>m   = ⊥-elim $ ¬0>x Nn 0>m
x>y→x≰y (sN Nm)     zN          _     = S≰0 Nm
x>y→x≰y (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  x≰y→Sx≰Sy m n (x>y→x≰y Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x>y∨x≤y : ∀ {m n} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ <-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m>n → inj₁ (trans (<-SS n m) m>n))
  , (λ m≤n → inj₂ (x≤y→Sx≤Sy m≤n))
  ] (x>y∨x≤y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → LT m n ∨ GE m n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x≤y∨x≰y : ∀ {m n} → N m → N n → LE m n ∨ NLE m n
x≤y∨x≰y zN Nn = inj₁ (0≤x Nn)
x≤y∨x≰y (sN Nm) zN = inj₂ (S≰0 Nm)
x≤y∨x≰y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m≤n → inj₁ (x≤y→Sx≤Sy m≤n))
  , (λ m≰n → inj₂ (x≰y→Sx≰Sy m n m≰n))
  ] (x≤y∨x≰y Nm Nn)

x≡y→x≤y : ∀ {m n} {Nm : N m} {Nn : N n} → m ≡ n → LE m n
x≡y→x≤y {Nm = Nm} refl = x≤x Nm

x<y→x≤y : ∀ {m n} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim $ ¬x<0 Nm m<0
x<y→x≤y zN (sN {n} Nn)          _     = <-0S $ succ n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<y→Sx≤y : ∀ {m n} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm          zN          m<0   = ⊥-elim $ ¬x<0 Nm m<0
x<y→Sx≤y zN          (sN Nn)     0<Sn  = x≤y→Sx≤Sy (0≤x Nn)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = trans (<-SS (succ m) (succ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim $ ¬S≤0 Nm Sm≤0
Sx≤y→x<y zN          (sN {n} Nn) _      = <-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

<-trans : ∀ {m n o} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN          _           0<0   _     = ⊥-elim $ 0<0-elim 0<0
<-trans zN          (sN Nn)     zN          _     Sn<0  = ⊥-elim $ S<0-elim Sn<0
<-trans zN          (sN Nn)     (sN {o} No) _     _     = <-0S o
<-trans (sN Nm)     Nn          zN          _     n<0   = ⊥-elim $ ¬x<0 Nn n<0
<-trans (sN Nm)     zN          (sN No)     Sm<0  _     = ⊥-elim $ S<0-elim Sm<0
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy $ <-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So)

≤-trans : ∀ {m n o} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim $ ¬S≤0 Nm Sm≤0
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim $ ¬S≤0 Nn Sn≤0
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

x≤x+y : ∀ {m n} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf $ x≤x+y Nm Nn
  where
    postulate prf : LE m (m + n) →  -- IH.
                    LE (succ m) (succ m + n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf #-}

x-y<Sx : ∀ {m n} → N m → N n → LT (m ∸ n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m ∸ zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero ∸ succ n) (succ zero)
    {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf $ x-y<Sx Nm Nn
  where
    postulate prf : LT (m ∸ n) (succ m) →  -- IH.
                    LT (succ m ∸ succ n) (succ (succ m))
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf <-trans ∸-N x<Sx #-}  -- Use the hint sN.

postulate
  Sx-Sy<Sx : ∀ {m n} → N m → N n → LT (succ m ∸ succ n) (succ m)
{-# ATP prove Sx-Sy<Sx ∸-SS x-y<Sx #-}

x>y→x-y+y≡x : ∀ {m n} → N m → N n → GT m n → (m ∸ n) + n ≡ m
x>y→x-y+y≡x zN          Nn 0>n  = ⊥-elim $ ¬0>x Nn 0>n
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m ∸ zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf $ x>y→x-y+y≡x Nm Nn m>n
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m ∸ n) + n ≡ m →  -- IH.
                    (succ m ∸ succ n) + succ n ≡ succ m
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x≤y→y-x+x≡y : ∀ {m n} → N m → N n → LE m n → (n ∸ m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n ∸ zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim $ ¬S≤0 Nm Sm≤0

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf $ x≤y→y-x+x≡y Nm Nn m≤n
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n ∸ m) + m ≡ n →  -- IH.
                    (succ n ∸ succ m) + succ m ≡ succ n
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}  -- Use the hint sN.

x<y→x<Sy : ∀ {m n} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim $ ¬x<0 Nm m<0
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = <-0S $ succ n
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (<-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim $ ¬x<0 Nm (trans (sym $ <-SS m zero) Sm<S0)
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (<-SS m n) m<n))
  , (λ m≡n → inj₂ (x≡y→Sx≡Sy m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT m n ∨ m ≡ n
    m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym $ <-SS m (succ n)) Sm<SSn)

postulate
  x<y→y≡z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : ∀ {m n o} → N m → N n → N o → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

x≥y→y>0→x-y<x : ∀ {m n} → N m → N n → GE m n → GT n zero → LT (m ∸ n) m
x≥y→y>0→x-y<x Nm          zN          _     0>0  = ⊥-elim $ ¬x>x zN 0>0
x≥y→y>0→x-y<x zN          (sN Nn)     0≥Sn  _    = ⊥-elim $ ¬S≤0 Nn 0≥Sn
x≥y→y>0→x-y<x (sN {m} Nm) (sN {n} Nn) Sm≥Sn Sn>0 = prf
  where
    postulate prf : LT (succ m ∸ succ n) (succ m)
    {-# ATP prove prf x-y<Sx #-}

x<y→y≤z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → LE n o → LT m o
x<y→y≤z→x<z Nm Nn No m<n n≤o =
  [ (λ n<o → <-trans Nm Nn No m<n n<o)
  , (λ n≡o → aux m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)
  where
    aux : ∀ {a b c} → LT a b → b ≡ c → LT a c
    aux a<b refl = a<b

x≤y+x-y : ∀ {m n} → N m → N n → LE m (n + (m ∸ n))
x≤y+x-y {n = n} zN Nn = prf0
  where postulate prf0 : LE zero (n + (zero ∸ n))
        {-# ATP prove prf0 0≤x +-N  #-}
x≤y+x-y (sN {m} Nm) zN = prfx0
  where postulate prfx0 : LE (succ m) (zero + (succ m ∸ zero))
        {-# ATP prove prfx0 x<Sx #-}
x≤y+x-y (sN {m} Nm) (sN {n} Nn) = prfSS (x≤y+x-y Nm Nn)
  where postulate prfSS : LE m (n + (m ∸ n)) →  -- IH.
                          LE (succ m) (succ n + (succ m ∸ succ n))
        {-# ATP prove prfSS x≤y→Sx≤Sy ≤-trans +-N ∸-N #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  ¬xy<00 : ∀ {m n} → N m → N n → ¬ (LT₂ m n zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove ¬xy<00 ¬x<0 #-}

postulate
  ¬Sxy₁<0y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove ¬Sxy₁<0y₂ ¬x<0 #-}  -- Use the hint sN.

postulate
  ¬0Sx<00 : ∀ {m} → N m → ¬ (LT₂ zero (succ m) zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove ¬0Sx<00 ¬x<0 #-}  -- Use the hint sN.

postulate
  x₁y<x₂0→x₁<x₂ : ∀ {m₁ n m₂} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove x₁y<x₂0→x₁<x₂ ¬x<0 #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ ¬x<0 #-}

[Sx-Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x-y<Sx #-}  -- Use the hint sN.

[Sx,Sy-Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x-y<Sx #-}  -- Use the hint sN.


Added automatic proof of ≡→≈N.

Added automatic proof of ≡→≈N.

------------------------------------------------------------------------------
-- Properties for the equality on Conat
------------------------------------------------------------------------------

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

-- References:
--
-- • Herbert P. Sander. A logic of functional programs with an
--   application to concurrency. PhD thesis, Chalmers University of
--   Technology and University of Gothenburg, Department of Computer
--   Sciences, 1992.

module FOTC.Data.Conat.Equality.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality

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

≈N-refl : ∀ {n} → Conat n → n ≈N n
≈N-refl {n} Cn = ≈N-coind R prf₁ prf₂
  where
  R : D → D → Set
  R a b = Conat a ∧ Conat b ∧ a ≡ b
  {-# ATP definition R #-}

  postulate
    prf₁ : ∀ {a b} → R a b →
           a ≡ zero ∧ b ≡ zero
           ∨ (∃[ a' ] ∃[ b' ] a ≡ succ₁ a' ∧ b ≡ succ₁ b' ∧ R a' b')
  {-# ATP prove prf₁ #-}

  postulate prf₂ : Conat n ∧ Conat n ∧ n ≡ n
  {-# ATP prove prf₂ #-}

postulate ≡→≈N : ∀ {m n} → Conat m → Conat n → m ≡ n → m ≈N n
{-# ATP prove ≡→≈N ≈N-refl #-}

------------------------------------------------------------------------------
-- Properties for the equality on Conat
------------------------------------------------------------------------------

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

-- References:
--
-- • Herbert P. Sander. A logic of functional programs with an
--   application to concurrency. PhD thesis, Chalmers University of
--   Technology and University of Gothenburg, Department of Computer
--   Sciences, 1992.

module FOTC.Data.Conat.Equality.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality

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

≈N-refl : ∀ {n} → Conat n → n ≈N n
≈N-refl {n} Cn = ≈N-coind R prf₁ prf₂
  where
  R : D → D → Set
  R a b = Conat a ∧ Conat b ∧ a ≡ b
  {-# ATP definition R #-}

  postulate
    prf₁ : ∀ {a b} → R a b →
           a ≡ zero ∧ b ≡ zero
           ∨ (∃[ a' ] ∃[ b' ] a ≡ succ₁ a' ∧ b ≡ succ₁ b' ∧ R a' b')
  {-# ATP prove prf₁ #-}

  postulate prf₂ : Conat n ∧ Conat n ∧ n ≡ n
  {-# ATP prove prf₂ #-}

≡→≈N : ∀ {m n} → Conat m → Conat n → m ≡ n → m ≈N n
≡→≈N h _ refl = ≈N-refl h


Removed unnecesary implicit arguments.

Removed unnecesary implicit arguments.

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open FOTC.Base.BList
open import FOTC.Base.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.List
open import FOTC.Data.Stream
open import FOTC.Relation.Binary.Bisimilarity

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

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS h with (Stream-unf h)
... | x' , xs' , Sxs' , h₁ = subst Stream (sym (∧-proj₂ (∷-injective h₁))) Sxs'

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} h = Stream-coind P₁ h₁ (ys , h) , Stream-coind P₂ h₂ (xs , h)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  h₁ : ∀ {ws} → P₁ ws → ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  h₁ {ws} (zs , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , prf₂ , _ = w' , ws' , (zs' , prf₁) , prf₂

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  h₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  h₂  {zs} (ws , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , _ , prf₂ = w' , zs' , (ws' , prf₁) , prf₂

-- Requires K.
lengthStream : ∀ {xs} → Stream xs → length xs ≈N ∞
lengthStream {xs} Sxs = ≈N-coind _R_ h₁ h₂
  where
  _R_ : D → D → Set
  m R n = ∃[ xs ] Stream xs ∧ m ≡ length xs ∧ n ≡ ∞

  h₁ : ∀ {m n} → m R n →
       m ≡ zero ∧ n ≡ zero ∨
       (∃[ m' ] ∃[ n' ] m' R n' ∧ m ≡ succ₁ m' ∧ n ≡ succ₁ n')
  h₁ (_ , Sxs' , _ ) with Stream-unf Sxs'
  h₁ {m} {n} (.(x'' ∷ xs'') , Sxs' , aux , n≡∞) | x'' , xs'' , Sxs'' , refl =
    inj₂ (length xs'' , ∞ , (xs'' , Sxs'' , refl , refl) , helper₁ , helper₂)
    where
    helper₁ : m ≡ succ₁ (length xs'')
    helper₁ = trans aux (length-∷ x'' xs'')

    helper₂ : n ≡ succ₁ ∞
    helper₂ = trans n≡∞ ∞-eq

  h₂ : length xs R ∞
  h₂ = xs , Sxs , refl , refl

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open FOTC.Base.BList
open import FOTC.Base.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.List
open import FOTC.Data.Stream
open import FOTC.Relation.Binary.Bisimilarity

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

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS {x} {xs} h with (Stream-unf h)
... | x' , xs' , Sxs' , h₁ = subst Stream (sym (∧-proj₂ (∷-injective h₁))) Sxs'

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} h = Stream-coind P₁ h₁ (ys , h) , Stream-coind P₂ h₂ (xs , h)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  h₁ : ∀ {ws} → P₁ ws → ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  h₁ {ws} (zs , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , prf₂ , _ = w' , ws' , (zs' , prf₁) , prf₂

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  h₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  h₂  {zs} (ws , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , _ , prf₂ = w' , zs' , (ws' , prf₁) , prf₂

-- Requires K.
lengthStream : ∀ {xs} → Stream xs → length xs ≈N ∞
lengthStream {xs} Sxs = ≈N-coind _R_ h₁ h₂
  where
  _R_ : D → D → Set
  m R n = ∃[ xs ] Stream xs ∧ m ≡ length xs ∧ n ≡ ∞

  h₁ : ∀ {m n} → m R n →
       m ≡ zero ∧ n ≡ zero ∨
       (∃[ m' ] ∃[ n' ] m' R n' ∧ m ≡ succ₁ m' ∧ n ≡ succ₁ n')
  h₁ (_ , Sxs' , _ ) with Stream-unf Sxs'
  h₁ {m} {n} (.(x'' ∷ xs'') , Sxs' , aux , n≡∞) | x'' , xs'' , Sxs'' , refl =
    inj₂ (length xs'' , ∞ , (xs'' , Sxs'' , refl , refl) , helper₁ , helper₂)
    where
    helper₁ : m ≡ succ₁ (length xs'')
    helper₁ = trans aux (length-∷ x'' xs'')

    helper₂ : n ≡ succ₁ ∞
    helper₂ = trans n≡∞ ∞-eq

  h₂ : length xs R ∞
  h₂ = xs , Sxs , refl , refl


Cosmetic change.

Cosmetic change.

Ignore-this: f3b9a4830249b8abbba002764a454e10

darcs-hash:20110912041947-3bd4e-a8e4c2508e86ade13b770c69c61835a022a773da.gz

------------------------------------------------------------------------------
-- ABP lemma 1
------------------------------------------------------------------------------

-- From the paper: The first lemma states that given a start state Abp
-- (of the alternating bit protocol) we will arrive at a state Abp',
-- where the message has been received by the receiver, but where the
-- acknowledgement has not yet been received by the sender.

module FOTC.Program.ABP.Lemma1ATP where

open import FOTC.Base

open import Common.Function

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

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

-- TODO: These variables are outside the where clause due to an issue
-- in the translation.

as⁵ : ∀ b i' is' ds → D
as⁵ b i' is' ds = await b i' is' ds
{-# ATP definition as⁵ #-}

bs⁵ : ∀ b i' is' ds os₀⁵ → D
bs⁵ b i' is' ds os₀⁵ = corrupt · os₀⁵ · (as⁵ b i' is' ds)
{-# ATP definition bs⁵ #-}

cs⁵ : ∀ b i' is' ds os₀⁵ → D
cs⁵ b i' is' ds os₀⁵ = abpack · b · (bs⁵ b i' is' ds os₀⁵)
{-# ATP definition cs⁵ #-}

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

os₀⁵ : ∀ os₀' ol₀⁵ → D
os₀⁵ os₀' ol₀⁵ = ol₀⁵ ++ os₀'
{-# ATP definition os₀⁵ #-}

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

lemma₁-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 →
                ∀ {ol₀} → O*L ol₀ →
                ∀ {os₀'-aux} → Fair os₀'-aux → os₀ ≡ ol₀ ++ os₀'-aux →
                ∃ λ os₀' → ∃ λ os₁' →
                ∃ λ as' → ∃ λ bs' → ∃ λ cs' → ∃ λ ds' → ∃ λ js' →
                Fair os₀'
                ∧ Fair os₁'
                ∧ Abp' b i' is' os₀' os₁' as' bs' cs' ds' js'
                ∧ js ≡ i' ∷ js'
lemma₁-helper {b} {i'} {is'} {js = js} Bb Fos₁ h nilO*L Fos₀' os₀-eq = prf
  where
  postulate
    prf : ∃ (λ os₀' → ∃ (λ os₁' →
          ∃ (λ as' → ∃ (λ bs' → ∃ (λ cs' → ∃ (λ ds' → ∃ (λ js' →
          Fair os₀'
          ∧ Fair os₁'
          ∧ (ds' ≡ corrupt · os₁' · (b ∷ cs')
             ∧ as' ≡ await b i' is' ds'
             ∧ bs' ≡ corrupt · os₀' · as'
             ∧ cs' ≡ abpack · (not b) · bs'
             ∧ js' ≡ abpout · (not b) · bs')
          ∧ js ≡ i' ∷ js')))))))
  {-# ATP prove prf #-}

lemma₁-helper {b} {i'} {is'} {os₀} {os₁} {as} {bs} {cs} {ds} {js}
              Bb Fos₁ abp
              (consO*L ol₀⁵ OLol₀⁵)
              {os₀'-aux = os₀'} Fos₀' os₀-eq =
                lemma₁-helper Bb (tail-Fair Fos₁) AbpIH OLol₀⁵ Fos₀' refl
  where
  postulate os₀-eq-helper : os₀ ≡ O ∷ os₀⁵ os₀' ol₀⁵
  {-# ATP prove os₀-eq-helper #-}

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

  postulate bs-eq : bs ≡ error ∷ (bs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵))
  {-# ATP prove bs-eq os₀-eq-helper as-eq #-}

  postulate cs-eq : cs ≡ not b ∷ cs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵)
  {-# ATP prove cs-eq bs-eq #-}

  postulate
    ds-eq-helper₁ : os₁ ≡ L ∷ tail os₁ →
                    ds ≡ ok (not b) ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  {-# ATP prove ds-eq-helper₁ cs-eq #-}

  postulate
    ds-eq-helper₂ : os₁ ≡ O ∷ tail os₁ →
                    ds ≡ error ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  {-# ATP prove ds-eq-helper₂ cs-eq #-}

  ds-eq : ds ≡ ok (not b) ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
          ∨ ds ≡ error ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  ds-eq = [ (λ h → inj₁ (ds-eq-helper₁ h))
          , (λ h → inj₂ (ds-eq-helper₂ h))
          ] (head-tail-Fair Fos₁)

  postulate
    as⁵-eq-helper₁ : ds ≡ ok (not b) ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁) →
                     as⁵ b i' is' ds ≡
                     abpsend · b · (i' ∷ is') · ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  {- ATP prove as⁵-eq-helper₁ #-}

  postulate
    as⁵-eq-helper₂ : ds ≡ error ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁) →
                     as⁵ b i' is' ds ≡
                     abpsend · b · (i' ∷ is') · ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  {- ATP prove as⁵-eq-helper₂ #-}

  as⁵-eq : as⁵ b i' is' ds ≡
           abpsend · b · (i' ∷ is') · ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  as⁵-eq = [ as⁵-eq-helper₁ , as⁵-eq-helper₂ ] ds-eq

  postulate js-eq : js ≡ abpout · b · bs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵)
  {-# ATP prove js-eq bs-eq #-}

  AbpIH : Abp b
              (i' ∷ is')
              (os₀⁵ os₀' ol₀⁵)
              (os₁⁵ os₁)
              (as⁵ b i' is' ds)
              (bs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵))
              (cs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵))
              (ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁))
              js
  AbpIH = as⁵-eq , refl , refl , refl , js-eq

-- From the paper: From the assumption that os₀ ∈ Fair, and hence by
-- unfolding Fair we conclude that there are ol₀ : O*L and os₀' :
-- Fair, such that
--
-- os₀ = ol₀ ++ os₀'.
--
-- We proceed by induction on ol₀ : O*L using lemma₁-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' → ∃ λ js' →
         Fair os₀'
         ∧ Fair os₁'
         ∧ Abp' b i' is' os₀' os₁' as' bs' cs' ds' js'
         ∧ js ≡ i' ∷ js'
lemma₁ {os₀ = os₀} Bb Fos₀ Fos₁ h = lemma₁-helper Bb Fos₁ h OLol₀ Fos₀' os₀-eq
  where
  unfold-os₀ : ∃ λ ol₀ → ∃ λ os₀' → O*L ol₀ ∧ Fair os₀' ∧ os₀ ≡ ol₀ ++ os₀'
  unfold-os₀ = Fair-gfp₁ Fos₀

  ol₀ : D
  ol₀ = ∃-proj₁ unfold-os₀

  os₀' : D
  os₀' = ∃-proj₁ (∃-proj₂ unfold-os₀)

  OLol₀ : O*L ol₀
  OLol₀ = ∧-proj₁ (∃-proj₂ (∃-proj₂ unfold-os₀))

  Fos₀' : Fair os₀'
  Fos₀' = ∧-proj₁ (∧-proj₂ (∃-proj₂ (∃-proj₂ unfold-os₀)))

  os₀-eq : os₀ ≡ ol₀ ++ os₀'
  os₀-eq = ∧-proj₂ (∧-proj₂ (∃-proj₂ (∃-proj₂ unfold-os₀)))

------------------------------------------------------------------------------
-- ABP lemma 1
------------------------------------------------------------------------------

-- From the paper: The first lemma states that given a start state Abp
-- (of the alternating bit protocol) we will arrive at a state Abp',
-- where the message has been received by the receiver, but where the
-- acknowledgement has not yet been received by the sender.

module FOTC.Program.ABP.Lemma1ATP where

open import FOTC.Base

open import Common.Function

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

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

-- TODO: These variables are outside the where clause due to an issue
-- in the translation.

as⁵ : ∀ b i' is' ds → D
as⁵ b i' is' ds = await b i' is' ds
{-# ATP definition as⁵ #-}

bs⁵ : ∀ b i' is' ds os₀⁵ → D
bs⁵ b i' is' ds os₀⁵ = corrupt · os₀⁵ · (as⁵ b i' is' ds)
{-# ATP definition bs⁵ #-}

cs⁵ : ∀ b i' is' ds os₀⁵ → D
cs⁵ b i' is' ds os₀⁵ = abpack · b · (bs⁵ b i' is' ds os₀⁵)
{-# ATP definition cs⁵ #-}

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

os₀⁵ : ∀ os₀' ol₀⁵ → D
os₀⁵ os₀' ol₀⁵ = ol₀⁵ ++ os₀'
{-# ATP definition os₀⁵ #-}

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

lemma₁-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 →
                ∀ {ol₀} → O*L ol₀ →
                ∀ {os₀'-aux} → Fair os₀'-aux → os₀ ≡ ol₀ ++ os₀'-aux →
                ∃ λ os₀' → ∃ λ os₁' →
                ∃ λ as' → ∃ λ bs' → ∃ λ cs' → ∃ λ ds' → ∃ λ js' →
                Fair os₀'
                ∧ Fair os₁'
                ∧ Abp' b i' is' os₀' os₁' as' bs' cs' ds' js'
                ∧ js ≡ i' ∷ js'
lemma₁-helper {b} {i'} {is'} {js = js} Bb Fos₁ h nilO*L Fos₀' os₀-eq = prf
  where
  postulate
    prf : ∃ (λ os₀' → ∃ (λ os₁' →
          ∃ (λ as' → ∃ (λ bs' → ∃ (λ cs' → ∃ (λ ds' → ∃ (λ js' →
          Fair os₀'
          ∧ Fair os₁'
          ∧ (ds' ≡ corrupt · os₁' · (b ∷ cs')
             ∧ as' ≡ await b i' is' ds'
             ∧ bs' ≡ corrupt · os₀' · as'
             ∧ cs' ≡ abpack · (not b) · bs'
             ∧ js' ≡ abpout · (not b) · bs')
          ∧ js ≡ i' ∷ js')))))))
  {-# ATP prove prf #-}

lemma₁-helper {b} {i'} {is'} {os₀} {os₁} {as} {bs} {cs} {ds} {js}
              Bb Fos₁ abp
              (consO*L ol₀⁵ OLol₀⁵)
              {os₀'-aux = os₀'} Fos₀' os₀-eq =
                lemma₁-helper Bb (tail-Fair Fos₁) AbpIH OLol₀⁵ Fos₀' refl
  where
  postulate os₀-eq-helper : os₀ ≡ O ∷ os₀⁵ os₀' ol₀⁵
  {-# ATP prove os₀-eq-helper #-}

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

  postulate bs-eq : bs ≡ error ∷ (bs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵))
  {-# ATP prove bs-eq os₀-eq-helper as-eq #-}

  postulate cs-eq : cs ≡ not b ∷ cs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵)
  {-# ATP prove cs-eq bs-eq #-}

  postulate
    ds-eq-helper₁ : os₁ ≡ L ∷ tail os₁ →
                    ds ≡ ok (not b) ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  {-# ATP prove ds-eq-helper₁ cs-eq #-}

  postulate
    ds-eq-helper₂ : os₁ ≡ O ∷ tail os₁ →
                    ds ≡ error ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  {-# ATP prove ds-eq-helper₂ cs-eq #-}

  ds-eq : ds ≡ ok (not b) ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
          ∨ ds ≡ error ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  ds-eq = [ (λ h → inj₁ (ds-eq-helper₁ h))
          , (λ h → inj₂ (ds-eq-helper₂ h))
          ] (head-tail-Fair Fos₁)

  postulate
    as⁵-eq-helper₁ : ds ≡ ok (not b) ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁) →
                     as⁵ b i' is' ds ≡
                     abpsend · b · (i' ∷ is') · ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  {- ATP prove as⁵-eq-helper₁ #-}

  postulate
    as⁵-eq-helper₂ : ds ≡ error ∷ ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁) →
                     as⁵ b i' is' ds ≡
                     abpsend · b · (i' ∷ is') · ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵ )(os₁⁵ os₁)
  {- ATP prove as⁵-eq-helper₂ #-}

  as⁵-eq : as⁵ b i' is' ds ≡
           abpsend · b · (i' ∷ is') · ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁)
  as⁵-eq = [ as⁵-eq-helper₁ , as⁵-eq-helper₂ ] ds-eq

  postulate js-eq : js ≡ abpout · b · bs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵)
  {-# ATP prove js-eq bs-eq #-}

  AbpIH : Abp b
              (i' ∷ is')
              (os₀⁵ os₀' ol₀⁵)
              (os₁⁵ os₁)
              (as⁵ b i' is' ds)
              (bs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵))
              (cs⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵))
              (ds⁵ b i' is' ds (os₀⁵ os₀' ol₀⁵) (os₁⁵ os₁))
              js
  AbpIH = as⁵-eq , refl , refl , refl , js-eq

-- From the paper: From the assumption that os₀ ∈ Fair, and hence by
-- unfolding Fair we conclude that there are ol₀ : O*L and os₀' :
-- Fair, such that
--
-- os₀ = ol₀ ++ os₀'.
--
-- We proceed by induction on ol₀ : O*L using lemma₁-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' → ∃ λ js' →
         Fair os₀'
         ∧ Fair os₁'
         ∧ Abp' b i' is' os₀' os₁' as' bs' cs' ds' js'
         ∧ js ≡ i' ∷ js'
lemma₁ {os₀ = os₀} Bb Fos₀ Fos₁ h = lemma₁-helper Bb Fos₁ h OLol₀ Fos₀' os₀-eq
  where
  unfold-os₀ : ∃ λ ol₀ → ∃ λ os₀' → O*L ol₀ ∧ Fair os₀' ∧ os₀ ≡ ol₀ ++ os₀'
  unfold-os₀ = Fair-gfp₁ Fos₀

  ol₀ : D
  ol₀ = ∃-proj₁ unfold-os₀

  os₀' : D
  os₀' = ∃-proj₁ (∃-proj₂ unfold-os₀)

  OLol₀ : O*L ol₀
  OLol₀ = ∧-proj₁ (∃-proj₂ (∃-proj₂ unfold-os₀))

  Fos₀' : Fair os₀'
  Fos₀' = ∧-proj₁ (∧-proj₂ (∃-proj₂ (∃-proj₂ unfold-os₀)))

  os₀-eq : os₀ ≡ ol₀ ++ os₀'
  os₀-eq = ∧-proj₂ (∧-proj₂ (∃-proj₂ (∃-proj₂ unfold-os₀)))