Remove instance arguments from Agda code.

Instance argument behavior was changed in a recent release. Remove use of instance arguments to avoid the hassle of changing them.

module Text.Greek.Script where

open import Data.Maybe
open import Data.Vec
open import Relation.Nullary using (¬_)
open import Relation.Binary.PropositionalEquality using (_≢_)

data Case : Set where
  lower upper : Case

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

vowels : Vec _ _
vowels = α′ ∷ ε′ ∷ η′ ∷ ι′ ∷ ο′ ∷ υ′ ∷ ω′ ∷ []

always-short-letters : Vec _ _
always-short-letters = ε′ ∷ ο′ ∷ []

diaeresis-letters : Vec _ _
diaeresis-letters = ι′ ∷ υ′ ∷ []

iota-subscript-letters : Vec _ _
iota-subscript-letters = α′ ∷ η′ ∷ ω′ ∷ []

data _vowel : Letter → Set where
  is-vowel : ∀ {v} → v ∈ vowels → v vowel

data _always-short : Letter → Set where
  is-always-short : ∀ {v} → v vowel → v ∈ always-short-letters → v always-short

data _diaeresis : Letter → Set where
  add-diaeresis : ∀ {v} → v vowel → v ∈ diaeresis-letters → v diaeresis

data _⟦_⟧-final : Letter → Case → Set where
  make-final : σ′ ⟦ lower ⟧-final

data _⟦_⟧-smooth : Letter → Case → Set where
  add-smooth-lower-vowel : ∀ {v} → v vowel → v ⟦ lower ⟧-smooth
  add-smooth-ρ : ρ′ ⟦ lower ⟧-smooth
  add-smooth-upper-vowel-not-Υ : ∀ {v} → v vowel → v ≢ υ′ → v ⟦ upper ⟧-smooth

data _with-rough : Letter → Set where
  add-rough-vowel : ∀ {v} → v vowel → v with-rough
  add-rough-ρ : ρ′ with-rough

data _iota-subscript : Letter → Set where
  add-iota-subscript : ∀ {v} → v vowel → v ∈ iota-subscript-letters → v iota-subscript

data _⟦_⟧-breathing : Letter → Case → Set where
  smooth : ∀ {ℓ c} → ℓ ⟦ c ⟧-smooth → ℓ ⟦ c ⟧-breathing
  rough : ∀ {ℓ c} → ℓ with-rough → ℓ ⟦ c ⟧-breathing

data _long-vowel : Letter → Set where
  make-long-vowel : ∀ {v} → v vowel → ¬ v always-short → v long-vowel

data _accent : Letter → Set where
  acute : ∀ {ℓ} → ℓ vowel → ℓ accent
  grave : ∀ {ℓ} → ℓ vowel → ℓ accent
  circumflex : ∀ {ℓ} → ℓ long-vowel → ℓ accent

data Token : Set where
  unmarked : (ℓ : Letter) → (c : Case) → Token
  with-accent : (ℓ : Letter) → (c : Case) → ℓ accent → Token
  with-breathing : (ℓ : Letter) → (c : Case) → ℓ ⟦ c ⟧-breathing → Token
  with-accent-breathing : (ℓ : Letter) → (c : Case) → ℓ accent → ℓ ⟦ c ⟧-breathing → Token
  with-accent-breathing-iota : (ℓ : Letter) → (c : Case) → ℓ accent → ℓ ⟦ c ⟧-breathing → ℓ iota-subscript → Token
  with-diaeresis : (ℓ : Letter) → (c : Case) → ℓ diaeresis → Token
  with-accent-diaeresis : (ℓ : Letter) → (c : Case) → ℓ accent → ℓ diaeresis → Token
  with-accent-iota : (ℓ : Letter) → (c : Case) → ℓ accent → ℓ iota-subscript → Token
  with-breathing-iota : (ℓ : Letter) → (c : Case) → ℓ ⟦ c ⟧-breathing → ℓ iota-subscript → Token
  with-iota : (ℓ : Letter) → (c : Case) → ℓ iota-subscript → Token
  final : (ℓ : Letter) → (c : Case) → ℓ ⟦ c ⟧-final → Token

-- Constructions

-- Α α
α-vowel : α′ vowel
α-vowel = is-vowel here

¬α-always-short : ¬ α′ always-short
¬α-always-short (is-always-short x (there (there ())))

α-long-vowel : α′ long-vowel
α-long-vowel = make-long-vowel α-vowel ¬α-always-short

α-smooth : α′ ⟦ lower ⟧-smooth
α-smooth = add-smooth-lower-vowel (is-vowel here)

Α-smooth : α′ ⟦ upper ⟧-smooth
Α-smooth = add-smooth-upper-vowel-not-Υ (is-vowel here) (λ ())

α-rough : α′ with-rough
α-rough = add-rough-vowel (is-vowel here)

α-iota-subscript : α′ iota-subscript
α-iota-subscript = add-iota-subscript (is-vowel here) here

-- Ε ε
ε-vowel : ε′ vowel
ε-vowel = is-vowel (there here)

ε-always-short : ε′ always-short
ε-always-short = is-always-short (is-vowel (there here)) here

ε-smooth : ε′ ⟦ lower ⟧-smooth
ε-smooth = add-smooth-lower-vowel (is-vowel (there here))

Ε-smooth : ε′ ⟦ upper ⟧-smooth
Ε-smooth = add-smooth-upper-vowel-not-Υ (is-vowel (there here)) (λ ())

ε-rough : ε′ with-rough
ε-rough = add-rough-vowel (is-vowel (there here))

-- Η η
η-vowel : η′ vowel
η-vowel = is-vowel (there (there here))

¬η-always-short : ¬ η′ always-short
¬η-always-short (is-always-short x (there (there ())))

η-long-vowel : η′ long-vowel
η-long-vowel = make-long-vowel (is-vowel (there (there here))) ¬η-always-short

η-smooth : η′ ⟦ lower ⟧-smooth
η-smooth = add-smooth-lower-vowel (is-vowel (there (there here)))

Η-smooth : η′ ⟦ upper ⟧-smooth
Η-smooth = add-smooth-upper-vowel-not-Υ (is-vowel (there (there here))) (λ ())

η-rough : η′ with-rough
η-rough = add-rough-vowel (is-vowel (there (there here)))

η-iota-subscript : η′ iota-subscript
η-iota-subscript = add-iota-subscript (is-vowel (there (there here))) (there here)

-- Ι ι

ι-vowel : ι′ vowel
ι-vowel = is-vowel (there (there (there here)))

¬ι-always-short : ¬ ι′ always-short
¬ι-always-short (is-always-short x (there (there ())))

ι-long-vowel : ι′ long-vowel
ι-long-vowel = make-long-vowel (is-vowel (there (there (there here)))) ¬ι-always-short

ι-smooth : ι′ ⟦ lower ⟧-smooth
ι-smooth = add-smooth-lower-vowel (is-vowel (there (there (there here))))

Ι-smooth : ι′ ⟦ upper ⟧-smooth
Ι-smooth = add-smooth-upper-vowel-not-Υ
             (is-vowel (there (there (there here)))) (λ ())

ι-rough : ι′ with-rough
ι-rough = add-rough-vowel (is-vowel (there (there (there here))))

ι-diaeresis : ι′ diaeresis
ι-diaeresis = add-diaeresis (is-vowel (there (there (there here)))) here

-- Ο ο
ο-vowel : ο′ vowel
ο-vowel = is-vowel (there (there (there (there here))))

ο-always-short : ο′ always-short
ο-always-short = is-always-short (is-vowel (there (there (there (there here)))))
                   (there here)

ο-smooth : ο′ ⟦ lower ⟧-smooth
ο-smooth = add-smooth-lower-vowel
             (is-vowel (there (there (there (there here)))))

Ο-smooth : ο′ ⟦ upper ⟧-smooth
Ο-smooth = add-smooth-upper-vowel-not-Υ
             (is-vowel (there (there (there (there here))))) (λ ())

ο-rough : ο′ with-rough
ο-rough = add-rough-vowel (is-vowel (there (there (there (there here)))))

-- Ρ ρ
ρ-smooth : ρ′ ⟦ lower ⟧-smooth
ρ-smooth = add-smooth-ρ

ρ-rough : ρ′ with-rough
ρ-rough = add-rough-ρ

-- Σ σ
σ-final : σ′ ⟦ lower ⟧-final
σ-final = make-final

-- Υ υ
υ-vowel : υ′ vowel
υ-vowel = is-vowel (there (there (there (there (there here)))))

¬υ-always-short : ¬ υ′ always-short
¬υ-always-short (is-always-short x (there (there ())))

υ-long-vowel : υ′ long-vowel
υ-long-vowel = make-long-vowel υ-vowel ¬υ-always-short

υ-smooth : υ′ ⟦ lower ⟧-smooth
υ-smooth = add-smooth-lower-vowel
             (is-vowel (there (there (there (there (there here))))))

υ-rough : υ′ with-rough
υ-rough = add-rough-vowel
            (is-vowel (there (there (there (there (there here))))))

υ-diaeresis : υ′ diaeresis
υ-diaeresis = add-diaeresis
                (is-vowel (there (there (there (there (there here))))))
                (there here)

-- Ω ω
ω-vowel : ω′ vowel
ω-vowel = is-vowel (there (there (there (there (there (there here))))))

¬ω-always-short : ¬ ω′ always-short
¬ω-always-short (is-always-short x (there (there ())))

ω-long-vowel : ω′ long-vowel
ω-long-vowel = make-long-vowel ω-vowel ¬ω-always-short

ω-smooth : ω′ ⟦ lower ⟧-smooth
ω-smooth = add-smooth-lower-vowel
             (is-vowel (there (there (there (there (there (there here)))))))

Ω-smooth : ω′ ⟦ upper ⟧-smooth
Ω-smooth = add-smooth-upper-vowel-not-Υ
             (is-vowel (there (there (there (there (there (there here)))))))
             (λ ())

ω-rough : ω′ with-rough
ω-rough = add-rough-vowel
            (is-vowel (there (there (there (there (there (there here)))))))

ω-iota-subscript : ω′ iota-subscript
ω-iota-subscript = add-iota-subscript
                     (is-vowel (there (there (there (there (there (there here)))))))
                     (there (there here))

-- Mapping

get-letter : Token → Letter
get-letter (unmarked ℓ _) = ℓ
get-letter (with-accent ℓ _ _) = ℓ
get-letter (with-breathing ℓ _ _) = ℓ
get-letter (with-accent-breathing ℓ _ _ _) = ℓ
get-letter (with-accent-breathing-iota ℓ _ _ _ _) = ℓ
get-letter (with-diaeresis ℓ _ _) = ℓ
get-letter (with-accent-diaeresis ℓ _ _ _) = ℓ
get-letter (with-accent-iota ℓ _ _ _) = ℓ
get-letter (with-breathing-iota ℓ _ _ _) = ℓ
get-letter (with-iota ℓ _ _) = ℓ
get-letter (final ℓ _ _) = ℓ

get-case : Token → Case
get-case (unmarked _ c) = c
get-case (with-accent _ c _) = c
get-case (with-breathing _ c _) = c
get-case (with-accent-breathing _ c _ _) = c
get-case (with-accent-breathing-iota _ c _ _ _) = c
get-case (with-diaeresis _ c _) = c
get-case (with-accent-diaeresis _ c _ _) = c
get-case (with-accent-iota _ c _ _) = c
get-case (with-breathing-iota _ c _ _) = c
get-case (with-iota _ c _) = c
get-case (final _ c _) = c

data Accent : Set where
  acute-mark grave-mark circumflex-mark : Accent

letter-to-accent : ∀ {v} → v accent → Accent
letter-to-accent (acute x) = acute-mark
letter-to-accent (grave x) = grave-mark
letter-to-accent (circumflex x) = circumflex-mark

get-accent : Token → Maybe Accent
get-accent (with-accent _ _ a) = just (letter-to-accent a)
get-accent (with-accent-breathing _ _ a _) = just (letter-to-accent a)
get-accent (with-accent-breathing-iota _ _ a _ _) = just (letter-to-accent a)
get-accent (with-accent-diaeresis _ _ a _) = just (letter-to-accent a)
get-accent (with-accent-iota _ _ a _) = just (letter-to-accent a)
get-accent _ = nothing

data Breathing : Set where
  smooth-mark rough-mark : Breathing

letter-to-breathing : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → Breathing
letter-to-breathing (smooth x) = smooth-mark
letter-to-breathing (rough x) = rough-mark

get-breathing : Token → Maybe Breathing
get-breathing (with-breathing _ _ x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing _ _ _ x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing-iota _ _ _ x _) = just (letter-to-breathing x)
get-breathing (with-breathing-iota _ _ x _) = just (letter-to-breathing x)
get-breathing _ = nothing

data IotaSubscript : Set where
  iota-subscript-mark : IotaSubscript

get-iota-subscript : Token → Maybe IotaSubscript
get-iota-subscript (with-accent-breathing-iota _ _ _ _ _) = just iota-subscript-mark
get-iota-subscript (with-accent-iota _ _ _ _) = just iota-subscript-mark
get-iota-subscript (with-breathing-iota _ _ _ _) = just iota-subscript-mark
get-iota-subscript _ = nothing

data Diaeresis : Set where
  diaeresis-mark : Diaeresis

get-diaeresis : Token → Maybe Diaeresis
get-diaeresis (with-diaeresis _ _ _) = just diaeresis-mark
get-diaeresis (with-accent-diaeresis _ _ _ _) = just diaeresis-mark
get-diaeresis _ = nothing

data FinalForm : Set where
  final-form : FinalForm

get-final-form : Token → Maybe FinalForm
get-final-form (final _ _ _) = just final-form
get-final-form _ = nothing

module Text.Greek.Script where

open import Data.Maybe
open import Data.Vec
open import Relation.Nullary using (¬_)
open import Relation.Binary.PropositionalEquality using (_≢_)

data Case : Set where
  lower upper : Case

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

vowels : Vec _ _
vowels = α′ ∷ ε′ ∷ η′ ∷ ι′ ∷ ο′ ∷ υ′ ∷ ω′ ∷ []

always-short-letters : Vec _ _
always-short-letters = ε′ ∷ ο′ ∷ []

diaeresis-letters : Vec _ _
diaeresis-letters = ι′ ∷ υ′ ∷ []

iota-subscript-letters : Vec _ _
iota-subscript-letters = α′ ∷ η′ ∷ ω′ ∷ []

data _vowel : Letter → Set where
  is-vowel : ∀ {v} → v ∈ vowels → v vowel

data _always-short : Letter → Set where
  is-always-short : ∀ {v} → ⦃ p : v vowel ⦄ → v ∈ always-short-letters → v always-short

data _diaeresis : Letter → Set where
  add-diaeresis : ∀ {v} → ⦃ p : v vowel ⦄ → v ∈ diaeresis-letters → v diaeresis

data _⟦_⟧-final : Letter → Case → Set where
  make-final : σ′ ⟦ lower ⟧-final

data _⟦_⟧-smooth : Letter → Case → Set where
  add-smooth-lower-vowel : ∀ {v} → ⦃ p : v vowel ⦄ → v ⟦ lower ⟧-smooth
  add-smooth-ρ : ρ′ ⟦ lower ⟧-smooth
  add-smooth-upper-vowel-not-Υ : ∀ {v} → ⦃ p : v vowel ⦄ → v ≢ υ′ → v ⟦ upper ⟧-smooth

data _with-rough : Letter → Set where
  add-rough-vowel : ∀ {v} → ⦃ p : v vowel ⦄ → v with-rough
  add-rough-ρ : ρ′ with-rough

data _iota-subscript : Letter → Set where
  add-iota-subscript : ∀ {v} → ⦃ p : v vowel ⦄ → v ∈ iota-subscript-letters → v iota-subscript

data _⟦_⟧-breathing : Letter → Case → Set where
  smooth : ∀ {ℓ c} → ⦃ p : ℓ ⟦ c ⟧-smooth ⦄ → ℓ ⟦ c ⟧-breathing
  rough : ∀ {ℓ c} → ⦃ p : ℓ with-rough ⦄ → ℓ ⟦ c ⟧-breathing

data _long-vowel : Letter → Set where
  make-long-vowel : ∀ {v} → ⦃ p : v vowel ⦄ → ¬ v always-short → v long-vowel

data _accent : Letter → Set where
  acute : ∀ {ℓ} → ⦃ p : ℓ vowel ⦄ → ℓ accent
  grave : ∀ {ℓ} → ⦃ p : ℓ vowel ⦄ → ℓ accent
  circumflex : ∀ {ℓ} → ⦃ p : ℓ long-vowel ⦄ → ℓ accent

data Token : Set where
  unmarked : (ℓ : Letter) → (c : Case) → Token
  with-accent : (ℓ : Letter) → (c : Case) → ℓ accent → Token
  with-breathing : (ℓ : Letter) → (c : Case) → ℓ ⟦ c ⟧-breathing → Token
  with-accent-breathing : (ℓ : Letter) → (c : Case) → ℓ accent → ℓ ⟦ c ⟧-breathing → Token
  with-accent-breathing-iota : (ℓ : Letter) → (c : Case) → ℓ accent → ℓ ⟦ c ⟧-breathing → ⦃ p : ℓ iota-subscript ⦄ → Token
  with-diaeresis : (ℓ : Letter) → (c : Case) → ⦃ p : ℓ diaeresis ⦄ → Token
  with-accent-diaeresis : (ℓ : Letter) → (c : Case) → ℓ accent → ⦃ p : ℓ diaeresis ⦄ → Token
  with-accent-iota : (ℓ : Letter) → (c : Case) → ℓ accent → ⦃ p : ℓ iota-subscript ⦄ → Token
  with-breathing-iota : (ℓ : Letter) → (c : Case) → ℓ ⟦ c ⟧-breathing → ⦃ p : ℓ iota-subscript ⦄ → Token
  with-iota : (ℓ : Letter) → (c : Case) → ⦃ p : ℓ iota-subscript ⦄ → Token
  final : (ℓ : Letter) → (c : Case) → ⦃ p : ℓ ⟦ c ⟧-final ⦄ → Token

-- Constructions

-- Α α
instance α-vowel : α′ vowel
α-vowel = is-vowel here

¬α-always-short : ¬ α′ always-short
¬α-always-short (is-always-short (there (there ())))

instance α-long-vowel : α′ long-vowel
α-long-vowel = make-long-vowel ¬α-always-short

instance α-smooth : α′ ⟦ lower ⟧-smooth
α-smooth = add-smooth-lower-vowel

instance Α-smooth : α′ ⟦ upper ⟧-smooth
Α-smooth = add-smooth-upper-vowel-not-Υ (λ ())

instance α-rough : α′ with-rough
α-rough = add-rough-vowel

instance α-iota-subscript : α′ iota-subscript
α-iota-subscript = add-iota-subscript here

-- Ε ε
instance ε-vowel : ε′ vowel
ε-vowel = is-vowel (there here)

ε-always-short : ε′ always-short
ε-always-short = is-always-short here

instance ε-smooth : ε′ ⟦ lower ⟧-smooth
ε-smooth = add-smooth-lower-vowel

instance Ε-smooth : ε′ ⟦ upper ⟧-smooth
Ε-smooth = add-smooth-upper-vowel-not-Υ (λ ())

instance ε-rough : ε′ with-rough
ε-rough = add-rough-vowel

-- Η η
instance η-vowel : η′ vowel
η-vowel = is-vowel (there (there here))

¬η-always-short : ¬ η′ always-short
¬η-always-short (is-always-short (there (there ())))

instance η-long-vowel : η′ long-vowel
η-long-vowel = make-long-vowel ¬η-always-short

instance η-smooth : η′ ⟦ lower ⟧-smooth
η-smooth = add-smooth-lower-vowel

instance Η-smooth : η′ ⟦ upper ⟧-smooth
Η-smooth = add-smooth-upper-vowel-not-Υ (λ ())

instance η-rough : η′ with-rough
η-rough = add-rough-vowel

instance η-iota-subscript : η′ iota-subscript
η-iota-subscript = add-iota-subscript (there here)

-- Ι ι

instance ι-vowel : ι′ vowel
ι-vowel = is-vowel (there (there (there here)))

¬ι-always-short : ¬ ι′ always-short
¬ι-always-short (is-always-short (there (there ())))

instance ι-long-vowel : ι′ long-vowel
ι-long-vowel = make-long-vowel ¬ι-always-short

instance ι-smooth : ι′ ⟦ lower ⟧-smooth
ι-smooth = add-smooth-lower-vowel

instance Ι-smooth : ι′ ⟦ upper ⟧-smooth
Ι-smooth = add-smooth-upper-vowel-not-Υ (λ ())

instance ι-rough : ι′ with-rough
ι-rough = add-rough-vowel

instance ι-diaeresis : ι′ diaeresis
ι-diaeresis = add-diaeresis here

-- Ο ο
instance ο-vowel : ο′ vowel
ο-vowel = is-vowel (there (there (there (there here))))

ο-always-short : ο′ always-short
ο-always-short = is-always-short (there here)

instance ο-smooth : ο′ ⟦ lower ⟧-smooth
ο-smooth = add-smooth-lower-vowel

instance Ο-smooth : ο′ ⟦ upper ⟧-smooth
Ο-smooth = add-smooth-upper-vowel-not-Υ (λ ())

instance ο-rough : ο′ with-rough
ο-rough = add-rough-vowel

-- Ρ ρ
instance ρ-smooth : ρ′ ⟦ lower ⟧-smooth
ρ-smooth = add-smooth-ρ

instance ρ-rough : ρ′ with-rough
ρ-rough = add-rough-ρ

-- Σ σ
instance σ-final : σ′ ⟦ lower ⟧-final
σ-final = make-final

-- Υ υ
instance υ-vowel : υ′ vowel
υ-vowel = is-vowel (there (there (there (there (there here)))))

¬υ-always-short : ¬ υ′ always-short
¬υ-always-short (is-always-short (there (there ())))

instance υ-long-vowel : υ′ long-vowel
υ-long-vowel = make-long-vowel ¬υ-always-short

instance υ-smooth : υ′ ⟦ lower ⟧-smooth
υ-smooth = add-smooth-lower-vowel

instance υ-rough : υ′ with-rough
υ-rough = add-rough-vowel

instance υ-diaeresis : υ′ diaeresis
υ-diaeresis = add-diaeresis (there here)

-- Ω ω
instance ω-vowel : ω′ vowel
ω-vowel = is-vowel (there (there (there (there (there (there here))))))

¬ω-always-short : ¬ ω′ always-short
¬ω-always-short (is-always-short (there (there ())))

instance ω-long-vowel : ω′ long-vowel
ω-long-vowel = make-long-vowel ¬ω-always-short

instance ω-smooth : ω′ ⟦ lower ⟧-smooth
ω-smooth = add-smooth-lower-vowel

instance Ω-smooth : ω′ ⟦ upper ⟧-smooth
Ω-smooth = add-smooth-upper-vowel-not-Υ (λ ())

instance ω-rough : ω′ with-rough
ω-rough = add-rough-vowel

instance ω-iota-subscript : ω′ iota-subscript
ω-iota-subscript = add-iota-subscript (there (there here))

-- Mapping

get-letter : Token → Letter
get-letter (unmarked ℓ _) = ℓ
get-letter (with-accent ℓ _ _) = ℓ
get-letter (with-breathing ℓ _ _) = ℓ
get-letter (with-accent-breathing ℓ _ _ _) = ℓ
get-letter (with-accent-breathing-iota ℓ _ _ _) = ℓ
get-letter (with-diaeresis ℓ _) = ℓ
get-letter (with-accent-diaeresis ℓ _ _) = ℓ
get-letter (with-accent-iota ℓ _ _) = ℓ
get-letter (with-breathing-iota ℓ _ _) = ℓ
get-letter (with-iota ℓ _) = ℓ
get-letter (final ℓ _) = ℓ

get-case : Token → Case
get-case (unmarked _ c) = c
get-case (with-accent _ c _) = c
get-case (with-breathing _ c _) = c
get-case (with-accent-breathing _ c _ _) = c
get-case (with-accent-breathing-iota _ c _ _) = c
get-case (with-diaeresis _ c) = c
get-case (with-accent-diaeresis _ c _) = c
get-case (with-accent-iota _ c _) = c
get-case (with-breathing-iota _ c _) = c
get-case (with-iota _ c) = c
get-case (final _ c) = c

data Accent : Set where
  acute-mark grave-mark circumflex-mark : Accent

letter-to-accent : ∀ {v} → v accent → Accent
letter-to-accent acute = acute-mark
letter-to-accent grave = grave-mark
letter-to-accent circumflex = circumflex-mark

get-accent : Token → Maybe Accent
get-accent (with-accent _ _ a) = just (letter-to-accent a)
get-accent (with-accent-breathing _ _ a _) = just (letter-to-accent a)
get-accent (with-accent-breathing-iota _ _ a _) = just (letter-to-accent a)
get-accent (with-accent-diaeresis _ _ a) = just (letter-to-accent a)
get-accent (with-accent-iota _ _ a) = just (letter-to-accent a)
get-accent _ = nothing

data Breathing : Set where
  smooth-mark rough-mark : Breathing

letter-to-breathing : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → Breathing
letter-to-breathing smooth = smooth-mark
letter-to-breathing rough = rough-mark

get-breathing : Token → Maybe Breathing
get-breathing (with-breathing _ _ x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing _ _ _ x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing-iota _ _ _ x) = just (letter-to-breathing x)
get-breathing (with-breathing-iota _ _ x) = just (letter-to-breathing x)
get-breathing _ = nothing

data IotaSubscript : Set where
  iota-subscript-mark : IotaSubscript

get-iota-subscript : Token → Maybe IotaSubscript
get-iota-subscript (with-accent-breathing-iota _ _ _ _) = just iota-subscript-mark
get-iota-subscript (with-accent-iota _ _ _) = just iota-subscript-mark
get-iota-subscript (with-breathing-iota _ _ _) = just iota-subscript-mark
get-iota-subscript _ = nothing

data Diaeresis : Set where
  diaeresis-mark : Diaeresis

get-diaeresis : Token → Maybe Diaeresis
get-diaeresis (with-diaeresis _ _) = just diaeresis-mark
get-diaeresis (with-accent-diaeresis _ _ _) = just diaeresis-mark
get-diaeresis _ = nothing

data FinalForm : Set where
  final-form : FinalForm

get-final-form : Token → Maybe FinalForm
get-final-form (final _ _) = just final-form
get-final-form _ = nothing


IDesc in IDesc, stratified, with a 'lift'ing axiom

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

lift : {i : Level} -> Set i -> Set (suc i)
lift = {!!}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc (l : Level)(I : Set l) : Set (suc l) where
  var : I -> IDesc l I
  const : Set l -> IDesc l I
  prod : IDesc l I -> IDesc l I -> IDesc l I
  sigma : (S : Set l) -> (S -> IDesc l I) -> IDesc l I
  pi : (S : Set l) -> (S -> IDesc l I) -> IDesc l I

--********************************************
-- Desc interpretation
--********************************************

desc : (I : Set) -> IDesc zero I -> (I -> Set) -> Set
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

{-
data IMu (I : Set)(R : I -> IDesc I) : IDesc I -> Set1 where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)
-}

data IMu (I : Set)(R : I -> IDesc zero I)(i : I) : Set where
  con : desc I (R i) (\j -> IMu I R j) -> IMu I R i

--********************************************
-- Predicate: Box
--********************************************

box : (I : Set)(D : IDesc zero I)(P : I -> Set) -> desc I D P -> IDesc zero (Sigma I P)
box I (var i)     P x        = var (i , x)
box I (const X)   P x        = const X
box I (prod D D') P (d , d') = prod (box I D P d) (box I D' P d')
box I (sigma S T) P (a , b)  = box I (T a) P b
box I (pi S T)    P f        = pi S (\s -> box I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (I : Set)
            (R : I -> IDesc zero I)
            (P : Sigma I (IMu I R) -> Set)
            (m : (i : I)(xs : desc I (R i) (IMu I R))(hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) -> P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc zero I) -> (xs : desc I D (IMu I R)) -> desc (Sigma I (IMu I R)) (box I D (IMu I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (I : Set)(R : I -> IDesc zero I)(P : Sigma I (IMu I R) -> Set)
            (m : (i : I)
                 (xs : desc I (R i) (IMu I R))
                 (hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu I R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst : Set1 where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : Set -> DescDConst -> IDesc (suc zero) Unit
descDChoice I lvar = const (lift I)
descDChoice _ lconst = const Set
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma Set (\S -> pi (lift S) (\s -> var Void))
descDChoice _ lsigma = sigma Set (\S -> pi (lift S) (\s -> var Void))

descD : (I : Set) -> IDesc (suc zero) Unit
descD I = sigma DescDConst (descDChoice I)

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
record One  {i : Level} : Set i where

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set1 where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : (I : Set) -> IDesc I -> (I -> Set) -> Set
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

{-
data IMu (I : Set)(R : I -> IDesc I) : IDesc I -> Set1 where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)
-}

data IMu (I : Set)(R : I -> IDesc I)(i : I) : Set where
  con : desc I (R i) (\j -> IMu I R j) -> IMu I R i

--********************************************
-- Predicate: Box
--********************************************

box : (I : Set)(D : IDesc I)(P : I -> Set) -> desc I D P -> IDesc (Sigma I P)
box I (var i)     P x        = var (i , x)
box I (const X)   P x        = const X
box I (prod D D') P (d , d') = prod (box I D P d) (box I D' P d')
box I (sigma S T) P (a , b)  = box I (T a) P b
box I (pi S T)    P f        = pi S (\s -> box I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (I : Set)
            (R : I -> IDesc I)
            (P : Sigma I (IMu I R) -> Set)
            (m : (i : I)(xs : desc I (R i) (IMu I R))(hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) -> P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) -> (xs : desc I D (IMu I R)) -> desc (Sigma I (IMu I R)) (box I D (IMu I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (I : Set)(R : I -> IDesc I)(P : Sigma I (IMu I R) -> Set)
            (m : (i : I)
                 (xs : desc I (R i) (IMu I R))
                 (hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu I R i) -> P ( i , x )
induction = Elim.induction


Renamed a proof.

Renamed a proof.

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

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

-- The main properties proved of the McCarthy 91 function (called
-- mc91) are

-- 1. The function always terminates.
-- 2. For all n, n < mc91 n + 11.
-- 3. For all n > 100, then mc91 n = n - 10.
-- 4. For all n <= 100, then mc91 n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.AuxiliaryPropertiesATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.LT2WF-RelationATP
open import FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP

------------------------------------------------------------------------------
-- For all n > 100, then mc91 n = n - 10.
postulate mc91-res>100 : ∀ n → n > [100] → mc91 n ≡ n ∸ [10]
{-# ATP prove mc91-res>100 #-}

-- For all n <= 100, then mc91 n = 91.
mc91-res≯100 : ∀ {n} → N n → n ≯ [100] → mc91 n ≡ [91]
mc91-res≯100 = ≪-wfind A h
  where
  A : D → Set
  A d = d ≯ [100] → mc91 d ≡ [91]

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = λ m≯100 →
                     ⊥-elim (x>y→x≤y→⊥ Nm 100-N m>100 (x≯y→x≤y Nm 100-N m≯100))
  ... | inj₂ m≯100 with x≯Sy→x≯y∨x≡Sy Nm 99-N m≯100
  ... | inj₂ m≡100 = λ _ → mc91-res-aux mc91-res-100 m≡100
  ... | inj₁ m≯99 with x≯Sy→x≯y∨x≡Sy Nm 98-N m≯99
  ... | inj₂ m≡99 = λ _ → mc91-res-aux mc91-res-99 m≡99
  ... | inj₁ m≯98 with x≯Sy→x≯y∨x≡Sy Nm 97-N m≯98
  ... | inj₂ m≡98 = λ _ → mc91-res-aux mc91-res-98 m≡98
  ... | inj₁ m≯97 with x≯Sy→x≯y∨x≡Sy Nm 96-N m≯97
  ... | inj₂ m≡97 = λ _ → mc91-res-aux mc91-res-97 m≡97
  ... | inj₁ m≯96 with x≯Sy→x≯y∨x≡Sy Nm 95-N m≯96
  ... | inj₂ m≡96 = λ _ → mc91-res-aux mc91-res-96 m≡96
  ... | inj₁ m≯95 with x≯Sy→x≯y∨x≡Sy Nm 94-N m≯95
  ... | inj₂ m≡95 = λ _ → mc91-res-aux mc91-res-95 m≡95
  ... | inj₁ m≯94 with x≯Sy→x≯y∨x≡Sy Nm 93-N m≯94
  ... | inj₂ m≡94 = λ _ → mc91-res-aux mc91-res-94 m≡94
  ... | inj₁ m≯93 with x≯Sy→x≯y∨x≡Sy Nm 92-N m≯93
  ... | inj₂ m≡93 = λ _ → mc91-res-aux mc91-res-93 m≡93
  ... | inj₁ m≯92 with x≯Sy→x≯y∨x≡Sy Nm 91-N m≯92
  ... | inj₂ m≡92 = λ _ → mc91-res-aux mc91-res-92 m≡92
  ... | inj₁ m≯91 with x≯Sy→x≯y∨x≡Sy Nm 90-N m≯91
  ... | inj₂ m≡91 = λ _ → mc91-res-aux mc91-res-91 m≡91
  ... | inj₁ m≯90 with x≯Sy→x≯y∨x≡Sy Nm 89-N m≯90
  ... | inj₂ m≡90 = λ _ → mc91-res-aux mc91-res-90 m≡90
  ... | inj₁ m≯89 = λ _ → mc91-res-m≯89
    where
    m≤89 : m ≤ [89]
    m≤89 = x≯y→x≤y Nm 89-N m≯89

    mc91-res-m+11 : m + [11] ≯ [100] → mc91 (m + [11]) ≡ [91]
    mc91-res-m+11 = f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

    mc91-res-m≯89 : mc91 m ≡ [91]
    mc91-res-m≯89 = mc91x-res≯100 m [91] m≯100
                                  (mc91-res-m+11 (x≤89→x+11≯100 Nm m≤89))
                                  mc91-res-91
-- The function always terminates.
mc91-N : ∀ {n} → N n → N (mc91 n)
mc91-N {n} Nn with x>y∨x≯y Nn 100-N
... | inj₁ n>100 = subst N (sym (mc91-res>100 n n>100)) (∸-N Nn 10-N)
... | inj₂ n≮100 = subst N (sym (mc91-res≯100 Nn n≮100)) 91-N

-- For all n, n < mc91 n + 11.
mc91-ineq : ∀ {n} → N n → n < mc91 n + [11]
mc91-ineq = ≪-wfind A h
  where
  A : D → Set
  A d = d < mc91 d + [11]

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = x<mc91x+11>100 Nm m>100
  ... | inj₂ m≯100 =
    let mc91-m+11-N : N (mc91 (m + [11]))
        mc91-m+11-N = mc91-N (+-N Nm 11-N)

        h₁ : A (m + [11])
        h₁ = f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

        m<mc91m+11 : m < mc91 (m + [11])
        m<mc91m+11 = x+k<y+k→x<y Nm mc91-m+11-N 11-N h₁

        h₂ : A (mc91 (m + [11]))
        h₂ = f mc91-m+11-N (<→≪ mc91-m+11-N Nm m≯100 m<mc91m+11)

    in (<-trans Nm mc91-m+11-N (x+11-N (mc91-N Nm))
                m<mc91m+11
                (mc91x+11<mc91x+11 m m≯100 h₂))

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

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

-- The main properties proved of the McCarthy 91 function (called
-- mc91) are

-- 1. The function always terminates.
-- 2. For all n, n < mc91 n + 11.
-- 3. For all n > 100, then mc91 n = n - 10.
-- 4. For all n <= 100, then mc91 n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.AuxiliaryPropertiesATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.LT2WF-RelationATP
open import FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP

------------------------------------------------------------------------------
-- For all n > 100, then mc91 n = n - 10.
postulate mc91-res>100 : ∀ n → n > [100] → mc91 n ≡ n ∸ [10]
{-# ATP prove mc91-res>100 #-}

-- For all n <= 100, then mc91 n = 91.
mc91-res≯100 : ∀ {n} → N n → n ≯ [100] → mc91 n ≡ [91]
mc91-res≯100 = ≪-wfind A h
  where
  A : D → Set
  A d = d ≯ [100] → mc91 d ≡ [91]

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = λ m≯100 →
                     ⊥-elim (x>y→x≤y→⊥ Nm 100-N m>100 (x≯y→x≤y Nm 100-N m≯100))
  ... | inj₂ m≯100 with x≯Sy→x≯y∨x≡Sy Nm 99-N m≯100
  ... | inj₂ m≡100 = λ _ → mc91-res-aux mc91-res-100 m≡100
  ... | inj₁ m≯99 with x≯Sy→x≯y∨x≡Sy Nm 98-N m≯99
  ... | inj₂ m≡99 = λ _ → mc91-res-aux mc91-res-99 m≡99
  ... | inj₁ m≯98 with x≯Sy→x≯y∨x≡Sy Nm 97-N m≯98
  ... | inj₂ m≡98 = λ _ → mc91-res-aux mc91-res-98 m≡98
  ... | inj₁ m≯97 with x≯Sy→x≯y∨x≡Sy Nm 96-N m≯97
  ... | inj₂ m≡97 = λ _ → mc91-res-aux mc91-res-97 m≡97
  ... | inj₁ m≯96 with x≯Sy→x≯y∨x≡Sy Nm 95-N m≯96
  ... | inj₂ m≡96 = λ _ → mc91-res-aux mc91-res-96 m≡96
  ... | inj₁ m≯95 with x≯Sy→x≯y∨x≡Sy Nm 94-N m≯95
  ... | inj₂ m≡95 = λ _ → mc91-res-aux mc91-res-95 m≡95
  ... | inj₁ m≯94 with x≯Sy→x≯y∨x≡Sy Nm 93-N m≯94
  ... | inj₂ m≡94 = λ _ → mc91-res-aux mc91-res-94 m≡94
  ... | inj₁ m≯93 with x≯Sy→x≯y∨x≡Sy Nm 92-N m≯93
  ... | inj₂ m≡93 = λ _ → mc91-res-aux mc91-res-93 m≡93
  ... | inj₁ m≯92 with x≯Sy→x≯y∨x≡Sy Nm 91-N m≯92
  ... | inj₂ m≡92 = λ _ → mc91-res-aux mc91-res-92 m≡92
  ... | inj₁ m≯91 with x≯Sy→x≯y∨x≡Sy Nm 90-N m≯91
  ... | inj₂ m≡91 = λ _ → mc91-res-aux mc91-res-91 m≡91
  ... | inj₁ m≯90 with x≯Sy→x≯y∨x≡Sy Nm 89-N m≯90
  ... | inj₂ m≡90 = λ _ → mc91-res-aux mc91-res-90 m≡90
  ... | inj₁ m≯89 = λ _ → mc91-res-m≯89
    where
    m≤89 : m ≤ [89]
    m≤89 = x≯y→x≤y Nm 89-N m≯89

    mc91-res-m+11 : m + [11] ≯ [100] → mc91 (m + [11]) ≡ [91]
    mc91-res-m+11 = f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

    mc91-res-m≯89 : mc91 m ≡ [91]
    mc91-res-m≯89 = mc91x-res≯100 m [91] m≯100
                                  (mc91-res-m+11 (x≤89→x+11≯100 Nm m≤89))
                                  mc91-res-91
-- The function always terminates.
mc91-N : ∀ {n} → N n → N (mc91 n)
mc91-N {n} Nn with x>y∨x≯y Nn 100-N
... | inj₁ n>100 = subst N (sym (mc91-res>100 n n>100)) (∸-N Nn 10-N)
... | inj₂ n≮100 = subst N (sym (mc91-res≯100 Nn n≮100)) 91-N

-- For all n, n < mc91 n + 11.
mc91-N-ineq : ∀ {n} → N n → n < mc91 n + [11]
mc91-N-ineq = ≪-wfind A h
  where
  A : D → Set
  A d = d < mc91 d + [11]

  h : ∀ {m} → N m → (∀ {k} → N k → k ≪ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = x<mc91x+11>100 Nm m>100
  ... | inj₂ m≯100 =
    let mc91-m+11-N : N (mc91 (m + [11]))
        mc91-m+11-N = mc91-N (+-N Nm 11-N)

        h₁ : A (m + [11])
        h₁ = f (x+11-N Nm) (<→≪ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

        m<mc91m+11 : m < mc91 (m + [11])
        m<mc91m+11 = x+k<y+k→x<y Nm mc91-m+11-N 11-N h₁

        h₂ : A (mc91 (m + [11]))
        h₂ = f mc91-m+11-N (<→≪ mc91-m+11-N Nm m≯100 m<mc91m+11)

    in (<-trans Nm mc91-m+11-N (x+11-N (mc91-N Nm))
                m<mc91m+11
                (mc91x+11<mc91x+11 m m≯100 h₂))


adding some rule names and small step rules

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_]    : (Nat × subst) → ë
    ⦇_⦈[_]   : ë → (Nat × subst) → ë
    _∘_      : ë → ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  postulate -- todo: write this stuff later
    id : {A : Set} → A ctx → subst
    [_]_ : subst → ë → ë

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → τ̇ → (Nat × tctx × τ̇)
  u ::[ Γ ] t = u , Γ , t

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- todo: do we care about completeness of ė or e-umlauts?
  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< e1' > t2) ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 t2 t e1' e2' Δ1 Δ2 t2' e2} →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2' ⊣ Δ2 →
              (t2 == t2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ (< e2' > t2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 t e1' Δ1 e2 t2 e2' Δ2 } →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u , id Γ ] ⊣  ⟦ u ::[ Γ ] ⦇⦈ ⟧
      ESNEHole : ∀{ Γ e t e' u Δ } →
                 Γ ⊢ e ⇒ t ~> e' ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ e' ⦈[ u , id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e t e' t' Δ} →
                 Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
                 (t == t' → ⊥) →
                 Γ ⊢ (e ·: t) ⇒ t ~> (< e' > t) ⊣ Δ
      ESAsc2 : ∀{Γ e t e' t' Δ } →
               Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
               Γ ⊢ (e ·: t) ⇒ t ~> e' ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      EALam : ∀{Γ x t1 t2 e e' t2' Δ } →
              (Γ ,, (x , t1)) ⊢ e ⇐ t2 ~> e' :: t2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ (t1 ==> t2) ~> ·λ x [ t1 ] e' :: (t1 ==> t2') ⊣ Δ
      EASubsume : ∀{e u m Γ t' e' Δ t} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ m ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                  t ~ t' →
                  Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ
      EAEHole : ∀{ Γ u t  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ t ~> ⦇⦈[ u , id Γ ] :: t ⊣ ⟦ u ::[ Γ ] t ⟧
      EANEHole : ∀{ Γ e u t e' t' Δ  } →
                 Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                 t ~ t' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ t ~> ⦇ e' ⦈[ u , id Γ ] :: t ⊣ (Δ ,, u ::[ Γ ] t)

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where
    TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
    TAVar : ∀{Δ Γ x t} → Δ , (Γ ,, (x , t)) ⊢ X x :: t
    TALam : ∀{ Δ Γ x t1 e t2} →
            Δ , (Γ ,, (x , t1)) ⊢ e :: t2 →
            Δ , Γ ⊢ ·λ x [ t1 ] e :: (t1 ==> t2)
    TAAp : ∀{ Δ Γ e1 e2 t1 t2 t} →
           Δ , Γ ⊢ e1 :: t1 →
           t1 ▸arr (t2 ==> t) →
           Δ , Γ ⊢ e2 :: t2 →
           Δ , Γ ⊢ e1 ∘ e2 :: t
    -- TAEHole : ∀{ Δ Γ σ u Γ' } → -- todo: overloaded form in the paper here
    -- TANEHole : ∀ { Δ Γ e t' Γ' u σ t }
    TACast : ∀{ Δ Γ e t t'} →
           Δ , Γ ⊢ e :: t' →
           t ~ t' →
           Δ , Γ ⊢ < e > t :: t

  -- todo: substition goes here

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u , σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u , σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< e > t) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- error
  data _err[_] : ë → hctx → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : ë → ë → Set where
    STHole : ∀{ e e' u σ } →
             e ↦ e' →
             ⦇ e ⦈[ u , σ ] ↦ ⦇ e' ⦈[ u , σ ]
    -- STCast
    STAp1 : ∀{ e1 e2 e1' } →
            e1 ↦ e1' →
            (e1 ∘ e2) ↦ (e1' ∘ e2)
    STAp2 : ∀{ e1 e2 e2' } →
            e1 final →
            e2 ↦ e2' →
            (e1 ∘ e2) ↦ (e1 ∘ e2')
    STApβ : ∀{ e1 e2 t x } →
            e2 final →
            ((·λ x [ t ] e1) ∘ e2) ↦ ([ ⟦ x , {!!} ⟧ ] e2)

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_]    : (Nat × subst) → ë
    ⦇_⦈[_]   : ë → (Nat × subst) → ë
    _∘_      : ë → ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  postulate -- todo: write this stuff later
    id : {A : Set} → A ctx → subst
    [_]_ : subst → ë → ë

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → τ̇ → (Nat × tctx × τ̇)
  u ::[ Γ ] t = u , Γ , t

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- todo: do we care about completeness of ė or e-umlauts?
  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< e1' > t2) ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 t2 t e1' e2' Δ1 Δ2 t2' e2} →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2' ⊣ Δ2 →
              (t2 == t2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ (< e2' > t2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 t e1' Δ1 e2 t2 e2' Δ2 } →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u , id Γ ] ⊣  ⟦ u ::[ Γ ] ⦇⦈ ⟧
      ESNEHole : ∀{ Γ e t e' u Δ } →
                 Γ ⊢ e ⇒ t ~> e' ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ e' ⦈[ u , id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e t e' t' Δ} →
                 Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
                 (t == t' → ⊥) →
                 Γ ⊢ (e ·: t) ⇒ t ~> (< e' > t) ⊣ Δ
      ESAsc2 : ∀{Γ e t e' t' Δ } →
               Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
               Γ ⊢ (e ·: t) ⇒ t ~> e' ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      EALam : ∀{Γ x t1 t2 e e' t2' Δ } →
              (Γ ,, (x , t1)) ⊢ e ⇐ t2 ~> e' :: t2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ (t1 ==> t2) ~> ·λ x [ t1 ] e' :: (t1 ==> t2') ⊣ Δ
      EASubsume : ∀{e u m Γ t' e' Δ t} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ m ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                  t ~ t' →
                  Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ
      EAEHole : ∀{ Γ u t  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ t ~> ⦇⦈[ u , id Γ ] :: t ⊣ ⟦ u ::[ Γ ] t ⟧
      EANEHole : ∀{ Γ e u t e' t' Δ  } →
                 Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                 t ~ t' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ t ~> ⦇ e' ⦈[ u , id Γ ] :: t ⊣ (Δ ,, u ::[ Γ ] t)

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where
    TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
    TAVar : ∀{Δ Γ x t} → Δ , (Γ ,, (x , t)) ⊢ X x :: t
    TALam : ∀{ Δ Γ x t1 e t2} →
            Δ , (Γ ,, (x , t1)) ⊢ e :: t2 →
            Δ , Γ ⊢ ·λ x [ t1 ] e :: (t1 ==> t2)
    TAAp : ∀{ Δ Γ e1 e2 t1 t2 t} →
           Δ , Γ ⊢ e1 :: t1 →
           t1 ▸arr (t2 ==> t) →
           Δ , Γ ⊢ e2 :: t2 →
           Δ , Γ ⊢ e1 ∘ e2 :: t
    -- TAEHole : ∀{ Δ Γ σ u Γ' } → -- todo: overloaded form in the paper here
    -- TANEHole : ∀ { Δ Γ e t' Γ' u σ t }
    TACast : ∀{ Δ Γ e t t'} →
           Δ , Γ ⊢ e :: t' →
           t ~ t' →
           Δ , Γ ⊢ < e > t :: t

  -- todo: substition goes here

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  -- error
  data _err[_] : ë → hctx → Set where

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u , σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u , σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< e > t) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- small step semantics
  data _↦_ : ë → ë → Set where


Removed Agda with constructor from the proof ∷-Stream.

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

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

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality.Type
open import FOTC.Data.Colist
open import FOTC.Data.Colist.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream.Type

-----------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Stream predicate is also a pre-fixed point of the functional
-- StreamF, i.e.
--
-- StreamF Stream ≤ Stream (see FOTC.Data.Stream.Type).
Stream-in : ∀ {xs} →
            ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs' →
            Stream xs
Stream-in h = Stream-coind A h' h
  where
  A : D → Set
  A xs = ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs'

  h' : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h' (x' , xs' , prf , Sxs') = x' , xs' , prf , Stream-out Sxs'

foo : ∀ {xs} → Stream xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs'
foo Sxs = Stream-out Sxs

∷-Stream : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
∷-Stream {x} {xs} h = ∷-Stream-helper (Stream-out h)
  where
  ∷-Stream-helper : ∃[ x' ] ∃[ xs' ] x ∷ xs ≡ x' ∷ xs' ∧ Stream xs' →
                    Stream xs
  ∷-Stream-helper (x' , xs' , prf , Sxs') =
    subst Stream (sym (∧-proj₂ (∷-injective prf))) Sxs'

-- Version using Agda with constructor.
∷-Stream' : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
∷-Stream' h with Stream-out h
... | x' , xs' , prf , Sxs' =
  subst Stream (sym (∧-proj₂ (∷-injective prf))) Sxs'

Stream→Colist : ∀ {xs} → Stream xs → Colist xs
Stream→Colist {xs} Sxs = Colist-coind A h₁ h₂
  where
  A : D → Set
  A ys = Stream ys

  h₁ : ∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')
  h₁ Axs with Stream-out Axs
  ... | x' , xs' , prf , Sxs' = inj₂ (x' , xs' , prf , Sxs')

  h₂ : A xs
  h₂ = Sxs

-- Adapted from (Sander 1992, p. 59).
streamLength : ∀ {xs} → Stream xs → length xs ≈N ∞
streamLength {xs} Sxs = ≈N-coind R h₁ h₂
  where
  R : D → D → Set
  R m n = ∃[ xs ] Stream xs ∧ m ≡ length xs ∧ n ≡ ∞

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

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

------------------------------------------------------------------------------
-- References
--
-- Sander, Herbert P. (1992). A Logic of Functional Programs with an
-- Application to Concurrency. PhD thesis. Department of Computer
-- Sciences: Chalmers University of Technology and University of
-- Gothenburg.

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

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

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality.Type
open import FOTC.Data.Colist
open import FOTC.Data.Colist.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream.Type

-----------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Stream predicate is also a pre-fixed point of the functional
-- StreamF, i.e.
--
-- StreamF Stream ≤ Stream (see FOTC.Data.Stream.Type).
Stream-in : ∀ {xs} →
            ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs' →
            Stream xs
Stream-in h = Stream-coind A h' h
  where
  A : D → Set
  A xs = ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs'

  h' : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h' (x' , xs' , prf , Sxs') = x' , xs' , prf , Stream-out Sxs'

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

Stream→Colist : ∀ {xs} → Stream xs → Colist xs
Stream→Colist {xs} Sxs = Colist-coind A h₁ h₂
  where
  A : D → Set
  A ys = Stream ys

  h₁ : ∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')
  h₁ Axs with Stream-out Axs
  ... | x' , xs' , prf , Sxs' = inj₂ (x' , xs' , prf , Sxs')

  h₂ : A xs
  h₂ = Sxs

-- Adapted from (Sander 1992, p. 59).
streamLength : ∀ {xs} → Stream xs → length xs ≈N ∞
streamLength {xs} Sxs = ≈N-coind R h₁ h₂
  where
  R : D → D → Set
  R m n = ∃[ xs ] Stream xs ∧ m ≡ length xs ∧ n ≡ ∞

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

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

------------------------------------------------------------------------------
-- References
--
-- Sander, Herbert P. (1992). A Logic of Functional Programs with an
-- Application to Concurrency. PhD thesis. Department of Computer
-- Sciences: Chalmers University of Technology and University of
-- Gothenburg.


Describe the purpose of TotalTerms.agda (see #28).

There are three comments because I intend to split this file.

Old-commit-hash: 9fddcf21b9f59d47ad8a67a88f1304cc9098741a

module TotalTerms where

-- TERMS with a primitive for TOTAL DERIVATIVES
--
-- This module defines the syntax of terms that support a
-- primitive (Δ e) for computing the total derivative according
-- to all free variables in e and all future arguments of e if e
-- is a function.

-- EVALUATION with a primitive for TOTAL DERIVATIVES
--
-- This module defines the semantics of terms that support a
-- primitive (Δ e) for computing the total derivative according
-- to all free variables in e and all future arguments of e if e
-- is a function.

-- TERM EQUIVALENCE
--
-- This module defines term equivalence as the relation that
-- identifies terms with the same meaning.

open import Relation.Binary.PropositionalEquality as P
open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

  true false : ∀ {Γ} → Term Γ bool
  if : ∀ {Γ τ} → (t₁ : Term Γ bool) (t₂ t₃ : Term Γ τ) → Term Γ τ

  -- `Δ t` describes how t changes if its free variables or arguments change
  Δ : ∀ {Γ τ} → (t : Term Γ τ) → Term (Δ-Context Γ) (Δ-Type τ)
  weakenOne : ∀ Γ₁ τ₂ {Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ (τ₂ • Γ₃)) τ

-- Denotational Semantics

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ if t₁ t₂ t₃ ⟧Term ρ with ⟦ t₁ ⟧Term ρ
... | true = ⟦ t₂ ⟧Term ρ
... | false = ⟦ t₃ ⟧Term ρ
⟦ Δ t ⟧Term ρ = diff (⟦ t ⟧Term (update ρ)) (⟦ t ⟧Term (ignore ρ))
⟦ weakenOne Γ₁ τ₂ t ⟧Term ρ = ⟦ t ⟧Term (weakenEnv Γ₁ τ₂ ρ)

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

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext-t :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext-t (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext-t ≈) = ext-t (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open EqR (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()

substTerm : ∀ {τ Γ₁ Γ₂} → Γ₁ P.≡ Γ₂ → Term Γ₁ τ → Term Γ₂ τ
substTerm {τ} {Γ₁} {Γ₂} ≡₁ t = subst (λ Γ → Term Γ τ) ≡₁ t

module TotalTerms where

open import Relation.Binary.PropositionalEquality as P
open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

  true false : ∀ {Γ} → Term Γ bool
  if : ∀ {Γ τ} → (t₁ : Term Γ bool) (t₂ t₃ : Term Γ τ) → Term Γ τ

  -- `Δ t` describes how t changes if its free variables or arguments change
  Δ : ∀ {Γ τ} → (t : Term Γ τ) → Term (Δ-Context Γ) (Δ-Type τ)
  weakenOne : ∀ Γ₁ τ₂ {Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ (τ₂ • Γ₃)) τ

-- Denotational Semantics

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ if t₁ t₂ t₃ ⟧Term ρ with ⟦ t₁ ⟧Term ρ
... | true = ⟦ t₂ ⟧Term ρ
... | false = ⟦ t₃ ⟧Term ρ
⟦ Δ t ⟧Term ρ = diff (⟦ t ⟧Term (update ρ)) (⟦ t ⟧Term (ignore ρ))
⟦ weakenOne Γ₁ τ₂ t ⟧Term ρ = ⟦ t ⟧Term (weakenEnv Γ₁ τ₂ ρ)

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

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext-t :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext-t (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext-t ≈) = ext-t (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open EqR (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()

substTerm : ∀ {τ Γ₁ Γ₂} → Γ₁ P.≡ Γ₂ → Term Γ₁ τ → Term Γ₂ τ
substTerm {τ} {Γ₁} {Γ₂} ≡₁ t = subst (λ Γ → Term Γ τ) ≡₁ t


less asinine names + moving lemmas around #14

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

module lemmas-progress-checks where
  indet-not-trans : ∀{d d'} → d indet → d →> d' → ⊥
  indet-not-trans IEHole ()
  indet-not-trans (INEHole x) ()
  indet-not-trans (IAp x₁ () x₂) (ITLam x₃)
  indet-not-trans (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  indet-not-trans (ICastArr x ind) (ITCastID (FBoxed x₁)) = x refl
  indet-not-trans (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  indet-not-trans (ICastGroundHole () ind) (ITCastID x₁)
  indet-not-trans (ICastGroundHole x ind) (ITCastSucceed x₁ ())
  indet-not-trans (ICastGroundHole GHole ind) (ITGround x₁ x₂) = x₂ refl
  indet-not-trans (ICastHoleGround x ind ()) (ITCastID x₂)
  indet-not-trans (ICastHoleGround x ind x₁) (ITCastSucceed x₂ x₃) = x _ _ refl
  indet-not-trans (ICastHoleGround x ind GHole) (ITExpand x₂ x₃) = x₃ refl

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

  final-not-trans : ∀{d d'} → d final → d →> d' → ⊥
  final-not-trans (FBoxed x) = boxedval-not-trans x
  final-not-trans (FIndet x) = indet-not-trans x

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

  final-sub-not-trans : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  final-sub-not-trans f sub step = final-not-trans (final-sub-final f sub) step

  ce-castarr : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
  ce-castarr (CECong FHOuter ce) = ce-castarr ce
  ce-castarr (CECong (FHCast x₁) ce) = CECong x₁ ce

  ce-castth : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
  ce-castth (CECastFail x₁ x₂ () x₄)
  ce-castth (CECong FHOuter ce) = ce-castth ce
  ce-castth (CECong (FHCast x₁) ce) = CECong x₁ ce

  ce-nehole : ∀{d u σ} → ⦇ d ⦈⟨ u , σ ⟩ casterr → d casterr
  ce-nehole (CECong FHOuter ce) = ce-nehole ce
  ce-nehole (CECong (FHNEHole x₁) ce) = CECong x₁ ce

  ce-ap : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
  ce-ap (CECong FHOuter ce) = ce-ap ce
  ce-ap (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
  ce-ap (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)

  ce-castht : ∀{d τ} → (d ⟨ ⦇⦈ ⇒ τ ⟩) casterr → ((d' : dhexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇⦈ ⟩)) → d casterr
  ce-castht (CECastFail x₂ x₃ x₄ x₅) f = abort (f _ _ refl)
  ce-castht (CECong FHOuter ce) = ce-castht ce
  ce-castht (CECong (FHCast x₂) ce) _ = CECong x₂ ce

  -- ce-cast : ∀{d τ1 τ2} → (d ⟨ τ1 ⇒ τ2 ⟩) casterr → d casterr
  -- ce-cast (CECastFail x x₁ x₂ x₃) = {!!}
  -- ce-cast (CECong x ce) = {!!}

  ce-out-cast : ∀{d d' ε} →
                d casterr →
                d' == ε ⟦ d ⟧ →
                d' casterr
  ce-out-cast (CECong x ce) FHOuter = ce-out-cast ce x
  ce-out-cast (CECong x ce) y = CECong y (ce-out-cast ce x)
  ce-out-cast z FHOuter = z
  ce-out-cast z y = CECong y z

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

module lemmas-progress-checks where
  ce-castarr : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
  ce-castarr (CECong FHOuter ce) = ce-castarr ce
  ce-castarr (CECong (FHCast x₁) ce) = CECong x₁ ce

  ce-castth : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
  ce-castth (CECastFail x₁ x₂ () x₄)
  ce-castth (CECong FHOuter ce) = ce-castth ce
  ce-castth (CECong (FHCast x₁) ce) = CECong x₁ ce

  ce-nehole : ∀{d u σ} → ⦇ d ⦈⟨ u , σ ⟩ casterr → d casterr
  ce-nehole (CECong FHOuter ce) = ce-nehole ce
  ce-nehole (CECong (FHNEHole x₁) ce) = CECong x₁ ce

  ce-ap : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
  ce-ap (CECong FHOuter ce) = ce-ap ce
  ce-ap (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
  ce-ap (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)

  ce-castht : ∀{d τ} → (d ⟨ ⦇⦈ ⇒ τ ⟩) casterr → ((d' : dhexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇⦈ ⟩)) → d casterr
  ce-castht (CECastFail x₂ x₃ x₄ x₅) f = abort (f _ _ refl)
  ce-castht (CECong FHOuter ce) = ce-castht ce
  ce-castht (CECong (FHCast x₂) ce) _ = CECong x₂ ce

  -- ce-cast : ∀{d τ1 τ2} → (d ⟨ τ1 ⇒ τ2 ⟩) casterr → d casterr
  -- ce-cast (CECastFail x x₁ x₂ x₃) = {!!}
  -- ce-cast (CECong x ce) = {!!}

  ce-out-cast : ∀{d d' ε} →
                d casterr →
                d' == ε ⟦ d ⟧ →
                d' casterr
  ce-out-cast (CECong x ce) FHOuter = ce-out-cast ce x
  ce-out-cast (CECong x ce) y = CECong y (ce-out-cast ce x)
  ce-out-cast z FHOuter = z
  ce-out-cast z y = CECong y z


List monad module

List monad module

{-# OPTIONS --universe-polymorphism #-}
module Data.List.NP where

open import Category.Monad
open import Category.Applicative.NP
open import Data.List  public
open import Data.Bool  using (Bool; not; if_then_else_)
open import Data.Nat   using (ℕ; zero; suc)
open import Data.Maybe using (Maybe; just; nothing)
open import Function   using (_∘_)

module Monad {ℓ} where
  open RawMonad (monad {ℓ}) public
  open RawApplicative rawIApplicative public using (replicateM)

-- Move this
Eq : ∀ {a} → Set a → Set a
Eq A = (x₁ x₂ : A) → Bool

uniqBy : ∀ {A : Set} → Eq A → List A → List A
uniqBy _==_ []       = []
uniqBy _==_ (x ∷ xs) = x ∷ filter (not ∘ _==_ x) (uniqBy _==_ xs)
                    -- x ∷ uniqBy _==_ (filter (not ∘ _==_ x) xs)

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

findIndices : ∀ {a} {A : Set a} → (A → Bool) → List A → List ℕ
-- findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ]
findIndices {A = A} p = go 0 where
  go : ℕ → List A → List ℕ
  go _ []       = []
  go i (x ∷ xs) = if p x then i ∷ go (suc i) xs else go (suc i) xs

findIndex : ∀ {a} {A : Set a} → (A → Bool) → List A → Maybe ℕ
findIndex p = listToMaybe ∘ findIndices p

index : ∀ {a} {A : Set a} → Eq A → A → List A → Maybe ℕ
index _==_ x = findIndex (_==_ x)

{-# OPTIONS --universe-polymorphism #-}
module Data.List.NP where

open import Data.List  public
open import Data.Bool  using (Bool; not; if_then_else_)
open import Data.Nat   using (ℕ; zero; suc)
open import Data.Maybe using (Maybe; just; nothing)
open import Function   using (_∘_)

-- Move this
Eq : ∀ {a} → Set a → Set a
Eq A = (x₁ x₂ : A) → Bool

uniqBy : ∀ {A : Set} → Eq A → List A → List A
uniqBy _==_ []       = []
uniqBy _==_ (x ∷ xs) = x ∷ filter (not ∘ _==_ x) (uniqBy _==_ xs)
                    -- x ∷ uniqBy _==_ (filter (not ∘ _==_ x) xs)

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

findIndices : ∀ {a} {A : Set a} → (A → Bool) → List A → List ℕ
-- findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ]
findIndices {A = A} p = go 0 where
  go : ℕ → List A → List ℕ
  go _ []       = []
  go i (x ∷ xs) = if p x then i ∷ go (suc i) xs else go (suc i) xs

findIndex : ∀ {a} {A : Set a} → (A → Bool) → List A → Maybe ℕ
findIndex p = listToMaybe ∘ findIndices p

index : ∀ {a} {A : Set a} → Eq A → A → List A → Maybe ℕ
index _==_ x = findIndex (_==_ x)


Isos: cleaner Lift↔id

Isos: cleaner Lift↔id

module Function.Related.TypeIsomorphisms.NP where

import Level as L
open import Algebra
open L using (Lift; lower; lift)
open import Type
import Function as F
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Maybe.NP
open import Data.Product
--open import Data.Product.N-ary
open import Data.Sum renaming (map to map⊎)
open import Data.Unit
open import Data.Empty
open import Function.Equality using (_⟨$⟩_)
open import Function.Related
open import Function.Related.TypeIsomorphisms public
open import Function.Inverse using (_↔_; _∘_; sym; id; module Inverse)
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (→-to-⟶)

Maybe↔⊤⊎ : ∀ {a} {A : Set a} → Maybe A ↔ (⊤ ⊎ A)
Maybe↔⊤⊎
  = record { to   = →-to-⟶ (maybe inj₂ (inj₁ _))
           ; from = →-to-⟶ [ F.const nothing , just ]
           ; inverse-of
           = record { left-inverse-of = maybe (λ _ → ≡.refl) ≡.refl
                    ; right-inverse-of = [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ] } }

Maybe-cong : ∀ {a b} {A : Set a} {B : Set b} → A ↔ B → Maybe A ↔ Maybe B
Maybe-cong A↔B = sym Maybe↔⊤⊎ ∘ id ⊎-cong A↔B ∘ Maybe↔⊤⊎

Maybe∘Maybe^↔Maybe^∘Maybe : ∀ {A} n → Maybe (Maybe^ n A) ↔ Maybe^ n (Maybe A)
Maybe∘Maybe^↔Maybe^∘Maybe zero    = id
Maybe∘Maybe^↔Maybe^∘Maybe (suc n) = Maybe-cong (Maybe∘Maybe^↔Maybe^∘Maybe n)

Maybe^-cong : ∀ {A B} n → A ↔ B → Maybe^ n A ↔ Maybe^ n B
Maybe^-cong zero    = F.id
Maybe^-cong (suc n) = Maybe-cong F.∘ Maybe^-cong n

Vec0↔⊤ : ∀ {a} {A : Set a} → Vec A 0 ↔ ⊤
Vec0↔⊤ = record { to         = →-to-⟶ _
                ; from       = →-to-⟶ (F.const [])
                ; inverse-of = record { left-inverse-of  = λ { [] → ≡.refl }
                                      ; right-inverse-of = λ _ → ≡.refl } }

Vec∘suc↔A×Vec : ∀ {a} {A : Set a} {n} → Vec A (suc n) ↔ (A × Vec A n)
Vec∘suc↔A×Vec
  = record { to         = →-to-⟶ (λ { (x ∷ xs) → x , xs })
           ; from       = →-to-⟶ (uncurry _∷_)
           ; inverse-of = record { left-inverse-of  = λ { (x ∷ xs) → ≡.refl }
                                 ; right-inverse-of = λ _ → ≡.refl } }

infix 8 _^_

_^_ : ★ → ℕ → ★
A ^ 0     = ⊤
A ^ suc n = A × A ^ n

^↔Vec : ∀ {A} n → (A ^ n) ↔ Vec A n
^↔Vec zero    = sym Vec0↔⊤
^↔Vec (suc n) = sym Vec∘suc↔A×Vec ∘ (id ×-cong (^↔Vec n))

Fin0↔⊥ : Fin 0 ↔ ⊥
Fin0↔⊥ = record { to   = →-to-⟶ λ()
                ; from = →-to-⟶ λ()
                ; inverse-of = record { left-inverse-of  = λ()
                                      ; right-inverse-of = λ() } }

Fin∘suc↔Maybe∘Fin : ∀ {n} → Fin (suc n) ↔ Maybe (Fin n)
Fin∘suc↔Maybe∘Fin {n}
  = record { to   = →-to-⟶ to
           ; from = →-to-⟶ (maybe suc zero)
           ; inverse-of
           = record { left-inverse-of = λ { zero → ≡.refl ; (suc n) → ≡.refl }
                    ; right-inverse-of = maybe (λ _ → ≡.refl) ≡.refl } }
  where to : Fin (suc n) → Maybe (Fin n)
        to zero = nothing
        to (suc n) = just n

Lift↔id : ∀ {a} {A : Set a} → Lift {a} {a} A ↔ A
Lift↔id = record { to = →-to-⟶ lower
                 ; from = →-to-⟶ lift
                 ; inverse-of = record { left-inverse-of = λ { (lift x) → ≡.refl }
                                       ; right-inverse-of = λ _ → ≡.refl } }

Maybe⊥↔⊤ : Maybe ⊥ ↔ ⊤
Maybe⊥↔⊤ = (proj₂ CMon.identity ⊤ ∘ id ⊎-cong (sym (Lift↔id {A = ⊥}))) ∘ Maybe↔⊤⊎
  where module CMon = CommutativeMonoid (⊎-CommutativeMonoid bijection L.zero)

Maybe^⊥↔Fin : ∀ n → Maybe^ n ⊥ ↔ Fin n
Maybe^⊥↔Fin zero    = sym Fin0↔⊥
Maybe^⊥↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^⊥↔Fin n)

Maybe^⊤↔Fin1+ : ∀ n → Maybe^ n ⊤ ↔ Fin (suc n)
Maybe^⊤↔Fin1+ n = Maybe^⊥↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe⊥↔⊤)

Fin∘suc↔⊤⊎Fin : ∀ {n} → Fin (suc n) ↔ (⊤ ⊎ Fin n)
Fin∘suc↔⊤⊎Fin = Maybe↔⊤⊎ ∘ Fin∘suc↔Maybe∘Fin

module Function.Related.TypeIsomorphisms.NP where

import Level as L
open import Algebra
open L using (Lift; lower; lift)
open import Type
import Function as F
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Maybe.NP
open import Data.Product
--open import Data.Product.N-ary
open import Data.Sum renaming (map to map⊎)
open import Data.Unit
open import Data.Empty
open import Function.Equality using (_⟨$⟩_)
open import Function.Related
open import Function.Related.TypeIsomorphisms public
open import Function.Inverse using (_↔_; _∘_; sym; id; module Inverse)
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (→-to-⟶)

Maybe↔⊤⊎ : ∀ {a} {A : Set a} → Maybe A ↔ (⊤ ⊎ A)
Maybe↔⊤⊎
  = record { to   = →-to-⟶ (maybe inj₂ (inj₁ _))
           ; from = →-to-⟶ [ F.const nothing , just ]
           ; inverse-of
           = record { left-inverse-of = maybe (λ _ → ≡.refl) ≡.refl
                    ; right-inverse-of = [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ] } }

Maybe-cong : ∀ {a b} {A : Set a} {B : Set b} → A ↔ B → Maybe A ↔ Maybe B
Maybe-cong A↔B = sym Maybe↔⊤⊎ ∘ id ⊎-cong A↔B ∘ Maybe↔⊤⊎

Maybe∘Maybe^↔Maybe^∘Maybe : ∀ {A} n → Maybe (Maybe^ n A) ↔ Maybe^ n (Maybe A)
Maybe∘Maybe^↔Maybe^∘Maybe zero    = id
Maybe∘Maybe^↔Maybe^∘Maybe (suc n) = Maybe-cong (Maybe∘Maybe^↔Maybe^∘Maybe n)

Maybe^-cong : ∀ {A B} n → A ↔ B → Maybe^ n A ↔ Maybe^ n B
Maybe^-cong zero    = F.id
Maybe^-cong (suc n) = Maybe-cong F.∘ Maybe^-cong n

Vec0↔⊤ : ∀ {a} {A : Set a} → Vec A 0 ↔ ⊤
Vec0↔⊤ = record { to         = →-to-⟶ _
                ; from       = →-to-⟶ (F.const [])
                ; inverse-of = record { left-inverse-of  = λ { [] → ≡.refl }
                                      ; right-inverse-of = λ _ → ≡.refl } }

Vec∘suc↔A×Vec : ∀ {a} {A : Set a} {n} → Vec A (suc n) ↔ (A × Vec A n)
Vec∘suc↔A×Vec
  = record { to         = →-to-⟶ (λ { (x ∷ xs) → x , xs })
           ; from       = →-to-⟶ (uncurry _∷_)
           ; inverse-of = record { left-inverse-of  = λ { (x ∷ xs) → ≡.refl }
                                 ; right-inverse-of = λ _ → ≡.refl } }

infix 8 _^_

_^_ : ★ → ℕ → ★
A ^ 0     = ⊤
A ^ suc n = A × A ^ n

^↔Vec : ∀ {A} n → (A ^ n) ↔ Vec A n
^↔Vec zero    = sym Vec0↔⊤
^↔Vec (suc n) = sym Vec∘suc↔A×Vec ∘ (id ×-cong (^↔Vec n))

Fin0↔⊥ : Fin 0 ↔ ⊥
Fin0↔⊥ = record { to   = →-to-⟶ λ()
                ; from = →-to-⟶ λ()
                ; inverse-of = record { left-inverse-of  = λ()
                                      ; right-inverse-of = λ() } }

Fin∘suc↔Maybe∘Fin : ∀ {n} → Fin (suc n) ↔ Maybe (Fin n)
Fin∘suc↔Maybe∘Fin {n}
  = record { to   = →-to-⟶ to
           ; from = →-to-⟶ (maybe suc zero)
           ; inverse-of
           = record { left-inverse-of = λ { zero → ≡.refl ; (suc n) → ≡.refl }
                    ; right-inverse-of = maybe (λ _ → ≡.refl) ≡.refl } }
  where to : Fin (suc n) → Maybe (Fin n)
        to zero = nothing
        to (suc n) = just n

Lift↔id : ∀ {a} {A : Set a} → Lift {a} {a} A ↔ A
Lift↔id = λ {a} {A} → record { to = →-to-⟶ lower
                             ; from = →-to-⟶ lift
                             ; inverse-of = record { left-inverse-of = λ { (lift x) → ≡.refl }
                                                   ; right-inverse-of = λ _ → ≡.refl } }

Maybe⊥↔⊤ : Maybe ⊥ ↔ ⊤
Maybe⊥↔⊤ = (proj₂ CMon.identity ⊤ ∘ id ⊎-cong (sym (Lift↔id {A = ⊥}))) ∘ Maybe↔⊤⊎
  where module CMon = CommutativeMonoid (⊎-CommutativeMonoid bijection L.zero)

Maybe^⊥↔Fin : ∀ n → Maybe^ n ⊥ ↔ Fin n
Maybe^⊥↔Fin zero    = sym Fin0↔⊥
Maybe^⊥↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^⊥↔Fin n)

Maybe^⊤↔Fin1+ : ∀ n → Maybe^ n ⊤ ↔ Fin (suc n)
Maybe^⊤↔Fin1+ n = Maybe^⊥↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe⊥↔⊤)

Fin∘suc↔⊤⊎Fin : ∀ {n} → Fin (suc n) ↔ (⊤ ⊎ Fin n)
Fin∘suc↔⊤⊎Fin = Maybe↔⊤⊎ ∘ Fin∘suc↔Maybe∘Fin


Desc model: iso1 implicit.

Desc model: iso1 implicit.


Desc introduction in operational semantics.

module Spire.Operational where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  {- Value introduction -}
  `tt : Value Γ `⊤
  `true `false : Value Γ `Bool
  _`,_ : ∀{A B} (a : Value Γ A) (b : Value Γ (subT B a)) → Value Γ (`Σ A B)
  `λ : ∀{A B} → Value (Γ , A) B → Value Γ (`Π A B)
  `neut : ∀{A} → Neutral Γ A → Value Γ A

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  {- Value introduction -}
  `tt : Term Γ `⊤
  `true `false : Term Γ `Bool
  _`,_ : ∀{A B}
    (a : Term Γ A) (b : Term Γ (subT B (eval a)))
    → Term Γ (`Σ A B)
  `λ : ∀{A B}
    (b : Term (Γ , A) B)
    → Term Γ (`Π A B)

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

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

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

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

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

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

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

module Spire.Operational where

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

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

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

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

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

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

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

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

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

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

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

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

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

  {- Value introduction -}
  `tt : Value Γ `⊤
  `true `false : Value Γ `Bool
  _`,_ : ∀{A B} (a : Value Γ A) (b : Value Γ (subT B a)) → Value Γ (`Σ A B)
  `λ : ∀{A B} → Value (Γ , A) B → Value Γ (`Π A B)
  `neut : ∀{A} → Neutral Γ A → Value Γ A

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

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

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

⟦ `Π A B ⟧ = `Π ⟦ A ⟧ ⟦ B ⟧
⟦ `Σ A B ⟧ = `Σ ⟦ A ⟧ ⟦ B ⟧
⟦ `⊥ ⟧ = `⊥
⟦ `⊤ ⟧ = `⊤
⟦ `Bool ⟧ = `Bool
⟦ `Type {zero} ⟧ = `⊥
⟦ `Type {suc ℓ} ⟧ = `Type ℓ
⟦ `⟦ A ⟧ ⟧ = ⟦ A ⟧
⟦ `neut A ⟧ = `⟦ A ⟧

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

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

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

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

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

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

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

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

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

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

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

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

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

  {- Value introduction -}
  `tt : Term Γ `⊤
  `true `false : Term Γ `Bool
  _`,_ : ∀{A B}
    (a : Term Γ A) (b : Term Γ (subT B (eval a)))
    → Term Γ (`Σ A B)
  `λ : ∀{A B}
    (b : Term (Γ , A) B)
    → Term Γ (`Π A B)

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

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

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

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

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

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