Data.Two.Base: +✓∧×

Data.Two.Base: +✓∧×

{-# OPTIONS --without-K #-}
module Data.Two.Base where

open import Data.Zero

open import Data.Bool
  public
  hiding (if_then_else_)
  renaming (Bool to 𝟚; false to 0₂; true to 1₂; T to ✓)

open import Data.Product
  renaming (proj₁ to fst; proj₂ to snd)

open import Data.Sum
  using (_⊎_) renaming (inj₁ to inl; inj₂ to inr)

open import Data.Nat.Base
  using (ℕ; _≤_; z≤n; s≤s; _⊓_; _⊔_; _∸_)

open import Type using (★_)

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

open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; refl)

0≢1₂ : 0₂ ≢ 1₂
0≢1₂ ()

_² : ∀ {a} → ★ a → ★ a
A ² = 𝟚 → A

module _ {p} {P : 𝟚 → ★ p} where

    [0:_1:_] : P 0₂ → P 1₂ → (b : 𝟚) → P b
    [0: e₀ 1: e₁ ] 0₂ = e₀
    [0: e₀ 1: e₁ ] 1₂ = e₁

    tabulate₂ : ((b : 𝟚) → P b) → P 0₂ × P 1₂
    tabulate₂ f = f 0₂ , f 1₂

    η-[0:1:] : ∀ (f : (b : 𝟚) → P b) b → [0: f 0₂ 1: f 1₂ ] b ≡ f b
    η-[0:1:] f 0₂ = refl
    η-[0:1:] f 1₂ = refl

    proj : P 0₂ × P 1₂ → (b : 𝟚) → P b
    proj = uncurry [0:_1:_]

    proj-tabulate₂ : ∀ (f : (b : 𝟚) → P b) b → proj (tabulate₂ f) b ≡ f b
    proj-tabulate₂ = η-[0:1:]

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

    [0:_1:_]′ : A → A → A ²
    [0:_1:_]′ = [0:_1:_]

    case_0:_1:_ : 𝟚 → A → A → A
    case b 0: e₀ 1: e₁ = [0: e₀
                          1: e₁ ] b

    proj′ : A × A → A ²
    proj′ = proj

    proj[_] : 𝟚 → A × A → A
    proj[_] = [0: fst 1: snd ]

    mux : 𝟚 × (A × A) → A
    mux (s , eᵢ) = proj eᵢ s

nor : (b₀ b₁ : 𝟚) → 𝟚
nor b₀ b₁ = not (b₀ ∨ b₁)

nand : (b₀ b₁ : 𝟚) → 𝟚
nand b₀ b₁ = not (b₀ ∧ b₁)

-- For properties about _==_ see Data.Two.Equality
_==_ : (b₀ b₁ : 𝟚) → 𝟚
b₀ == b₁ = (not b₀) xor b₁

≡→✓ : ∀ {b} → b ≡ 1₂ → ✓ b
≡→✓ refl = _

≡→✓not : ∀ {b} → b ≡ 0₂ → ✓ (not b)
≡→✓not refl = _

✓→≡ : ∀ {b} → ✓ b → b ≡ 1₂
✓→≡ {1₂} _ = refl
✓→≡ {0₂} ()

✓not→≡ : ∀ {b} → ✓ (not b) → b ≡ 0₂
✓not→≡ {0₂} _ = refl
✓not→≡ {1₂} ()

-- See also ✓-∧
✓∧ : ∀ {b₁ b₂} → ✓ b₁ → ✓ b₂ → ✓ (b₁ ∧ b₂)
✓∧ {0₂} p q = p
✓∧ {1₂} p q = q

-- See also ✓-∧
✓∧₁ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₁
✓∧₁ {0₂} ()
✓∧₁ {1₂} = _

✓∧₂ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₂
✓∧₂ {0₂} ()
✓∧₂ {1₂} p = p

✓∧× : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₁ × ✓ b₂
✓∧× {0₂} ()
✓∧× {1₂} p = _ , p

-- Similar to ✓-∨
✓∨-⊎ : ∀ {b₁ b₂} → ✓ (b₁ ∨ b₂) → ✓ b₁ ⊎ ✓ b₂
✓∨-⊎ {0₂} = inr
✓∨-⊎ {1₂} = inl

-- Similar to ✓-∨
✓∨₁ : ∀ {b₁ b₂} → ✓ b₁ → ✓ (b₁ ∨ b₂)
✓∨₁ {1₂} = _
✓∨₁ {0₂} ()

-- Similar to ✓-∨
✓∨₂ : ∀ {b₁ b₂} → ✓ b₂ → ✓ (b₁ ∨ b₂)
✓∨₂ {0₂} p = p
✓∨₂ {1₂} _ = _

✓-not-¬ : ∀ {b} → ✓ (not b) → ¬ (✓ b)
✓-not-¬ {0₂} _ = λ()
✓-not-¬ {1₂} ()

✓-¬-not : ∀ {b} → ¬ (✓ b) → ✓ (not b)
✓-¬-not {0₂} _ = _
✓-¬-not {1₂} f = f _

∧⇒∨ : ∀ x y → ✓ (x ∧ y) → ✓ (x ∨ y)
∧⇒∨ 0₂ _ = λ ()
∧⇒∨ 1₂ _ = _

-- This particular implementation has been
-- chosen for computational content.
-- Namely the proof is "re-created" when b is 1₂.
check : ∀ b → {pf : ✓ b} → ✓ b
check 0₂ {}
check 1₂ = _

✓dec : ∀ b → Dec (✓ b)
✓dec = [0: no (λ())
        1: yes _ ]

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan 0₂ _ = refl
de-morgan 1₂ _ = refl

≢0→≡1 : ∀ {x} → x ≢ 0₂ → x ≡ 1₂
≢0→≡1 {1₂} p = refl
≢0→≡1 {0₂} p = 𝟘-elim (p refl)

≢1→≡0 : ∀ {x} → x ≢ 1₂ → x ≡ 0₂
≢1→≡0 {0₂} p = refl
≢1→≡0 {1₂} p = 𝟘-elim (p refl)

-- 0₂ is 0 and 1₂ is 1
𝟚▹ℕ : 𝟚 → ℕ
𝟚▹ℕ = [0: 0
       1: 1 ]

𝟚▹ℕ≤1 : ∀ b → 𝟚▹ℕ b ≤ 1
𝟚▹ℕ≤1 = [0: z≤n
         1: s≤s z≤n ]

𝟚▹ℕ-⊓ : ∀ a b → 𝟚▹ℕ a ⊓ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ b)
𝟚▹ℕ-⊓ 1₂ 0₂ = refl
𝟚▹ℕ-⊓ 1₂ 1₂ = refl
𝟚▹ℕ-⊓ 0₂ _  = refl

𝟚▹ℕ-⊔ : ∀ a b → 𝟚▹ℕ a ⊔ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∨ b)
𝟚▹ℕ-⊔ 1₂ 0₂ = refl
𝟚▹ℕ-⊔ 1₂ 1₂ = refl
𝟚▹ℕ-⊔ 0₂ _  = refl

𝟚▹ℕ-∸ : ∀ a b → 𝟚▹ℕ a ∸ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ not b)
𝟚▹ℕ-∸ 0₂ 0₂ = refl
𝟚▹ℕ-∸ 0₂ 1₂ = refl
𝟚▹ℕ-∸ 1₂ 0₂ = refl
𝟚▹ℕ-∸ 1₂ 1₂ = refl

not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
not-inj {0₂} {0₂} _ = refl
not-inj {1₂} {1₂} _ = refl
not-inj {0₂} {1₂} ()
not-inj {1₂} {0₂} ()

{-# OPTIONS --without-K #-}
module Data.Two.Base where

open import Data.Zero

open import Data.Bool
  public
  hiding (if_then_else_)
  renaming (Bool to 𝟚; false to 0₂; true to 1₂; T to ✓)

open import Data.Product
  renaming (proj₁ to fst; proj₂ to snd)

open import Data.Sum
  using (_⊎_) renaming (inj₁ to inl; inj₂ to inr)

open import Data.Nat.Base
  using (ℕ; _≤_; z≤n; s≤s; _⊓_; _⊔_; _∸_)

open import Type using (★_)

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

open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; refl)

0≢1₂ : 0₂ ≢ 1₂
0≢1₂ ()

_² : ∀ {a} → ★ a → ★ a
A ² = 𝟚 → A

module _ {p} {P : 𝟚 → ★ p} where

    [0:_1:_] : P 0₂ → P 1₂ → (b : 𝟚) → P b
    [0: e₀ 1: e₁ ] 0₂ = e₀
    [0: e₀ 1: e₁ ] 1₂ = e₁

    tabulate₂ : ((b : 𝟚) → P b) → P 0₂ × P 1₂
    tabulate₂ f = f 0₂ , f 1₂

    η-[0:1:] : ∀ (f : (b : 𝟚) → P b) b → [0: f 0₂ 1: f 1₂ ] b ≡ f b
    η-[0:1:] f 0₂ = refl
    η-[0:1:] f 1₂ = refl

    proj : P 0₂ × P 1₂ → (b : 𝟚) → P b
    proj = uncurry [0:_1:_]

    proj-tabulate₂ : ∀ (f : (b : 𝟚) → P b) b → proj (tabulate₂ f) b ≡ f b
    proj-tabulate₂ = η-[0:1:]

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

    [0:_1:_]′ : A → A → A ²
    [0:_1:_]′ = [0:_1:_]

    case_0:_1:_ : 𝟚 → A → A → A
    case b 0: e₀ 1: e₁ = [0: e₀
                          1: e₁ ] b

    proj′ : A × A → A ²
    proj′ = proj

    proj[_] : 𝟚 → A × A → A
    proj[_] = [0: fst 1: snd ]

    mux : 𝟚 × (A × A) → A
    mux (s , eᵢ) = proj eᵢ s

nor : (b₀ b₁ : 𝟚) → 𝟚
nor b₀ b₁ = not (b₀ ∨ b₁)

nand : (b₀ b₁ : 𝟚) → 𝟚
nand b₀ b₁ = not (b₀ ∧ b₁)

-- For properties about _==_ see Data.Two.Equality
_==_ : (b₀ b₁ : 𝟚) → 𝟚
b₀ == b₁ = (not b₀) xor b₁

≡→✓ : ∀ {b} → b ≡ 1₂ → ✓ b
≡→✓ refl = _

≡→✓not : ∀ {b} → b ≡ 0₂ → ✓ (not b)
≡→✓not refl = _

✓→≡ : ∀ {b} → ✓ b → b ≡ 1₂
✓→≡ {1₂} _ = refl
✓→≡ {0₂} ()

✓not→≡ : ∀ {b} → ✓ (not b) → b ≡ 0₂
✓not→≡ {0₂} _ = refl
✓not→≡ {1₂} ()

-- See also ✓-∧
✓∧ : ∀ {b₁ b₂} → ✓ b₁ → ✓ b₂ → ✓ (b₁ ∧ b₂)
✓∧ {0₂} p q = p
✓∧ {1₂} p q = q

-- See also ✓-∧
✓∧₁ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₁
✓∧₁ {0₂} ()
✓∧₁ {1₂} = _

✓∧₂ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₂
✓∧₂ {0₂} ()
✓∧₂ {1₂} p = p

-- Similar to ✓-∨
✓∨-⊎ : ∀ {b₁ b₂} → ✓ (b₁ ∨ b₂) → ✓ b₁ ⊎ ✓ b₂
✓∨-⊎ {0₂} = inr
✓∨-⊎ {1₂} = inl

-- Similar to ✓-∨
✓∨₁ : ∀ {b₁ b₂} → ✓ b₁ → ✓ (b₁ ∨ b₂)
✓∨₁ {1₂} = _
✓∨₁ {0₂} ()

-- Similar to ✓-∨
✓∨₂ : ∀ {b₁ b₂} → ✓ b₂ → ✓ (b₁ ∨ b₂)
✓∨₂ {0₂} p = p
✓∨₂ {1₂} _ = _

✓-not-¬ : ∀ {b} → ✓ (not b) → ¬ (✓ b)
✓-not-¬ {0₂} _ = λ()
✓-not-¬ {1₂} ()

✓-¬-not : ∀ {b} → ¬ (✓ b) → ✓ (not b)
✓-¬-not {0₂} _ = _
✓-¬-not {1₂} f = f _

∧⇒∨ : ∀ x y → ✓ (x ∧ y) → ✓ (x ∨ y)
∧⇒∨ 0₂ _ = λ ()
∧⇒∨ 1₂ _ = _

-- This particular implementation has been
-- chosen for computational content.
-- Namely the proof is "re-created" when b is 1₂.
check : ∀ b → {pf : ✓ b} → ✓ b
check 0₂ {}
check 1₂ = _

✓dec : ∀ b → Dec (✓ b)
✓dec = [0: no (λ())
        1: yes _ ]

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan 0₂ _ = refl
de-morgan 1₂ _ = refl

≢0→≡1 : ∀ {x} → x ≢ 0₂ → x ≡ 1₂
≢0→≡1 {1₂} p = refl
≢0→≡1 {0₂} p = 𝟘-elim (p refl)

≢1→≡0 : ∀ {x} → x ≢ 1₂ → x ≡ 0₂
≢1→≡0 {0₂} p = refl
≢1→≡0 {1₂} p = 𝟘-elim (p refl)

-- 0₂ is 0 and 1₂ is 1
𝟚▹ℕ : 𝟚 → ℕ
𝟚▹ℕ = [0: 0
       1: 1 ]

𝟚▹ℕ≤1 : ∀ b → 𝟚▹ℕ b ≤ 1
𝟚▹ℕ≤1 = [0: z≤n
         1: s≤s z≤n ]

𝟚▹ℕ-⊓ : ∀ a b → 𝟚▹ℕ a ⊓ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ b)
𝟚▹ℕ-⊓ 1₂ 0₂ = refl
𝟚▹ℕ-⊓ 1₂ 1₂ = refl
𝟚▹ℕ-⊓ 0₂ _  = refl

𝟚▹ℕ-⊔ : ∀ a b → 𝟚▹ℕ a ⊔ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∨ b)
𝟚▹ℕ-⊔ 1₂ 0₂ = refl
𝟚▹ℕ-⊔ 1₂ 1₂ = refl
𝟚▹ℕ-⊔ 0₂ _  = refl

𝟚▹ℕ-∸ : ∀ a b → 𝟚▹ℕ a ∸ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ not b)
𝟚▹ℕ-∸ 0₂ 0₂ = refl
𝟚▹ℕ-∸ 0₂ 1₂ = refl
𝟚▹ℕ-∸ 1₂ 0₂ = refl
𝟚▹ℕ-∸ 1₂ 1₂ = refl

not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
not-inj {0₂} {0₂} _ = refl
not-inj {1₂} {1₂} _ = refl
not-inj {0₂} {1₂} ()
not-inj {1₂} {0₂} ()


Weaken the ∙-opt assumption! Adapt generic-zero-knowledge-interactive to new sums

open import Data.Bool.NP as Bool hiding (check)
open import Data.Nat
open import Data.Maybe
open import Data.Product.NP
open import Data.Bits
open import Function.NP
open import Relation.Binary.PropositionalEquality.NP

open import sum

module generic-zero-knowledge-interactive where

private
  ★ : Set₁
  ★ = Set

-- A random argument, this is only a formal notation to
-- indicate that the argument is supposed to be picked
-- at random uniformly. (do not confuse with our randomness
-- monad).
record ↺ (A : ★) : ★ where
  constructor rand
  field get : A

module M (Permutation : ★)
         (_⁻¹         : Endo Permutation)
         (sumπ        : Sum Permutation)
         (μπ          : SumProp sumπ)

         (Rₚ-xtra     : ★) -- extra prover/adversary randomness
         (sumRₚ-xtra  : Sum Rₚ-xtra)
         (μRₚ-xtra    : SumProp sumRₚ-xtra)

         (Problem     : ★)
         (_==_        : Problem → Problem → Bit)
         (==-refl     : ∀ {pb} → (pb == pb) ≡ true)
         (_∙P_        : Permutation → Endo Problem)
         (⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x)

         (Solution    : ★)
         (_∙S_        : Permutation → Endo Solution)
         (⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x)

         (check       : Problem → Solution → Bit)
         (check-∙     : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s)

         (easy-pb     : Permutation → Problem)
         (easy-sol    : Permutation → Solution)
         (check-easy  : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true)
    where

    -- prover/adversary randomness
    Rₚ : ★
    Rₚ = Permutation × Rₚ-xtra

    sumRₚ : Sum Rₚ
    sumRₚ = sumπ ×Sum sumRₚ-xtra

    μRₚ : SumProp sumRₚ
    μRₚ = μπ ×μ μRₚ-xtra

    R = Bit × Rₚ

    sumR : Sum R
    sumR = sumBit ×Sum sumRₚ

    μR : SumProp sumR
    μR = μBit ×μ μRₚ

    check-π : Problem → Solution → Rₚ → Bit
    check-π p s (π , _) = check (π ∙P p) (π ∙S s)

    otp-∙-check : let #_ = count μRₚ
                  in
                  ∀ p₀ s₀ p₁ s₁ →
                    check p₀ s₀ ≡ check p₁ s₁ →
                    #(check-π p₀ s₀) ≡ #(check-π p₁ s₁)
    otp-∙-check p₀ s₀ p₁ s₁ check-pf =
      count-ext μRₚ {f = check-π p₀ s₀} {check-π p₁ s₁} (λ π,r →
        check-π p₀ s₀ π,r ≡⟨ check-∙ p₀ s₀ (proj₁ π,r) ⟩
        check p₀ s₀       ≡⟨ check-pf ⟩
        check p₁ s₁       ≡⟨ sym (check-∙ p₁ s₁ (proj₁ π,r)) ⟩
        check-π p₁ s₁ π,r ∎)
        where open ≡-Reasoning

    #_ : (↺ (Bit × Permutation × Rₚ-xtra) → Bit) → ℕ
    # f = count μR (f ∘ rand)

    _≡#_ : (f g : ↺ (Bit × Rₚ) → Bit) → ★
    f ≡# g = # f ≡ # g

{-
    otp-∙ : let otp = λ O pb s → count μRₚ (λ { (π , _) → O (π ∙P pb) (π ∙S s) }) in
            ∀ pb₀ s₀ pb₁ s₁ →
              check pb₀ s₀ ≡ check pb₁ s₁ →
              (O : _ → _ → Bit) → otp O pb₀ s₀ ≡ otp O pb₁ s₁
    otp-∙ pb₀ s₀ pb₁ s₁ check-pf O = {!(μπ ×Sum-proj₂ μRₚ-xtra    ?!}
-}
    Answer : Bit → ★
    Answer false{-0b-} = Permutation
    Answer true {-1b-} = Solution

    answer : Permutation → Solution → ∀ b → Answer b
    answer π _ false = π
    answer _ s true  = s

    -- The prover is the advesary in the generic terminology,
    -- and the verifier is the challenger.
    DepProver : ★
    DepProver = Problem → ↺ Rₚ → (b : Bit) → Problem × Answer b

    Prover₀ : ★
    Prover₀ = Problem → ↺ Rₚ → Problem × Permutation

    Prover₁ : ★
    Prover₁ = Problem → ↺ Rₚ → Problem × Solution

    Prover : ★
    Prover = Prover₀ × Prover₁

    prover : DepProver → Prover
    prover dpr = (λ pb r → dpr pb r 0b) , (λ pb r → dpr pb r 1b)

    depProver : Prover → DepProver
    depProver (pr₀ , pr₁) pb r false = pr₀ pb r
    depProver (pr₀ , pr₁) pb r true  = pr₁ pb r

    -- Here we show that the explicit commitment step seems useless given
    -- the formalization. The verifier can "trust" the prover on the fact
    -- that any choice is going to be govern only by the problem and the
    -- randomness.
    module WithCommitment (Commitment : ★)
                          (AnswerWC   : Bit → ★)
                          (reveal     : ∀ b → Commitment → AnswerWC b → Problem × Answer b) where
        ProverWC = (Problem → Rₚ → Commitment)
                 × (Problem → Rₚ → (b : Bit) → AnswerWC b)

        depProver' : ProverWC → DepProver
        depProver' (pr₀ , pr₁) pb (rand rₚ) b = reveal b (pr₀ pb rₚ) (pr₁ pb rₚ b)

    Verif : Problem → ∀ b → Problem × Answer b → Bit
    Verif pb false{-0b-} (π∙pb , π)   = (π ∙P pb) == π∙pb
    Verif pb true {-1b-} (π∙pb , π∙s) = check π∙pb π∙s

    _⇄′_ : Problem → DepProver → Bit → ↺ Rₚ → Bit
    (pb ⇄′ pr) b (rand rₚ) = Verif pb b (pr pb (rand rₚ) b)

    _⇄_ : Problem → DepProver → ↺ (Bit × Rₚ) → Bit
    (pb ⇄ pr) (rand (b , rₚ)) = (pb ⇄′ pr) b (rand rₚ)

    _⇄''_ : Problem → Prover → ↺ (Bit × Rₚ) → Bit
    pb ⇄'' pr = pb ⇄ depProver pr

    honest : (Problem → Maybe Solution) → DepProver
    honest solve pb (rand (π , rₚ)) b = (π ∙P pb , answer π sol b)
      module Honest where
        sol : Solution
        sol with solve pb
        ...    | just sol = π ∙S sol
        ...    | nothing  = π ∙S easy-sol π

    module WithCorrectSolver (pb      : Problem)
                             (s       : Solution)
                             (check-s : check pb s ≡ true)
                             where

        -- When the honest prover has a solution, he gets accepted
        -- unconditionally by the verifier.
        honest-accepted : ∀ r → (pb ⇄ honest (const (just s))) r ≡ 1b
        honest-accepted (rand (true  , π , rₚ)) rewrite check-∙ pb s π = check-s
        honest-accepted (rand (false , π , rₚ)) = ==-refl

    honest-⅁ = λ pb s → (pb ⇄ honest (const (just s)))

    module HonestLeakZeroKnowledge (pb₀ pb₁  : Problem)
                                   (s₀ s₁    : Solution)
                                   (check-pf : check pb₀ s₀ ≡ check pb₁ s₁) where

        helper : ∀ rₚ → Bool.toℕ ((pb₀ ⇄′ honest (const (just s₀))) 0b (rand rₚ))
                      ≡ Bool.toℕ ((pb₁ ⇄′ honest (const (just s₁))) 0b (rand rₚ))
        helper (π , rₚ) rewrite ==-refl {π ∙P pb₀} | ==-refl {π ∙P pb₁} = refl

        honest-leak : honest-⅁ pb₀ s₀ ≡# honest-⅁ pb₁ s₁
        honest-leak rewrite otp-∙-check pb₀ s₀ pb₁ s₁ check-pf | sum-ext μRₚ helper = refl

    module HonestLeakZeroKnowledge' (pb       : Problem)
                                    (s₀ s₁    : Solution)
                                    (check-pf : check pb s₀ ≡ check pb s₁) where

        honest-leak : honest-⅁ pb s₀ ≡# honest-⅁ pb s₁
        honest-leak = HonestLeakZeroKnowledge.honest-leak pb pb s₀ s₁ check-pf

    -- Predicts b=b′
    cheater : ∀ b′ → DepProver
    cheater b′ pb (rand (π , _)) b = π ∙P (case b′ 0→ pb 1→ easy-pb π)
                                   , answer π (π ∙S easy-sol π) b

    -- If cheater predicts correctly, verifer accepts him
    cheater-accepted : ∀ b pb rₚ → (pb ⇄′ cheater b) b rₚ ≡ 1b
    cheater-accepted true  pb (rand (π , rₚ)) = check-easy π
    cheater-accepted false pb (rand (π , rₚ)) = ==-refl

    -- If cheater predicts incorrecty, verifier rejects him
    module CheaterRejected (pb : Problem)
                           (not-easy-sol : ∀ π → check (π ∙P pb) (π ∙S easy-sol π) ≡ false)
                           (not-easy-pb  : ∀ π → ((π ∙P pb) == (π ∙P easy-pb π)) ≡ false) where

        cheater-rejected : ∀ b rₚ → (pb ⇄′ cheater (not b)) b rₚ ≡ 0b
        cheater-rejected true  (rand (π , rₚ)) = not-easy-sol π
        cheater-rejected false (rand (π , rₚ)) = not-easy-pb π

module DLog (ℤq  : ★)
            (_⊞_ : ℤq → ℤq → ℤq)
            (⊟_  : ℤq → ℤq)
            (G   : ★)
            (g   : G)
            (_^_ : G → ℤq → G)
            (_∙_ : G → G → G)
            (⊟-⊞ : ∀ π x → (⊟ π) ⊞ (π ⊞ x) ≡ x)
            (^⊟-∙ : ∀ α β x → ((α ^ (⊟ x)) ∙ ((α ^ x) ∙ β)) ≡ β)
            -- (∙-assoc : ∀ α β γ → α ∙ (β ∙ γ) ≡ (α ∙ β) ∙ γ)
            (dist-^-⊞ : ∀ α x y → α ^ (x ⊞ y) ≡ (α ^ x) ∙ (α ^ y))
            (_==_ : G → G → Bool)
            (==-refl  : ∀ {α} → (α == α) ≡ true)
            (==-true  : ∀ {α β} → α == β ≡ true → α ≡ β)
            (==-false : ∀ {α β} → α == β ≡ false → α ≢ β)
            (sumℤq      : Sum ℤq)
            (μℤq        : SumProp sumℤq)
            (Rₚ-xtra    : ★) -- extra prover/adversary randomness
            (sumRₚ-xtra : Sum Rₚ-xtra)
            (μRₚ-xtra   : SumProp sumRₚ-xtra)
            (some-ℤq    : ℤq)
   where

   Permutation = ℤq
   Problem = G
   Solution = ℤq

   _⁻¹ : Endo Permutation
   π ⁻¹ = ⊟ π

   g^_ : ℤq → G
   g^ x = g ^ x

   _∙P_ : Permutation → Endo Problem
   π ∙P p = g^ π ∙ p

   ⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x
   ⁻¹-inverseP π x rewrite ^⊟-∙ g x π = refl

   _∙S_ : Permutation → Endo Solution
   π ∙S s = π ⊞ s

   ⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x
   ⁻¹-inverseS = ⊟-⊞

   check : Problem → Solution → Bit
   check p s = p == g^ s

   check-∙' : ∀ p s π b → check p s ≡ b → check (π ∙P p) (π ∙S s) ≡ b
   check-∙' p s π true  check-p-s rewrite dist-^-⊞ g π s | ==-true check-p-s = ==-refl
   check-∙' p s π false check-p-s rewrite dist-^-⊞ g π s
      with ==-false check-p-s ?
   ... | ()

   check-∙ : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s
   check-∙ p s π = check-∙' p s π (check p s) refl

   easy-sol : Permutation → Solution
   easy-sol π = some-ℤq

   easy-pb : Permutation → Problem
   easy-pb π = g^(easy-sol π)

   check-easy : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true
   check-easy π rewrite dist-^-⊞ g π (easy-sol π) = ==-refl

   open M Permutation _⁻¹ sumℤq μℤq Rₚ-xtra sumRₚ-xtra μRₚ-xtra
          Problem _==_ ==-refl _∙P_ ⁻¹-inverseP Solution _∙S_ ⁻¹-inverseS check check-∙ easy-pb easy-sol check-easy
-- -}
-- -}
-- -}
-- -}
-- -}

open import Data.Bool.NP as Bool
open import Data.Nat
open import Data.Maybe
open import Data.Product.NP
open import Data.Bits
open import Function.NP
open import Relation.Binary.PropositionalEquality

open import sum

module generic-zero-knowledge-interactive where

private
  ★ : Set₁
  ★ = Set

-- record VerifiableProblem :

-- A random argument, this is only a formal notation to
-- indicate that the argument is supposed to be picked
-- at random uniformly. (do not confuse with our randomness
-- monad).
record ↺ (A : ★) : ★ where
  constructor rand
  field get : A

⟨0,⟩ : ∀ {A} → ↺ A → ↺ (Bit × A)
⟨0,⟩ (rand x) = rand (0b , x)

⟨1,⟩ : ∀ {A} → ↺ A → ↺ (Bit × A)
⟨1,⟩ (rand x) = rand (1b , x)

module G (Permutation : ★)
         (sumπ        : Sum Permutation)
         (sumπ-ext    : SumExt sumπ)
         -- (_⁻¹         : Endo Permutation)

         (Rₚ-xtra     : ★) -- extra prover/adversary randomness
         (sumRₚ-xtra  : Sum Rₚ-xtra)
         (sumRₚ-xtra-ext : SumExt sumRₚ-xtra)

         (Problem     : ★)
         (_==_        : Problem → Problem → Bit)
         (==-refl     : ∀ {pb} → (pb == pb) ≡ true)
         (_∙P_        : Permutation → Endo Problem)

         (Solution    : ★)
         (_∙S_        : Permutation → Endo Solution)

         (otp-∙       : let otp = λ A pb s → (sumToCount (sumProd sumπ sumRₚ-xtra)) (λ { (π , _) → A (π ∙P pb) (π ∙S s) }) in
                        ∀ pb₀ s₀ pb₁ s₁ (A : _ → _ → Bit) → otp A pb₀ s₀ ≡ otp A pb₁ s₁)
                        {-
                        -- is this enough
         (otp-∙′      : let otp = λ A pb s → sumπ (λ π → A (π ∙P pb) (π ∙S s)) in
                        ∀ pb₀ s₀ pb₁ s₁ (A : _ → _ → ℕ) → otp A pb₀ s₀ ≡ otp A pb₁ s₁)
                        -}

         (check       : Problem → Solution → Bit)
         (check-∙     : ∀ p s π → check p s ≡ check (π ∙P p) (π ∙S s))

         (easy-pb     : Permutation → Problem)
         (easy-sol    : Permutation → Solution)
         (check-easy  : ∀ π → check (easy-pb π) (easy-sol π) ≡ true)
    where

    -- prover/adversary randomness
    Rₚ : ★
    Rₚ = Permutation × Rₚ-xtra

    sumRₚ : Sum Rₚ
    sumRₚ = sumProd sumπ sumRₚ-xtra

    #Rₚ : Count Rₚ
    #Rₚ = sumToCount sumRₚ

    sumRₚ-ext : SumExt sumRₚ
    sumRₚ-ext = sumProd-ext sumπ-ext sumRₚ-xtra-ext

    sum : Sum (Bit × Rₚ)
    sum = sumProd sumBit sumRₚ

    sum-ext : SumExt sum
    sum-ext = sumProd-ext sumBit-ext sumRₚ-ext

    #_ : (↺ (Bit × Permutation × Rₚ-xtra) → Bit) → ℕ
    # f = sumToCount sum (f ∘ rand)

    _≡#_ : (f g : ↺ (Bit × Rₚ) → Bit) → ★
    f ≡# g = # f ≡ # g

    {-
    otp-∙ : let otp = λ A pb s → #Rₚ(λ { (π , _) → A (π ∙P pb) (π ∙S s) }) in
            ∀ pb₀ s₀ pb₁ s₁ (A : _ → _ → Bit) → otp A pb₀ s₀ ≡ otp A pb₁ s₁
    otp-∙ pb₀ s₀ pb₁ s₁ A = ?
    -}

    Answer : Bit → ★
    Answer false{-0b-} = Permutation
    Answer true {-1b-} = Solution

    -- The prover is the advesary in the generic terminology,
    -- and the verifier is the challenger.
    Prover : ★
    Prover = Problem → ↺ Rₚ → (b : Bit) → Problem × Answer b

    -- Here we show that the explicit commitment step seems useless given
    -- the formalization. The verifier can "trust" the prover on the fact
    -- that any choice is going to be govern only by the problem and the
    -- randomness.
    module WithCommitment (Commitment : ★)
                          (AnswerWC   : Bit → ★)
                          (reveal     : ∀ b → Commitment → AnswerWC b → Problem × Answer b) where
        ProverWC = (Problem → Rₚ → Commitment)
                 × (Problem → Rₚ → (b : Bit) → AnswerWC b)
        prover : ProverWC → Prover
        prover (pr₀ , pr₁) pb (rand rₚ) b = reveal b (pr₀ pb rₚ) (pr₁ pb rₚ b)

    Verif : Problem → ∀ b → Problem × Answer b → Bit
    Verif pb false{-0b-} (π∙pb , π) = (π ∙P pb) == π∙pb
    Verif pb true {-1b-} (π∙pb , s) = check π∙pb s

    _⇄′_ : Problem → Prover → Bit → ↺ Rₚ → Bit
    (pb ⇄′ pr) b (rand rₚ) = Verif pb b (pr pb (rand rₚ) b)

    _⇄_ : Problem → Prover → ↺ (Bit × Rₚ) → Bit
    (pb ⇄ pr) (rand (b , rₚ)) = (pb ⇄′ pr) b (rand rₚ)

    honest : (Problem → Maybe Solution) → Prover
    honest solve pb (rand (π , rₚ)) b = (π ∙P pb , ans b)
      module Honest where
        ans : ∀ b → Answer b
        ans false = π
        ans true  with solve pb
        ...          | just sol = π ∙S sol
        ...          | nothing  = easy-sol π

    module WithCorrectSolver (pb      : Problem)
                             (s       : Solution)
                             (check-s : check pb s ≡ true)
                             where

        -- When the honest prover has a solution, he gets accepted
        -- unconditionally by the verifier.
        honest-accepted : ∀ r → (pb ⇄ honest (const (just s))) r ≡ 1b
        honest-accepted (rand (true  , π , rₚ)) rewrite sym (check-∙ pb s π) = check-s
        honest-accepted (rand (false , π , rₚ)) = ==-refl

    honest-⅁ = λ pb s → (pb ⇄ honest (const (just s)))

    module HonestLeakZeroKnowledge (pb₀ pb₁ : Problem)
                                   (s₀ s₁   : Solution) where

        helper : ∀ rₚ → Bool.toℕ ((pb₀ ⇄′ honest (const (just s₀))) 0b (rand rₚ))
                      ≡ Bool.toℕ ((pb₁ ⇄′ honest (const (just s₁))) 0b (rand rₚ))
        helper (π , rₚ) rewrite ==-refl {π ∙P pb₀} | ==-refl {π ∙P pb₁} = refl

        honest-leak : honest-⅁ pb₀ s₀ ≡# honest-⅁ pb₁ s₁
        honest-leak rewrite otp-∙ pb₀ s₀ pb₁ s₁ check | sumRₚ-ext helper = refl

    -- Predicts b=b′
    cheater : ∀ b′ → Prover
    cheater b′ pb (rand (π , _)) b = pb′ b′ , ans b
      module Cheater where
        pb′ : ∀ b′ → Problem
        pb′ true  = easy-pb π
        pb′ false = π ∙P pb
        ans : ∀ b → Answer b
        ans true  = easy-sol π
        ans false = π

    -- If cheater predicts correctly, verifer accepts him
    cheater-accepted : ∀ b pb rₚ → (pb ⇄′ cheater b) b rₚ ≡ 1b
    cheater-accepted true  pb (rand (π , rₚ)) = check-easy π
    cheater-accepted false pb (rand (π , rₚ)) = ==-refl

    -- If cheater predicts incorrecty, verifier rejects him
    module CheaterRejected (pb : Problem)
                           (not-easy-sol : ∀ π → check (π ∙P pb) (easy-sol π) ≡ false)
                           (not-easy-pb  : ∀ π → ((π ∙P pb) == easy-pb π) ≡ false) where

        cheater-rejected : ∀ b rₚ → (pb ⇄′ cheater (not b)) b rₚ ≡ 0b
        cheater-rejected true  (rand (π , rₚ)) = not-easy-sol π
        cheater-rejected false (rand (π , rₚ)) = not-easy-pb π

-- -}
-- -}
-- -}
-- -}
-- -}


easy cases

easy cases

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

module expansion-unicity where
  mutual
    expansion-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                            Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 →
                            Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 →
                            τ1 == τ2 × d1 == d2 × Δ1 == Δ2
    expansion-unicity-synth ESConst ESConst = refl , refl , refl
    expansion-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl
    expansion-unicity-synth (ESLam d1) (ESLam d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = ap1 _ ih1  , ap1 _ ih2 , refl
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp1 x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp2 x₄ d5 x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp3 x₄ d5 x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp1 x₃ x₄ x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp2 x₃ d6 x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp3 x₃ d6 x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp1 x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp2 x₂ d6 x₃ x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp3 x₂ d6 x₃) = {!!}
    expansion-unicity-synth ESEHole ESEHole = refl , refl , refl
    expansion-unicity-synth (ESNEHole d1) (ESNEHole d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc1 x₂ x₃) = {!!}
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc2 x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc1 x₁ x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc2 x₁) = {!!}

    expansion-unicity-ana : {Γ : tctx} {e : hexp} {τ1 τ1' τ2 τ2' : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                          Γ ⊢ e ⇐ τ1 ~> d1 :: τ1' ⊣ Δ1 →
                          Γ ⊢ e ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
                          τ1 == τ2 × d1 == d2 × τ1' == τ2' × Δ1 == Δ2
    expansion-unicity-ana (EALam d1) (EALam d2) = {!!}
    expansion-unicity-ana (EALam d1) (EASubsume x₁ x₂ x₃ x₄) = {!!}
    expansion-unicity-ana (EASubsume x₁ x₂ x₃ x₄) (EALam d2) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) EAEHole = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole x₄ x₅) = {!!}
    expansion-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = {!!}
    expansion-unicity-ana EAEHole EAEHole = {!!}
    expansion-unicity-ana (EANEHole x x₁) (EASubsume x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-ana (EANEHole x x₁) (EANEHole x₂ x₃) = {!!}

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

module expansion-unicity where
  mutual
    expansion-unicity-synth : (Γ : tctx) (e : hexp) (τ1 τ2 : htyp) (d1 d2 : dhexp) (Δ1 Δ2 : hctx) →
                            Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 →
                            Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 →
                            τ1 == τ2 × d1 == d2 × Δ1 == Δ2
    expansion-unicity-synth = {!!}

    expansion-unicity-ana : (Γ : tctx) (e : hexp) (τ1 τ1' τ2 τ2' : htyp) (d1 d2 : dhexp) (Δ1 Δ2 : hctx) →
                          Γ ⊢ e ⇐ τ1 ~> d1 :: τ1' ⊣ Δ1 →
                          Γ ⊢ e ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
                          τ1 == τ2 × d1 == d2 × τ1' == τ2' × Δ1 == Δ2
    expansion-unicity-ana = {!!}


Generalize environments to values in higher universes.

Old-commit-hash: 4ff4102742306da9be77151d785aa608f8558977

module Denotational.Environments
    (Type : Set)
    {ℓ}
    (⟦_⟧Type : Type → Set ℓ)
  where

-- ENVIRONMENTS
--
-- This module defines the meaning of contexts, that is,
-- the type of environments that fit a context, together
-- with operations and properties of these operations.
--
-- This module is parametric in the syntax and semantics
-- of types, so it can be reused for different calculi
-- and models.

open import Relation.Binary.PropositionalEquality

open import Syntactic.Contexts Type
open import Denotational.Notation

private
  meaningOfType : Meaning Type
  meaningOfType = meaning ⟦_⟧Type

-- TYPING CONTEXTS

-- Denotational Semantics : Contexts Represent Environments

data Empty : Set ℓ where
  ∅ : Empty

data Bind A B : Set ℓ where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set ℓ
⟦ ∅ ⟧Context = Empty
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

-- VARIABLES

-- Denotational Semantics

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

-- WEAKENING

-- Remove a variable from an environment

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → (Γ′ : Γ₁ ≼ Γ₂) → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅ ⟧≼ ∅ = ∅
⟦ keep τ • Γ′ ⟧≼ (v • ρ) = v • ⟦ Γ′ ⟧≼ ρ
⟦ drop τ • Γ′ ⟧≼ (v • ρ) = ⟦ Γ′ ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

-- Properties

⟦⟧-≼-trans : ∀ {Γ₃ Γ₁ Γ₂} → (Γ′ : Γ₁ ≼ Γ₂) (Γ″ : Γ₂ ≼ Γ₃) →
  ∀ (ρ : ⟦ Γ₃ ⟧) → ⟦ ≼-trans Γ′ Γ″ ⟧ ρ ≡ ⟦ Γ′ ⟧ (⟦ Γ″ ⟧ ρ)
⟦⟧-≼-trans Γ′ ∅ ∅ = refl
⟦⟧-≼-trans (keep τ • Γ′) (keep .τ • Γ″) (v • ρ) = cong₂ _•_ refl (⟦⟧-≼-trans Γ′ Γ″ ρ)
⟦⟧-≼-trans (drop τ • Γ′) (keep .τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ
⟦⟧-≼-trans Γ′ (drop τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ

⟦⟧-≼-refl : ∀ {Γ : Context} →
  ∀ (ρ : ⟦ Γ ⟧) → ⟦ ≼-refl ⟧ ρ ≡ ρ
⟦⟧-≼-refl {∅} ∅ = refl
⟦⟧-≼-refl {τ • Γ} (v • ρ) = cong₂ _•_ refl (⟦⟧-≼-refl ρ)

-- SOUNDNESS of variable lifting

lift-sound : ∀ {Γ₁ Γ₂ τ} (Γ′ : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ lift Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (⟦ Γ′ ⟧ ρ)
lift-sound ∅ () ρ
lift-sound (keep τ • Γ′) this (v • ρ) = refl
lift-sound (keep τ • Γ′) (that x) (v • ρ) = lift-sound Γ′ x ρ
lift-sound (drop τ • Γ′) this (v • ρ) = lift-sound Γ′ this ρ
lift-sound (drop τ • Γ′) (that x) (v • ρ) = lift-sound Γ′ (that x) ρ

module Denotational.Environments
    (Type : Set)
    (⟦_⟧Type : Type → Set)
  where

-- ENVIRONMENTS
--
-- This module defines the meaning of contexts, that is,
-- the type of environments that fit a context, together
-- with operations and properties of these operations.
--
-- This module is parametric in the syntax and semantics
-- of types, so it can be reused for different calculi
-- and models.

open import Relation.Binary.PropositionalEquality

open import Syntactic.Contexts Type
open import Denotational.Notation

private
  meaningOfType : Meaning Type
  meaningOfType = meaning ⟦_⟧Type

-- TYPING CONTEXTS

-- Denotational Semantics : Contexts Represent Environments

data Empty : Set where
  ∅ : Empty

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = Empty
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

-- VARIABLES

-- Denotational Semantics

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

-- WEAKENING

-- Remove a variable from an environment

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → (Γ′ : Γ₁ ≼ Γ₂) → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅ ⟧≼ ∅ = ∅
⟦ keep τ • Γ′ ⟧≼ (v • ρ) = v • ⟦ Γ′ ⟧≼ ρ
⟦ drop τ • Γ′ ⟧≼ (v • ρ) = ⟦ Γ′ ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

-- Properties

⟦⟧-≼-trans : ∀ {Γ₃ Γ₁ Γ₂} → (Γ′ : Γ₁ ≼ Γ₂) (Γ″ : Γ₂ ≼ Γ₃) →
  ∀ (ρ : ⟦ Γ₃ ⟧) → ⟦ ≼-trans Γ′ Γ″ ⟧ ρ ≡ ⟦ Γ′ ⟧ (⟦ Γ″ ⟧ ρ)
⟦⟧-≼-trans Γ′ ∅ ∅ = refl
⟦⟧-≼-trans (keep τ • Γ′) (keep .τ • Γ″) (v • ρ) = cong₂ _•_ refl (⟦⟧-≼-trans Γ′ Γ″ ρ)
⟦⟧-≼-trans (drop τ • Γ′) (keep .τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ
⟦⟧-≼-trans Γ′ (drop τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ

⟦⟧-≼-refl : ∀ {Γ : Context} →
  ∀ (ρ : ⟦ Γ ⟧) → ⟦ ≼-refl ⟧ ρ ≡ ρ
⟦⟧-≼-refl {∅} ∅ = refl
⟦⟧-≼-refl {τ • Γ} (v • ρ) = cong₂ _•_ refl (⟦⟧-≼-refl ρ)

-- SOUNDNESS of variable lifting

lift-sound : ∀ {Γ₁ Γ₂ τ} (Γ′ : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ lift Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (⟦ Γ′ ⟧ ρ)
lift-sound ∅ () ρ
lift-sound (keep τ • Γ′) this (v • ρ) = refl
lift-sound (keep τ • Γ′) (that x) (v • ρ) = lift-sound Γ′ x ρ
lift-sound (drop τ • Γ′) this (v • ρ) = lift-sound Γ′ this ρ
lift-sound (drop τ • Γ′) (that x) (v • ρ) = lift-sound Γ′ (that x) ρ


Working in the equivalence N as lfp and N using data.

------------------------------------------------------------------------------
-- Equivalence: N as the least fixed-point and N using Agda's data constructor
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module LeastFixedPoints.N where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions and properties

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

cong : (f : D → D) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

------------------------------------------------------------------------------
module LFP where

  -- N is a least fixed-point of a functor

  -- The functor.
  NatF : (D → Set) → D → Set
  NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

  -- The natural numbers are the least fixed-point of NatF.
  postulate
    N : D → Set

    -- N is a pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the introduction rules.
    N-in : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n

    -- The higher-order version.
    N-in-ho : ∀ {n} → NatF N n → N n

    -- N is the least pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the elimination rule of an inductively
    -- defined predicate.
    N-least-pre-fixed :
      ∀ (A : D → Set) {n} →
      (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
      N n → A n

    -- Higher-order version (incomplete?).
    N-least-pre-fixed-ho :
      ∀ (A : D → Set) {n} →
      (NatF A n → A n) →
      N n → A n

  ----------------------------------------------------------------------------
  -- From/to N-in/N-in-ho.

  N-in₁ : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n
  N-in₁ = N-in-ho

  N-in-ho₁ : ∀ {n} → NatF N n → N n
  N-in-ho₁ = N-in₁

  ----------------------------------------------------------------------------
  -- From/to N-least-pre-fixed/N-least-pre-fixed-ho
  N-least-pre-fixed' :
    ∀ (A : D → Set) {n} →
    (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
    N n → A n
  N-least-pre-fixed' = N-least-pre-fixed-ho

  N-least-pre-fixed-ho' :
    ∀ (A : D → Set) {n} →
    (NatF A n → A n) →
    N n → A n
  N-least-pre-fixed-ho' = N-least-pre-fixed

  ----------------------------------------------------------------------------
  -- The data constructors of N.
  nzero : N zero
  nzero = N-in (inj₁ refl)

  nsucc : ∀ {n} → N n → N (succ₁ n)
  nsucc Nn = N-in (inj₂ (_ , refl , Nn))

  ----------------------------------------------------------------------------
  -- Because N is the least pre-fixed point of NatF (i.e. N-in and
  -- N-ind), we can proof that N is also a post-fixed point of NatF.

  -- N is a post-fixed point of NatF.
  N-post-fixed : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n')
  N-post-fixed = N-least-pre-fixed A h
    where
    A : D → Set
    A m = m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ N m')

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h (inj₁ prf)              = inj₁ prf
    h (inj₂ (m' , prf , Am')) = inj₂ (m' , prf , helper Am')
      where
      helper : A m' → N m'
      helper (inj₁ prf')                = subst N (sym prf') nzero
      helper (inj₂ (m'' , prf' , Am'')) = subst N (sym prf') (nsucc Am'')

  ----------------------------------------------------------------------------
  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step.

  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 is {n} Nn = N-least-pre-fixed A h Nn
    where
    h : n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n
    h (inj₁ prf)              = subst A (sym prf) A0
    h (inj₂ (n' , prf , An')) = subst A (sym prf) (is helper An')
      where
      helper : N n'
      helper with N-post-fixed Nn
      ... | inj₁ n≡0 = ⊥-elim (0≢S (trans (sym n≡0) prf))
      ... | inj₂ (m' , prf' , Nm') =
        subst N (succInjective (trans (sym prf') prf)) Nm'

  ----------------------------------------------------------------------------
  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step.

  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 is {n} = N-least-pre-fixed A h
    where
    h : n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n
    h (inj₁ prf)              = subst A (sym prf) A0
    h (inj₂ (n' , prf , An')) = subst A (sym prf) (is An')

  ----------------------------------------------------------------------------
  -- Example: We will use N-least-pre-fixed as the induction principle on N.

  postulate
    _+_  : D → D → D
    +-0x : ∀ d → zero + d      ≡ d
    +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

  +-leftIdentity : ∀ n → zero + n ≡ n
  +-leftIdentity n = +-0x n

  +-N : ∀ {m n} → N m → N n → N (m + n)
  +-N {m} {n} Nm Nn = N-least-pre-fixed A h Nm
    where
    A : D → Set
    A i = N (i + n)

    h : m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h (inj₁ prf) = subst N (cong (flip _+_ n) (sym prf)) A0
      where
      A0 : A zero
      A0 = subst N (sym (+-leftIdentity n)) Nn
    h (inj₂ (m' , m≡Sm' , Am')) =
      subst N (cong (flip _+_ n) (sym m≡Sm')) (is Am')
      where
      is : ∀ {i} → A i → A (succ₁ i)
      is {i} Ai = subst N (sym (+-Sx i n)) (nsucc Ai)

  ----------------------------------------------------------------------------
  -- Example: A proof using N-post-fixed.

  pred-N : ∀ {n} → N n → N (pred₁ n)
  pred-N {n} Nn = case h₁ h₂ (N-post-fixed Nn)
    where
    h₁ : n ≡ zero → N (pred₁ n)
    h₁ n≡0 = subst N (sym (trans (predCong n≡0) pred-0)) nzero

    h₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → N (pred₁ n)
    h₂ (n' , prf , Nn') = subst N (sym (trans (predCong prf) (pred-S n'))) Nn'

  ----------------------------------------------------------------------------
  -- From/to N as a least fixed-point to/from N as data type.

  data N' : D → Set where
    nzero' : N' zero
    nsucc' : ∀ {n} → N' n → N' (succ₁ n)

  N'→N : ∀ {n} → N' n → N n
  N'→N nzero'      = nzero
  N'→N (nsucc' Nn) = nsucc (N'→N Nn)

  -- Using N-ind₁.
  N→N' : ∀ {n} → N n → N' n
  N→N' = N-ind₁ N' nzero' (λ _ → nsucc')

  -- Using N-ind₂.
  N→N'₁ : ∀ {n} → N n → N' n
  N→N'₁ = N-ind₂ N' nzero' nsucc'

------------------------------------------------------------------------------
module Data where

  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step.
  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 is nzero      = A0
  N-ind₁ A A0 is (nsucc Nn) = is Nn (N-ind₁ A A0 is Nn)

  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step.
  N-ind₂ : (A : D → Set) →
          A zero →
          (∀ {n} → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
  N-ind₂ A A0 h nzero      = A0
  N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

  ----------------------------------------------------------------------------
  -- N-in.

  N-in : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n
  N-in {n} h = case prf₁ prf₂ h
    where
    prf₁ : n ≡ zero → N n
    prf₁ n≡0 = subst N (sym n≡0) nzero

    prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → N n
    prf₂ (n' , prf , Nn') = subst N (sym prf) (nsucc Nn')

  ----------------------------------------------------------------------------
  -- From N-ind₂ to N-least-pre-fixed.

  N→0∨S : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n')
  N→0∨S = N-ind₂ A A0 is
    where
    A : D → Set
    A i = i ≡ zero ∨ (∃[ i' ] i ≡ succ₁ i' ∧ N i')

    A0 : A zero
    A0 = inj₁ refl

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} Ai = case prf₁ prf₂ Ai
      where
      prf₁ : i ≡ zero → succ₁ i ≡ zero ∨ (∃[ i' ] succ₁ i ≡ succ₁ i' ∧ N i')
      prf₁ h' = inj₂ (i , refl , (subst N (sym h') nzero))

      prf₂ : ∃[ i' ] i ≡ succ₁ i' ∧ N i' →
             succ₁ i ≡ zero ∨ (∃[ i' ] succ₁ i ≡ succ₁ i' ∧ N i')
      prf₂ (i' , prf , Ni') = inj₂ (i , refl , subst N (sym prf) (nsucc Ni'))

  N-least-pre-fixed₂ :
    ∀ (A : D → Set) {n} →
    (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
    N n → A n
  N-least-pre-fixed₂ A {n} h Nn = case prf₁ prf₂ (N→0∨S Nn)
    where
    prf₁ : n ≡ zero → A n
    prf₁ n≡0 = h (inj₁ n≡0)

    prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → A n
    prf₂ (n' , prf , Nn') = h (inj₂ (n' , prf , {!!}))

------------------------------------------------------------------------------
-- From N as the least fixed-point to N using Agda's data constructor
------------------------------------------------------------------------------

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

-- We want to represent the total natural numbers data type
--
-- data N : D → Set where
--   nzero : N zero
--   nsucc : ∀ {n} → N n → N (succ₁ n)
--
-- using the representation of N as the least fixed-point.

module LeastFixedPoints.N where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions and properties

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

cong : (f : D → D) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

------------------------------------------------------------------------------
-- N is a least fixed-point of a functor

-- The functor.
NatF : (D → Set) → D → Set
NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

-- The natural numbers are the least fixed-point of NatF.
postulate
  N : D → Set

  -- N is a pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the introduction rules.
  N-in : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n

  -- The higher-order version.
  N-in-ho : ∀ {n} → NatF N n → N n

  -- N is the least pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  N-least-pre-fixed :
    ∀ (A : D → Set) {n} →
    (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
    N n → A n

  -- Higher-order version (incomplete?)
  N-least-pre-fixed-ho :
    ∀ (A : D → Set) {n} →
    (NatF A n → A n) →
    N n → A n

------------------------------------------------------------------------------
-- From/to N-in/N-in-ho.

N-in₁ : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n
N-in₁ = N-in-ho

N-in-ho₁ : ∀ {n} → NatF N n → N n
N-in-ho₁ = N-in₁

------------------------------------------------------------------------------
-- From/to N-least-pre-fixed/N-least-pre-fixed-ho
N-least-pre-fixed' :
  ∀ (A : D → Set) {n} →
  (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
  N n → A n
N-least-pre-fixed' = N-least-pre-fixed-ho

N-least-pre-fixed-ho' :
  ∀ (A : D → Set) {n} →
  (NatF A n → A n) →
  N n → A n
N-least-pre-fixed-ho' = N-least-pre-fixed

------------------------------------------------------------------------------
-- The data constructors of N.
nzero : N zero
nzero = N-in (inj₁ refl)

nsucc : ∀ {n} → N n → N (succ₁ n)
nsucc Nn = N-in (inj₂ (_ , refl , Nn))

------------------------------------------------------------------------------
-- Because N is the least pre-fixed point of NatF (i.e. N-in and
-- N-ind), we can proof that N is also a post-fixed point of NatF.

-- N is a post-fixed point of NatF.
N-post-fixed : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n')
N-post-fixed = N-least-pre-fixed A h
  where
  A : D → Set
  A m = m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ N m')

  h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
  h (inj₁ prf)              = inj₁ prf
  h (inj₂ (m' , prf , Am')) = inj₂ (m' , prf , helper Am')
    where
    helper : A m' → N m'
    helper (inj₁ prf')                = subst N (sym prf') nzero
    helper (inj₂ (m'' , prf' , Am'')) = subst N (sym prf') (nsucc Am'')

------------------------------------------------------------------------------
-- The induction principle for N *with* the hypothesis N n in the
-- induction step.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 is {n} Nn = N-least-pre-fixed A h Nn
  where
  h : n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n
  h (inj₁ prf)              = subst A (sym prf) A0
  h (inj₂ (n' , prf , An')) = subst A (sym prf) (is helper An')
    where
    helper : N n'
    helper with N-post-fixed Nn
    ... | inj₁ n≡0 = ⊥-elim (0≢S (trans (sym n≡0) prf))
    ... | inj₂ (m' , prf' , Nm') = subst N (succInjective (trans (sym prf') prf)) Nm'

------------------------------------------------------------------------------
-- The induction principle for N *without* the hypothesis N n in the
-- induction step.
N-ind₂ : (A : D → Set) →
         A zero →
         (∀ {n} → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₂ A A0 is {n} = N-least-pre-fixed A h
  where
  h : n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n
  h (inj₁ prf)              = subst A (sym prf) A0
  h (inj₂ (n' , prf , An')) = subst A (sym prf) (is An')

------------------------------------------------------------------------------
-- Example: We will use N-least-pre-fixed as the induction principle on N.

postulate
  _+_  : D → D → D
  +-0x : ∀ d → zero + d      ≡ d
  +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-least-pre-fixed A h Nm
  where
  A : D → Set
  A i = N (i + n)

  h : m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
  h (inj₁ prf) = subst N (cong (flip _+_ n) (sym prf)) A0
    where
    A0 : A zero
    A0 = subst N (sym (+-leftIdentity n)) Nn
  h (inj₂ (m' , m≡Sm' , Am')) = subst N (cong (flip _+_ n) (sym m≡Sm')) (is Am')
    where
    is : ∀ {i} → A i → A (succ₁ i)
    is {i} Ai = subst N (sym (+-Sx i n)) (nsucc Ai)

------------------------------------------------------------------------------
-- Example: A proof using N-post-fixed

pred-N : ∀ {n} → N n → N (pred₁ n)
pred-N {n} Nn = case h₁ h₂ (N-post-fixed Nn)
  where
  h₁ : n ≡ zero → N (pred₁ n)
  h₁ n≡0 = subst N (sym (trans (predCong n≡0) pred-0)) nzero

  h₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → N (pred₁ n)
  h₂ (n' , prf , Nn') = subst N (sym (trans (predCong prf) (pred-S n'))) Nn'

------------------------------------------------------------------------------
-- From/to N as a least fixed-point to/from N as data type.

open import FOTC.Data.Nat.Type renaming
  ( N to N'
  ; nsucc to nsucc'
  ; nzero to nzero'
  )

N'→N : ∀ {n} → N' n → N n
N'→N nzero'      = nzero
N'→N (nsucc' Nn) = nsucc (N'→N Nn)

-- Using N-ind₁.
N→N' : ∀ {n} → N n → N' n
N→N' = N-ind₁ N' nzero' (λ _ → nsucc')

-- Using N-ind₂.
N→N'₁ : ∀ {n} → N n → N' n
N→N'₁ = N-ind₂ N' nzero' nsucc'


Swapped premises and the conclusion in the introduction rules.

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

module LeastFixedPoints where

open import FOTC.Base
open import FOTC.Base.PropertiesI

-- infixl 9 _+_

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

------------------------------------------------------------------------------
-- N is a least fixed-point of a functor

-- Instead defining the least fixed-point via a (higher-order)
-- operator, we will define it using an instance of that operator.

-- The functor
NatF : (D → Set) → D → Set
NatF P n = n ≡ zero ∨ (∃[ m ] P m ∧ n ≡ succ₁ m)

-- The natural numbers are the least fixed-point of NatF.
postulate
  N : D → Set

  -- N is a pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the introduction rules.
  N-lfp₁    : ∀ {n} → n ≡ zero ∨ (∃[ m ] N m ∧ n ≡ succ₁ m) → N n
  -- N-lfp₁ : ∀ n → NatF N n → N n  -- Higher-order version

  -- N is a the least pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  N-lfp₂    : (A : D → Set) →
              (∀ {n} → n ≡ zero ∨ (∃[ m ] A m ∧ n ≡ succ₁ m) → A n) →
              ∀ {n} → N n → A n
  -- N-lfp₂ : (A : D → Set) →  -- Higher-order version
  --          (∀ {n} → NatF A n → A n) →
  --          ∀ {n} → N n → A n

------------------------------------------------------------------------------
-- The data constructors of N.
zN : N zero
zN = N-lfp₁ (inj₁ refl)

sN : ∀ {n} → N n → N (succ₁ n)
sN Nn = N-lfp₁ (inj₂ (_ , (Nn , refl)))

------------------------------------------------------------------------------
-- Because N is the least pre-fixed point of NatF (i.e. N-lfp₁ and
-- N-lfp₂), we can proof that N is also a post-fixed point of NatF.

-- N is a post-fixed point of NatF.
N-lfp₃ : ∀ {n} → N n → n ≡ zero ∨ (∃ λ m → N m ∧ n ≡ succ₁ m)
N-lfp₃ Nn = N-lfp₂ A prf Nn
  where
  A : D → Set
  A x = x ≡ zero ∨ (∃ λ m → N m ∧ x ≡ succ₁ m)

  prf : ∀ {n'} → n' ≡ zero ∨ (∃[ m ] A m ∧ n' ≡ succ₁ m) → A n'
  prf {n'} h = case inj₁ ((λ h₁ → inj₂ (prf₁ h₁))) h -- case inj₁ prf₁ h
    where
    prf₁ : ∃ (λ m → A m ∧ n' ≡ succ₁ m) → ∃ (λ m → N m ∧ n' ≡ succ₁ m)
    prf₁ (m , Am , n'=Sm) = m , prf₂ Am , n'=Sm
      where
      prf₂ : A m → N m
      prf₂ Am = case (λ ah → subst N (sym ah) zN) prf₃ Am
        where
        prf₃ : ∃ (λ m' → N m' ∧ m ≡ succ₁ m') → N m
        prf₃ (_ , Nm' , m≡Sm' ) = subst N (sym m≡Sm') (sN Nm')

------------------------------------------------------------------------------
-- The induction principle for N *without* the hypothesis N n in the
-- induction step.
indN₁ : (A : D → Set) →
       A zero →
       (∀ {n} → A n → A (succ₁ n)) →
       ∀ {n} → N n → A n
indN₁ A A0 is Nn = N-lfp₂ A (case prf₁ prf₂) Nn
  where
  prf₁ : ∀ {n'} → n' ≡ zero → A n'
  prf₁ n'≡0 = subst A (sym n'≡0) A0

  prf₂ : ∀ {n'} → ∃ (λ m → A m ∧ n' ≡ succ₁ m) → A n'
  prf₂ (_ , Am , n'≡Sm) = subst A (sym n'≡Sm) (is Am)

-- The induction principle for N *with* the hypothesis N n in the
-- induction step.
--
-- 2012-03-06. We cannot proof this principle because N-lfp₂ does not
-- have the hypothesis N n.
--
-- indN₂ : (A : D → Set) →
--        A zero →
--        (∀ {n} → N n → A n → A (succ₁ n)) →
--        ∀ {n} → N n → A n
-- indN₂ A A0 is Nn = N-lfp₂ A [ prf₁ , prf₂ ] Nn
--   where
--   prf₁ : ∀ {n'} → n' ≡ zero → A n'
--   prf₁ n'≡0 = subst A (sym n'≡0) A0

--   prf₂ : ∀ {n'} → ∃ (λ m → n' ≡ succ₁ m ∧ A m) → A n'
--   prf₂ {n'} (m , n'≡Sm , Am) = subst A (sym n'≡Sm) (is helper Am)
--     where
--     helper : N m
--     helper = [ prf₃ , prf₄ ] (N-lfp₃ {!!})
--       where
--       prf₃ : n' ≡ zero → N m
--       prf₃ n'≡0 = ⊥-elim (0≢S (trans (sym n'≡0) n'≡Sm))

--       prf₄ : ∃ (λ m' → n' ≡ succ₁ m' ∧ N m') → N m
--       prf₄ (_ , n'≡Sm' , Nm') =
--         subst N (succInjective (trans (sym n'≡Sm') n'≡Sm)) Nm'

------------------------------------------------------------------------------
-- Example: We will use N-lfp₂ as the induction principle on N.
postulate
  _+_  : D → D → D
  +-0x : ∀ d →   zero    + d ≡ d
  +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} Nm Nn = N-lfp₂ A prf Nm
  where
  A : D → Set
  A i = N (i + n)

  prf : ∀ {m'} → m' ≡ zero ∨ ∃ (λ m'' → A m'' ∧ m' ≡ succ₁ m'') → A m'
  prf h = case prf₁ prf₂ h
    where
    A0 : A zero
    A0 = subst N (sym (+-leftIdentity n)) Nn

    prf₁ : ∀ {m} → m ≡ zero → A m
    prf₁ h₁ = subst N (cong (flip _+_ n) (sym h₁)) A0

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (sN ih)

    prf₂ : ∀ {m} → ∃ (λ m'' → A m'' ∧ m ≡ succ₁ m'') → A m
    prf₂ (_ ,  Am'' , m≡Sm'') =
      subst N (cong (flip _+_ n) (sym m≡Sm'')) (is Am'')

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

module LeastFixedPoints where

open import FOTC.Base
open import FOTC.Base.PropertiesI

infixl 9 _+_

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

------------------------------------------------------------------------------
-- N is a least fixed-point of a functor

-- Instead defining the least fixed-point via a (higher-order)
-- operator, we will define it using an instance of that operator.

-- The functor
NatF : (D → Set) → D → Set
NatF P n = n ≡ zero ∨ (∃[ m ] n ≡ succ₁ m ∧ P m)

-- The natural numbers are the least fixed-point of NatF.
postulate
  N : D → Set

  -- N is a pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the introduction rules.
  N-lfp₁    : ∀ {n} → n ≡ zero ∨ (∃[ m ] n ≡ succ₁ m ∧ N m) → N n
  -- N-lfp₁ : ∀ n → NatF N n → N n  -- Higher-order version

  -- N is a the least pre-fixed point of NatF.
  --
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  N-lfp₂    : (A : D → Set) →
              (∀ {n} → n ≡ zero ∨ (∃[ m ] n ≡ succ₁ m ∧ A m) → A n) →
              ∀ {n} → N n → A n
  -- N-lfp₂ : (A : D → Set) →  -- Higher-order version
  --          (∀ {n} → NatF A n → A n) →
  --          ∀ {n} → N n → A n

------------------------------------------------------------------------------
-- The data constructors of N.
zN : N zero
zN = N-lfp₁ (inj₁ refl)

sN : ∀ {n} → N n → N (succ₁ n)
sN Nn = N-lfp₁ (inj₂ (_ , (refl , Nn)))

------------------------------------------------------------------------------
-- Because N is the least pre-fixed point of NatF (i.e. N-lfp₁ and
-- N-lfp₂), we can proof that N is also a post-fixed point of NatF.

-- N is a post-fixed point of NatF.
N-lfp₃ : ∀ {n} → N n → n ≡ zero ∨ (∃ λ m → n ≡ succ₁ m ∧ N m)
N-lfp₃ Nn = N-lfp₂ A prf Nn
  where
  A : D → Set
  A x = x ≡ zero ∨ ∃ λ m → x ≡ succ₁ m ∧ N m

  prf : ∀ {n'} → n' ≡ zero ∨ ∃ (λ m → n' ≡ succ₁ m ∧ A m) → A n'
  prf {n'} h = case inj₁ (λ h₁ → inj₂ (prf₁ h₁)) h
    where
    prf₁ : ∃ (λ m → n' ≡ succ₁ m ∧ (m ≡ zero ∨ ∃ (λ m' → m ≡ succ₁ m' ∧ N m'))) →
           ∃ λ m → n' ≡ succ₁ m ∧ N m
    prf₁ (m , n'=Sm , h₂) = m , n'=Sm , prf₂ h₂
      where
      prf₂ : m ≡ zero ∨ ∃ (λ m' → m ≡ succ₁ m' ∧ N m') → N m
      prf₂ h₂ = case (λ h₃ → subst N (sym h₃) zN) prf₃ h₂
        where
        prf₃ : ∃ (λ m' → m ≡ succ₁ m' ∧ N m') → N m
        prf₃ (_ , m≡Sm' , Nm') = subst N (sym m≡Sm') (sN Nm')

------------------------------------------------------------------------------
-- The induction principle for N *without* the hypothesis N n in the
-- induction step.
indN₁ : (A : D → Set) →
       A zero →
       (∀ {n} → A n → A (succ₁ n)) →
       ∀ {n} → N n → A n
indN₁ A A0 is Nn = N-lfp₂ A (case prf₁ prf₂) Nn
  where
  prf₁ : ∀ {n'} → n' ≡ zero → A n'
  prf₁ n'≡0 = subst A (sym n'≡0) A0

  prf₂ : ∀ {n'} → ∃ (λ m → n' ≡ succ₁ m ∧ A m) → A n'
  prf₂ (_ , n'≡Sm , Am) = subst A (sym n'≡Sm) (is Am)

-- The induction principle for N *with* the hypothesis N n in the
-- induction step.
--
-- 2012-03-06. We cannot proof this principle because N-lfp₂ does not
-- have the hypothesis N n.
--
-- indN₂ : (A : D → Set) →
--        A zero →
--        (∀ {n} → N n → A n → A (succ₁ n)) →
--        ∀ {n} → N n → A n
-- indN₂ A A0 is Nn = N-lfp₂ A [ prf₁ , prf₂ ] Nn
--   where
--   prf₁ : ∀ {n'} → n' ≡ zero → A n'
--   prf₁ n'≡0 = subst A (sym n'≡0) A0

--   prf₂ : ∀ {n'} → ∃ (λ m → n' ≡ succ₁ m ∧ A m) → A n'
--   prf₂ {n'} (m , n'≡Sm , Am) = subst A (sym n'≡Sm) (is helper Am)
--     where
--     helper : N m
--     helper = [ prf₃ , prf₄ ] (N-lfp₃ {!!})
--       where
--       prf₃ : n' ≡ zero → N m
--       prf₃ n'≡0 = ⊥-elim (0≢S (trans (sym n'≡0) n'≡Sm))

--       prf₄ : ∃ (λ m' → n' ≡ succ₁ m' ∧ N m') → N m
--       prf₄ (_ , n'≡Sm' , Nm') =
--         subst N (succInjective (trans (sym n'≡Sm') n'≡Sm)) Nm'

------------------------------------------------------------------------------
-- Example: We will use N-lfp₂ as the induction principle on N.
postulate
  _+_  : D → D → D
  +-0x : ∀ d →   zero    + d ≡ d
  +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} Nm Nn = N-lfp₂ A prf Nm
  where
  A : D → Set
  A i = N (i + n)

  prf : ∀ {m'} → m' ≡ zero ∨ ∃ (λ m'' → m' ≡ succ₁ m'' ∧ A m'') → A m'
  prf h = case prf₁ prf₂ h
    where
    A0 : A zero
    A0 = subst N (sym (+-leftIdentity n)) Nn

    prf₁ : ∀ {m} → m ≡ zero → A m
    prf₁ h₁ = subst N (cong (flip _+_ n) (sym h₁)) A0

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (sN ih)

    prf₂ : ∀ {m} → ∃ (λ m'' → m ≡ succ₁ m'' ∧ A m'') → A m
    prf₂ (_ , m≡Sm'' , Am'') =
      subst N (cong (flip _+_ n) (sym m≡Sm'')) (is Am'')


Added x+1+y≡1+x+y (ER version).

Added x+1+y≡1+x+y (ER version).

Ignore-this: cc262563efb9ce925db01b6a8ada7680

darcs-hash:20100531135507-3bd4e-18c905f00f1d32eeba52f68aef14a2d237602dbb.gz

------------------------------------------------------------------------------
-- Arithmetic properties using equational reasoning
------------------------------------------------------------------------------

module LTC.Function.Arithmetic.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties using ( +-comm )
open import LTC.Relation.Equalities.PropertiesER

open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module APER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

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

minus-N : {m n : D} → N m → N n → N (m - n)
minus-N {m} Nm          zN          = subst (λ t → N t) (sym (minus-x0 m)) Nm
minus-N     zN          (sN {n} Nn) = subst (λ t → N t) (sym (minus-0S n)) zN
minus-N     (sN {m} Nm) (sN {n} Nn) = subst (λ t → N t)
                                            (sym (minus-SS m n))
                                            (minus-N Nm Nn)

minus-0x : {n : D} → N n → zero - n  ≡ zero
minus-0x zN          = minus-x0 zero
minus-0x (sN {n} Nn) = minus-0S n

+-leftIdentity : {n : D} → N n → zero + n ≡ n
+-leftIdentity {n} _ = +-0x n

+-rightIdentity : {n : D} → N n → n + zero ≡ n
+-rightIdentity zN          = +-leftIdentity zN
+-rightIdentity (sN {n} Nn) =
  trans (+-Sx n zero)
        (subst (λ t → succ (n + zero) ≡ succ t)
               (+-rightIdentity Nn)
               refl
        )

+-N : {m n : D} → N m → N n → N (m + n)
+-N zN Nn = subst (λ t → N t) (sym (+-leftIdentity Nn)) Nn
+-N {n = n} (sN {m} Nm ) Nn =
  subst (λ t → N t) (sym (+-Sx m n)) (sN (+-N Nm Nn))

+-assoc : {m n o : D} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assoc {n = n} {o = o} zN Nn No =
  begin
    zero + n + o ≡⟨ subst (λ t → zero + n + o ≡ t + o)
                          (+-leftIdentity Nn)
                          refl
                 ⟩
    n + o        ≡⟨ sym (+-leftIdentity (+-N Nn No)) ⟩
    zero + (n + o)
  ∎

+-assoc {n = n} {o = o} (sN {m} Nm) Nn No =
  begin
    succ m + n + o     ≡⟨ subst (λ t → succ m + n + o ≡ t + o)
                                (+-Sx m n)
                                refl
                       ⟩
    succ (m + n) + o   ≡⟨ +-Sx (m + n) o ⟩
    succ (m + n + o)   ≡⟨ subst (λ t → succ (m + n + o) ≡ succ t)
                                (+-assoc Nm Nn No)
                                refl
                       ⟩
    succ (m + (n + o)) ≡⟨ sym (+-Sx m (n + o)) ⟩
    succ m + (n + o)
  ∎

[x+y]-[x+z]≡y-z : {m n o : D} → N m → N n → N o →
                  (m + n) - (m + o) ≡ n - o
[x+y]-[x+z]≡y-z {n = n} {o} zN Nn No =
  begin
    (zero + n) - (zero + o) ≡⟨ subst (λ t → (zero + n) - (zero + o) ≡
                                            t - (zero + o))
                                      (+-0x n) refl
                            ⟩
     n - (zero + o)         ≡⟨ subst (λ t → n - (zero + o) ≡ n - t)
                                     (+-0x o)
                                     refl ⟩
    n - o
  ∎

[x+y]-[x+z]≡y-z {n = n} {o} (sN {m} Nm) Nn No =
  begin
    (succ m + n) - (succ m + o) ≡⟨ subst (λ t → succ m + n - (succ m + o) ≡
                                                t - (succ m + o))
                                         (+-Sx m n)
                                         refl
                                ⟩
    succ (m + n) - (succ m + o) ≡⟨ subst (λ t → succ (m + n) - (succ m + o) ≡
                                                succ (m + n) - t)
                                         (+-Sx m o)
                                         refl ⟩
    succ (m + n) - succ (m + o) ≡⟨ minus-SS (m + n) (m + o) ⟩
    (m + n) - (m + o) ≡⟨ [x+y]-[x+z]≡y-z Nm Nn No ⟩
    n - o
  ∎

*-leftZero : {n : D} → N n → zero * n ≡ zero
*-leftZero {n} _ = *-0x n

*-N : {m n : D} → N m → N n → N (m * n)
*-N zN Nn = subst (λ t → N t) (sym (*-leftZero Nn)) zN
*-N {n = n} (sN {m} Nm) Nn =
  subst (λ t → N t) (sym (*-Sx m n)) (+-N Nn (*-N Nm Nn))

*-rightZero : {n : D} → N n → n * zero ≡ zero
*-rightZero zN          = *-leftZero zN
*-rightZero (sN {n} Nn) =
  trans (*-Sx n zero)
        (trans (+-leftIdentity (*-N Nn zN)) (*-rightZero Nn))

x*1+y≡x+xy : {m n : D} → N m → N n → m * succ n ≡ m + m * n
x*1+y≡x+xy {n = n} zN Nn = sym
  (
    begin
      zero + zero * n ≡⟨ subst (λ t → zero + zero * n ≡ zero + t)
                         (*-leftZero Nn)
                         refl
                      ⟩
      zero + zero     ≡⟨ +-leftIdentity zN ⟩
      zero            ≡⟨ sym (*-leftZero (sN Nn)) ⟩
      zero * succ n
    ∎
  )

x*1+y≡x+xy {n = n} (sN {m} Nm) Nn =
  begin
    succ m * succ n        ≡⟨ *-Sx m (succ n) ⟩
    succ n + m * succ n    ≡⟨ subst (λ t → succ n + m * succ n ≡ succ n + t)
                                    (x*1+y≡x+xy Nm Nn)
                                    refl
                           ⟩
    succ n + (m + m * n)   ≡⟨ +-Sx n (m + m * n) ⟩
    succ (n + (m + m * n)) ≡⟨ subst (λ t → succ (n + (m + m * n)) ≡ succ t)
                                    (sym (+-assoc Nn Nm (*-N Nm Nn)))
                                    refl
                           ⟩
    succ (n + m + m * n)   ≡⟨ subst (λ t → succ (n + m + m * n) ≡
                                           succ (t + m * n))
                                    (+-comm Nn Nm)
                                    refl
                           ⟩
     succ (m + n + m * n)  ≡⟨ subst (λ t → succ (m + n + m * n) ≡ succ t)
                                    (+-assoc Nm Nn (*-N Nm Nn))
                                    refl
                           ⟩

    succ (m + (n + m * n)) ≡⟨ sym (+-Sx m (n + m * n)) ⟩
    succ m + (n + m * n)   ≡⟨ subst (λ t → succ m + (n + m * n) ≡ succ m + t)
                                    (sym (*-Sx m n))
                                    refl
                           ⟩
    succ m + succ m * n
    ∎

*-comm : {m n : D} → N m → N n → m * n ≡ n * m
*-comm zN Nn = trans (*-leftZero Nn) (sym (*-rightZero Nn))
*-comm {n = n} (sN {m} Nm) Nn =
  begin
    succ m * n   ≡⟨ *-Sx m n ⟩
    n + m * n    ≡⟨ subst (λ t → n + m * n ≡ n + t)
                          (*-comm Nm Nn)
                          refl
                  ⟩
    n + n * m     ≡⟨ sym (x*1+y≡x+xy Nn Nm) ⟩
    n * succ m
  ∎

[x-y]z≡xz*yz : {m n o : D} → N m → N n → N o → (m - n) * o ≡ m * o - n * o
[x-y]z≡xz*yz {m} {o = o} Nm zN No =
  begin
    (m - zero) * o   ≡⟨ subst (λ t → (m - zero) * o ≡ t * o)
                              (minus-x0 m)
                              refl
                      ⟩
    m * o            ≡⟨ sym (minus-x0 (m * o)) ⟩
    m * o - zero     ≡⟨ subst (λ t → m * o - zero ≡ m * o - t)
                              (sym (*-0x o))
                              refl
                     ⟩
    m * o - zero * o
  ∎

[x-y]z≡xz*yz {o = o} zN (sN {n} Nn) No =
  begin
    (zero - succ n) * o  ≡⟨ subst (λ t → (zero - succ n) * o ≡ t * o)
                                  (minus-0S n)
                                  refl
                         ⟩
    zero * o             ≡⟨ *-0x o ⟩
    zero                 ≡⟨ sym (minus-0x (*-N (sN Nn) No)) ⟩
    zero - succ n * o    ≡⟨ subst (λ t → zero - succ n * o ≡ t - succ n * o)
                                   (sym (*-0x o))
                                   refl
                         ⟩
    zero * o - succ n * o
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) zN =
  begin
    (succ m - succ n) * zero      ≡⟨ *-comm (minus-N (sN Nm) (sN Nn)) zN ⟩
    zero * (succ m - succ n)      ≡⟨ *-0x (succ m - succ n) ⟩
    zero                          ≡⟨ sym (minus-0x (*-N (sN Nn) zN)) ⟩
    zero - succ n * zero          ≡⟨ subst (λ t → zero - succ n * zero ≡
                                                  t - succ n * zero)
                                           (sym (*-0x (succ m)))
                                           refl
                                  ⟩
    zero * succ m - succ n * zero ≡⟨ subst
                                       (λ t → zero * succ m - succ n * zero ≡
                                              t - succ n * zero)
                                       (*-comm zN (sN Nm))
                                       refl
                                  ⟩
    succ m * zero - succ n * zero
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  begin
    (succ m - succ n) * succ o  ≡⟨ subst (λ t → (succ m - succ n) * succ o ≡
                                                t * succ o)
                                         (minus-SS m n)
                                         refl
                                ⟩
    (m - n) * succ o            ≡⟨ [x-y]z≡xz*yz Nm Nn (sN No) ⟩
    m * succ o - n * succ o     ≡⟨ sym ([x+y]-[x+z]≡y-z (sN No)
                                                        (*-N Nm (sN No))
                                                        (*-N Nn (sN No)))
                                ⟩
    (succ o + m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ o + m * succ o) - (succ o + n * succ o) ≡
                      t - (succ o + n * succ o))
               (sym (*-Sx m (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ m * succ o) - (succ o + n * succ o) ≡
                      (succ m * succ o) - t)
               (sym (*-Sx n (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ n * succ o)
  ∎

[x+y]z≡xz*yz : {m n o : D} → N m → N n → N o → (m + n) * o ≡ m * o + n * o
[x+y]z≡xz*yz {m} {n} Nm Nn zN =
  begin
    (m + n) * zero       ≡⟨ *-comm (+-N Nm Nn) zN ⟩
    zero * (m + n)       ≡⟨ *-0x (m + n) ⟩
    zero                 ≡⟨ sym (*-0x m) ⟩
    zero * m             ≡⟨ *-comm zN Nm ⟩
    m * zero             ≡⟨ sym (+-rightIdentity (*-N Nm zN)) ⟩
    m * zero + zero      ≡⟨ subst (λ t → m * zero + zero ≡ m * zero + t)
                                  (trans (sym (*-0x n)) (*-comm zN Nn))
                                  refl
                         ⟩
    m * zero + n * zero
  ∎

[x+y]z≡xz*yz {n = n} zN Nn (sN {o} No) =
  begin
    (zero + n) * succ o  ≡⟨ subst (λ t → (zero + n) * succ o ≡ t * succ o)
                                  (+-leftIdentity Nn)
                                  refl
                         ⟩
    n * succ o           ≡⟨ sym (+-leftIdentity (*-N Nn (sN No))) ⟩
    zero + n * succ o    ≡⟨ subst (λ t → zero + n * succ o ≡ t +  n * succ o)
                                (sym (*-0x (succ o)))
                                refl
                         ⟩
    zero * succ o + n * succ o
  ∎

[x+y]z≡xz*yz (sN {m} Nm) zN (sN {o} No) =
 begin
    (succ m + zero) * succ o ≡⟨ subst (λ t → (succ m + zero) * succ o ≡
                                             t * succ o)
                                      (+-rightIdentity (sN Nm))
                                      refl
                              ⟩
    succ m * succ o          ≡⟨ sym (+-rightIdentity (*-N (sN Nm) (sN No))) ⟩
    succ m * succ o + zero   ≡⟨ subst (λ t → succ m * succ o + zero ≡
                                             succ m * succ o + t)
                                      (sym (*-leftZero (sN No)))
                                      refl
                             ⟩
    succ m * succ o + zero * succ o
  ∎

[x+y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  begin
    (succ m + succ n) * succ o
      ≡⟨ subst (λ t → (succ m + succ n) * succ o ≡ t * succ o)
               (+-Sx m (succ n))
               refl
      ⟩
    succ ( m + succ n) * succ o ≡⟨ *-Sx (m + succ n) (succ o) ⟩
    succ o + (m + succ n) * succ o
      ≡⟨ subst (λ t → succ o + (m + succ n) * succ o ≡ succ o + t)
               ([x+y]z≡xz*yz Nm (sN Nn) (sN No))
               refl
      ⟩
    succ o + (m * succ o + succ n * succ o)
      ≡⟨ sym (+-assoc (sN No) (*-N Nm (sN No)) (*-N (sN Nn) (sN No))) ⟩
    succ o + m * succ o + succ n * succ o
      ≡⟨ subst (λ t → succ o + m * succ o + succ n * succ o ≡
                      t + succ n * succ o)
               (sym (*-Sx m (succ o)))
               refl
      ⟩
    succ m * succ o + succ n * succ o
      ∎

------------------------------------------------------------------------------
-- Arithmetic properties using equational reasoning
------------------------------------------------------------------------------

module LTC.Function.Arithmetic.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
  using ( x*1+y≡x+xy )
open import LTC.Relation.Equalities.PropertiesER

open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module APER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

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

minus-N : {m n : D} → N m → N n → N (m - n)
minus-N {m} Nm          zN          = subst (λ t → N t) (sym (minus-x0 m)) Nm
minus-N     zN          (sN {n} Nn) = subst (λ t → N t) (sym (minus-0S n)) zN
minus-N     (sN {m} Nm) (sN {n} Nn) = subst (λ t → N t)
                                            (sym (minus-SS m n))
                                            (minus-N Nm Nn)

minus-0x : {n : D} → N n → zero - n  ≡ zero
minus-0x zN          = minus-x0 zero
minus-0x (sN {n} Nn) = minus-0S n

+-leftIdentity : {n : D} → N n → zero + n ≡ n
+-leftIdentity {n} _ = +-0x n

+-rightIdentity : {n : D} → N n → n + zero ≡ n
+-rightIdentity zN          = +-leftIdentity zN
+-rightIdentity (sN {n} Nn) =
  trans (+-Sx n zero)
        (subst (λ t → succ (n + zero) ≡ succ t)
               (+-rightIdentity Nn)
               refl
        )

+-N : {m n : D} → N m → N n → N (m + n)
+-N zN Nn = subst (λ t → N t) (sym (+-leftIdentity Nn)) Nn
+-N {n = n} (sN {m} Nm ) Nn =
  subst (λ t → N t) (sym (+-Sx m n)) (sN (+-N Nm Nn))

+-assoc : {m n o : D} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assoc {n = n} {o = o} zN Nn No =
  begin
    zero + n + o ≡⟨ subst (λ t → zero + n + o ≡ t + o)
                          (+-leftIdentity Nn)
                          refl
                 ⟩
    n + o        ≡⟨ sym (+-leftIdentity (+-N Nn No)) ⟩
    zero + (n + o)
  ∎

+-assoc {n = n} {o = o} (sN {m} Nm) Nn No =
  begin
    succ m + n + o     ≡⟨ subst (λ t → succ m + n + o ≡ t + o)
                                (+-Sx m n)
                                refl
                       ⟩
    succ (m + n) + o   ≡⟨ +-Sx (m + n) o ⟩
    succ (m + n + o)   ≡⟨ subst (λ t → succ (m + n + o) ≡ succ t)
                                (+-assoc Nm Nn No)
                                refl
                       ⟩
    succ (m + (n + o)) ≡⟨ sym (+-Sx m (n + o)) ⟩
    succ m + (n + o)
  ∎

[x+y]-[x+z]≡y-z : {m n o : D} → N m → N n → N o →
                  (m + n) - (m + o) ≡ n - o
[x+y]-[x+z]≡y-z {n = n} {o} zN Nn No =
  begin
    (zero + n) - (zero + o) ≡⟨ subst (λ t → (zero + n) - (zero + o) ≡
                                            t - (zero + o))
                                      (+-0x n) refl
                            ⟩
     n - (zero + o)         ≡⟨ subst (λ t → n - (zero + o) ≡ n - t)
                                     (+-0x o)
                                     refl ⟩
    n - o
  ∎

[x+y]-[x+z]≡y-z {n = n} {o} (sN {m} Nm) Nn No =
  begin
    (succ m + n) - (succ m + o) ≡⟨ subst (λ t → succ m + n - (succ m + o) ≡
                                                t - (succ m + o))
                                         (+-Sx m n)
                                         refl
                                ⟩
    succ (m + n) - (succ m + o) ≡⟨ subst (λ t → succ (m + n) - (succ m + o) ≡
                                                succ (m + n) - t)
                                         (+-Sx m o)
                                         refl ⟩
    succ (m + n) - succ (m + o) ≡⟨ minus-SS (m + n) (m + o) ⟩
    (m + n) - (m + o) ≡⟨ [x+y]-[x+z]≡y-z Nm Nn No ⟩
    n - o
  ∎

*-leftZero : {n : D} → N n → zero * n ≡ zero
*-leftZero {n} _ = *-0x n

*-N : {m n : D} → N m → N n → N (m * n)
*-N zN Nn = subst (λ t → N t) (sym (*-leftZero Nn)) zN
*-N {n = n} (sN {m} Nm) Nn =
  subst (λ t → N t) (sym (*-Sx m n)) (+-N Nn (*-N Nm Nn))

*-rightZero : {n : D} → N n → n * zero ≡ zero
*-rightZero zN          = *-leftZero zN
*-rightZero (sN {n} Nn) =
  trans (*-Sx n zero)
        (trans (+-leftIdentity (*-N Nn zN)) (*-rightZero Nn))

*-comm : {m n : D} → N m → N n → m * n ≡ n * m
*-comm zN Nn = trans (*-leftZero Nn) (sym (*-rightZero Nn))
*-comm {n = n} (sN {m} Nm) Nn =
  begin
    succ m * n   ≡⟨ *-Sx m n ⟩
    n + m * n    ≡⟨ subst (λ t → n + m * n ≡ n + t)
                          (*-comm Nm Nn)
                          refl
                  ⟩
    n + n * m     ≡⟨ sym (x*1+y≡x+xy Nn Nm) ⟩
    n * succ m
  ∎

[x-y]z≡xz*yz : {m n o : D} → N m → N n → N o → (m - n) * o ≡ m * o - n * o
[x-y]z≡xz*yz {m} {o = o} Nm zN No =
  begin
    (m - zero) * o   ≡⟨ subst (λ t → (m - zero) * o ≡ t * o)
                              (minus-x0 m)
                              refl
                      ⟩
    m * o            ≡⟨ sym (minus-x0 (m * o)) ⟩
    m * o - zero     ≡⟨ subst (λ t → m * o - zero ≡ m * o - t)
                              (sym (*-0x o))
                              refl
                     ⟩
    m * o - zero * o
  ∎

[x-y]z≡xz*yz {o = o} zN (sN {n} Nn) No =
  begin
    (zero - succ n) * o  ≡⟨ subst (λ t → (zero - succ n) * o ≡ t * o)
                                  (minus-0S n)
                                  refl
                         ⟩
    zero * o             ≡⟨ *-0x o ⟩
    zero                 ≡⟨ sym (minus-0x (*-N (sN Nn) No)) ⟩
    zero - succ n * o    ≡⟨ subst (λ t → zero - succ n * o ≡ t - succ n * o)
                                   (sym (*-0x o))
                                   refl
                         ⟩
    zero * o - succ n * o
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) zN =
  begin
    (succ m - succ n) * zero      ≡⟨ *-comm (minus-N (sN Nm) (sN Nn)) zN ⟩
    zero * (succ m - succ n)      ≡⟨ *-0x (succ m - succ n) ⟩
    zero                          ≡⟨ sym (minus-0x (*-N (sN Nn) zN)) ⟩
    zero - succ n * zero          ≡⟨ subst (λ t → zero - succ n * zero ≡
                                                  t - succ n * zero)
                                           (sym (*-0x (succ m)))
                                           refl
                                  ⟩
    zero * succ m - succ n * zero ≡⟨ subst
                                       (λ t → zero * succ m - succ n * zero ≡
                                              t - succ n * zero)
                                       (*-comm zN (sN Nm))
                                       refl
                                  ⟩
    succ m * zero - succ n * zero
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  begin
    (succ m - succ n) * succ o  ≡⟨ subst (λ t → (succ m - succ n) * succ o ≡
                                                t * succ o)
                                         (minus-SS m n)
                                         refl
                                ⟩
    (m - n) * succ o            ≡⟨ [x-y]z≡xz*yz Nm Nn (sN No) ⟩
    m * succ o - n * succ o     ≡⟨ sym ([x+y]-[x+z]≡y-z (sN No)
                                                        (*-N Nm (sN No))
                                                        (*-N Nn (sN No)))
                                ⟩
    (succ o + m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ o + m * succ o) - (succ o + n * succ o) ≡
                      t - (succ o + n * succ o))
               (sym (*-Sx m (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ m * succ o) - (succ o + n * succ o) ≡
                      (succ m * succ o) - t)
               (sym (*-Sx n (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ n * succ o)
  ∎

[x+y]z≡xz*yz : {m n o : D} → N m → N n → N o → (m + n) * o ≡ m * o + n * o
[x+y]z≡xz*yz {m} {n} Nm Nn zN =
  begin
    (m + n) * zero       ≡⟨ *-comm (+-N Nm Nn) zN ⟩
    zero * (m + n)       ≡⟨ *-0x (m + n) ⟩
    zero                 ≡⟨ sym (*-0x m) ⟩
    zero * m             ≡⟨ *-comm zN Nm ⟩
    m * zero             ≡⟨ sym (+-rightIdentity (*-N Nm zN)) ⟩
    m * zero + zero      ≡⟨ subst (λ t → m * zero + zero ≡ m * zero + t)
                                  (trans (sym (*-0x n)) (*-comm zN Nn))
                                  refl
                         ⟩
    m * zero + n * zero
  ∎

[x+y]z≡xz*yz {n = n} zN Nn (sN {o} No) =
  begin
    (zero + n) * succ o  ≡⟨ subst (λ t → (zero + n) * succ o ≡ t * succ o)
                                  (+-leftIdentity Nn)
                                  refl
                         ⟩
    n * succ o           ≡⟨ sym (+-leftIdentity (*-N Nn (sN No))) ⟩
    zero + n * succ o    ≡⟨ subst (λ t → zero + n * succ o ≡ t +  n * succ o)
                                (sym (*-0x (succ o)))
                                refl
                         ⟩
    zero * succ o + n * succ o
  ∎

[x+y]z≡xz*yz (sN {m} Nm) zN (sN {o} No) =
 begin
    (succ m + zero) * succ o ≡⟨ subst (λ t → (succ m + zero) * succ o ≡
                                             t * succ o)
                                      (+-rightIdentity (sN Nm))
                                      refl
                              ⟩
    succ m * succ o          ≡⟨ sym (+-rightIdentity (*-N (sN Nm) (sN No))) ⟩
    succ m * succ o + zero   ≡⟨ subst (λ t → succ m * succ o + zero ≡
                                             succ m * succ o + t)
                                      (sym (*-leftZero (sN No)))
                                      refl
                             ⟩
    succ m * succ o + zero * succ o
  ∎

[x+y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  begin
    (succ m + succ n) * succ o
      ≡⟨ subst (λ t → (succ m + succ n) * succ o ≡ t * succ o)
               (+-Sx m (succ n))
               refl
      ⟩
    succ ( m + succ n) * succ o ≡⟨ *-Sx (m + succ n) (succ o) ⟩
    succ o + (m + succ n) * succ o
      ≡⟨ subst (λ t → succ o + (m + succ n) * succ o ≡ succ o + t)
               ([x+y]z≡xz*yz Nm (sN Nn) (sN No))
               refl
      ⟩
    succ o + (m * succ o + succ n * succ o)
      ≡⟨ sym (+-assoc (sN No) (*-N Nm (sN No)) (*-N (sN Nn) (sN No))) ⟩
    succ o + m * succ o + succ n * succ o
      ≡⟨ subst (λ t → succ o + m * succ o + succ n * succ o ≡
                      t + succ n * succ o)
               (sym (*-Sx m (succ o)))
               refl
      ⟩
    succ m * succ o + succ n * succ o
      ∎


Updated agda2atp: The TPTP definitions use an unique name.

Ignore-this: 46560a3592efd4fdf23dc29fe3ee2d5a

darcs-hash:20101201173120-3bd4e-1c669d5b56abab12ba22ba65c0c8ed7ac50be6b8.gz

------------------------------------------------------------------------------
-- PA properties
------------------------------------------------------------------------------

module PA.Properties where

open import PA.Base

------------------------------------------------------------------------------
-- Some proofs are based on the proofs in the standard library.

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity = S₅

+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity = S₉ P P0 iStep
  where
    P : ℕ → Set
    P i = i + zero ≡ i
    {-# ATP definition P #-}

    P0 : P zero
    P0 = S₅ zero

    postulate
      iStep : ∀ i → P i → P (succ i)
    {-# ATP prove iStep #-}

+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc m n o = S₉ P P0 iStep m
  where
    P : ℕ → Set
    P i = i + n + o ≡ i + (n + o)
    {-# ATP definition P #-}

    postulate
      P0 : P zero
    {-# ATP prove P0 #-}

    postulate
      iStep : ∀ i → P i → P (succ i)
    {-# ATP prove iStep #-}

x+1+y≡1+x+y : ∀ m n → m + succ n ≡ succ (m + n)
x+1+y≡1+x+y m n = S₉ P P0 iStep m
  where
    P : ℕ → Set
    P i = i + succ n ≡ succ (i + n)
    {-# ATP definition P #-}

    postulate
      P0 : P zero
    {-# ATP prove P0 #-}

    postulate
      iStep : ∀ i → P i → P (succ i)
    {-# ATP prove iStep #-}

+-comm : ∀ m n → m + n ≡ n + m
+-comm m n = S₉ P P0 iStep m
  where
    P : ℕ → Set
    P i = i + n ≡ n + i
    {-# ATP definition P #-}

    postulate
      P0 : P zero
    {-# ATP prove P0 +-rightIdentity #-}

    postulate
      iStep : ∀ i → P i → P (succ i)
    {-# ATP prove iStep x+1+y≡1+x+y #-}

------------------------------------------------------------------------------
-- PA properties
------------------------------------------------------------------------------

module PA.Properties where

open import PA.Base

------------------------------------------------------------------------------
-- Some proofs are based on the proofs in the standard library.

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity = S₅

+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity = S₉ P P0 iStep
  where
    P : ℕ → Set
    P i = i + zero ≡ i

    P0 : zero + zero ≡ zero
    P0 = S₅ zero

    postulate
      iStep : ∀ i →
              i + zero ≡ i →
              succ i + zero ≡ succ i
    {-# ATP prove iStep #-}

+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc m n o = S₉ P P0 iStep m
  where
    P : ℕ → Set
    P i = i + n + o ≡ i + (n + o)

    postulate
      P0 : zero + n + o ≡ zero + (n + o)
    {-# ATP prove P0 #-}

    postulate
      iStep : ∀ i →
              i + n + o ≡ i + (n + o) →
              succ i + n + o ≡ succ i + (n + o)
    {-# ATP prove iStep #-}

x+1+y≡1+x+y : ∀ m n → m + succ n ≡ succ (m + n)
x+1+y≡1+x+y m n = S₉ P P0 iStep m
  where
    P : ℕ → Set
    P i = i + succ n ≡ succ (i + n)

    postulate
      P0 : zero + succ n ≡ succ (zero + n)
    {-# ATP prove P0 #-}

    postulate
      iStep : ∀ i →
              i + succ n ≡ succ (i + n) →
              succ i + succ n ≡ succ (succ i + n)
    {-# ATP prove iStep #-}

+-comm : ∀ m n → m + n ≡ n + m
+-comm m n = S₉ P P0 iStep m
  where
    P : ℕ → Set
    P i = i + n ≡ n + i

    postulate
      P0 : zero + n ≡ n + zero
    {-# ATP prove P0 +-rightIdentity #-}

    postulate
      iStep : ∀ i →
              i + n ≡ n + i →
              succ i + n ≡ n + succ i
    {-# ATP prove iStep x+1+y≡1+x+y #-}


#31 missed another file

#31 missed another file

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + d casterr[ Δ ] + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    E : ∀{d Δ} → d casterr → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is an error, the whole thing is an error
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
    -- if the left is indeterminate, inspect the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | I x | E x₁ = E (CECong (FHAp2 FHOuter) x₁)
  progress (TAAp wt1 wt2) | I x | I x₁ = I (IAp {!!} x (FIndet x₁)) -- todo: check that it's not that form, otherwise the cast can progress maybe
  progress (TAAp wt1 wt2) | I x | V x₁ = I (IAp {!!} x (FBoxed x₁)) --
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | V v | E e = E (CECong (FHAp2 FHOuter) e)
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FIndet i)) --cyrus, as below
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FBoxed v₂)) --cyrus

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | E x = E (CECong (FHNEHole FHOuter) x)
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  ... | E x = E (CECong (FHCast FHOuter) x)
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = V {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + d casterr[ Δ ] + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    E : ∀{d Δ} → d casterr → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is an error, the whole thing is an error
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
    -- if the left is indeterminate, inspect the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 (FIndet i) x) y (FHAp2 (FIndet i) z))
  progress (TAAp wt1 wt2) | I x | E x₁ = E (CECong (FHAp2 (FIndet x) FHOuter) x₁)
  progress (TAAp wt1 wt2) | I x | I x₁ = I (IAp {!!} x (FIndet x₁)) -- todo: check that it's not that form, otherwise the cast can progress maybe
  progress (TAAp wt1 wt2) | I x | V x₁ = I (IAp {!!} x (FBoxed x₁)) --
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2 (FBoxed v) x) y (FHAp2 (FBoxed v) z))
  progress (TAAp wt1 wt2) | V v | E e = E (CECong (FHAp2 (FBoxed v) FHOuter) e)
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter (ITLam (FIndet i)) FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FIndet i)) --cyrus, as below
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter (ITLam (FBoxed v₂)) FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FBoxed v₂)) --cyrus

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | E x = E (CECong (FHNEHole FHOuter) x)
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  ... | E x = E (CECong (FHCast FHOuter) x)
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter (ITCastID (FIndet x)) FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter (ITCastID (FBoxed x)) FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = V {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus

  -- this would fill two above, but it's false: ⦇⦈ indet but its type, ⦇⦈, is not ground
  postulate
    lem-groundindet : ∀{ Δ d τ} → Δ , ∅ ⊢ d :: τ → d indet → τ ground

  -- this is also false, but tempting looking in two holes above from the ap case
  postulate
    lem : ∀{ Δ d1 τ τ'} → Δ , ∅ ⊢ d1 :: (τ ==> τ') →
                          d1 indet →
                          ((τ1 τ2 τ3 τ4 : htyp) (d1' : dhexp) → d1 ≠ (d1' ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩))

  counter : Σ[ d ∈ dhexp ] Σ[ τ ∈ htyp ] Σ[ τ' ∈ htyp ] Σ[ Δ ∈ hctx ]
               ((d indet) × (Δ , ∅ ⊢ d :: τ ==> τ'))
  counter = (⦇⦈⟨ Z , ∅ ⟩ ⟨ b ==> b ⇒ b ==> ⦇⦈ ⟩) ,
            b , ⦇⦈ ,  ■ (Z , ∅ , b ==> b ) ,
            ICastArr (λ ()) IEHole , TACast (TAEHole refl (λ x d → λ ())) (TCArr TCRefl TCHole1)

  oops : ⊥
  oops = lem (π2 (π2 (π2 (π2 (π2 counter)))))
                (π1 (π2 (π2 (π2 (π2 counter))))) b b b ⦇⦈ ⦇⦈⟨ Z , ∅ ⟩ refl


The agda2atp tool fixed the issue related to the eta-expansion of TPTP definitions.

Ignore-this: 447b379a77cb14d71c8a7b51a2b87837

darcs-hash:20110730142709-3bd4e-d570ee27862523ca742a98082ef46b71ab657230.gz

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

module FOTC.Data.Stream.PropertiesATP where

open import FOTC.Base

open import FOTC.Base.PropertiesATP

open import FOTC.Data.Stream.Type

open import FOTC.Relation.Binary.Bisimilarity

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

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃ λ zs → ws ≈ zs
  {-# ATP definition P₁ #-}

  P₂ : D → Set
  P₂ zs = ∃ λ ws → ws ≈ zs
  {-# ATP definition P₂ #-}

  postulate
    helper₁ : ∀ {ws} → P₁ ws →
              ∃ (λ w' → ∃ (λ ws' → ws ≡ w' ∷ ws' ∧ P₁ ws'))
  {-# ATP prove helper₁ #-}

  postulate
    helper₂ : ∀ {zs} → P₂ zs →
              ∃ (λ z' → ∃ (λ zs' → zs ≡ z' ∷ zs' ∧ P₂ zs'))
  {-# ATP prove helper₂ #-}

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

module FOTC.Data.Stream.PropertiesATP where

open import FOTC.Base

open import FOTC.Base.PropertiesATP

open import FOTC.Data.Stream.Type

open import FOTC.Relation.Binary.Bisimilarity

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

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃ λ zs → ws ≈ zs

  P₂ : D → Set
  P₂ zs = ∃ λ ws → ws ≈ zs
  {-# ATP definition P₂ #-}

  -- TODO: We don't use the predicate P₁ in the type of the function
  -- helper₁, because at the moment the agda2atp tool doesn't handle
  -- the eta-expansion for equations.
  postulate
    helper₁ : ∀ {ws} → (∃ λ zs → ws ≈ zs) →
              ∃ (λ w' → ∃ (λ ws' → ws ≡ w' ∷ ws' ∧ (∃ λ zs → ws' ≈ zs)))
  {-# ATP prove helper₁ #-}

  postulate
    helper₂ : ∀ {zs} → P₂ zs →
              ∃ (λ z' → ∃ (λ zs' → zs ≡ z' ∷ zs' ∧ P₂ zs'))
  {-# ATP prove helper₂ #-}