Removed $ from a module.

Removed $ from a module.

Ignore-this: 4538e6f19fd38a4038b09471605febf6

darcs-hash:20120602034612-3bd4e-1e9935da91bfd44d3818eef64dbc3da563f75109.gz

------------------------------------------------------------------------------
-- Arithmetic properties
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Base.Properties
open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Rec
open import LTC-PCF.Data.Nat.Rec.EquationsI

------------------------------------------------------------------------------
-- Congruence properties

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong refl = refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong refl = refl

∸-leftCong : ∀ {m n o} → m ≡ n → m ∸ o ≡ n ∸ o
∸-leftCong refl = refl

∸-rightCong : ∀ {m n o} → n ≡ o → m ∸ n ≡ m ∸ o
∸-rightCong refl = refl

*-leftCong : ∀ {m n o} → m ≡ n → m * o ≡ n * o
*-leftCong refl = refl

*-rightCong : ∀ {m n o} → n ≡ o → m * n ≡ m * o
*-rightCong refl = refl

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

+-0x : ∀ n → zero + n ≡ n
+-0x n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

+-Sx : ∀ m n → succ₁ m + n ≡ succ₁ (m + n)
+-Sx m n =
  rec (succ₁ m) n (lam (λ x → lam (λ y → succ₁ y)))
    ≡⟨ rec-S m n (lam (λ x → lam (λ y → succ₁ y))) ⟩
  (lam (λ x → lam (λ y → succ₁ y))) · m · (m + n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → succ₁ y)) m) ⟩
  (λ x → lam (λ y → succ₁ y)) m · (m + n)
    ≡⟨ refl ⟩
  lam succ₁ · (m + n)
    ≡⟨ beta succ₁ (m + n) ⟩
  succ₁ (m + n) ∎

∸-x0 : ∀ n → n ∸ zero ≡ n
∸-x0 n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

∸-0S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
∸-0S zN =
  rec (succ₁ zero) zero (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S zero zero (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · zero · (zero ∸ zero)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) zero) ⟩
  (λ x → lam (λ y → pred₁ y)) zero · (zero ∸ zero)
    ≡⟨ refl ⟩
  lam pred₁ · (zero ∸ zero)
    ≡⟨ beta pred₁ (zero ∸ zero) ⟩
  pred₁ (zero ∸ zero)
    ≡⟨ cong pred₁ (∸-x0 zero) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0S (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) zero (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) zero (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y))  (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ refl ⟩
  lam pred₁ · (zero ∸ (succ₁ n))
    ≡⟨ beta pred₁ (zero ∸ (succ₁ n)) ⟩
  pred₁ (zero ∸ (succ₁ n))
    ≡⟨ cong pred₁ (∸-0S Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

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

∸-SS : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n ≡ m ∸ n
∸-SS {m} _ zN =
  rec (succ₁ zero) (succ₁ m) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S zero (succ₁ m) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y))  · zero · (succ₁ m ∸ zero)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) zero) ⟩
  (λ x → lam (λ y → pred₁ y)) zero · (succ₁ m ∸ zero)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ m ∸ zero)
    ≡⟨ beta pred₁ (succ₁ m ∸ zero) ⟩
  pred₁ (succ₁ m ∸ zero)
    ≡⟨ cong pred₁ (∸-x0 (succ₁ m)) ⟩
  pred₁ (succ₁ m)
    ≡⟨ pred-S m ⟩
  m
    ≡⟨ sym (∸-x0 m) ⟩
  m ∸ zero ∎

∸-SS zN (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ zero) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) (succ₁ zero) (lam (λ x → lam (λ y → pred₁ y)))  ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y)) (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ zero ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ zero ∸ succ₁ n) ⟩
  pred₁ (succ₁ zero ∸ succ₁ n)
    ≡⟨ cong pred₁ (∸-SS zN Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ cong pred₁ (∸-0x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym (∸-0S Nn) ⟩
  zero ∸ succ₁ n ∎

∸-SS (sN {m} Nm) (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ (succ₁ m)) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) (succ₁ (succ₁ m)) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y)) (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ (succ₁ m) ∸ succ₁ n) ⟩
  pred₁ (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ cong pred₁ (∸-SS (sN Nm) Nn) ⟩
  pred₁ (succ₁ m ∸ n)
    ≡⟨ sym (beta pred₁ (succ₁ m ∸ n)) ⟩
  lam pred₁ · (succ₁ m ∸ n)
    ≡⟨ refl ⟩
  (λ x → lam (λ y → pred₁ y)) n · (succ₁ m ∸ n)
    ≡⟨ ·-leftCong (sym (beta (λ x → lam (λ y → pred₁ y)) n)) ⟩
  (lam (λ x → lam (λ y → pred₁ y))) · n · (succ₁ m ∸ n)
    ≡⟨ sym (rec-S n (succ₁ m) (lam (λ x → lam (λ y → pred₁ y)))) ⟩
  rec (succ₁ n) (succ₁ m) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ refl ⟩
  succ₁ m ∸ succ₁ n ∎

*-0x : ∀ n → zero * n ≡ zero
*-0x n = rec zero zero (lam (λ _ → lam (λ y → n + y))) ≡⟨ rec-0 zero ⟩
         zero                                          ∎

*-Sx : ∀ m n → succ₁ m * n ≡ n + m * n
*-Sx m n =
  rec (succ₁ m) zero (lam (λ _ → lam (λ y → n + y)))
    ≡⟨ rec-S m zero (lam (λ _ → lam (λ y → n + y))) ⟩
  (lam (λ _ → lam (λ y → n + y))) · m · (m * n)
    ≡⟨ ·-leftCong (beta (λ _ → lam (λ y → n + y)) m) ⟩
  (λ _ → lam (λ y → n + y)) m · (m * n)
    ≡⟨ refl ⟩
  lam (λ y → n + y) · (m * n)
    ≡⟨ beta (λ y → n + y) (m * n) ⟩
  (λ y → n + y) (m * n)
    ≡⟨ refl ⟩
  n + (m * n) ∎

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} zN          Nn = subst N (sym (+-0x n)) Nn
+-N {n = n} (sN {m} Nm) Nn = subst N (sym (+-Sx m n)) (sN (+-N Nm Nn))

∸-N : ∀ {m n} → N m → N n → N (m ∸ n)
∸-N {m} Nm       zN     = subst N (sym (∸-x0 m)) Nm
∸-N     zN      (sN Nn) = subst N (sym (∸-0S Nn)) zN
∸-N     (sN Nm) (sN Nn) = subst N (sym (∸-SS Nm Nn)) (∸-N Nm Nn)

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

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

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

+-assoc (sN {m} Nm) n o =
  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 n o) refl ⟩
  succ₁ (m + (n + o))
    ≡⟨ sym (+-Sx m (n + o)) ⟩
  succ₁ m + (n + o) ∎

x+Sy≡S[x+y] : ∀ {m} → N m → ∀ n → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] zN n =
  zero + succ₁ n ≡⟨ +-0x (succ₁ n) ⟩
  succ₁ n ≡⟨ subst (λ t → succ₁ n ≡ succ₁ t) (sym (+-leftIdentity n)) refl ⟩
  succ₁ (zero + n) ∎

x+Sy≡S[x+y] (sN {m} Nm) n =
  succ₁ m + succ₁ n
    ≡⟨ +-Sx m (succ₁ n) ⟩
  succ₁ (m + succ₁ n)
    ≡⟨ subst (λ t → succ₁ (m + succ₁ n) ≡ succ₁ t) (x+Sy≡S[x+y] Nm n) refl ⟩
  succ₁ (succ₁ (m + n))
    ≡⟨ subst (λ t → succ₁ (succ₁ (m + n)) ≡ succ₁ t) (sym (+-Sx m n)) refl ⟩
  succ₁ (succ₁ m + n) ∎

[x+y]∸[x+z]≡y∸z : ∀ {m n o} → N m → N n → N o → (m + n) ∸ (m + o) ≡ n ∸ o
[x+y]∸[x+z]≡y∸z {n = n} {o} zN _ _ =
  (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 =
  (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)
    ≡⟨ ∸-SS (+-N Nm Nn) (+-N Nm No) ⟩
  (m + n) ∸ (m + o)
    ≡⟨ [x+y]∸[x+z]≡y∸z Nm Nn No ⟩
  n ∸ o ∎

+-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
+-comm {n = n} zN Nn =
  zero + n ≡⟨ +-leftIdentity n ⟩
  n        ≡⟨ sym (+-rightIdentity Nn) ⟩
  n + zero ∎

+-comm {n = n} (sN {m} Nm) Nn =
  succ₁ m + n   ≡⟨ +-Sx m n ⟩
  succ₁ (m + n) ≡⟨ cong succ₁ (+-comm Nm Nn) ⟩
  succ₁ (n + m) ≡⟨ sym (x+Sy≡S[x+y] Nn m) ⟩
  n + succ₁ m   ∎

*-leftZero : ∀ n → zero * n ≡ zero
*-leftZero = *-0x

*-N : ∀ {m n} → N m → N n → N (m * n)
*-N {n = n} zN          _  = subst N (sym (*-0x n)) zN
*-N {n = n} (sN {m} Nm) Nn = subst N (sym (*-Sx m n)) (+-N Nn (*-N Nm Nn))

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

*-leftIdentity : ∀ {n} → N n → succ₁ zero * n ≡ n
*-leftIdentity {n} Nn =
  succ₁ zero * n ≡⟨ *-Sx zero n ⟩
  n + zero * n   ≡⟨ subst (λ t → n + zero * n ≡ n + t) (*-leftZero n) refl ⟩
  n + zero       ≡⟨ +-rightIdentity Nn ⟩
  n              ∎

x*Sy≡x+xy : ∀ {m n} → N m → N n → m * succ₁ n ≡ m + m * n
x*Sy≡x+xy {n = n} zN _ = sym
  ( zero + zero * n
      ≡⟨ subst (λ t → zero + zero * n ≡ zero + t) (*-leftZero n) refl ⟩
    zero + zero
      ≡⟨ +-leftIdentity zero ⟩
    zero
      ≡⟨ sym (*-leftZero (succ₁ n)) ⟩
    zero * succ₁ n ∎
  )

x*Sy≡x+xy {n = n} (sN {m} Nm) Nn =
  succ₁ m * succ₁ n
    ≡⟨ *-Sx m (succ₁ n) ⟩
  succ₁ n + m * succ₁ n
    ≡⟨ subst (λ t → succ₁ n + m * succ₁ n ≡ succ₁ n + t)
             (x*Sy≡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 m (m * n)))
             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 n (m * n))
             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} → N m → N n → m * n ≡ n * m
*-comm {n = n} zN Nn          = trans (*-leftZero n) (sym (*-rightZero Nn))
*-comm {n = n} (sN {m} Nm) Nn =
  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*Sy≡x+xy Nn Nm) ⟩
  n * succ₁ m  ∎

*∸-leftDistributive : ∀ {m n o} → N m → N n → N o → (m ∸ n) * o ≡ m * o ∸ n * o
*∸-leftDistributive {m} {o = o} _ zN _ =
  (m ∸ zero) * o   ≡⟨ subst (λ t → (m ∸ zero) * o ≡ t * o) (∸-x0 m) refl ⟩
  m * o            ≡⟨ sym (∸-x0 (m * o)) ⟩
  m * o ∸ zero     ≡⟨ subst (λ t → m * o ∸ zero ≡ m * o ∸ t) (sym (*-0x o)) refl ⟩
  m * o ∸ zero * o ∎

*∸-leftDistributive {o = o} zN (sN {n} Nn) No =
  (zero ∸ succ₁ n) * o
    ≡⟨ subst (λ t → (zero ∸ succ₁ n) * o ≡ t * o) (∸-0S Nn) refl ⟩
  zero * o
    ≡⟨ *-0x o ⟩
  zero
    ≡⟨ sym (∸-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 ∎

*∸-leftDistributive (sN {m} Nm) (sN {n} Nn) zN =
  (succ₁ m ∸ succ₁ n) * zero
    ≡⟨ *-comm (∸-N (sN Nm) (sN Nn)) zN ⟩
  zero * (succ₁ m ∸ succ₁ n)
    ≡⟨ *-0x (succ₁ m ∸ succ₁ n) ⟩
  zero
    ≡⟨ sym (∸-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 ∎

*∸-leftDistributive (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  (succ₁ m ∸ succ₁ n) * succ₁ o
    ≡⟨ subst (λ t → (succ₁ m ∸ succ₁ n) * succ₁ o ≡ t * succ₁ o)
             (∸-SS Nm Nn)
             refl
    ⟩
  (m ∸ n) * succ₁ o
    ≡⟨ *∸-leftDistributive 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) ∎

*+-leftDistributive : ∀ {m n o} → N m → N n → N o → (m + n) * o ≡ m * o + n * o
*+-leftDistributive {m} {n} Nm Nn zN =
  (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  ∎

*+-leftDistributive {n = n} zN Nn (sN {o} No) =
  (zero + n) * succ₁ o
    ≡⟨ subst (λ t → (zero + n) * succ₁ o ≡ t * succ₁ o)
             (+-leftIdentity n)
             refl
    ⟩
  n * succ₁ o
    ≡⟨ sym (+-leftIdentity (n * succ₁ o)) ⟩
  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 ∎

*+-leftDistributive (sN {m} Nm) zN (sN {o} No) =
  (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 (succ₁ o)))
             refl
    ⟩
    succ₁ m * succ₁ o + zero * succ₁ o ∎

*+-leftDistributive (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  (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)
             (*+-leftDistributive Nm (sN Nn) (sN No))
             refl
    ⟩
  succ₁ o + (m * succ₁ o + succ₁ n * succ₁ o)
    ≡⟨ sym (+-assoc (sN No) (m * succ₁ o) (succ₁ n * succ₁ o)) ⟩
  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
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning
open import Common.Function

open import LTC-PCF.Base
open import LTC-PCF.Base.Properties
open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Rec
open import LTC-PCF.Data.Nat.Rec.EquationsI

------------------------------------------------------------------------------
-- Congruence properties

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong refl = refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong refl = refl

∸-leftCong : ∀ {m n o} → m ≡ n → m ∸ o ≡ n ∸ o
∸-leftCong refl = refl

∸-rightCong : ∀ {m n o} → n ≡ o → m ∸ n ≡ m ∸ o
∸-rightCong refl = refl

*-leftCong : ∀ {m n o} → m ≡ n → m * o ≡ n * o
*-leftCong refl = refl

*-rightCong : ∀ {m n o} → n ≡ o → m * n ≡ m * o
*-rightCong refl = refl

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

+-0x : ∀ n → zero + n ≡ n
+-0x n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

+-Sx : ∀ m n → succ₁ m + n ≡ succ₁ (m + n)
+-Sx m n =
  rec (succ₁ m) n (lam (λ x → lam (λ y → succ₁ y)))
    ≡⟨ rec-S m n (lam (λ x → lam (λ y → succ₁ y))) ⟩
  (lam (λ x → lam (λ y → succ₁ y))) · m · (m + n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → succ₁ y)) m) ⟩
  (λ x → lam (λ y → succ₁ y)) m · (m + n)
    ≡⟨ refl ⟩
  lam succ₁ · (m + n)
    ≡⟨ beta succ₁ (m + n) ⟩
  succ₁ (m + n) ∎

∸-x0 : ∀ n → n ∸ zero ≡ n
∸-x0 n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

∸-0S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
∸-0S zN =
  rec (succ₁ zero) zero (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S zero zero (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · zero · (zero ∸ zero)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) zero) ⟩
  (λ x → lam (λ y → pred₁ y)) zero · (zero ∸ zero)
    ≡⟨ refl ⟩
  lam pred₁ · (zero ∸ zero)
    ≡⟨ beta pred₁ (zero ∸ zero) ⟩
  pred₁ (zero ∸ zero)
    ≡⟨ cong pred₁ (∸-x0 zero) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0S (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) zero (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) zero (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y))  (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ refl ⟩
  lam pred₁ · (zero ∸ (succ₁ n))
    ≡⟨ beta pred₁ (zero ∸ (succ₁ n)) ⟩
  pred₁ (zero ∸ (succ₁ n))
    ≡⟨ cong pred₁ (∸-0S Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

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

∸-SS : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n ≡ m ∸ n
∸-SS {m} _ zN =
  rec (succ₁ zero) (succ₁ m) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S zero (succ₁ m) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y))  · zero · (succ₁ m ∸ zero)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) zero) ⟩
  (λ x → lam (λ y → pred₁ y)) zero · (succ₁ m ∸ zero)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ m ∸ zero)
    ≡⟨ beta pred₁ (succ₁ m ∸ zero) ⟩
  pred₁ (succ₁ m ∸ zero)
    ≡⟨ cong pred₁ (∸-x0 (succ₁ m)) ⟩
  pred₁ (succ₁ m)
    ≡⟨ pred-S m ⟩
  m
    ≡⟨ sym $ ∸-x0 m ⟩
  m ∸ zero ∎

∸-SS zN (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ zero) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) (succ₁ zero) (lam (λ x → lam (λ y → pred₁ y)))  ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y)) (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ zero ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ zero ∸ succ₁ n) ⟩
  pred₁ (succ₁ zero ∸ succ₁ n)
    ≡⟨ cong pred₁ (∸-SS zN Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ cong pred₁ (∸-0x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym $ ∸-0S Nn ⟩
  zero ∸ succ₁ n ∎

∸-SS (sN {m} Nm) (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ (succ₁ m)) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) (succ₁ (succ₁ m)) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y)) (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ (succ₁ m) ∸ succ₁ n) ⟩
  pred₁ (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ cong pred₁ (∸-SS (sN Nm) Nn) ⟩
  pred₁ (succ₁ m ∸ n)
    ≡⟨ sym $ beta pred₁ (succ₁ m ∸ n) ⟩
  lam pred₁ · (succ₁ m ∸ n)
    ≡⟨ refl ⟩
  (λ x → lam (λ y → pred₁ y)) n · (succ₁ m ∸ n)
    ≡⟨ ·-leftCong (sym $ beta (λ x → lam (λ y → pred₁ y)) n) ⟩
  (lam (λ x → lam (λ y → pred₁ y))) · n · (succ₁ m ∸ n)
    ≡⟨ sym $ rec-S n (succ₁ m) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  rec (succ₁ n) (succ₁ m) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ refl ⟩
  succ₁ m ∸ succ₁ n ∎

*-0x : ∀ n → zero * n ≡ zero
*-0x n = rec zero zero (lam (λ _ → lam (λ y → n + y))) ≡⟨ rec-0 zero ⟩
         zero                                          ∎

*-Sx : ∀ m n → succ₁ m * n ≡ n + m * n
*-Sx m n =
  rec (succ₁ m) zero (lam (λ _ → lam (λ y → n + y)))
    ≡⟨ rec-S m zero (lam (λ _ → lam (λ y → n + y))) ⟩
  (lam (λ _ → lam (λ y → n + y))) · m · (m * n)
    ≡⟨ ·-leftCong (beta (λ _ → lam (λ y → n + y)) m) ⟩
  (λ _ → lam (λ y → n + y)) m · (m * n)
    ≡⟨ refl ⟩
  lam (λ y → n + y) · (m * n)
    ≡⟨ beta (λ y → n + y) (m * n) ⟩
  (λ y → n + y) (m * n)
    ≡⟨ refl ⟩
  n + (m * n) ∎

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} zN          Nn = subst N (sym $ +-0x n) Nn
+-N {n = n} (sN {m} Nm) Nn = subst N (sym $ +-Sx m n) (sN (+-N Nm Nn))

∸-N : ∀ {m n} → N m → N n → N (m ∸ n)
∸-N {m} Nm       zN     = subst N (sym $ ∸-x0 m) Nm
∸-N     zN      (sN Nn) = subst N (sym $ ∸-0S Nn) zN
∸-N     (sN Nm) (sN Nn) = subst N (sym $ ∸-SS Nm Nn) (∸-N Nm Nn)

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

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

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

+-assoc (sN {m} Nm) n o =
  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 n o) refl ⟩
  succ₁ (m + (n + o))
    ≡⟨ sym $ +-Sx m (n + o) ⟩
  succ₁ m + (n + o) ∎

x+Sy≡S[x+y] : ∀ {m} → N m → ∀ n → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] zN n =
  zero + succ₁ n ≡⟨ +-0x (succ₁ n) ⟩
  succ₁ n ≡⟨ subst (λ t → succ₁ n ≡ succ₁ t) (sym $ +-leftIdentity n) refl ⟩
  succ₁ (zero + n) ∎

x+Sy≡S[x+y] (sN {m} Nm) n =
  succ₁ m + succ₁ n
    ≡⟨ +-Sx m (succ₁ n) ⟩
  succ₁ (m + succ₁ n)
    ≡⟨ subst (λ t → succ₁ (m + succ₁ n) ≡ succ₁ t) (x+Sy≡S[x+y] Nm n) refl ⟩
  succ₁ (succ₁ (m + n))
    ≡⟨ subst (λ t → succ₁ (succ₁ (m + n)) ≡ succ₁ t) (sym $ +-Sx m n) refl ⟩
  succ₁ (succ₁ m + n) ∎

[x+y]∸[x+z]≡y∸z : ∀ {m n o} → N m → N n → N o → (m + n) ∸ (m + o) ≡ n ∸ o
[x+y]∸[x+z]≡y∸z {n = n} {o} zN _ _ =
  (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 =
  (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)
    ≡⟨ ∸-SS (+-N Nm Nn) (+-N Nm No) ⟩
  (m + n) ∸ (m + o)
    ≡⟨ [x+y]∸[x+z]≡y∸z Nm Nn No ⟩
  n ∸ o ∎

+-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
+-comm {n = n} zN Nn =
  zero + n ≡⟨ +-leftIdentity n ⟩
  n        ≡⟨ sym $ +-rightIdentity Nn ⟩
  n + zero ∎

+-comm {n = n} (sN {m} Nm) Nn =
  succ₁ m + n   ≡⟨ +-Sx m n ⟩
  succ₁ (m + n) ≡⟨ cong succ₁ (+-comm Nm Nn) ⟩
  succ₁ (n + m) ≡⟨ sym $ x+Sy≡S[x+y] Nn m ⟩
  n + succ₁ m   ∎

*-leftZero : ∀ n → zero * n ≡ zero
*-leftZero = *-0x

*-N : ∀ {m n} → N m → N n → N (m * n)
*-N {n = n} zN          _  = subst N (sym $ *-0x n) zN
*-N {n = n} (sN {m} Nm) Nn = subst N (sym $ *-Sx m n) (+-N Nn (*-N Nm Nn))

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

*-leftIdentity : ∀ {n} → N n → succ₁ zero * n ≡ n
*-leftIdentity {n} Nn =
  succ₁ zero * n ≡⟨ *-Sx zero n ⟩
  n + zero * n   ≡⟨ subst (λ t → n + zero * n ≡ n + t) (*-leftZero n) refl ⟩
  n + zero       ≡⟨ +-rightIdentity Nn ⟩
  n              ∎

x*Sy≡x+xy : ∀ {m n} → N m → N n → m * succ₁ n ≡ m + m * n
x*Sy≡x+xy {n = n} zN _ = sym
  ( zero + zero * n
      ≡⟨ subst (λ t → zero + zero * n ≡ zero + t) (*-leftZero n) refl ⟩
    zero + zero
      ≡⟨ +-leftIdentity zero ⟩
    zero
      ≡⟨ sym $ *-leftZero (succ₁ n) ⟩
    zero * succ₁ n ∎
  )

x*Sy≡x+xy {n = n} (sN {m} Nm) Nn =
  succ₁ m * succ₁ n
    ≡⟨ *-Sx m (succ₁ n) ⟩
  succ₁ n + m * succ₁ n
    ≡⟨ subst (λ t → succ₁ n + m * succ₁ n ≡ succ₁ n + t)
             (x*Sy≡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 m (m * n))
             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 n (m * n))
             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} → N m → N n → m * n ≡ n * m
*-comm {n = n} zN Nn          = trans (*-leftZero n) (sym $ *-rightZero Nn)
*-comm {n = n} (sN {m} Nm) Nn =
  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*Sy≡x+xy Nn Nm ⟩
  n * succ₁ m  ∎

*∸-leftDistributive : ∀ {m n o} → N m → N n → N o → (m ∸ n) * o ≡ m * o ∸ n * o
*∸-leftDistributive {m} {o = o} _ zN _ =
  (m ∸ zero) * o   ≡⟨ subst (λ t → (m ∸ zero) * o ≡ t * o) (∸-x0 m) refl ⟩
  m * o            ≡⟨ sym $ ∸-x0 (m * o) ⟩
  m * o ∸ zero     ≡⟨ subst (λ t → m * o ∸ zero ≡ m * o ∸ t) (sym $ *-0x o) refl ⟩
  m * o ∸ zero * o ∎

*∸-leftDistributive {o = o} zN (sN {n} Nn) No =
  (zero ∸ succ₁ n) * o
    ≡⟨ subst (λ t → (zero ∸ succ₁ n) * o ≡ t * o) (∸-0S Nn) refl ⟩
  zero * o
    ≡⟨ *-0x o ⟩
  zero
    ≡⟨ sym $ ∸-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 ∎

*∸-leftDistributive (sN {m} Nm) (sN {n} Nn) zN =
  (succ₁ m ∸ succ₁ n) * zero
    ≡⟨ *-comm (∸-N (sN Nm) (sN Nn)) zN ⟩
  zero * (succ₁ m ∸ succ₁ n)
    ≡⟨ *-0x (succ₁ m ∸ succ₁ n) ⟩
  zero
    ≡⟨ sym $ ∸-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 ∎

*∸-leftDistributive (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  (succ₁ m ∸ succ₁ n) * succ₁ o
    ≡⟨ subst (λ t → (succ₁ m ∸ succ₁ n) * succ₁ o ≡ t * succ₁ o)
             (∸-SS Nm Nn)
             refl
    ⟩
  (m ∸ n) * succ₁ o
    ≡⟨ *∸-leftDistributive 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) ∎

*+-leftDistributive : ∀ {m n o} → N m → N n → N o → (m + n) * o ≡ m * o + n * o
*+-leftDistributive {m} {n} Nm Nn zN =
  (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  ∎

*+-leftDistributive {n = n} zN Nn (sN {o} No) =
  (zero + n) * succ₁ o
    ≡⟨ subst (λ t → (zero + n) * succ₁ o ≡ t * succ₁ o)
             (+-leftIdentity n)
             refl
    ⟩
  n * succ₁ o
    ≡⟨ sym $ +-leftIdentity (n * succ₁ o) ⟩
  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 ∎

*+-leftDistributive (sN {m} Nm) zN (sN {o} No) =
  (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 (succ₁ o))
             refl
    ⟩
    succ₁ m * succ₁ o + zero * succ₁ o ∎

*+-leftDistributive (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  (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)
             (*+-leftDistributive Nm (sN Nn) (sN No))
             refl
    ⟩
  succ₁ o + (m * succ₁ o + succ₁ n * succ₁ o)
    ≡⟨ sym $ +-assoc (sN No) (m * succ₁ o) (succ₁ n * succ₁ o) ⟩
  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 ∎


scraps

scraps

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

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

  -- values and errors are disjoint
  ve : ∀{d Δ} → d val → Δ ⊢ d err → ⊥
  ve VConst ()
  ve VLam ()

  -- values and expressions that step are disjoint
  vs : ∀{d Δ} → d val → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  vs VConst (d , Step (FHFinal x) () (FHFinal x₂))
  vs VConst (_ , Step (FHFinal x) () FHEHole)
  vs VConst (_ , Step (FHFinal x) () FHNEHoleEvaled)
  vs VConst (_ , Step (FHFinal x) () (FHNEHoleFinal x₂))
  vs VConst (_ , Step (FHFinal x) () (FHCastFinal x₂))
  vs VLam (d , Step (FHFinal x₁) () (FHFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () FHEHole)
  vs VLam (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  vs VLam (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () (FHCastFinal x₃))

  -- indeterminates and errors are disjoint
  ie : ∀{d Δ} → d indet → Δ ⊢ d err → ⊥
  ie IEHole ()
  ie (INEHole (FVal x)) (ENEHole e) = ve x e
  ie (INEHole (FIndet x)) (ENEHole e) = ie x e
  ie (IAp i x) (EAp1 e) = ie i e
  ie (IAp i (FVal x)) (EAp2 e) = ve x e
  ie (IAp i (FIndet x)) (EAp2 e) = ie x e

  -- indeterminates and expressions that step are disjoint
  is : ∀{d Δ} → d indet → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  is IEHole (d0' , Step (FHFinal x) () (FHFinal x₁))
  is IEHole (d0' , Step FHEHole () (FHFinal x))
  is IEHole (_ , Step (FHFinal x) () FHEHole)
  is IEHole (_ , Step FHEHole () FHEHole)
  is IEHole (_ , Step (FHFinal x) () FHNEHoleEvaled)
  is IEHole (_ , Step FHEHole () FHNEHoleEvaled)
  is IEHole (_ , Step (FHFinal x) () (FHNEHoleFinal x₁))
  is IEHole (_ , Step FHEHole () (FHNEHoleFinal x))
  is IEHole (_ , Step (FHFinal x) () (FHCastFinal x₁))
  is IEHole (_ , Step FHEHole () (FHCastFinal x))
  is (INEHole x) (d , Step (FHFinal x₁) () (FHFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () FHEHole)
  is (INEHole x) (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHCastFinal x₂))
  is (INEHole x) (d , Step FHNEHoleEvaled () (FHFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHEHole)
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHNEHoleEvaled)
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHNEHoleFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHCastFinal x₁))
  is (IAp i x) (d' , Step p q r) = {!!}

  -- errors and expressions that step are disjoint
  es : ∀{d Δ} → Δ ⊢ d err → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  es (ECastError x x₁) (d' , Step (FHFinal (FVal ())) x₃ x₄)
  es (ECastError x x₁) (d' , Step (FHFinal (FIndet ())) x₃ x₄)
--  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}
  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}

  es (ECastError x x₁) (d' , Step (FHCastFinal (FVal x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (ECastError x x₁) (d' , Step (FHCastFinal (FIndet x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (EAp1 e) (d , Step (FHFinal (FVal x)) x₁ q) = vs x (d , Step (FHFinal (FVal x)) x₁ q)
  es (EAp1 e) (d , Step (FHFinal (FIndet x)) x₁ q) = is x (d , Step (FHFinal (FIndet x)) x₁ q)
  es (EAp1 e) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = {!!}
  es (EAp1 e) (_ , Step (FHAp2 x) x₁ (FHAp2 x₂)) = {!!}
  es (EAp2 e) s = {!!}

  --es (ENEHole e) x = {!e!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step FHNEHoleEvaled x₂ x₃) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleInside x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  -- es (ENEHole e) (d' , Step (FHFinal (FVal ())) x₁ x₂)
  -- es (ENEHole e) (d' , Step (FHFinal (FIndet (INEHole x))) () x₂)
  -- es (ENEHole e) (d' , Step FHNEHoleEvaled () x₂)
  -- es (ENEHole e) (_ , Step (FHNEHoleInside x) x₁ (FHNEHoleInside x₂)) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FVal ())))
  -- es (ENEHole (ECastError x x₁)) (_ , Step (FHNEHoleFinal x₂) (ITNEHole x₃) (FHFinal (FIndet (INEHole x₄)))) = {!x₁!}
  -- es (ENEHole (EAp1 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (EAp2 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ENEHole e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ECastProp e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) FHNEHoleEvaled) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FVal x)) (ITCast x₁ x₂ x₃) x₄) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FIndet x)) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCast x) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCastFinal x) x₁ x₂) = {!!}

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

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

  -- values and errors are disjoint
  ve : ∀{d Δ} → d val → Δ ⊢ d err → ⊥
  ve VConst ()
  ve VLam ()

  -- values and expressions that step are disjoint
  vs : ∀{d Δ} → d val → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  vs VConst (d , Step (FHFinal x) () (FHFinal x₂))
  vs VConst (_ , Step (FHFinal x) () FHEHole)
  vs VConst (_ , Step (FHFinal x) () FHNEHoleEvaled)
  vs VConst (_ , Step (FHFinal x) () (FHNEHoleFinal x₂))
  vs VConst (_ , Step (FHFinal x) () (FHCastFinal x₂))
  vs VLam (d , Step (FHFinal x₁) () (FHFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () FHEHole)
  vs VLam (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  vs VLam (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () (FHCastFinal x₃))

  -- indeterminates and errors are disjoint
  ie : ∀{d Δ} → d indet → Δ ⊢ d err → ⊥
  ie IEHole ()
  ie (INEHole (FVal x)) (ENEHole e) = ve x e
  ie (INEHole (FIndet x)) (ENEHole e) = ie x e
  ie (IAp i x) (EAp1 e) = ie i e
  ie (IAp i (FVal x)) (EAp2 e) = ve x e
  ie (IAp i (FIndet x)) (EAp2 e) = ie x e

  -- indeterminates and expressions that step are disjoint
  is : ∀{d Δ} → d indet → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  is IEHole (d0' , Step (FHFinal x) () (FHFinal x₁))
  is IEHole (d0' , Step FHEHole () (FHFinal x))
  is IEHole (_ , Step (FHFinal x) () FHEHole)
  is IEHole (_ , Step FHEHole () FHEHole)
  is IEHole (_ , Step (FHFinal x) () FHNEHoleEvaled)
  is IEHole (_ , Step FHEHole () FHNEHoleEvaled)
  is IEHole (_ , Step (FHFinal x) () (FHNEHoleFinal x₁))
  is IEHole (_ , Step FHEHole () (FHNEHoleFinal x))
  is IEHole (_ , Step (FHFinal x) () (FHCastFinal x₁))
  is IEHole (_ , Step FHEHole () (FHCastFinal x))
  is (INEHole x) (d , Step (FHFinal x₁) () (FHFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () FHEHole)
  is (INEHole x) (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHCastFinal x₂))
  is (INEHole x) (d , Step FHNEHoleEvaled () (FHFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHEHole)
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHNEHoleEvaled)
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHNEHoleFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHCastFinal x₁))
  is (IAp i x) (d' , Step p q r) = {!p r!}

  -- errors and expressions that step are disjoint
  es : ∀{d Δ} → Δ ⊢ d err → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  es (ECastError x x₁) (d' , Step (FHFinal (FVal ())) x₃ x₄)
  es (ECastError x x₁) (d' , Step (FHFinal (FIndet ())) x₃ x₄)
  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₃!}
  es (ECastError x x₁) (d' , Step (FHCastFinal (FVal x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (ECastError x x₁) (d' , Step (FHCastFinal (FIndet x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (EAp1 e) (d , Step (FHFinal (FVal x)) x₁ q) = vs x (d , Step (FHFinal (FVal x)) x₁ q)
  es (EAp1 e) (d , Step (FHFinal (FIndet x)) x₁ q) = is x (d , Step (FHFinal (FIndet x)) x₁ q)
  es (EAp1 e) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = {!!}
  es (EAp1 e) (_ , Step (FHAp2 x) x₁ (FHAp2 x₂)) = {!!}
  es (EAp2 e) s = {!!}
  es (ENEHole e) s = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FVal x)) (ITCast x₁ x₂ x₃) x₄) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FIndet x)) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCast x) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCastFinal x) x₁ x₂) = {!!}


FunUniverse.Category: layout

FunUniverse.Category: layout

{-# OPTIONS --without-K #-}
open import Level.NP using (_⊔_)
open import Type hiding (★)
open import Function.NP using (Endo)
open import Data.Nat using (ℕ; zero; suc)

module FunUniverse.Category {t ℓ} {T : ★ t} (_`→_ : T → T → ★ ℓ) where

module CompositionNotations
  (_∘_ : ∀ {A B C} → (B `→ C) → (A `→ B) → (A `→ C))
  {A B C} where

  infixr 1 _⁏_
  infixr 1 _>>>_

  _⁏_ : (A `→ B) → (B `→ C) → (A `→ C)
  f ⁏ g = g ∘ f

  _<<<_ : (B `→ C) → (A `→ B) → (A `→ C)
  g <<< f = g ∘ f

  _>>>_ : (A `→ B) → (B `→ C) → (A `→ C)
  f >>> g = f ⁏ g

record Category : ★ (ℓ ⊔ t) where
  constructor _,_

  infixr 9 _∘_
  field
    id : ∀ {A} → A `→ A
    _∘_ : ∀ {A B C} → (B `→ C) → (A `→ B) → (A `→ C)

  private
    `Endo : T → Set ℓ
    `Endo A = A `→ A

  iterate : ∀ {A} → ℕ → Endo (`Endo A)
  iterate zero    _ = id
  iterate (suc n) f = iterate n f ∘ f


Added 91>100→⊥.

Added 91>100→⊥.

Ignore-this: c6c081ad69301a024e7cac361fe06542

darcs-hash:20110211220224-3bd4e-0a3b532bdac6d8621101a096859b8f946e7125dc.gz

------------------------------------------------------------------------------
-- Arithmetic stuff used by the McCarthy 91 function
------------------------------------------------------------------------------

module Draft.McCarthy91.ArithmeticATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.IsN-ATP

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

postulate
  1+x-N  : ∀ {n} → N n → N (one + n)
  11+x-N : ∀ {n} → N n → N (eleven + n)
  x∸10-N : ∀ {n} → N n → N (n ∸ ten)
  x+11-N : ∀ {n} → N n → N (n + eleven)
{-# ATP prove 1+x-N #-}
{-# ATP prove 11+x-N #-}
{-# ATP prove x∸10-N ∸-N N10 #-}
{-# ATP prove x+11-N 11+x-N +-comm #-}

postulate
  n111' : eleven + one-hundred ≡ hundred-eleven
  n111  : one-hundred + eleven ≡ hundred-eleven
  n101' : hundred-eleven ∸ ten ≡ hundred-one
  n101  : (one-hundred + eleven) ∸ ten ≡ hundred-one
  n91'  : hundred-one ∸ ten ≡ ninety-one
  n91   : ((one-hundred + eleven) ∸ ten) ∸ ten ≡ ninety-one
  n102' : eleven + ninety-one ≡ hundred-two
  n102  : ninety-one + eleven ≡ hundred-two
  n100' : eleven + eighty-nine ≡ one-hundred
  n100  : eighty-nine + eleven ≡ one-hundred
{-# ATP prove n111' #-}
{-# ATP prove n111 +-comm n111' #-}
{-# ATP prove n101' #-}
{-# ATP prove n101 n111 n101' #-}
{-# ATP prove n91' #-}
{-# ATP prove n91 n101 n91' #-}
{-# ATP prove n102' #-}
{-# ATP prove n102 n102' +-comm #-}
{-# ATP prove n100' #-}
{-# ATP prove n100 n100' +-comm #-}

postulate
  101>100' : GT hundred-one one-hundred
  101>100  : GT ((one-hundred + eleven) ∸ ten) one-hundred
  111>100' : GT hundred-eleven one-hundred
  111>100  : GT (one-hundred + eleven) one-hundred
  100<102' : LT one-hundred hundred-two
  100<102  : LT one-hundred (ninety-one + eleven)
{-# ATP prove 101>100' #-}
{-# ATP prove 101>100 101>100' n101 #-}
{-# ATP prove 111>100' #-}
{-# ATP prove 111>100 111>100' n111 #-}
{-# ATP prove 100<102' #-}
{-# ATP prove 100<102 100<102' n102 #-}

postulate 91>100→⊥ : GT ninety-one one-hundred → ⊥
{-# ATP prove 91>100→⊥ #-}


Added n100' and n100.

Added n100' and n100.

Ignore-this: e44aad0771a0721e01719e3a2fdca522

darcs-hash:20110211215613-3bd4e-212ecd0be383d9a032cc44bf046374145d6cc141.gz

------------------------------------------------------------------------------
-- Arithmetic stuff used by the McCarthy 91 function
------------------------------------------------------------------------------

module Draft.McCarthy91.ArithmeticATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.IsN-ATP

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

postulate
  1+x-N  : ∀ {n} → N n → N (one + n)
  11+x-N : ∀ {n} → N n → N (eleven + n)
  x∸10-N : ∀ {n} → N n → N (n ∸ ten)
  x+11-N : ∀ {n} → N n → N (n + eleven)
{-# ATP prove 1+x-N #-}
{-# ATP prove 11+x-N #-}
{-# ATP prove x∸10-N ∸-N N10 #-}
{-# ATP prove x+11-N 11+x-N +-comm #-}

postulate
  n111' : eleven + one-hundred ≡ hundred-eleven
  n111  : one-hundred + eleven ≡ hundred-eleven
  n101' : hundred-eleven ∸ ten ≡ hundred-one
  n101  : (one-hundred + eleven) ∸ ten ≡ hundred-one
  n91'  : hundred-one ∸ ten ≡ ninety-one
  n91   : ((one-hundred + eleven) ∸ ten) ∸ ten ≡ ninety-one
  n102' : eleven + ninety-one ≡ hundred-two
  n102  : ninety-one + eleven ≡ hundred-two
  n100' : eleven + eighty-nine ≡ one-hundred
  n100  : eighty-nine + eleven ≡ one-hundred
{-# ATP prove n111' #-}
{-# ATP prove n111 +-comm n111' #-}
{-# ATP prove n101' #-}
{-# ATP prove n101 n111 n101' #-}
{-# ATP prove n91' #-}
{-# ATP prove n91 n101 n91' #-}
{-# ATP prove n102' #-}
{-# ATP prove n102 n102' +-comm #-}
{-# ATP prove n100' #-}
{-# ATP prove n100 n100' +-comm #-}

postulate
  101>100' : GT hundred-one one-hundred
  101>100  : GT ((one-hundred + eleven) ∸ ten) one-hundred
  111>100' : GT hundred-eleven one-hundred
  111>100  : GT (one-hundred + eleven) one-hundred
  100<102' : LT one-hundred hundred-two
  100<102  : LT one-hundred (ninety-one + eleven)
{-# ATP prove 101>100' #-}
{-# ATP prove 101>100 101>100' n101 #-}
{-# ATP prove 111>100' #-}
{-# ATP prove 111>100 111>100' n111 #-}
{-# ATP prove 100<102' #-}
{-# ATP prove 100<102 100<102' n102 #-}

------------------------------------------------------------------------------
-- Arithmetic stuff used by the McCarthy 91 function
------------------------------------------------------------------------------

module Draft.McCarthy91.ArithmeticATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.IsN-ATP

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

postulate
  1+x-N  : ∀ {n} → N n → N (one + n)
  11+x-N : ∀ {n} → N n → N (eleven + n)
  x∸10-N : ∀ {n} → N n → N (n ∸ ten)
  x+11-N : ∀ {n} → N n → N (n + eleven)
{-# ATP prove 1+x-N #-}
{-# ATP prove 11+x-N #-}
{-# ATP prove x∸10-N ∸-N N10 #-}
{-# ATP prove x+11-N 11+x-N +-comm #-}

postulate
  n111' : eleven + one-hundred ≡ hundred-eleven
  n111  : one-hundred + eleven ≡ hundred-eleven
  n101' : hundred-eleven ∸ ten ≡ hundred-one
  n101  : (one-hundred + eleven) ∸ ten ≡ hundred-one
  n91'  : hundred-one ∸ ten ≡ ninety-one
  n91   : ((one-hundred + eleven) ∸ ten) ∸ ten ≡ ninety-one
  n102' : eleven + ninety-one ≡ hundred-two
  n102  : ninety-one + eleven ≡ hundred-two
{-# ATP prove n111' #-}
{-# ATP prove n111 +-comm n111' #-}
{-# ATP prove n101' #-}
{-# ATP prove n101 n111 n101' #-}
{-# ATP prove n91' #-}
{-# ATP prove n91 n101 n91' #-}
{-# ATP prove n102' #-}
{-# ATP prove n102 n102' +-comm #-}

postulate
  101>100' : GT hundred-one one-hundred
  101>100  : GT ((one-hundred + eleven) ∸ ten) one-hundred
  111>100' : GT hundred-eleven one-hundred
  111>100  : GT (one-hundred + eleven) one-hundred
  100<102' : LT one-hundred hundred-two
  100<102  : LT one-hundred (ninety-one + eleven)
{-# ATP prove 101>100' #-}
{-# ATP prove 101>100 101>100' n101 #-}
{-# ATP prove 111>100' #-}
{-# ATP prove 111>100 111>100' n111 #-}
{-# ATP prove 100<102' #-}
{-# ATP prove 100<102 100<102' n102 #-}


Clarify

Clarify

module New.Correctness where

open import New.Lang
open import New.Changes
open import New.Derive
open import New.LangChanges
open import New.LangOps

-- Lemmas
alternate : ∀ {Γ} → ⟦ Γ ⟧Context → eCh Γ → ⟦ ΔΓ Γ ⟧Context
alternate {∅} ∅ ∅ = ∅
alternate {τ • Γ} (v • ρ) (dv • dρ) = dv • v • alternate ρ dρ

⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  ρ ≡ ⟦ Γ≼ΔΓ ⟧≼ (alternate ρ dρ)
⟦Γ≼ΔΓ⟧ ∅ ∅ = refl
⟦Γ≼ΔΓ⟧ (v • ρ) (dv • dρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ dρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  ⟦ t ⟧Term ρ ≡ ⟦ fit t ⟧Term (alternate ρ dρ)
fit-sound t ρ dρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ ρ dρ))
  (sym (weaken-sound t _))

-- The change semantics is just the semantics composed with derivation!
⟦_⟧ΔVar : ∀ {Γ τ} → (t : Var Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → Cht τ
⟦ x ⟧ΔVar ρ dρ = ⟦ deriveVar x ⟧Var (alternate ρ dρ)

⟦_⟧ΔTerm : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → Cht τ
⟦ t ⟧ΔTerm ρ dρ = ⟦ derive t ⟧Term (alternate ρ dρ)

-- XXX Should try to simply relate the semantics to the nil change, and prove
-- that validity can be carried over, instead of proving separately validity and
-- correctness; elsewhere this does make things simpler.

validDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  validΓ ρ dρ → valid (⟦ x ⟧Var ρ) (⟦ x ⟧ΔVar ρ dρ)

validDeriveVar this (v • ρ) (dv • dρ) (vdv , ρdρ) = vdv
validDeriveVar (that x) (v • ρ) (dv • dρ) (vdv , ρdρ) = validDeriveVar x ρ dρ ρdρ

correctDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  IsDerivative ⟦ x ⟧Var (⟦ x ⟧ΔVar)
correctDeriveVar this (v • ρ) (dv • dρ) ρdρ = refl
correctDeriveVar (that x) (v • ρ) (dv • dρ) (vdv , ρdρ) = correctDeriveVar x ρ dρ ρdρ

validDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
    valid (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
correctDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  IsDerivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm

⟦_⟧ΔConst : ∀ {τ} (c : Const τ) → Cht τ
⟦ c ⟧ΔConst = ⟦ deriveConst c ⟧Term ∅

⟦_⟧ΔConst-rewrite : ∀ {τ Γ} (c : Const τ) (ρ : ⟦ Γ ⟧Context) dρ → ⟦_⟧ΔTerm (const c) ρ dρ ≡ ⟦ c ⟧ΔConst
⟦ c ⟧ΔConst-rewrite ρ dρ rewrite weaken-sound {Γ₁≼Γ₂ = ∅≼Γ} (deriveConst c) (alternate ρ dρ) | ⟦∅≼Γ⟧-∅ (alternate ρ dρ) = refl

module _ {t1 t2 t3 : Type}
  (f : ⟦ t1 ⟧Type → ⟦ t3 ⟧Type)
  (df : Cht (t1 ⇒ t3))
  (g : ⟦ t2 ⟧Type → ⟦ t3 ⟧Type)
  (dg : Cht (t2 ⇒ t3))
  where
  private
    Γ = sum t1 t2 •
      (t2 ⇒ Δt t2 ⇒ Δt t3) •
      (t2 ⇒ t3) •
      (t1 ⇒ Δt t1 ⇒ Δt t3) •
      (t1 ⇒ t3) •
      sum (sum (Δt t1) (Δt t2)) (sum t1 t2) •
      sum t1 t2 • ∅
  module _ where
    private
      Γ′ = t2 • (t2 ⇒ Δt t2 ⇒ Δt t3) • (t2 ⇒ t3) • Γ
      Γ′′ = t2 • Γ′
    changeMatchSem-lem1 :
      ∀ a1 b2 →
        ⟦ match ⟧ΔConst (inj₁ a1) (inj₂ (inj₂ b2)) f df g dg
      ≡
        g b2 ⊕ dg b2 (nil b2) ⊝ f a1
    changeMatchSem-lem1 a1 b2 rewrite ominusτ-equiv-ext t2 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl
  module _ where
    private
      Γ′ = t1 • (t1 ⇒ Δt t1 ⇒ Δt t3) • (t1 ⇒ t3) • Γ
      Γ′′ = t1 • Γ′
    changeMatchSem-lem2 :
      ∀ b1 a2 →
        ⟦ match ⟧ΔConst (inj₂ b1) (inj₂ (inj₁ a2)) f df g dg
      ≡
        f a2 ⊕ df a2 (nil a2) ⊝ g b1
    changeMatchSem-lem2 b1 a2 rewrite ominusτ-equiv-ext t1 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl

validDeriveConst : ∀ {τ} (c : Const τ) → valid ⟦ c ⟧Const (⟦_⟧ΔConst c)
correctDeriveConst : ∀ {τ} (c : Const τ) → ⟦ c ⟧Const ≡ ⟦ c ⟧Const ⊕ (⟦_⟧ΔConst c)
correctDeriveConst plus = ext (λ m → ext (lemma m))
  where
    lemma : ∀ m n → m + n ≡ m + n + (m + - m + (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m + n) = refl

correctDeriveConst minus = ext (λ m → ext (λ n → lemma m n))
  where
    lemma : ∀ m n → m - n ≡ m - n + (m + - m - (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m - n) = refl
correctDeriveConst cons = ext (λ v1 → ext (λ v2 → sym (update-nil (v1 , v2))))
correctDeriveConst fst = ext (λ vp → sym (update-nil (proj₁ vp)))
correctDeriveConst snd = ext (λ vp → sym (update-nil (proj₂ vp)))
correctDeriveConst linj = ext (λ va → sym (cong inj₁ (update-nil va)))
correctDeriveConst rinj = ext (λ vb → sym (cong inj₂ (update-nil vb)))
correctDeriveConst (match {t1} {t2} {t3}) = ext³ lemma
  where
    lemma : ∀ s f g →
      ⟦ match {t1} {t2} {t3} ⟧Const s f g ≡
      (⟦ match ⟧Const ⊕ ⟦ match ⟧ΔConst) s f g
    lemma (inj₁ x) f g rewrite update-nil x | update-nil (f x) = refl
    lemma (inj₂ y) f g rewrite update-nil y | update-nil (g y) = refl

open import New.Equivalence
validDeriveConst {τ = t1 ⇒ t2 ⇒ pair .t1 .t2} cons = binary-valid (λ a da ada b db bdb → (ada , bdb)) dcons-eq
  where
    open BinaryValid ⟦ cons {t1} {t2} ⟧Const (⟦ cons ⟧ΔConst)
    dcons-eq : binary-valid-eq-hp
    dcons-eq a da ada b db bdb rewrite update-nil (a ⊕ da) | update-nil (b ⊕ db) = refl
validDeriveConst fst (a , b) (da , db) (ada , bdb) = ada , update-nil (a ⊕ da)
validDeriveConst snd (a , b) (da , db) (ada , bdb) = bdb , update-nil (b ⊕ db)

validDeriveConst plus = binary-valid (λ a da ada b db bdb → tt) dplus-eq
  where
    open BinaryValid ⟦ plus ⟧Const (⟦ plus ⟧ΔConst)
    dplus-eq : binary-valid-eq-hp
    dplus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da + (b + db)) = mn·pq=mp·nq {a} {da} {b} {db}
validDeriveConst minus = binary-valid (λ a da ada b db bdb → tt) dminus-eq
  where
    open BinaryValid ⟦ minus ⟧Const (⟦ minus ⟧ΔConst)
    dminus-eq : binary-valid-eq-hp
    dminus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da - (b + db)) | sym (-m·-n=-mn {b} {db}) = mn·pq=mp·nq {a} {da} { - b} { - db}
validDeriveConst linj a da ada = sv₁ a da ada , cong inj₁ (update-nil (a ⊕ da))
validDeriveConst rinj b db bdb = sv₂ b db bdb , cong inj₂ (update-nil (b ⊕ db))
validDeriveConst (match {t1} {t2} {t3}) =
  ternary-valid dmatch-valid dmatch-eq
  where
    open TernaryValid {{chAlgt (sum t1 t2)}} {{chAlgt (t1 ⇒ t3)}} {{chAlgt (t2 ⇒ t3)}} {{chAlgt t3}} ⟦ match ⟧Const (⟦ match ⟧ΔConst)

    dmatch-valid : ternary-valid-preserve-hp
    dmatch-valid .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg = proj₁ (fdf a da ada)
    dmatch-valid .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg = proj₁ (gdg b db bdb)
    dmatch-valid .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
      rewrite changeMatchSem-lem1 f df g dg a1 b2
      = ⊝-valid (f a1) (g b2 ⊕ dg b2 (nil b2))
    dmatch-valid .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
      rewrite changeMatchSem-lem2 f df g dg b1 a2
      = ⊝-valid (g b1) (f a2 ⊕ df a2 (nil a2))
    dmatch-eq : ternary-valid-eq-hp
    dmatch-eq .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg
      rewrite update-nil (a ⊕ da)
      | update-nil (f (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))) = proj₂ (fdf a da ada)
    dmatch-eq .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg
      rewrite update-nil (b ⊕ db)
      | update-nil (g (b ⊕ db) ⊕ dg (b ⊕ db) (nil (b ⊕ db))) = proj₂ (gdg b db bdb)
    dmatch-eq .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
      rewrite changeMatchSem-lem1 f df g dg a1 b2
      | update-nil b2
      | update-diff (g b2 ⊕ dg b2 (nil b2)) (f a1)
      | update-nil (g b2 ⊕ dg b2 (nil b2))
      = refl
    dmatch-eq .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
      rewrite changeMatchSem-lem2 f df g dg b1 a2
      | update-nil a2
      | update-diff (f a2 ⊕ df a2 (nil a2)) (g b1)
      | update-nil (f a2 ⊕ df a2 (nil a2))
      = refl

correctDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = correctDeriveConst c
correctDerive (var x) ρ dρ ρdρ = correctDeriveVar x ρ dρ ρdρ
correctDerive (app s t) ρ dρ ρdρ rewrite sym (fit-sound t ρ dρ) =
  let
    open ≡-Reasoning
    a0 = ⟦ t ⟧Term ρ
    da0 = ⟦ derive t ⟧Term (alternate ρ dρ)
    a0da0 = validDerive t ρ dρ ρdρ
  in
    begin
      ⟦ s ⟧Term (ρ ⊕ dρ) (⟦ t ⟧Term (ρ ⊕ dρ))
    ≡⟨ correctDerive s ρ dρ ρdρ ⟨$⟩ correctDerive t ρ dρ ρdρ ⟩
      (⟦ s ⟧Term ρ ⊕ ⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ ⊕ ⟦ t ⟧ΔTerm ρ dρ)
    ≡⟨ proj₂ (validDerive s ρ dρ ρdρ a0 da0 a0da0)  ⟩
      ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ) ⊕ (⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
    ∎
  where
    open import Theorem.CongApp
correctDerive (abs t) ρ dρ ρdρ = ext (λ a →
  let
    open ≡-Reasoning
    ρ1 = a • ρ
    dρ1 = nil a • dρ
    ρ1dρ1 : valid ρ1 dρ1
    ρ1dρ1 = nil-valid a , ρdρ
  in
    begin
      ⟦ t ⟧Term (a • ρ ⊕ dρ)
    ≡⟨ cong (λ a′ → ⟦ t ⟧Term (a′ • ρ ⊕ dρ)) (sym (update-nil a)) ⟩
      ⟦ t ⟧Term (ρ1 ⊕ dρ1)
    ≡⟨ correctDerive t ρ1 dρ1 ρ1dρ1 ⟩
      ⟦ t ⟧Term ρ1 ⊕ ⟦ t ⟧ΔTerm ρ1 dρ1
    ∎)

validDerive (app s t) ρ dρ ρdρ =
  let
    f = ⟦ s ⟧Term ρ
    df = ⟦ derive s ⟧Term (alternate ρ dρ)
    v = ⟦ t ⟧Term ρ
    dv = ⟦ derive t ⟧Term (alternate ρ dρ)
    vdv = validDerive t ρ dρ ρdρ
    fdf = validDerive s ρ dρ ρdρ
    fvdfv = proj₁ (fdf v dv vdv)
  in subst (λ v′ → valid (f v) (df v′ dv)) (fit-sound t ρ dρ) fvdfv
validDerive (abs t) ρ dρ ρdρ =
  λ a da ada →
  let
    ρ1 = a ⊕ da • ρ
    dρ1 = nil (a ⊕ da) • dρ
    ρ2 = a • ρ
    dρ2 = da • dρ
    ρ1dρ1 : valid ρ1 dρ1
    ρ1dρ1 = nil-valid (a ⊕ da) , ρdρ
    ρ2dρ2 : valid ρ2 dρ2
    ρ2dρ2 = ada , ρdρ
    fv = ⟦ t ⟧Term ρ2
    dfvdv = ⟦ t ⟧ΔTerm ρ2 dρ2
    rdr = validDerive t ρ2 dρ2 ρ2dρ2
    open ≡-Reasoning
   in
     rdr ,
     (begin
       ⟦ t ⟧Term ρ1 ⊕ ⟦ t ⟧ΔTerm ρ1 dρ1
      ≡⟨ sym ( correctDerive t ρ1 dρ1 ρ1dρ1) ⟩
       ⟦ t ⟧Term (ρ1 ⊕ dρ1)
      ≡⟨⟩
       ⟦ t ⟧Term (a ⊕ da ⊕ (nil (a ⊕ da)) • ρ ⊕ dρ)
      ≡⟨ cong (λ a′ → ⟦ t ⟧Term (a′ • ρ ⊕ dρ)) (update-nil (a ⊕ da)) ⟩
       ⟦ t ⟧Term (a ⊕ da • ρ ⊕ dρ)
      ≡⟨ correctDerive t ρ2 dρ2 ρ2dρ2 ⟩
        ⟦ t ⟧Term ρ2 ⊕ ⟦ t ⟧ΔTerm ρ2 dρ2
      ∎)
validDerive (var x) ρ dρ ρdρ = validDeriveVar x ρ dρ ρdρ
validDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = validDeriveConst c

module New.Correctness where

open import New.Lang
open import New.Changes
open import New.Derive
open import New.LangChanges
open import New.LangOps

-- Lemmas
alternate : ∀ {Γ} → ⟦ Γ ⟧Context → eCh Γ → ⟦ ΔΓ Γ ⟧Context
alternate {∅} ∅ ∅ = ∅
alternate {τ • Γ} (v • ρ) (dv • dρ) = dv • v • alternate ρ dρ

⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  ρ ≡ ⟦ Γ≼ΔΓ ⟧≼ (alternate ρ dρ)
⟦Γ≼ΔΓ⟧ ∅ ∅ = refl
⟦Γ≼ΔΓ⟧ (v • ρ) (dv • dρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ dρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  ⟦ t ⟧Term ρ ≡ ⟦ fit t ⟧Term (alternate ρ dρ)
fit-sound t ρ dρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ ρ dρ))
  (sym (weaken-sound t _))

-- The change semantics is just the semantics composed with derivation!
⟦_⟧ΔVar : ∀ {Γ τ} → (t : Var Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → Cht τ
⟦ x ⟧ΔVar ρ dρ = ⟦ deriveVar x ⟧Var (alternate ρ dρ)

⟦_⟧ΔTerm : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → Cht τ
⟦ t ⟧ΔTerm ρ dρ = ⟦ derive t ⟧Term (alternate ρ dρ)

-- XXX Should try to simply relate the semantics to the nil change, and prove
-- that validity can be carried over, instead of proving separately validity and
-- correctness; elsewhere this does make things simpler.

validDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  validΓ ρ dρ → valid (⟦ x ⟧Var ρ) (⟦ x ⟧ΔVar ρ dρ)

validDeriveVar this (v • ρ) (dv • dρ) (vdv , ρdρ) = vdv
validDeriveVar (that x) (v • ρ) (dv • dρ) (vdv , ρdρ) = validDeriveVar x ρ dρ ρdρ

correctDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  IsDerivative ⟦ x ⟧Var (⟦ x ⟧ΔVar)
correctDeriveVar this (v • ρ) (dv • dρ) ρdρ = refl
correctDeriveVar (that x) (v • ρ) (dv • dρ) (vdv , ρdρ) = correctDeriveVar x ρ dρ ρdρ

validDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
    valid (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
correctDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  IsDerivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm

⟦_⟧ΔConst : ∀ {τ} (c : Const τ) → Cht τ
⟦ c ⟧ΔConst = ⟦ deriveConst c ⟧Term ∅

⟦_⟧ΔConst-rewrite : ∀ {τ Γ} (c : Const τ) (ρ : ⟦ Γ ⟧Context) dρ → ⟦_⟧ΔTerm (const c) ρ dρ ≡ ⟦ c ⟧ΔConst
⟦ c ⟧ΔConst-rewrite ρ dρ rewrite weaken-sound {Γ₁≼Γ₂ = ∅≼Γ} (deriveConst c) (alternate ρ dρ) | ⟦∅≼Γ⟧-∅ (alternate ρ dρ) = refl

module _ {t1 t2 t3 : Type}
  (f : ⟦ t1 ⟧Type → ⟦ t3 ⟧Type)
  (df : Cht (t1 ⇒ t3))
  (g : ⟦ t2 ⟧Type → ⟦ t3 ⟧Type)
  (dg : Cht (t2 ⇒ t3))
  where
  private
    Γ = sum t1 t2 •
      (t2 ⇒ Δt t2 ⇒ Δt t3) •
      (t2 ⇒ t3) •
      (t1 ⇒ Δt t1 ⇒ Δt t3) •
      (t1 ⇒ t3) •
      sum (sum (Δt t1) (Δt t2)) (sum t1 t2) •
      sum t1 t2 • ∅
  module _ where
    private
      Γ′ = t2 • (t2 ⇒ Δt t2 ⇒ Δt t3) • (t2 ⇒ t3) • Γ
      Γ′′ = t2 • Γ′
    changeMatchSem-lem1 :
      ∀ a1 b2 →
        ⟦ match ⟧ΔConst (inj₁ a1) (inj₂ (inj₂ b2)) f df g dg
      ≡
        g b2 ⊕ dg b2 (nil b2) ⊝ f a1
    changeMatchSem-lem1 a1 b2 rewrite ominusτ-equiv-ext t2 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl
  module _ where
    private
      Γ′ = t1 • (t1 ⇒ Δt t1 ⇒ Δt t3) • (t1 ⇒ t3) • Γ
      Γ′′ = t1 • Γ′
    changeMatchSem-lem2 :
      ∀ b1 a2 →
        ⟦ match ⟧ΔConst (inj₂ b1) (inj₂ (inj₁ a2)) f df g dg
      ≡
        f a2 ⊕ df a2 (nil a2) ⊝ g b1
    changeMatchSem-lem2 b1 a2 rewrite ominusτ-equiv-ext t1 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl

validDeriveConst : ∀ {τ} (c : Const τ) → valid ⟦ c ⟧Const (⟦_⟧ΔConst c)
correctDeriveConst : ∀ {τ} (c : Const τ) → ⟦ c ⟧Const ≡ ⟦ c ⟧Const ⊕ (⟦_⟧ΔConst c)
correctDeriveConst plus = ext (λ m → ext (lemma m))
  where
    lemma : ∀ m n → m + n ≡ m + n + (m + - m + (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m + n) = refl

correctDeriveConst minus = ext (λ m → ext (λ n → lemma m n))
  where
    lemma : ∀ m n → m - n ≡ m - n + (m + - m - (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m - n) = refl
correctDeriveConst cons = ext (λ v1 → ext (λ v2 → sym (update-nil (v1 , v2))))
correctDeriveConst fst = ext (λ vp → sym (update-nil (proj₁ vp)))
correctDeriveConst snd = ext (λ vp → sym (update-nil (proj₂ vp)))
correctDeriveConst linj = ext (λ va → sym (cong inj₁ (update-nil va)))
correctDeriveConst rinj = ext (λ vb → sym (cong inj₂ (update-nil vb)))
correctDeriveConst (match {t1} {t2} {t3}) = ext³ lemma
  where
    lemma : ∀ s f g →
      ⟦ match {t1} {t2} {t3} ⟧Const s f g ≡
      (⟦ match ⟧Const ⊕ ⟦ match ⟧ΔConst) s f g
    lemma (inj₁ x) f g rewrite update-nil x | update-nil (f x) = refl
    lemma (inj₂ y) f g rewrite update-nil y | update-nil (g y) = refl

open import New.Equivalence
validDeriveConst {τ = t1 ⇒ t2 ⇒ pair .t1 .t2} cons = binary-valid (λ a da ada b db bdb → (ada , bdb)) dcons-eq
  where
    open BinaryValid ⟦ cons {t1} {t2} ⟧Const (⟦ cons ⟧ΔConst)
    dcons-eq : binary-valid-eq-hp
    dcons-eq a da ada b db bdb rewrite update-nil (a ⊕ da) | update-nil (b ⊕ db) = refl
validDeriveConst fst (a , b) (da , db) (ada , bdb) = ada , update-nil (a ⊕ da)
validDeriveConst snd (a , b) (da , db) (ada , bdb) = bdb , update-nil (b ⊕ db)

validDeriveConst plus = binary-valid (λ a da ada b db bdb → tt) dplus-eq
  where
    open BinaryValid ⟦ plus ⟧Const (⟦ plus ⟧ΔConst)
    dplus-eq : binary-valid-eq-hp
    dplus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da + (b + db)) = mn·pq=mp·nq {a} {da} {b} {db}
validDeriveConst minus = binary-valid (λ a da ada b db bdb → tt) dminus-eq
  where
    open BinaryValid ⟦ minus ⟧Const (⟦ minus ⟧ΔConst)
    dminus-eq : binary-valid-eq-hp
    dminus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da - (b + db)) | sym (-m·-n=-mn {b} {db}) = mn·pq=mp·nq {a} {da} { - b} { - db}
validDeriveConst linj a da ada = sv₁ a da ada , cong inj₁ (update-nil (a ⊕ da))
validDeriveConst rinj b db bdb = sv₂ b db bdb , cong inj₂ (update-nil (b ⊕ db))
validDeriveConst (match {t1} {t2} {t3}) =
  ternary-valid dmatch-valid dmatch-eq
  where
    open TernaryValid {{chAlgt (sum t1 t2)}} {{chAlgt (t1 ⇒ t3)}} {{chAlgt (t2 ⇒ t3)}} {{chAlgt t3}} ⟦ match ⟧Const (⟦ match ⟧ΔConst)

    dmatch-valid : ternary-valid-preserve-hp
    dmatch-valid .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg = proj₁ (fdf a da ada)
    dmatch-valid .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg = proj₁ (gdg b db bdb)
    dmatch-valid .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
      rewrite changeMatchSem-lem1 f df g dg a1 b2
      = ⊝-valid (f a1) (g b2 ⊕ dg b2 (nil b2))
    dmatch-valid .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
      rewrite changeMatchSem-lem2 f df g dg b1 a2
      = ⊝-valid (g b1) (f a2 ⊕ df a2 (nil a2))
    dmatch-eq : ternary-valid-eq-hp
    dmatch-eq .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg
      rewrite update-nil (a ⊕ da)
      | update-nil (f (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))) = proj₂ (fdf a da ada)
    dmatch-eq .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg
      rewrite update-nil (b ⊕ db)
      | update-nil (g (b ⊕ db) ⊕ dg (b ⊕ db) (nil (b ⊕ db))) = proj₂ (gdg b db bdb)
    dmatch-eq .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
      rewrite changeMatchSem-lem1 f df g dg a1 b2
      | update-nil b2
      | update-diff (g b2 ⊕ dg b2 (nil b2)) (f a1)
      | update-nil (g b2 ⊕ dg b2 (nil b2))
      = refl
    dmatch-eq .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
      rewrite changeMatchSem-lem2 f df g dg b1 a2
      | update-nil a2
      | update-diff (f a2 ⊕ df a2 (nil a2)) (g b1)
      | update-nil (f a2 ⊕ df a2 (nil a2))
      = refl

correctDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = correctDeriveConst c
correctDerive (var x) ρ dρ ρdρ = correctDeriveVar x ρ dρ ρdρ
correctDerive (app s t) ρ dρ ρdρ rewrite sym (fit-sound t ρ dρ) =
  let
    open ≡-Reasoning
    a0 = ⟦ t ⟧Term ρ
    da0 = ⟦ derive t ⟧Term (alternate ρ dρ)
    a0da0 = validDerive t ρ dρ ρdρ
  in
    begin
      ⟦ s ⟧Term (ρ ⊕ dρ) (⟦ t ⟧Term (ρ ⊕ dρ))
    ≡⟨ correctDerive s ρ dρ ρdρ ⟨$⟩ correctDerive t ρ dρ ρdρ ⟩
      (⟦ s ⟧Term ρ ⊕ ⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ ⊕ ⟦ t ⟧ΔTerm ρ dρ)
    ≡⟨ proj₂ (validDerive s ρ dρ ρdρ a0 da0 a0da0)  ⟩
      ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ) ⊕ (⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
    ∎
  where
    open import Theorem.CongApp
correctDerive (abs t) ρ dρ ρdρ = ext (λ a →
  let
    open ≡-Reasoning
    ρ1 = a • ρ
    dρ1 = nil a • dρ
    ρ1dρ1 : valid ρ1 dρ1
    ρ1dρ1 = nil-valid a , ρdρ
  in
    begin
      ⟦ t ⟧Term (a • ρ ⊕ dρ)
    ≡⟨ cong (λ a′ → ⟦ t ⟧Term (a′ • ρ ⊕ dρ)) (sym (update-nil a)) ⟩
      ⟦ t ⟧Term (ρ1 ⊕ dρ1)
    ≡⟨ correctDerive t ρ1 dρ1 ρ1dρ1 ⟩
      ⟦ t ⟧Term ρ1 ⊕ ⟦ t ⟧ΔTerm ρ1 dρ1
    ∎)

validDerive (app s t) ρ dρ ρdρ =
  let
    f = ⟦ s ⟧Term ρ
    df = ⟦ derive s ⟧Term (alternate ρ dρ)
    v = ⟦ t ⟧Term ρ
    dv = ⟦ derive t ⟧Term (alternate ρ dρ)
    vdv = validDerive t ρ dρ ρdρ
    fdf = validDerive s ρ dρ ρdρ
    fvdfv = proj₁ (fdf v dv vdv)
  in subst (λ v′ → valid (f v) (df v′ dv)) (fit-sound t ρ dρ) fvdfv
validDerive (abs t) ρ dρ ρdρ =
  λ a da ada →
  let
    fv = ⟦ t ⟧Term (a • ρ)
    dfvdv = ⟦ derive t ⟧Term (da • a • alternate ρ dρ)
    rdr = validDerive t (a • ρ) (da • dρ) (ada , ρdρ)
    ρ1 = a ⊕ da • ρ
    dρ1 = nil (a ⊕ da) • dρ
    ρ2 = a • ρ
    dρ2 = da • dρ
    ρ1dρ1 : valid ρ1 dρ1
    ρ1dρ1 = nil-valid (a ⊕ da) , ρdρ
    ρ2dρ2 : valid ρ2 dρ2
    ρ2dρ2 = ada , ρdρ
    open ≡-Reasoning
   in
     rdr ,
     (begin
       ⟦ t ⟧Term ρ1 ⊕ ⟦ t ⟧ΔTerm ρ1 dρ1
      ≡⟨ sym ( correctDerive t ρ1 dρ1 ρ1dρ1) ⟩
       ⟦ t ⟧Term (ρ1 ⊕ dρ1)
      ≡⟨⟩
       ⟦ t ⟧Term (a ⊕ da ⊕ (nil (a ⊕ da)) • ρ ⊕ dρ)
      ≡⟨ cong (λ a′ → ⟦ t ⟧Term (a′ • ρ ⊕ dρ)) (update-nil (a ⊕ da)) ⟩
       ⟦ t ⟧Term (a ⊕ da • ρ ⊕ dρ)
      ≡⟨ correctDerive t ρ2 dρ2 ρ2dρ2 ⟩
        ⟦ t ⟧Term ρ2 ⊕ ⟦ t ⟧ΔTerm ρ2 dρ2
      ∎)
validDerive (var x) ρ dρ ρdρ = validDeriveVar x ρ dρ ρdρ
validDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = validDeriveConst c


getting stuck in the predictable places #2

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

open import htype-decidable
open import lemmas-consistency
open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (pres-lem eps D1 D3 D4 D5) D2
  pres-lem (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (pres-lem eps D2 D3 D4 D5)
  pres-lem (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (pres-lem eps D1 D2 D3 D4) x₁
  pres-lem (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (pres-lem eps D1 D2 D3 D4) x
  pres-lem (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (pres-lem x y D3 D4 eps) x₁ x₂ x₃

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  pres-lem2 (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = pres-lem2 x y

  -- this is the literal contents of the hole in lem3; it might not go
  -- through exactly like this.
  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
              Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
              Δ , Γ ⊢ d2 :: τ1 →
              Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst TAConst D2 = TAConst
  lem-subst {Γ = Γ} {x = x'} (TAVar {x = x} x₂) D2
    with Γ x
  lem-subst {x = x} (TAVar {x = x'} x₃) D2 | Some x₁
    with natEQ x' x
  lem-subst (TAVar xin) D2 | Some x₃ | Inl refl = {!!}
  lem-subst (TAVar refl) D2 | Some x₃ | Inr x₂ = {!!}
  lem-subst {x = x} (TAVar {x = x'} x₂) D2 | None with natEQ x' x
  lem-subst {x = x} (TAVar x₃) D2 | None | Inl refl with natEQ x x
  lem-subst (TAVar refl) D2 | None | Inl refl | Inl refl = D2
  lem-subst (TAVar x₃) D2 | None | Inl refl | Inr x₁ = abort (somenotnone (! x₃))
  lem-subst {x = x} (TAVar {x = x'} x₃) D2 | None | Inr x₂ with natEQ x x'
  lem-subst (TAVar x₄) D2 | None | Inr x₃ | Inl x₂ = abort ((flip x₃) x₂)
  lem-subst (TAVar x₄) D2 | None | Inr x₃ | Inr x₂ = abort (somenotnone (! x₄))
  lem-subst (TALam D1) D2 = {!!}
  lem-subst (TAAp D1 D2) D3 = TAAp (lem-subst D1 D3) (lem-subst D2 D3)
  lem-subst (TAEHole x₁ x₂) D2 = TAEHole x₁ {!!}
  lem-subst (TANEHole x₁ D1 x₂) D2 = TANEHole x₁ (lem-subst D1 D2) {!!}
  lem-subst (TACast D1 x₁) D2 = TACast (lem-subst D1 D2) x₁
  lem-subst (TAFailedCast D1 x₁ x₂ x₃) D2 = TAFailedCast (lem-subst D1 D2) x₁ x₂ x₃

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp (TALam ta) ta₁) ITLam = lem-subst ta ta₁
  pres-lem3 (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  pres-lem3 (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) ()
  pres-lem3 (TACast ta x) (ITCastID) = ta
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  pres-lem3 (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  pres-lem3 (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  pres-lem3 (TAFailedCast x y z q) ()

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂

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

open import lemmas-consistency
open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (pres-lem eps D1 D3 D4 D5) D2
  pres-lem (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (pres-lem eps D2 D3 D4 D5)
  pres-lem (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (pres-lem eps D1 D2 D3 D4) x₁
  pres-lem (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (pres-lem eps D1 D2 D3 D4) x
  pres-lem (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (pres-lem x y D3 D4 eps) x₁ x₂ x₃

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  pres-lem2 (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = pres-lem2 x y

  -- this is the literal contents of the hole in lem3; it might not go
  -- through exactly like this.
  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
              Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
              Δ , Γ ⊢ d2 :: τ1 →
              Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst D1 D2 = {!!}

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp (TALam ta) ta₁) ITLam = lem-subst ta ta₁
  pres-lem3 (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  pres-lem3 (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) ()
  pres-lem3 (TACast ta x) (ITCastID) = ta
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  pres-lem3 (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  pres-lem3 (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  pres-lem3 (TAFailedCast x y z q) ()

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂