We could not prove the subtraction conversion rules without using totality hypotheses.

------------------------------------------------------------------------------
-- Subtraction using the rec combinator
------------------------------------------------------------------------------

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

module FOT.LTC-PCF.Data.Nat.SubtractionRecCombinator 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.Properties hiding ( ∸-x0 ; ∸-0x ; ∸-0S ; ∸-SS )
open import LTC-PCF.Data.Nat.Rec
open import LTC-PCF.Data.Nat.Rec.Equations
open import LTC-PCF.Data.Nat.Type

-- We add 3 to the fixities of the standard library.
infixl 9 _∸_

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

-- Subtraction
_∸_ : D → D → D
m ∸ n = rec n m (lam (λ _ → lam pred₁))

-- Conversion rules (from the Agda standard library)

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

∸-0S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
∸-0S nzero =
  rec (succ₁ zero) zero (lam (λ _ → lam pred₁))
    ≡⟨ rec-S zero zero (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · zero · (zero ∸ zero)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) zero) ⟩
  lam pred₁ · (zero ∸ zero)
    ≡⟨ beta pred₁ (zero ∸ zero) ⟩
  pred₁ (zero ∸ zero)
    ≡⟨ predCong (∸-x0 zero) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0S (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) zero (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) zero (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · (zero ∸ (succ₁ n))
    ≡⟨ beta pred₁ (zero ∸ (succ₁ n)) ⟩
  pred₁ (zero ∸ (succ₁ n))
    ≡⟨ predCong (∸-0S Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

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

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

∸-SS nzero (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ zero) (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) (succ₁ zero) (lam (λ _ → lam pred₁))  ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · (succ₁ zero ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ zero ∸ succ₁ n) ⟩
  pred₁ (succ₁ zero ∸ succ₁ n)
    ≡⟨ predCong (∸-SS nzero Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ predCong (∸-0x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym (∸-0S Nn) ⟩
  zero ∸ succ₁ n ∎

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

------------------------------------------------------------------------------
-- Conversion rules from the Agda standard library without totality
-- hypotheses.

-- We could not prove this property.
-- ∸-0S₁ : ∀ n → zero ∸ succ₁ n ≡ zero
-- ∸-0S₁ n =
--   rec (succ₁ n) zero (lam (λ _ → lam pred₁))
--     ≡⟨ rec-S n zero (lam (λ _ → lam pred₁)) ⟩
--   lam (λ _ → lam pred₁) · n · (zero ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (zero ∸ n)
--     ≡⟨ beta pred₁ (zero ∸ n) ⟩
--   pred₁ (zero ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   zero ∎

-- We could not prove this property.
-- ∸-SS₁ : ∀ m n → succ₁ m ∸ succ₁ n ≡ m ∸ n
-- ∸-SS₁ m n =
--   rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
--   ≡⟨ rec-S n (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (succ₁ m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (succ₁ m ∸ n)
--     ≡⟨ beta pred₁ (succ₁ m ∸ n) ⟩
--   pred₁ (succ₁ m ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   m ∸ n ∎

------------------------------------------------------------------------------
-- Coq conversion rules

-- Fixpoint minus (n m:nat) : nat :=
--   match n, m with
--   | O, _ => n
--   | S k, O => S k
--   | S k, S l => k - l
--   end

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

∸-S0-coq : ∀ n → succ₁ n ∸ zero ≡ succ₁ n
∸-S0-coq n =
  rec zero (succ₁ n) (lam (λ _ → lam pred₁))
    ≡⟨ rec-0 (succ₁ n) ⟩
  succ₁ n ∎

-- We could not prove this property.
-- ∸-SS-coq : ∀ m n → succ₁ m ∸ succ₁ n ≡ m ∸ n
-- ∸-SS-coq m n =
--   rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
--   ≡⟨ rec-S n (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (succ₁ m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (succ₁ m ∸ n)
--     ≡⟨ beta pred₁ (succ₁ m ∸ n) ⟩
--   pred₁ (succ₁ m ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   m ∸ n ∎

------------------------------------------------------------------------------
-- Subtraction using the rec combinator
------------------------------------------------------------------------------

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

module FOT.LTC-PCF.Data.Nat.SubtractionRecCombinator 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.Properties hiding ( ∸-x0 ; ∸-0x ; ∸-0S ; ∸-SS )
open import LTC-PCF.Data.Nat.Rec
open import LTC-PCF.Data.Nat.Rec.Equations
open import LTC-PCF.Data.Nat.Type

-- We add 3 to the fixities of the standard library.
infixl 9 _∸_

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

-- Subtraction
_∸_ : D → D → D
m ∸ n = rec n m (lam (λ _ → lam (λ x → pred₁ x)))

-- Conversion rules

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

∸-0S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
∸-0S nzero =
  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) ⟩
  lam pred₁ · (zero ∸ zero)
    ≡⟨ beta pred₁ (zero ∸ zero) ⟩
  pred₁ (zero ∸ zero)
    ≡⟨ predCong (∸-x0 zero) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0S (nsucc {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)) ⟩
  lam pred₁ · (zero ∸ (succ₁ n))
    ≡⟨ beta pred₁ (zero ∸ (succ₁ n)) ⟩
  pred₁ (zero ∸ (succ₁ n))
    ≡⟨ predCong (∸-0S Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

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

∸-SS : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n ≡ m ∸ n
∸-SS {m} _ nzero =
  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) ⟩
  lam pred₁ · (succ₁ m ∸ zero)
    ≡⟨ beta pred₁ (succ₁ m ∸ zero) ⟩
  pred₁ (succ₁ m ∸ zero)
    ≡⟨ predCong (∸-x0 (succ₁ m)) ⟩
  pred₁ (succ₁ m)
    ≡⟨ pred-S m ⟩
  m
    ≡⟨ sym (∸-x0 m) ⟩
  m ∸ zero ∎

∸-SS nzero (nsucc {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)) ⟩
  lam pred₁ · (succ₁ zero ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ zero ∸ succ₁ n) ⟩
  pred₁ (succ₁ zero ∸ succ₁ n)
    ≡⟨ predCong (∸-SS nzero Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ predCong (∸-0x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym (∸-0S Nn) ⟩
  zero ∸ succ₁ n ∎

∸-SS (nsucc {m} Nm) (nsucc {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)) ⟩
  lam pred₁ · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ (succ₁ m) ∸ succ₁ n) ⟩
  pred₁ (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ predCong (∸-SS (nsucc Nm) Nn) ⟩
  pred₁ (succ₁ m ∸ n)
    ≡⟨ sym (beta pred₁ (succ₁ m ∸ n)) ⟩
  lam pred₁ · (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 ∎


more goofing around

more goofing around

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

module preservation where
  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             Δ ⊢ d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation TAConst (Step _ _ _) = TAConst
  preservation (TAVar x₁) step = abort (somenotnone (! x₁))
  preservation (TALam wt) (Step x₁ x₂ x₃) = {!!}
  preservation (TAAp wt x wt₁) step = {!!}
  preservation (TAEHole x x₁) (Step x₂ x₃ x₄) = {!!}
  preservation (TANEHole x wt x₁) step = {!!}
  preservation (TACast wt x) step = {!!}

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

module preservation where
  preservation : (Δ : hctx) (d d' : dhexp) (τ : htyp) →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation = {!!}


Added nest-x≡0 and nest-N.

Added nest-x≡0 and nest-N.

Ignore-this: c3690576d9951142c70d174776b87d3

darcs-hash:20110405145834-3bd4e-84427e8786b525a2afd0693da15c7b1484b8f47f.gz

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

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

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

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

open import FOTC.Relation.Binary.EqReasoning

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

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

-- The nest function is total (non-terminating version).
-- nest-N : ∀ {n} → N n → N (nest n)
-- nest-N zN          = subst N (sym nest-0) zN
-- nest-N (sN {n} Nn) = subst N (sym (nest-S n)) (nest-N (nest-N Nn))

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

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

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

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

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

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

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

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

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

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

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

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

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

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

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

open import FOTC.Relation.Binary.EqReasoning

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

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

-- The nest function is total (non-terminating version).
-- nest-N : ∀ {n} → N n → N (nest n)
-- nest-N zN          = subst N (sym nest-0) zN
-- nest-N (sN {n} Nn) = subst N (sym (nest-S n)) (nest-N (nest-N Nn))

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

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

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

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

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

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

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

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

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


Rel.Bin.ToNat: fix

Rel.Bin.ToNat: fix

import Data.Nat.NP as ℕ
open ℕ using (ℕ; zero; suc; module ℕ≤)
open import Data.Bool
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum renaming (map to ⊎-map)
open import Function
open import Relation.Binary
open import Algebra.FunctionProperties
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module Relation.Binary.ToNat {a} {A : Set a} (f : A → ℕ) (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) where

_<=_ : A → A → Bool
_<=_ = ℕ._<=_ on f

_≤_ : A → A → Set
x ≤ y = T (x <= y)

_⊓_ : A → A → A
x ⊓ y = if x <= y then x else y

_⊔_ : A → A → A
x ⊔ y = if x <= y then y else x

isPreorder : IsPreorder _≡_ _≤_
isPreorder = record { isEquivalence = ≡.isEquivalence
                    ; reflexive = reflexive
                    ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
  where open ℕ.<= using (sound; complete)
        reflexive : ∀ {i j} → i ≡ j → i ≤ j
        reflexive {i} ≡.refl = complete (ℕ≤.refl {f i})
        trans : Transitive _≤_
        trans {x} {y} {z} p q = complete (ℕ≤.trans (sound (f x) (f y) p) (sound (f y) (f z) q))

isPartialOrder : IsPartialOrder _≡_ _≤_
isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }
  where open ℕ.<= using (sound)
        antisym : Antisymmetric _≡_ _≤_
        antisym {x} {y} p q = f-inj (ℕ≤.antisym (sound (f x) (f y) p) (sound (f y) (f x) q))

isTotalOrder : IsTotalOrder _≡_ _≤_
isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total (f x) (f y)) }
  where open ℕ.<= using (complete)

open IsTotalOrder isTotalOrder

⊔-spec : ∀ {x y} → x ≤ y → x ⊔ y ≡ y
⊔-spec {x} {y} p with x <= y
⊔-spec _    | true = ≡.refl
⊔-spec ()   | false

⊓-spec : ∀ {x y} → x ≤ y → x ⊓ y ≡ x
⊓-spec {x} {y} p with x <= y
⊓-spec _    | true = ≡.refl
⊓-spec ()   | false

⊓-comm : Commutative _≡_ _⊓_
⊓-comm x y with x <= y | y <= x | antisym {x} {y} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊔-comm : Commutative _≡_ _⊔_
⊔-comm x y with x <= y | y <= x | antisym {y} {x} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊓-≤ : ∀ x y → (x ⊓ y) ≤ y
⊓-≤ x y with total x y
⊓-≤ x y | inj₁ p rewrite ⊓-spec p = p
⊓-≤ x y | inj₂ p rewrite ⊓-comm x y | ⊓-spec p = refl

≤-⊔ : ∀ x y → x ≤ (y ⊔ x)
≤-⊔ x y with total x y
≤-⊔ x y | inj₁ p rewrite ⊔-comm y x | ⊔-spec p = p
≤-⊔ x y | inj₂ p rewrite ⊔-spec p = refl

≤-<_,_> : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ (y ⊓ z)
≤-<_,_> {x} {y} {z} x≤y y≤z with total y z
... | inj₁ p rewrite ⊓-spec p = x≤y
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = y≤z

≤-[_,_] : ∀ {x y z} → x ≤ z → y ≤ z → (x ⊔ y) ≤ z
≤-[_,_] {x} {y} {z} x≤z y≤z with total x y
... | inj₁ p rewrite ⊔-spec p = y≤z
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = x≤z

≤-⊓₀ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ y
≤-⊓₀ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = id
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = flip trans p

≤-⊓₁ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ z
≤-⊓₁ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = flip trans p
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = id

≤-⊔₀ : ∀ {x y z} → (x ⊔ y) ≤ z → x ≤ z
≤-⊔₀ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = trans p
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = id

≤-⊔₁ : ∀ {x y z} → (x ⊔ y) ≤ z → y ≤ z
≤-⊔₁ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = id
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = trans p

import Data.Nat.NP as ℕ
open ℕ using (ℕ; zero; suc; module ℕ≤)
open import Data.Bool
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum renaming (map to ⊎-map)
open import Function
open import Relation.Binary
open import Algebra.FunctionProperties
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module Relation.Binary.ToNat {a} {A : Set a} (f : A → ℕ) (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) where

_<=_ : A → A → Bool
_<=_ = ℕ._<=_ on f

_≤_ : A → A → Set
x ≤ y = T (x <= y)

_⊓_ : A → A → A
x ⊓ y = if x <= y then x else y

_⊔_ : A → A → A
x ⊔ y = if x <= y then y else x

isPreorder : IsPreorder _≡_ _≤_
isPreorder = record { isEquivalence = ≡.isEquivalence
                    ; reflexive = reflexive
                    ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
  where open ℕ.<=
        reflexive : ∀ {i j} → i ≡ j → i ≤ j
        reflexive {i} ≡.refl = complete (ℕ≤.refl {f i})
        trans : Transitive _≤_
        trans {x} {y} {z} p q = complete (ℕ≤.trans (sound (f x) (f y) p) (sound (f y) (f z) q))

isPartialOrder : IsPartialOrder _≡_ _≤_
isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }
  where open ℕ.<= using (sound)
        antisym : Antisymmetric _≡_ _≤_
        antisym {x} {y} p q = f-inj (ℕ≤.antisym (sound (f x) (f y) p) (sound (f y) (f x) q))

isTotalOrder : IsTotalOrder _≡_ _≤_
isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total (f x) (f y)) }
  where open ℕ.<= using (complete)

open IsTotalOrder isTotalOrder

⊔-spec : ∀ {x y} → x ≤ y → x ⊔ y ≡ y
⊔-spec {x} {y} p with x <= y
⊔-spec _    | true = ≡.refl
⊔-spec ()   | false

⊓-spec : ∀ {x y} → x ≤ y → x ⊓ y ≡ x
⊓-spec {x} {y} p with x <= y
⊓-spec _    | true = ≡.refl
⊓-spec ()   | false

⊓-comm : Commutative _≡_ _⊓_
⊓-comm x y with x <= y | y <= x | antisym {x} {y} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊔-comm : Commutative _≡_ _⊔_
⊔-comm x y with x <= y | y <= x | antisym {y} {x} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊓-≤ : ∀ x y → (x ⊓ y) ≤ y
⊓-≤ x y with total x y
⊓-≤ x y | inj₁ p rewrite ⊓-spec p = p
⊓-≤ x y | inj₂ p rewrite ⊓-comm x y | ⊓-spec p = refl

≤-⊔ : ∀ x y → x ≤ (y ⊔ x)
≤-⊔ x y with total x y
≤-⊔ x y | inj₁ p rewrite ⊔-comm y x | ⊔-spec p = p
≤-⊔ x y | inj₂ p rewrite ⊔-spec p = refl

≤-<_,_> : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ (y ⊓ z)
≤-<_,_> {x} {y} {z} x≤y y≤z with total y z
... | inj₁ p rewrite ⊓-spec p = x≤y
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = y≤z

≤-[_,_] : ∀ {x y z} → x ≤ z → y ≤ z → (x ⊔ y) ≤ z
≤-[_,_] {x} {y} {z} x≤z y≤z with total x y
... | inj₁ p rewrite ⊔-spec p = y≤z
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = x≤z

≤-⊓₀ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ y
≤-⊓₀ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = id
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = flip trans p

≤-⊓₁ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ z
≤-⊓₁ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = flip trans p
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = id

≤-⊔₀ : ∀ {x y z} → (x ⊔ y) ≤ z → x ≤ z
≤-⊔₀ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = trans p
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = id

≤-⊔₁ : ∀ {x y z} → (x ⊔ y) ≤ z → y ≤ z
≤-⊔₁ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = id
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = trans p


Added doc.

Added doc.

Ignore-this: c85750b448aff287e79a31ee0a9493a1

darcs-hash:20120305232404-3bd4e-72b4f4dfe122fd57996eacaac807c149e85500d7.gz

------------------------------------------------------------------------------
-- Equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality where

-- 2012-02-05. Although this module does not use the predicate Stream,
-- it is defined in the Stream directory due to the theorem
--
-- ≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
--
-- in the module FOTC.Data.Stream.PropertiesI/ATP.

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infix 7 _≈_

------------------------------------------------------------------------------
-- The equality on streams.
postulate
  _≈_ : D → D → Set

-- The relation _≈_ is the greatest post-fixed point (by ≈-gfp₁ and
-- ≈-gfp₂) of the bisimulation functional (see below).

-- The relation _≈_ is a post-fixed point of the bisimulation functional
-- (see below).
postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  ≈-gfp₂ : (_R_ : D → D → Set) →
           -- R is a post-fixed point of the bisimulation functional.
           (∀ {xs ys} → xs R ys →
            ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
            xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
           -- _≈_ is greater than R.
           ∀ {xs ys} → xs R ys → xs ≈ ys

-- Because a greatest post-fixed point is a fixed point, the relation
-- _≈_ is also a pre-fixed point of the bisimulation functional (see
-- below).
≈-gfp₃ : ∀ {xs ys} →
         (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
          xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
         xs ≈ ys
≈-gfp₃ h = ≈-gfp₂ _R_ helper h
  where
  _R_ : D → D → Set
  _R_ xs ys = ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  helper : ∀ {xs ys} → xs R ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  helper (_ , _ , _ , xs'≈ys' , prf) = _ , _ , _ , ≈-gfp₁ xs'≈ys' , prf

private
  module Bisimulation where
  -- In FOTC we won't use the bisimulation functional. This module is
  -- only for illustrative purposes.

  -- References:
  --
  -- • Peter Dybjer and Herbert Sander. A functional programming
  -- approach to the specification and verification of concurrent
  -- systems. Formal Aspects of Computing, 1:303–319, 1989.

  -- • Bart Jacobs and Jan Rutten. (Co)algebras and
  -- (co)induction. EATCS Bulletin, 62:222–259, 1997.

  ----------------------------------------------------------------------------
  -- Adapted from (Dybjer and Sander, 1989, p. 310). In this paper, the
  -- authors use the name

  -- as (R :: R') bs'

  -- for the bisimulation functional.

  -- The bisimulation functional (Jacobs and Rutten, 1997, p. 30).
  Bisimulation : (D → D → Set) → D → D → Set
  Bisimulation _R_ xs ys =
    ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  -- The relation _≈_ is the greatest post-fixed point of
  -- Bisimulation (by post-fp and gpfp).

  -- The relation _≈_ is a post-fixed point of Bisimulation.
  post-fp : ∀ {xs ys} → xs ≈ ys → Bisimulation _≈_ xs ys
  post-fp = ≈-gfp₁

  gpfp : (_R_ : D → D → Set) →
         -- R is a post-fixed point of Bisimulation.
         (∀ {xs ys} → xs R ys → Bisimulation _R_ xs ys) →
         -- _≈_ is greater than R.
         ∀ {xs ys} → xs R ys → xs ≈ ys
  gpfp = ≈-gfp₂

  -- The relation _≈_ is a pre-fixed point of Bisimulation.
  pre-fp : ∀ {xs ys} → Bisimulation _≈_ xs ys → xs ≈ ys
  pre-fp = ≈-gfp₃

------------------------------------------------------------------------------
-- Equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality where

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infix 7 _≈_

------------------------------------------------------------------------------
-- The equality on streams.
postulate
  _≈_ : D → D → Set

-- The relation _≈_ is the greatest post-fixed point (by ≈-gfp₁ and
-- ≈-gfp₂) of the bisimulation functional (see below).

-- The relation _≈_ is a post-fixed point of the bisimulation functional
-- (see below).
postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  ≈-gfp₂ : (_R_ : D → D → Set) →
           -- R is a post-fixed point of the bisimulation functional.
           (∀ {xs ys} → xs R ys →
            ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
            xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
           -- _≈_ is greater than R.
           ∀ {xs ys} → xs R ys → xs ≈ ys

-- Because a greatest post-fixed point is a fixed point, the relation
-- _≈_ is also a pre-fixed point of the bisimulation functional (see
-- below).
≈-gfp₃ : ∀ {xs ys} →
         (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
          xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
         xs ≈ ys
≈-gfp₃ h = ≈-gfp₂ _R_ helper h
  where
  _R_ : D → D → Set
  _R_ xs ys = ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  helper : ∀ {xs ys} → xs R ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  helper (_ , _ , _ , xs'≈ys' , prf) = _ , _ , _ , ≈-gfp₁ xs'≈ys' , prf

private
  module Bisimulation where
  -- In FOTC we won't use the bisimulation functional. This module is
  -- only for illustrative purposes.

  -- Adapted from [1]. In this paper the authors use the name

  -- as (R :: R') bs' (p. 310)

  -- for the bisimulation functional.

  -- [1] Peter Dybjer and Herbert Sander. A functional programming
  -- approach to the specification and verification of concurrent
  -- systems. Formal Aspects of Computing, 1:303–319, 1989.

  -- The bisimulation functional (Bart Jacobs and Jan
  -- Rutten. (Co)algebras and (co)induction. EATCS Bulletin,
  -- 62:222–259, 1997).
  Bisimulation : (D → D → Set) → D → D → Set
  Bisimulation _R_ xs ys =
    ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  -- The relation _≈_ is the greatest post-fixed point of
  -- Bisimulation (by post-fp and gpfp).

  -- The relation _≈_ is a post-fixed point of Bisimulation.
  post-fp : ∀ {xs ys} → xs ≈ ys → Bisimulation _≈_ xs ys
  post-fp = ≈-gfp₁

  gpfp : (_R_ : D → D → Set) →
         -- R is a post-fixed point of Bisimulation.
         (∀ {xs ys} → xs R ys → Bisimulation _R_ xs ys) →
         -- _≈_ is greater than R.
         ∀ {xs ys} → xs R ys → xs ≈ ys
  gpfp = ≈-gfp₂

  -- The relation _≈_ is a pre-fixed point of Bisimulation.
  pre-fp : ∀ {xs ys} → Bisimulation _≈_ xs ys → xs ≈ ys
  pre-fp = ≈-gfp₃


Typo.

Typo.

Ignore-this: 5d39e5a0d391478bcb2a2a2d62bf3207

darcs-hash:20110930182240-3bd4e-f32121202fa2cd4391c83100189d0ea648064e4e.gz

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

-- The FOTC natural numbers using data.
data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we choose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- The predicates

-- From the data predicate to the postulated one: Using the induction
-- principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- From the data predicate to the postulated one: Using pattern
-- matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

-- From the postulated predicate to the data one.
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- The induction principles

-- The postulated inductive principle from the data one.
indD2P : (P : D → Set) → P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n
indD2P P P0 ih Mn = indN P P0 (λ {n} Nn → ih (nat-D2P Nn)) (nat-P2D Mn)

-- The data inductive principle from the postulated one.
indP2D : (P : D → Set) → P zero →
         (∀ {n} → N n → P n → P (succ n)) →
         ∀ {n} → N n → P n
indP2D P P0 ih Nn = indM P P0 (λ {n} Mn → ih (nat-P2D Mn)) (nat-D2P Nn)

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

-- The FOTC natural numbers using data.
data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we choose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- The predicates

-- From the data predicate to the postulate predicate: Using the
-- induction principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- From the data predicate to the postulate predicate: Using pattern matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

-- From the postulate predicate to the data predicate
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- The induction principles

-- The postulated inductive principle from the data one.
indD2P : (P : D → Set) → P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n
indD2P P P0 ih Mn = indN P P0 (λ {n} Nn → ih (nat-D2P Nn)) (nat-P2D Mn)

-- The data inductive principle from the postulated one.
indP2D : (P : D → Set) → P zero →
         (∀ {n} → N n → P n → P (succ n)) →
         ∀ {n} → N n → P n
indP2D P P0 ih Nn = indM P P0 (λ {n} Mn → ih (nat-P2D Mn)) (nat-D2P Nn)


Simplify _⋎_

Simplify _⋎_

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Variables and contexts
--
-- This module defines the syntax of contexts, prefixes of
-- contexts and variables and properties of these notions.
--
-- This module is parametric in the syntax of types, so it
-- can be reused for different calculi.
------------------------------------------------------------------------

module Base.Syntax.Context
    (Type : Set)
  where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

-- Typing Contexts
-- ===============

import Data.List as List
open List public
  using ()
  renaming
    ( [] to ∅ ; _∷_ to _•_
    ; map to mapContext
    )

Context : Set
Context = List.List Type

-- Variables
-- =========
--
-- Here it is clear that we are using de Bruijn indices,
-- encoded as natural numbers, more or less.
data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ σ τ} → (x : Var Γ τ) → Var (σ • Γ) τ

-- Weakening
-- =========
--
-- We provide two approaches for weakening: context prefixes and
-- and subcontext relationship. In this formalization, we mostly
-- (maybe exclusively?) use the latter.

-- Context Prefixes
-- ----------------
--
-- Useful for making lemmas strong enough to prove by induction.
--
-- Consider using the Subcontexts module instead.

module Prefixes where

-- Prefix of a context

  data Prefix : Context → Set where
    ∅ : ∀ {Γ} → Prefix Γ
    _•_ : ∀ {Γ} → (τ : Type) → Prefix Γ → Prefix (τ • Γ)

-- take only the prefix of a context

  take : (Γ : Context) → Prefix Γ → Context
  take Γ ∅ = ∅
  take (τ • Γ) (.τ • Γ′) = τ • take Γ Γ′

-- drop the prefix of a context

  drop : (Γ : Context) → Prefix Γ → Context
  drop Γ ∅ = Γ
  drop (τ • Γ) (.τ • Γ′) = drop Γ Γ′

-- Extend a context to a super context

  infixr 10 _⋎_

  _⋎_ : (Γ₁ Γ₂ : Context) → Context
  _⋎_ = List._++_

  take-drop : ∀ Γ Γ′ → take Γ Γ′ ⋎ drop Γ Γ′ ≡ Γ
  take-drop ∅ ∅ = refl
  take-drop (τ • Γ) ∅ = refl
  take-drop (τ • Γ) (.τ • Γ′) rewrite take-drop Γ Γ′ = refl

  or-unit : ∀ Γ → Γ ⋎ ∅ ≡ Γ
  or-unit ∅ = refl
  or-unit (τ • Γ) rewrite or-unit Γ = refl

  move-prefix : ∀ Γ τ Γ′ →
    Γ ⋎ (τ • Γ′) ≡ (Γ ⋎ (τ • ∅)) ⋎ Γ′
  move-prefix ∅ τ Γ′ = refl
  move-prefix (τ • Γ) τ₁ ∅ = sym (or-unit (τ • Γ ⋎ (τ₁ • ∅)))
  move-prefix (τ • Γ) τ₁ (τ₂ • Γ′) rewrite move-prefix Γ τ₁ (τ₂ • Γ′) = refl

-- Lift a variable to a super context

  lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
  lift {∅} {∅} x = x
  lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
  lift {τ • Γ₁} {Γ₂} this = this
  lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- Subcontexts
-- -----------
--
-- Useful as a reified weakening operation,
-- and for making theorems strong enough to prove by induction.
--
-- The contents of this module are currently exported at the end
-- of this file.

-- This handling of contexts is recommended by [this
-- email](https://lists.chalmers.se/pipermail/agda/2011/003423.html) and
-- attributed to Conor McBride.
--
-- The associated thread discusses a few alternatives solutions, including one
-- where beta-reduction can handle associativity of ++.

module Subcontexts where
  infix 4 _≼_

  data _≼_ : (Γ₁ Γ₂ : Context) → Set where
    ∅ : ∅ ≼ ∅
    keep_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      τ • Γ₁ ≼ τ • Γ₂
    drop_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      Γ₁ ≼ τ • Γ₂

  -- Properties

  ∅≼Γ : ∀ {Γ} → ∅ ≼ Γ
  ∅≼Γ {∅} = ∅
  ∅≼Γ {τ • Γ} = drop τ • ∅≼Γ

  ≼-refl : Reflexive _≼_
  ≼-refl {∅} = ∅
  ≼-refl {τ • Γ} = keep τ • ≼-refl

  ≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
  ≼-reflexive refl = ≼-refl

  ≼-trans : Transitive _≼_
  ≼-trans ≼₁ ∅ = ≼₁
  ≼-trans (keep .τ • ≼₁) (keep τ • ≼₂) = keep τ • ≼-trans ≼₁ ≼₂
  ≼-trans (drop .τ • ≼₁) (keep τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂
  ≼-trans ≼₁ (drop τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂

  ≼-isPreorder : IsPreorder _≡_ _≼_
  ≼-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive = ≼-reflexive
    ; trans = ≼-trans
    }

  ≼-preorder : Preorder _ _ _
  ≼-preorder = record
    { Carrier = Context
    ; _≈_ = _≡_
    ; _∼_ = _≼_
    ; isPreorder = ≼-isPreorder
    }

  module ≼-Reasoning where
    open import Relation.Binary.PreorderReasoning ≼-preorder public
      renaming
        ( _≈⟨_⟩_ to _≡⟨_⟩_
        ; _∼⟨_⟩_ to _≼⟨_⟩_
        ; _≈⟨⟩_ to _≡⟨⟩_
        )

  -- Lift a variable to a super context

  weaken-var : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
  weaken-var (keep τ • ≼₁) this = this
  weaken-var (keep τ • ≼₁) (that x) = that (weaken-var ≼₁ x)
  weaken-var (drop τ • ≼₁) x = that (weaken-var ≼₁ x)

-- Currently, we export the subcontext relation as well as the
-- definition of _⋎_.

open Subcontexts public
open Prefixes public using (_⋎_)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Variables and contexts
--
-- This module defines the syntax of contexts, prefixes of
-- contexts and variables and properties of these notions.
--
-- This module is parametric in the syntax of types, so it
-- can be reused for different calculi.
------------------------------------------------------------------------

module Base.Syntax.Context
    (Type : Set)
  where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

-- Typing Contexts
-- ===============

import Data.List as List
open List public
  using ()
  renaming
    ( [] to ∅ ; _∷_ to _•_
    ; map to mapContext
    )

Context : Set
Context = List.List Type

-- Variables
-- =========
--
-- Here it is clear that we are using de Bruijn indices,
-- encoded as natural numbers, more or less.
data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ σ τ} → (x : Var Γ τ) → Var (σ • Γ) τ

-- Weakening
-- =========
--
-- We provide two approaches for weakening: context prefixes and
-- and subcontext relationship. In this formalization, we mostly
-- (maybe exclusively?) use the latter.

-- Context Prefixes
-- ----------------
--
-- Useful for making lemmas strong enough to prove by induction.
--
-- Consider using the Subcontexts module instead.

module Prefixes where

-- Prefix of a context

  data Prefix : Context → Set where
    ∅ : ∀ {Γ} → Prefix Γ
    _•_ : ∀ {Γ} → (τ : Type) → Prefix Γ → Prefix (τ • Γ)

-- take only the prefix of a context

  take : (Γ : Context) → Prefix Γ → Context
  take Γ ∅ = ∅
  take (τ • Γ) (.τ • Γ′) = τ • take Γ Γ′

-- drop the prefix of a context

  drop : (Γ : Context) → Prefix Γ → Context
  drop Γ ∅ = Γ
  drop (τ • Γ) (.τ • Γ′) = drop Γ Γ′

-- Extend a context to a super context

  infixr 10 _⋎_

  _⋎_ : (Γ₁ Γ₂ : Context) → Context
  ∅ ⋎ Γ₂ = Γ₂
  (τ • Γ₁) ⋎ Γ₂ = τ • (Γ₁ ⋎ Γ₂)

  take-drop : ∀ Γ Γ′ → take Γ Γ′ ⋎ drop Γ Γ′ ≡ Γ
  take-drop ∅ ∅ = refl
  take-drop (τ • Γ) ∅ = refl
  take-drop (τ • Γ) (.τ • Γ′) rewrite take-drop Γ Γ′ = refl

  or-unit : ∀ Γ → Γ ⋎ ∅ ≡ Γ
  or-unit ∅ = refl
  or-unit (τ • Γ) rewrite or-unit Γ = refl

  move-prefix : ∀ Γ τ Γ′ →
    Γ ⋎ (τ • Γ′) ≡ (Γ ⋎ (τ • ∅)) ⋎ Γ′
  move-prefix ∅ τ Γ′ = refl
  move-prefix (τ • Γ) τ₁ ∅ = sym (or-unit (τ • Γ ⋎ (τ₁ • ∅)))
  move-prefix (τ • Γ) τ₁ (τ₂ • Γ′) rewrite move-prefix Γ τ₁ (τ₂ • Γ′) = refl

-- Lift a variable to a super context

  lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
  lift {∅} {∅} x = x
  lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
  lift {τ • Γ₁} {Γ₂} this = this
  lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- Subcontexts
-- -----------
--
-- Useful as a reified weakening operation,
-- and for making theorems strong enough to prove by induction.
--
-- The contents of this module are currently exported at the end
-- of this file.

-- This handling of contexts is recommended by [this
-- email](https://lists.chalmers.se/pipermail/agda/2011/003423.html) and
-- attributed to Conor McBride.
--
-- The associated thread discusses a few alternatives solutions, including one
-- where beta-reduction can handle associativity of ++.

module Subcontexts where
  infix 4 _≼_

  data _≼_ : (Γ₁ Γ₂ : Context) → Set where
    ∅ : ∅ ≼ ∅
    keep_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      τ • Γ₁ ≼ τ • Γ₂
    drop_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      Γ₁ ≼ τ • Γ₂

  -- Properties

  ∅≼Γ : ∀ {Γ} → ∅ ≼ Γ
  ∅≼Γ {∅} = ∅
  ∅≼Γ {τ • Γ} = drop τ • ∅≼Γ

  ≼-refl : Reflexive _≼_
  ≼-refl {∅} = ∅
  ≼-refl {τ • Γ} = keep τ • ≼-refl

  ≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
  ≼-reflexive refl = ≼-refl

  ≼-trans : Transitive _≼_
  ≼-trans ≼₁ ∅ = ≼₁
  ≼-trans (keep .τ • ≼₁) (keep τ • ≼₂) = keep τ • ≼-trans ≼₁ ≼₂
  ≼-trans (drop .τ • ≼₁) (keep τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂
  ≼-trans ≼₁ (drop τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂

  ≼-isPreorder : IsPreorder _≡_ _≼_
  ≼-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive = ≼-reflexive
    ; trans = ≼-trans
    }

  ≼-preorder : Preorder _ _ _
  ≼-preorder = record
    { Carrier = Context
    ; _≈_ = _≡_
    ; _∼_ = _≼_
    ; isPreorder = ≼-isPreorder
    }

  module ≼-Reasoning where
    open import Relation.Binary.PreorderReasoning ≼-preorder public
      renaming
        ( _≈⟨_⟩_ to _≡⟨_⟩_
        ; _∼⟨_⟩_ to _≼⟨_⟩_
        ; _≈⟨⟩_ to _≡⟨⟩_
        )

  -- Lift a variable to a super context

  weaken-var : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
  weaken-var (keep τ • ≼₁) this = this
  weaken-var (keep τ • ≼₁) (that x) = that (weaken-var ≼₁ x)
  weaken-var (drop τ • ≼₁) x = that (weaken-var ≼₁ x)

-- Currently, we export the subcontext relation as well as the
-- definition of _⋎_.

open Subcontexts public
open Prefixes public using (_⋎_)


tidying

tidying

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

module structural where


s/prf₁/A0 and s/prf₂/is.

s/prf₁/A0 and s/prf₂/is.

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --schematic-propositional-functions #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

------------------------------------------------------------------------------
-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-ind A A0 is Nm
  where
    A : D → Set
    A i = N (i + n)

    A0 : A zero
    A0 = subst N (sym (+-0x n)) Nn

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

-- Interactive proof using an instance of the induction principle.
+-N-ind : ∀ {n} →
          N (zero + n) →
          (∀ {m} → N (m + n) → N (succ₁ m + n)) →
          ∀ {m} → N m → N (m + n)
+-N-ind {n} = N-ind (λ i → N (i + n))

+-N₁ : ∀ {m n} → N m → N n → N (m + n)
+-N₁ {n = n} Nm Nn = +-N-ind A0 is Nm
  where
  A0 : N (zero + n)
  A0 = subst N (sym (+-0x n)) Nn

  is : ∀ {m} → N (m + n) → N (succ₁ m + n)
  is {m} ih = subst N (sym (+-Sx m n)) (nsucc ih)

-- Combined proof using an instance of the induction principle.
postulate +-N₂ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₂ +-N-ind #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- N-ind
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate +-N₃ : ∀ {m n} → N m → N n → N (m + n)
-- Because the ATPs don't handle induction, them cannot prove this
-- postulate.
-- {-# ATP prove +-N₃ N-ind #-}

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --schematic-propositional-functions #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

------------------------------------------------------------------------------
-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-ind A A0 is Nm
  where
    A : D → Set
    A i = N (i + n)

    A0 : A zero
    A0 = subst N (sym (+-0x n)) Nn

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

-- Interactive proof using an instance of the induction principle.
+-N-ind : ∀ {n} →
          N (zero + n) →
          (∀ {m} → N (m + n) → N (succ₁ m + n)) →
          ∀ {m} → N m → N (m + n)
+-N-ind {n} = N-ind (λ i → N (i + n))

+-N₁ : ∀ {m n} → N m → N n → N (m + n)
+-N₁ {n = n} Nm Nn = +-N-ind prf₁ prf₂ Nm
  where
  prf₁ : N (zero + n)
  prf₁ = subst N (sym (+-0x n)) Nn

  prf₂ : ∀ {m} → N (m + n) → N (succ₁ m + n)
  prf₂ {m} ih = subst N (sym (+-Sx m n)) (nsucc ih)

-- Combined proof using an instance of the induction principle.
postulate +-N₂ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₂ +-N-ind #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- N-ind
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate +-N₃ : ∀ {m n} → N m → N n → N (m + n)
-- Because the ATPs don't handle induction, them cannot prove this
-- postulate.
-- {-# ATP prove +-N₃ N-ind #-}


Data.Bits: better sucBCarry

Data.Bits: better sucBCarry

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Maybe
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise)
open import Data.Vec.NP hiding (_⊛_) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties
import Data.List as L

open import Data.Bool.NP public using (_xor_)
open import Data.Vec.NP public using ([]; _∷_; head; tail; replicate)

Bit : Set
Bit = Bool

pattern 0b = false
pattern 1b = true

Bits : ℕ → Set
Bits = Vec Bit

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0b

-- Warning: 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ 0ⁿ
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ 1ⁿ
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1ⁿ ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1ⁿ x) ⟩
         x ⊕ (x ⊕ 1ⁿ) ≡⟨ sym (⊕-assoc x x 1ⁿ) ⟩
         (x ⊕ x) ⊕ 1ⁿ ≡⟨ cong (flip _⊕_ 1ⁿ) (⊕-≡ x) ⟩
         0ⁿ ⊕ 1ⁿ       ≡⟨ ⊕-left-identity 1ⁿ ⟩
         1ⁿ ∎ where open ≡-Reasoning

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad
allBits : ∀ n → Vec (Bits n) (2 ^ n)
allBits zero = [] ∷ []
allBits (suc n) rewrite ℕ°.+-comm (2 ^ n) 0 = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → Fin (suc (2 ^ n))
#⟨ pred ⟩ = count pred (allBits _)

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry [] = 0b ∷ []
sucBCarry (0b ∷ xs) = 0b ∷ sucBCarry xs
sucBCarry (1b ∷ xs) with sucBCarry xs
... | 0b ∷ bs = 0b ∷ 1b ∷ bs
... | 1b ∷ bs = 1b ∷ 0b ∷ bs

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

lookupTbl : ∀ {n a} {A : Set a} → Bits n → Vec A (2 ^ n) → A
lookupTbl         []         (x ∷ []) = x
lookupTbl         (0b ∷ key) tbl      = lookupTbl key (take _ tbl)
lookupTbl {suc n} (1b ∷ key) tbl      = lookupTbl key (take (2 ^ n) (drop (2 ^ n) tbl))

funFromTbl : ∀ {n a} {A : Set a} → Vec A (2 ^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Vec A (2 ^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero} f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_) ++ tblFromFun {n} (f ∘ 1∷_) ++ []

funFromTbl∘tblFromFun : ∀ {n a} {A : Set a} (fun : Bits n → A) → funFromTbl (tblFromFun fun) ≗ fun
funFromTbl∘tblFromFun {zero} f [] = refl
funFromTbl∘tblFromFun {suc n} f (0b ∷ xs)
  rewrite take-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ []) =
    funFromTbl∘tblFromFun {n} (f ∘ 0∷_) xs
funFromTbl∘tblFromFun {suc n} f (1b ∷ xs)
  rewrite drop-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ [])
        | take-++ (2 ^ n) (tblFromFun {n} (f ∘ 1∷_)) [] =
    funFromTbl∘tblFromFun {n} (f ∘ 1∷_) xs

tblFromFun∘funFromTbl : ∀ {n a} {A : Set a} (tbl : Vec A (2 ^ n)) → tblFromFun {n} (funFromTbl tbl) ≡ tbl
tblFromFun∘funFromTbl {zero} (x ∷ []) = refl
tblFromFun∘funFromTbl {suc n} tbl
  rewrite tblFromFun∘funFromTbl {n} (take _ tbl)
        | tblFromFun∘funFromTbl {n} (take (2 ^ n) (drop (2 ^ n) tbl))
        | take-them-all (2 ^ n) (drop (2 ^ n) tbl)
        | take-drop-lem (2 ^ n) tbl
   = refl

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Maybe
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise)
open import Data.Vec.NP hiding (_⊛_) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties
import Data.List as L

open import Data.Bool.NP public using (_xor_)
open import Data.Vec.NP public using ([]; _∷_; head; tail)

Bit : Set
Bit = Bool

pattern 0b = false
pattern 1b = true

Bits : ℕ → Set
Bits = Vec Bit

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0b

-- Warning: 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ replicate 0b
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ replicate 1b
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1ⁿ ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1ⁿ x) ⟩
         x ⊕ (x ⊕ 1ⁿ) ≡⟨ sym (⊕-assoc x x 1ⁿ) ⟩
         (x ⊕ x) ⊕ 1ⁿ ≡⟨ cong (flip _⊕_ 1ⁿ) (⊕-≡ x) ⟩
         0ⁿ ⊕ 1ⁿ       ≡⟨ ⊕-left-identity 1ⁿ ⟩
         1ⁿ ∎ where open ≡-Reasoning

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad
allBits : ∀ n → Vec (Bits n) (2 ^ n)
allBits zero = [] ∷ []
allBits (suc n) rewrite ℕ°.+-comm (2 ^ n) 0 = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → Fin (suc (2 ^ n))
#⟨ pred ⟩ = count pred (allBits _)

sucBCarry : ∀ {n} → Bits n → Maybe (Bits n)
sucBCarry [] = nothing
sucBCarry (0b ∷ xs) = just (maybe′ 0∷_ (1b ∷ 0ⁿ) (sucBCarry xs))
sucBCarry (1b ∷ xs) = maybe′ (just ∘′ 1∷_) nothing (sucBCarry xs)

sucB : ∀ {n} → Bits n → Bits n
sucB xs = maybe′ id 0ⁿ (sucBCarry xs)

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

lookupTbl : ∀ {n a} {A : Set a} → Bits n → Vec A (2 ^ n) → A
lookupTbl         []         (x ∷ []) = x
lookupTbl         (0b ∷ key) tbl      = lookupTbl key (take _ tbl)
lookupTbl {suc n} (1b ∷ key) tbl      = lookupTbl key (take (2 ^ n) (drop (2 ^ n) tbl))

funFromTbl : ∀ {n a} {A : Set a} → Vec A (2 ^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Vec A (2 ^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero} f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_) ++ tblFromFun {n} (f ∘ 1∷_) ++ []

funFromTbl∘tblFromFun : ∀ {n a} {A : Set a} (fun : Bits n → A) → funFromTbl (tblFromFun fun) ≗ fun
funFromTbl∘tblFromFun {zero} f [] = refl
funFromTbl∘tblFromFun {suc n} f (0b ∷ xs)
  rewrite take-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ []) =
    funFromTbl∘tblFromFun {n} (f ∘ 0∷_) xs
funFromTbl∘tblFromFun {suc n} f (1b ∷ xs)
  rewrite drop-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ [])
        | take-++ (2 ^ n) (tblFromFun {n} (f ∘ 1∷_)) [] =
    funFromTbl∘tblFromFun {n} (f ∘ 1∷_) xs

tblFromFun∘funFromTbl : ∀ {n a} {A : Set a} (tbl : Vec A (2 ^ n)) → tblFromFun {n} (funFromTbl tbl) ≡ tbl
tblFromFun∘funFromTbl {zero} (x ∷ []) = refl
tblFromFun∘funFromTbl {suc n} tbl
  rewrite tblFromFun∘funFromTbl {n} (take _ tbl)
        | tblFromFun∘funFromTbl {n} (take (2 ^ n) (drop (2 ^ n) tbl))
        | take-them-all (2 ^ n) (drop (2 ^ n) tbl)
        | take-drop-lem (2 ^ n) tbl
   = refl

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}


Fixed typo.

Fixed typo.

Ignore-this: 1dff44d99535d1bb494b667bcb944163

darcs-hash:20101208184847-3bd4e-45d95675ace25a7aee0c929d97204fa6fa3dc534.gz

------------------------------------------------------------------------------
-- Group theory properties (using equational reasoning)
------------------------------------------------------------------------------

module GroupTheory.PropertiesER where

open import GroupTheory.Base

open import Common.Relation.Binary.EqReasoning using ( _≡⟨_⟩_ ; _∎ ; begin_ )
open import Common.Relation.Binary.PropositionalEquality.PropertiesER
  using ( subst )

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

rightIdentityUnique : ∃D λ u → (∀ x → x ∙ u ≡ x) ∧
                               (∀ u' → (∀ x → x ∙ u' ≡ x) → u ≡ u')
rightIdentityUnique =
-- Paper proof:
-- 1.  We know that ε is a right identity.
-- 2.  Let suppose there is other right identity u', i.e. ∀ x → xu' ≡ x, then
-- 2.1 ε   = εu'  (Hypothesis)
-- 2.2 εu' = u    (Left identity)
-- 2.3 ε   = u    (Transitivity)
  ε , rightIdentity , λ u' hyp → trans (sym (hyp ε)) (leftIdentity u')

leftIdentityUnique : ∃D λ u → (∀ x → u ∙ x ≡ x) ∧
                              (∀ u' → (∀ x → u' ∙ x ≡ x) → u ≡ u')
leftIdentityUnique =
-- Paper proof:
-- 1.  We know that ε is a left identity.
-- 2.  Let's suppose there is other left identity u', i.e. ∀ x → u'x ≡ x, then
-- 2.1 ε   = u'ε  (Hypothesis)
-- 2.2 u'ε = u    (Right identity)
-- 2.3 ε   = u    (Transitivity)
  ε , leftIdentity , λ u' hyp → trans (sym (hyp ε)) (rightIdentity u')

rightCancellation : ∀ {x y z} → y ∙ x ≡ z ∙ x → y ≡ z
rightCancellation {x} {y} {z} yx≡zx =
-- Paper proof:
-- 1. (yx)x⁻¹  = (zx)x⁻¹  (Hypothesis xy = xz).
-- 2. (y)xx⁻¹  = (z)xx⁻¹  (Associative).
-- 3. yε       = zε       (Right inverse).
-- 4. y        = z        (Right identity).
  begin
    y              ≡⟨ sym (rightIdentity y) ⟩
    y ∙ ε          ≡⟨ subst (λ t → y ∙ ε ≡ y ∙ t)
                            (sym (rightInverse x))
                            refl
                   ⟩
    y ∙ (x ∙ x ⁻¹) ≡⟨ sym (assoc y x (x ⁻¹)) ⟩
    y ∙ x ∙ x ⁻¹   ≡⟨ subst (λ t → y ∙ x ∙ x ⁻¹ ≡ t ∙ x ⁻¹) yx≡zx refl ⟩
    z ∙ x ∙ x ⁻¹   ≡⟨ assoc z x (x ⁻¹) ⟩
    z ∙ (x ∙ x ⁻¹) ≡⟨ subst (λ t → z ∙ (x ∙ x ⁻¹) ≡ z ∙ t)
                            (rightInverse x)
                            refl
                   ⟩
    z ∙ ε          ≡⟨ rightIdentity z ⟩
    z
  ∎

leftCancellation : ∀ {x y z} → x ∙ y ≡ x ∙ z → y ≡ z
leftCancellation {x} {y} {z} xy≡xz =
-- Paper proof:
-- 1. x⁻¹(xy)  = x⁻¹(xz)  (Hypothesis xy = xz).
-- 2. x⁻¹x(y)  = x⁻¹x(z)  (Associative).
-- 3. εy       = εz       (Left inverse).
-- 4. y        = z        (Left identity).
  begin
    y              ≡⟨ sym (leftIdentity y) ⟩
    ε ∙ y          ≡⟨ subst (λ t → ε ∙ y ≡ t ∙ y) (sym (leftInverse x)) refl ⟩
    x ⁻¹ ∙ x ∙ y   ≡⟨ assoc (x ⁻¹) x y ⟩
    x ⁻¹ ∙ (x ∙ y) ≡⟨ subst (λ t → x ⁻¹ ∙ (x ∙ y) ≡ x ⁻¹ ∙ t) xy≡xz refl ⟩
    x ⁻¹ ∙ (x ∙ z) ≡⟨ sym (assoc (x ⁻¹) x z) ⟩
    x ⁻¹ ∙ x ∙ z   ≡⟨ subst (λ t → x ⁻¹ ∙ x ∙ z ≡ t ∙ z) (leftInverse x) refl ⟩
    ε ∙ z          ≡⟨ leftIdentity z ⟩
    z
  ∎

rightInverseUnique : ∀ {x} → ∃D λ r → (x ∙ r ≡ ε) ∧
                                      (∀ r' → x ∙ r' ≡ ε → r ≡ r')
rightInverseUnique {x} =
-- Paper proof:
-- 1.   We know that (x ⁻¹) is a right inverse for x.
-- 2.   Let's suppose there is other right inverse r for x, i.e. xr ≡ ε, then
-- 2.1. xx⁻¹ = ε  (Right inverse).
-- 2.2. xr   = ε  (Hypothesis).
-- 2.3. xx⁻¹ = xr (Transitivity).
-- 2.4  x⁻¹  = r  (Left cancellation).
  (x ⁻¹) , rightInverse x , λ r' hyp → leftCancellation
    ( begin
        x ∙ x ⁻¹ ≡⟨ rightInverse x ⟩
        ε        ≡⟨ sym hyp ⟩
        x ∙ r'
      ∎
    )

-- A more appropiate version to be used in the proofs.
rightInverseUnique' : ∀ {x r} → x ∙ r ≡ ε → x ⁻¹ ≡ r
rightInverseUnique' {x} {r} = λ hyp → leftCancellation
  ( begin
      x ∙ x ⁻¹ ≡⟨ rightInverse x ⟩
      ε        ≡⟨ sym hyp ⟩
      x ∙ r
    ∎
  )

leftInverseUnique : ∀ {x} → ∃D λ l → (l ∙ x ≡ ε) ∧
                                     (∀ l' → l' ∙ x ≡ ε → l ≡ l')
leftInverseUnique {x} =
-- Paper proof:
-- 1.   We know that (x ⁻¹) is a left inverse for x.
-- 2.   Let's suppose there is other right inverse l for x, i.e. lx ≡ ε, then
-- 2.1. x⁻¹x = ε  (Left inverse).
-- 2.2. lx   = ε  (Hypothesis).
-- 2.3. x⁻¹x = lx (Transitivity).
-- 2.4  x⁻¹  = l  (Right cancellation).
  (x ⁻¹) , leftInverse x , λ l' hyp → rightCancellation
    ( begin
        x ⁻¹ ∙ x ≡⟨ leftInverse x ⟩
        ε ≡⟨ sym hyp ⟩
        l' ∙ x
      ∎
    )

-- A more appropiate version to be used in the proofs.
leftInverseUnique' : ∀ {x l} → l ∙ x ≡ ε → x ⁻¹ ≡ l
leftInverseUnique' {x} {l} = λ hyp → rightCancellation
  ( begin
      x ⁻¹ ∙ x ≡⟨ leftInverse x ⟩
      ε        ≡⟨ sym hyp ⟩
      l ∙ x
    ∎
  )

⁻¹-involutive : ∀ x → x ⁻¹ ⁻¹ ≡ x
-- Paper proof:
-- 1. x⁻¹x = ε  (Left inverse).
-- 2. The previous equation states that x is the unique right
-- inverse (x⁻¹)⁻¹ of x⁻¹.
⁻¹-involutive x = rightInverseUnique' (leftInverse x)

identityInverse : ε ⁻¹ ≡ ε
-- Paper proof:
-- 1. εε = ε  (Left/Right identity).
-- 2. The previous equation states that ε is the unique left/right
-- inverse ε⁻¹ of ε.
identityInverse = rightInverseUnique' (leftIdentity ε)

inverseDistribution : ∀ x y → (x ∙ y) ⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
-- Paper proof:
-- (y⁻¹x⁻¹)(xy) = y⁻¹(x ⁻¹(xy))  (Associative).
--              = y⁻¹(x ⁻¹x)y    (Associative).
--              = y⁻¹(εy)        (Left inverse).
--              = y⁻¹y           (Left identity).
--              = ε              (Left inverse)
-- Therefore, y⁻¹x⁻¹ is the unique left inverse of xy.
inverseDistribution x y = leftInverseUnique' y⁻¹x⁻¹[xy]≡ε
  where
    y⁻¹x⁻¹[xy]≡ε : y ⁻¹ ∙ x ⁻¹ ∙ (x ∙ y) ≡ ε
    y⁻¹x⁻¹[xy]≡ε =
        begin
          y ⁻¹ ∙ x ⁻¹ ∙ (x ∙ y)   ≡⟨ assoc (y ⁻¹) (x ⁻¹) (x ∙ y) ⟩
          y ⁻¹ ∙ (x ⁻¹ ∙ (x ∙ y)) ≡⟨ subst (λ t → y ⁻¹ ∙ (x ⁻¹ ∙ (x ∙ y)) ≡
                                                  y ⁻¹ ∙ t)
                                           (sym (assoc (x ⁻¹) x y))
                                           refl
                                  ⟩
          y ⁻¹ ∙ (x ⁻¹ ∙ x ∙ y)   ≡⟨ subst (λ t → y ⁻¹ ∙ (x ⁻¹ ∙ x ∙ y) ≡
                                                  y ⁻¹ ∙ (t ∙ y))
                                           (leftInverse x)
                                           refl
                                  ⟩
          y ⁻¹ ∙ (ε ∙ y)          ≡⟨ subst (λ t → y ⁻¹ ∙ (ε ∙ y) ≡ y ⁻¹ ∙ t)
                                           (leftIdentity y)
                                           refl
                                  ⟩
          y ⁻¹ ∙ y                ≡⟨ leftInverse y ⟩
          ε
        ∎

------------------------------------------------------------------------------
-- Group theory properties (using equational reasoning)
------------------------------------------------------------------------------

module GroupTheory.PropertiesER where

open import GroupTheory.Base

open import Common.Relation.Binary.EqReasoning using ( _≡⟨_⟩_ ; _∎ ; begin_ )
open import Common.Relation.Binary.PropositionalEquality.PropertiesER
  using ( subst )

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

rightIdentityUnique : ∃D λ u → (∀ x → x ∙ u ≡ x) ∧
                               (∀ u' → (∀ x → x ∙ u' ≡ x) → u ≡ u')
rightIdentityUnique =
-- Paper proof:
-- 1.  We know that ε is a right identity.
-- 2.  Let suppose there is other right identity u', i.e. ∀ x → xu' ≡ x, then
-- 2.1 ε   = εu'  (Hypothesis)
-- 2.2 εu' = u    (Left identity)
-- 2.3 ε   = u    (Transitivity)
  ε , rightIdentity , λ u' hyp → trans (sym (hyp ε)) (leftIdentity u')

leftIdentityUnique : ∃D λ u → (∀ x → u ∙ x ≡ x) ∧
                              (∀ u' → (∀ x → u' ∙ x ≡ x) → u ≡ u')
leftIdentityUnique =
-- Paper proof:
-- 1.  We know that ε is a left identity.
-- 2.  Let's suppose there is other left identity u', i.e. ∀ x → u'x ≡ x, then
-- 2.1 ε   = u'ε  (Hypothesis)
-- 2.2 u'ε = u    (Right identity)
-- 2.3 ε   = u    (Transitivity)
  ε , leftIdentity , λ u' hyp → trans (sym (hyp ε)) (rightIdentity u')

rightCancellation : ∀ {x y z} → y ∙ x ≡ z ∙ x → y ≡ z
rightCancellation {x} {y} {z} yx≡zx =
-- Paper proof:
-- 1. (yx)x⁻¹  = (zx)x⁻¹  (Hypothesis xy = xz).
-- 2. (y)xx⁻¹  = (z)xx⁻¹  (Associative).
-- 3. yε       = zε       (Right inverse).
-- 4. y        = z        (Right identity).
  begin
    y              ≡⟨ sym (rightIdentity y) ⟩
    y ∙ ε          ≡⟨ subst (λ t → y ∙ ε ≡ y ∙ t)
                            (sym (rightInverse x))
                            refl
                   ⟩
    y ∙ (x ∙ x ⁻¹) ≡⟨ sym (assoc y x (x ⁻¹)) ⟩
    y ∙ x ∙ x ⁻¹   ≡⟨ subst (λ t → y ∙ x ∙ x ⁻¹ ≡ t ∙ x ⁻¹) yx≡zx refl ⟩
    z ∙ x ∙ x ⁻¹   ≡⟨ assoc z x (x ⁻¹) ⟩
    z ∙ (x ∙ x ⁻¹) ≡⟨ subst (λ t → z ∙ (x ∙ x ⁻¹) ≡ z ∙ t)
                            (rightInverse x)
                            refl
                   ⟩
    z ∙ ε          ≡⟨ rightIdentity z ⟩
    z
  ∎

leftCancellation : ∀ {x y z} → x ∙ y ≡ x ∙ z → y ≡ z
leftCancellation {x} {y} {z} xy≡xz =
-- Paper proof:
-- 1. x⁻¹ (xy) = x⁻¹(xz)  (Hypothesis xy = xz).
-- 2. x⁻¹x(y)  = x⁻¹x(z)  (Associative)-
-- 3. εy       = εz       (Left inverse).
-- 4. y        = z        (Left identity).
  begin
    y              ≡⟨ sym (leftIdentity y) ⟩
    ε ∙ y          ≡⟨ subst (λ t → ε ∙ y ≡ t ∙ y) (sym (leftInverse x)) refl ⟩
    x ⁻¹ ∙ x ∙ y   ≡⟨ assoc (x ⁻¹) x y ⟩
    x ⁻¹ ∙ (x ∙ y) ≡⟨ subst (λ t → x ⁻¹ ∙ (x ∙ y) ≡ x ⁻¹ ∙ t) xy≡xz refl ⟩
    x ⁻¹ ∙ (x ∙ z) ≡⟨ sym (assoc (x ⁻¹) x z) ⟩
    x ⁻¹ ∙ x ∙ z   ≡⟨ subst (λ t → x ⁻¹ ∙ x ∙ z ≡ t ∙ z) (leftInverse x) refl ⟩
    ε ∙ z          ≡⟨ leftIdentity z ⟩
    z
  ∎

rightInverseUnique : ∀ {x} → ∃D λ r → (x ∙ r ≡ ε) ∧
                                      (∀ r' → x ∙ r' ≡ ε → r ≡ r')
rightInverseUnique {x} =
-- Paper proof:
-- 1.   We know that (x ⁻¹) is a right inverse for x.
-- 2.   Let's suppose there is other right inverse r for x, i.e. xr ≡ ε, then
-- 2.1. xx⁻¹ = ε  (Right inverse).
-- 2.2. xr   = ε  (Hypothesis).
-- 2.3. xx⁻¹ = xr (Transitivity).
-- 2.4  x⁻¹  = r  (Left cancellation).
  (x ⁻¹) , rightInverse x , λ r' hyp → leftCancellation
    ( begin
        x ∙ x ⁻¹ ≡⟨ rightInverse x ⟩
        ε        ≡⟨ sym hyp ⟩
        x ∙ r'
      ∎
    )

-- A more appropiate version to be used in the proofs.
rightInverseUnique' : ∀ {x r} → x ∙ r ≡ ε → x ⁻¹ ≡ r
rightInverseUnique' {x} {r} = λ hyp → leftCancellation
  ( begin
      x ∙ x ⁻¹ ≡⟨ rightInverse x ⟩
      ε        ≡⟨ sym hyp ⟩
      x ∙ r
    ∎
  )

leftInverseUnique : ∀ {x} → ∃D λ l → (l ∙ x ≡ ε) ∧
                                     (∀ l' → l' ∙ x ≡ ε → l ≡ l')
leftInverseUnique {x} =
-- Paper proof:
-- 1.   We know that (x ⁻¹) is a left inverse for x.
-- 2.   Let's suppose there is other right inverse l for x, i.e. lx ≡ ε, then
-- 2.1. x⁻¹x = ε  (Left inverse).
-- 2.2. lx   = ε  (Hypothesis).
-- 2.3. x⁻¹x = lx (Transitivity).
-- 2.4  x⁻¹  = l  (Right cancellation).
  (x ⁻¹) , leftInverse x , λ l' hyp → rightCancellation
    ( begin
        x ⁻¹ ∙ x ≡⟨ leftInverse x ⟩
        ε ≡⟨ sym hyp ⟩
        l' ∙ x
      ∎
    )

-- A more appropiate version to be used in the proofs.
leftInverseUnique' : ∀ {x l} → l ∙ x ≡ ε → x ⁻¹ ≡ l
leftInverseUnique' {x} {l} = λ hyp → rightCancellation
  ( begin
      x ⁻¹ ∙ x ≡⟨ leftInverse x ⟩
      ε        ≡⟨ sym hyp ⟩
      l ∙ x
    ∎
  )

⁻¹-involutive : ∀ x → x ⁻¹ ⁻¹ ≡ x
-- Paper proof:
-- 1. x⁻¹x = ε  (Left inverse).
-- 2. The previous equation states that x is the unique right
-- inverse (x⁻¹)⁻¹ of x⁻¹.
⁻¹-involutive x = rightInverseUnique' (leftInverse x)

identityInverse : ε ⁻¹ ≡ ε
-- Paper proof:
-- 1. εε = ε  (Left/Right identity).
-- 2. The previous equation states that ε is the unique left/right
-- inverse ε⁻¹ of ε.
identityInverse = rightInverseUnique' (leftIdentity ε)

inverseDistribution : ∀ x y → (x ∙ y) ⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
-- Paper proof:
-- (y⁻¹x⁻¹)(xy) = y⁻¹(x ⁻¹(xy))  (Associative).
--              = y⁻¹(x ⁻¹x)y    (Associative).
--              = y⁻¹(εy)        (Left inverse).
--              = y⁻¹y           (Left identity).
--              = ε              (Left inverse)
-- Therefore, y⁻¹x⁻¹ is the unique left inverse of xy.
inverseDistribution x y = leftInverseUnique' y⁻¹x⁻¹[xy]≡ε
  where
    y⁻¹x⁻¹[xy]≡ε : y ⁻¹ ∙ x ⁻¹ ∙ (x ∙ y) ≡ ε
    y⁻¹x⁻¹[xy]≡ε =
        begin
          y ⁻¹ ∙ x ⁻¹ ∙ (x ∙ y)   ≡⟨ assoc (y ⁻¹) (x ⁻¹) (x ∙ y) ⟩
          y ⁻¹ ∙ (x ⁻¹ ∙ (x ∙ y)) ≡⟨ subst (λ t → y ⁻¹ ∙ (x ⁻¹ ∙ (x ∙ y)) ≡
                                                  y ⁻¹ ∙ t)
                                           (sym (assoc (x ⁻¹) x y))
                                           refl
                                  ⟩
          y ⁻¹ ∙ (x ⁻¹ ∙ x ∙ y)   ≡⟨ subst (λ t → y ⁻¹ ∙ (x ⁻¹ ∙ x ∙ y) ≡
                                                  y ⁻¹ ∙ (t ∙ y))
                                           (leftInverse x)
                                           refl
                                  ⟩
          y ⁻¹ ∙ (ε ∙ y)          ≡⟨ subst (λ t → y ⁻¹ ∙ (ε ∙ y) ≡ y ⁻¹ ∙ t)
                                           (leftIdentity y)
                                           refl
                                  ⟩
          y ⁻¹ ∙ y                ≡⟨ leftInverse y ⟩
          ε
        ∎


flailing at context junk

flailing at context junk

open import Prelude
open import List
open import Nat

module contexts where
  -- variables are named with naturals in ė. therefore we represent
  -- contexts as functions from names for variables (nats) to possible
  -- bindings.
  _ctx : Set → Set
  A ctx = Nat → Maybe A

  -- convenient shorthand for the (unique up to fun. ext.) empty context
  ∅ : {A : Set} → A ctx
  ∅ _ = None

  infixr 100 ■_

  -- membership, or presence, in a context
  _∈_ : {A : Set} (p : Nat × A) → (Γ : A ctx) → Set
  (x , y) ∈ Γ = (Γ x) == Some y

  -- apartness for contexts, so that we can follow barendregt's convention
  _#_ : {A : Set} (n : Nat) → (Γ : A ctx) → Set
  x # Γ = (Γ x) == None

  -- disjointness for contexts
  _##_ : {A : Set} → A ctx → A ctx → Set
  _##_ {A} Γ Γ'  = ((n : Nat) (a : A) → Γ n  == Some a → n # Γ') ×
                   ((n : Nat) (a : A) → Γ' n == Some a → n # Γ )

  -- without: remove a variable from a context
  _//_ : {A : Set} → A ctx → Nat → A ctx
  (Γ // x) y with natEQ x y
  (Γ // x) .x | Inl refl = None
  (Γ // x) y  | Inr neq  = Γ y

  -- a variable is apart from any context from which it is removed
  aar : {A : Set} → (Γ : A ctx) (x : Nat) → x # (Γ // x)
  aar Γ x with natEQ x x
  aar Γ x | Inl refl = refl
  aar Γ x | Inr x≠x  = abort (x≠x refl)

  -- contexts give at most one binding for each variable
  ctxunicity : {A : Set} → {Γ : A ctx} {n : Nat} {t t' : A} →
               (n , t) ∈ Γ →
               (n , t') ∈ Γ →
               t == t'
  ctxunicity {n = n} p q with natEQ n n
  ctxunicity p q | Inl refl = someinj (! p · q)
  ctxunicity _ _ | Inr x≠x = abort (x≠x refl)

  -- warning: this is union but it assumes WITHOUT CHECKING that the
  -- domains are disjoint.
  _∪_ : {A : Set} → A ctx → A ctx → A ctx
  (C1 ∪ C2) x with C1 x
  (C1 ∪ C2) x | Some x₁ = Some x₁
  (C1 ∪ C2) x | None = C2 x

  -- the singleton context
  ■_ : {A : Set} → (Nat × A) → A ctx
  (■ (x , a)) y with natEQ x y
  (■ (x , a)) .x | Inl refl = Some a
  ... | Inr _ = None

  -- add a new binding to the context, clobbering anything that might have
  -- been there before.
  _,,_ : {A : Set} → A ctx → (Nat × A) → A ctx
  (Γ ,, (x , t)) = Γ ∪ (■ (x , t))

  infixl 10 _,,_

  x∈∪l : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ → (n , x) ∈ (Γ ∪ Γ')
  x∈∪l Γ Γ' n x xin with Γ n
  x∈∪l Γ Γ' n x₁ xin | Some x = xin
  x∈∪l Γ Γ' n x ()   | None

  lem-stop : {A : Set} (Γ : A ctx) (x : Nat) → (Σ[ a ∈ A ] ((x , a) ∈ Γ)) + (x # Γ)
  lem-stop Γ x with Γ x
  lem-stop Γ x | Some x₁ = Inl (x₁ , refl)
  lem-stop Γ x | None = Inr refl

  -- x∈∪r Γ Γ' n x xin d with lem-stop Γ n
  -- x∈∪r Γ Γ' n x₁ xin d | Inl (a , ain) = {!ain!}
  -- x∈∪r Γ Γ' n x₁ xin d | Inr x = {!!}

  x∈■ : {A : Set} (n : Nat) (a : A) → (n , a) ∈ (■ (n , a))
  x∈■ n a with natEQ n n
  x∈■ n a | Inl refl = refl
  x∈■ n a | Inr x = abort (x refl)

  postulate -- TODO
    ∪comm : {A : Set} → (C1 C2 : A ctx) → (C1 ∪ C2) == (C2 ∪ C1)
    x∈sing : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ,, (n , a))
    x∈∪r : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ' → Γ ## Γ' → (n , x) ∈ (Γ ∪ Γ')

  -- x∈∪2 Γ Γ' n x₁ xin | None   | _ = abort (somenotnone (! xin))

  -- x∈∪■ : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ∪ (■ (n , a)))
  -- x∈∪■ Γ n a with natEQ n n
  -- x∈∪■ Γ n a | Inl refl = {!!} -- it might be in Γ because i don't know that they're disjoint. this is where that premise gets you
  -- x∈∪■ Γ n a | Inr x = {!!}

  -- x∈sing Γ n a  = {!!} -- x∈∪2 Γ (■ (n , a)) n a (x∈■ n a)

open import Prelude
open import List
open import Nat

module contexts where
  -- variables are named with naturals in ė. therefore we represent
  -- contexts as functions from names for variables (nats) to possible
  -- bindings.
  _ctx : Set → Set
  A ctx = Nat → Maybe A

  -- convenient shorthand for the (unique up to fun. ext.) empty context
  ∅ : {A : Set} → A ctx
  ∅ _ = None

  infixr 100 ■_

  -- membership, or presence, in a context
  _∈_ : {A : Set} (p : Nat × A) → (Γ : A ctx) → Set
  (x , y) ∈ Γ = (Γ x) == Some y

  -- apartness for contexts, so that we can follow barendregt's convention
  _#_ : {A : Set} (n : Nat) → (Γ : A ctx) → Set
  x # Γ = (Γ x) == None

  -- disjointness for contexts
  _##_ : {A : Set} → A ctx → A ctx → Set
  _##_ {A} Γ Γ'  = ((n : Nat) (a : A) → Γ n == Some a → Γ' n == None) ×
                   ((n : Nat) (a : A) → Γ' n == Some a → Γ n == None)

  -- without: remove a variable from a context
  _//_ : {A : Set} → A ctx → Nat → A ctx
  (Γ // x) y with natEQ x y
  (Γ // x) .x | Inl refl = None
  (Γ // x) y  | Inr neq  = Γ y

  -- a variable is apart from any context from which it is removed
  aar : {A : Set} → (Γ : A ctx) (x : Nat) → x # (Γ // x)
  aar Γ x with natEQ x x
  aar Γ x | Inl refl = refl
  aar Γ x | Inr x≠x  = abort (x≠x refl)

  -- contexts give at most one binding for each variable
  ctxunicity : {A : Set} → {Γ : A ctx} {n : Nat} {t t' : A} →
               (n , t) ∈ Γ →
               (n , t') ∈ Γ →
               t == t'
  ctxunicity {n = n} p q with natEQ n n
  ctxunicity p q | Inl refl = someinj (! p · q)
  ctxunicity _ _ | Inr x≠x = abort (x≠x refl)

  -- warning: this is union but it assumes WITHOUT CHECKING that the
  -- domains are disjoint.
  _∪_ : {A : Set} → A ctx → A ctx → A ctx
  (C1 ∪ C2) x with C1 x
  (C1 ∪ C2) x | Some x₁ = Some x₁
  (C1 ∪ C2) x | None = C2 x

  -- the singleton context
  ■_ : {A : Set} → (Nat × A) → A ctx
  (■ (x , a)) y with natEQ x y
  (■ (x , a)) .x | Inl refl = Some a
  ... | Inr _ = None

  -- add a new binding to the context, clobbering anything that might have
  -- been there before.
  _,,_ : {A : Set} → A ctx → (Nat × A) → A ctx
  (Γ ,, (x , t)) = Γ ∪ (■ (x , t))

  infixl 10 _,,_

  x∈∪1 : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ → (n , x) ∈ (Γ ∪ Γ')
  x∈∪1 Γ Γ' n x xin with Γ n
  x∈∪1 Γ Γ' n x₁ xin | Some x = xin
  x∈∪1 Γ Γ' n x ()   | None

  x∈■ : {A : Set} (n : Nat) (a : A) → (n , a) ∈ (■ (n , a))
  x∈■ n a with natEQ n n
  x∈■ n a | Inl refl = refl
  x∈■ n a | Inr x = abort (x refl)

  postulate -- TODO
    x∈sing : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ,, (n , a))
    ∪comm : {A : Set} → (C1 C2 : A ctx) → (C1 ∪ C2) == (C2 ∪ C1)

-- x∈sing Γ n x with Γ n
  -- x∈sing Γ n x  | Some y with natEQ n n
  -- x∈sing Γ n x₁ | Some y | Inl refl = {!!}
  -- x∈sing Γ n x₁ | Some y | Inr x = abort (x refl)
  -- x∈sing Γ n x  | None with natEQ n n
  -- x∈sing Γ n x₁ | None | Inl refl = refl
  -- x∈sing Γ n x₁ | None | Inr x = abort (x refl)

  -- x∈∪2 : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ' → (n , x) ∈ (Γ ∪ Γ')
  -- x∈∪2 Γ Γ' n x xin with Γ' n | Γ n
  -- x∈∪2 Γ Γ' n x₂ xin | Some x | Some x₁ = {!!}
  -- x∈∪2 Γ Γ' n x refl | Some .x | None = {!!}
  -- x∈∪2 Γ Γ' n x₁ xin | None   | _ = abort (somenotnone (! xin))

-- x∈∪■ : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ∪ (■ (n , a)))
  -- x∈∪■ Γ n a with natEQ n n
  -- x∈∪■ Γ n a | Inl refl = {!!} -- it might be in Γ because i don't know that they're disjoint. this is where that premise gets you
  -- x∈∪■ Γ n a | Inr x = {!!}

  -- x∈sing Γ n a  = {!!} -- x∈∪2 Γ (■ (n , a)) n a (x∈■ n a)


Break lines.

Break lines.

Old-commit-hash: c7c69f51c35066147017459aa226bebe26d68df2

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

open import Data.Product
open import Data.Unit

open import Relation.Binary.PropositionalEquality

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Equivalence

open import Changes
open import ChangeContexts

-- DEFINITION of valid changes via a logical relation

{-
What I wanted to write:

data ValidΔ : {T : Type} → (v : ⟦ T ⟧) → (dv : ⟦ Δ-Type T ⟧) → Set where
  base : (v : ⟦ bool ⟧) → (dv : ⟦ Δ-Type bool ⟧) → ValidΔ v dv
  fun : ∀ {S T} → (f : ⟦ S ⇒ T ⟧) → (df : ⟦ Δ-Type (S ⇒ T) ⟧) →
    (∀ (s : ⟦ S ⟧) ds (valid : ValidΔ s ds) → (ValidΔ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))) →
    ValidΔ f df
-}
-- What I had to write:
valid-Δ : {T : Type} → ⟦ T ⟧ → ⟦ Δ-Type T ⟧ → Set
valid-Δ {bool} v dv = ⊤
valid-Δ {S ⇒ T} f df =
  ∀ (s : ⟦ S ⟧) ds (valid-w : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×
    (apply df f) (apply ds s) ≡ apply (df s ds) (f s)

-- LIFTING terms into Δ-Contexts

lift-term : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ τ
lift-term {Γ₁} {Γ₂} {{Γ′}} = weaken (≼-trans ≼-Δ-Context Γ′)

-- PROPERTIES of lift-term

lift-term-ignore : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} {ρ : ⟦ Γ₂ ⟧} (t : Term Γ₁ τ) →
  ⟦ lift-term {{Γ′}} t ⟧ ρ ≡ ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
lift-term-ignore {{Γ′}} {ρ} t = let Γ″ = ≼-trans ≼-Δ-Context Γ′ in
  begin
    ⟦ lift-term {{Γ′}} t ⟧ ρ
  ≡⟨⟩
    ⟦ weaken Γ″ t ⟧ ρ
  ≡⟨ weaken-sound t ρ ⟩
    ⟦ t ⟧ (⟦ ≼-trans ≼-Δ-Context Γ′ ⟧ ρ)
  ≡⟨ cong (λ x → ⟦ t ⟧ x) (⟦⟧-≼-trans ≼-Δ-Context Γ′ ρ) ⟩
    ⟦ t ⟧Term (⟦ ≼-Δ-Context ⟧≼ (⟦ Γ′ ⟧≼ ρ))
  ≡⟨⟩
    ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
  ∎ where open ≡-Reasoning

-- PROPERTIES of Δ

Δ-abs : ∀ {τ₁ τ₂ Γ₁ Γ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t : Term (τ₁ • Γ₁) τ₂) →
  let Γ″ = keep Δ-Type τ₁ • keep τ₁ • Γ′ in
  Δ {{Γ′}} (abs t) ≈ abs (abs (Δ {τ₁ • Γ₁} t))
Δ-abs t = ext-t (λ ρ → refl)

Δ-app : ∀ {Γ₁ Γ₂ τ₁ τ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t₁ : Term Γ₁ (τ₁ ⇒ τ₂)) (t₂ : Term Γ₁ τ₁) →
  Δ {{Γ′}} (app t₁ t₂) ≈ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
Δ-app {{Γ′}} t₁ t₂ = ≈-sym (ext-t (λ ρ′ → let ρ = ⟦ Γ′ ⟧ ρ′ in
  begin
    ⟦ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂) ⟧ ρ′
  ≡⟨⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {{Γ′}} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨⟩
     ⟦ Δ {{Γ′}} (app t₁ t₂) ⟧ ρ′
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var {τ • Γ} this = this
derive-var {τ • Γ} (that x) = that (that (derive-var x))

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs {!!}
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) ({!Δ {Γ} (var this)!}))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term {τ ⇒ τ₁} = λ f₁ f₂ → {!diff-term (f₁ x) (f₂ x)!}
diff-term {bool} = _xor-term_

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = {!!}
apply-term {bool} = _xor-term_

derive-term : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ (Δ-Type τ)
derive-term {Γ₁} {{Γ′}} (abs {τ} t) = abs (abs (derive-term {τ • Γ₁} {{Γ″}} t))
  where Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term {{Γ′}} (app t₁ t₂) = app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
derive-term {{Γ′}} (var x) = var (lift Γ′ (derive-var x))
derive-term {{Γ′}} true = false
derive-term {{Γ′}} false = false
derive-term {{Γ′}} (if c t e) =
  if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} c))
    (diff-term (apply-term (derive-term {{Γ′}} e) (lift-term {{Γ′}} e)) (lift-term {{Γ′}} t))
    (if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} (! c)))
      (diff-term (apply-term (derive-term {{Γ′}} t) (lift-term {{Γ′}} t)) (lift-term {{Γ′}} e))
      (if (lift-term {{Γ′}} c)
        (derive-term {{Γ′}} t)
        (derive-term {{Γ′}} e)))
derive-term {{Γ′}} (Δ {{Γ″}} t) = Δ {{Γ′}} (derive-term {{Γ″}} t)

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → (t : Term Γ₁ τ) →
  Δ {{Γ′}} t ≈ derive-term {{Γ′}} t
derive-term-correct {Γ₁} {{Γ′}} (abs {τ} t) =
  begin
     Δ (abs t)
  ≈⟨  Δ-abs t  ⟩
     abs (abs (Δ {τ • Γ₁} t))
  ≈⟨  ≈-abs (≈-abs (derive-term-correct {τ • Γ₁} t))  ⟩
     abs (abs (derive-term {τ • Γ₁} t))
  ≡⟨⟩
     derive-term (abs t)
  ∎ where
      open ≈-Reasoning
      Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term-correct {Γ₁} {{Γ′}} (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨  Δ-app t₁ t₂  ⟩
     app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
  ≈⟨  ≈-app (≈-app (derive-term-correct {{Γ′}} t₁) ≈-refl) (derive-term-correct {{Γ′}} t₂)  ⟩
     app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
  ≡⟨⟩
    derive-term {{Γ′}} (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct {Γ₁} {{Γ′}} (var x) = ext-t (λ ρ →
  begin
    ⟦ Δ {{Γ′}} (var x) ⟧ ρ
  ≡⟨⟩
    diff
      (⟦ x ⟧ (update (⟦ Γ′ ⟧ ρ)))
      (⟦ x ⟧ (ignore (⟦ Γ′ ⟧ ρ)))
  ≡⟨  derive-var-correct {Γ₁} (⟦ Γ′ ⟧ ρ) x  ⟩
    ⟦ derive-var x ⟧Var (⟦ Γ′ ⟧ ρ)
  ≡⟨ sym (lift-sound Γ′ (derive-var x) ρ) ⟩
    ⟦ lift Γ′ (derive-var x) ⟧Var ρ
  ∎) where open ≡-Reasoning
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

open import Data.Product
open import Data.Unit

open import Relation.Binary.PropositionalEquality

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Equivalence

open import Changes
open import ChangeContexts

-- DEFINITION of valid changes via a logical relation

{-
What I wanted to write:

data ValidΔ : {T : Type} → (v : ⟦ T ⟧) → (dv : ⟦ Δ-Type T ⟧) → Set where
  base : (v : ⟦ bool ⟧) → (dv : ⟦ Δ-Type bool ⟧) → ValidΔ v dv
  fun : ∀ {S T} → (f : ⟦ S ⇒ T ⟧) → (df : ⟦ Δ-Type (S ⇒ T) ⟧) →
    (∀ (s : ⟦ S ⟧) ds (valid : ValidΔ s ds) → (ValidΔ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))) →
    ValidΔ f df
-}
-- What I had to write:
valid-Δ : {T : Type} → ⟦ T ⟧ → ⟦ Δ-Type T ⟧ → Set
valid-Δ {bool} v dv = ⊤
valid-Δ {S ⇒ T} f df = ∀ (s : ⟦ S ⟧) ds (valid-w : valid-Δ s ds) → (valid-Δ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))

-- LIFTING terms into Δ-Contexts

lift-term : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ τ
lift-term {Γ₁} {Γ₂} {{Γ′}} = weaken (≼-trans ≼-Δ-Context Γ′)

-- PROPERTIES of lift-term

lift-term-ignore : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} {ρ : ⟦ Γ₂ ⟧} (t : Term Γ₁ τ) →
  ⟦ lift-term {{Γ′}} t ⟧ ρ ≡ ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
lift-term-ignore {{Γ′}} {ρ} t = let Γ″ = ≼-trans ≼-Δ-Context Γ′ in
  begin
    ⟦ lift-term {{Γ′}} t ⟧ ρ
  ≡⟨⟩
    ⟦ weaken Γ″ t ⟧ ρ
  ≡⟨ weaken-sound t ρ ⟩
    ⟦ t ⟧ (⟦ ≼-trans ≼-Δ-Context Γ′ ⟧ ρ)
  ≡⟨ cong (λ x → ⟦ t ⟧ x) (⟦⟧-≼-trans ≼-Δ-Context Γ′ ρ) ⟩
    ⟦ t ⟧Term (⟦ ≼-Δ-Context ⟧≼ (⟦ Γ′ ⟧≼ ρ))
  ≡⟨⟩
    ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
  ∎ where open ≡-Reasoning

-- PROPERTIES of Δ

Δ-abs : ∀ {τ₁ τ₂ Γ₁ Γ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t : Term (τ₁ • Γ₁) τ₂) →
  let Γ″ = keep Δ-Type τ₁ • keep τ₁ • Γ′ in
  Δ {{Γ′}} (abs t) ≈ abs (abs (Δ {τ₁ • Γ₁} t))
Δ-abs t = ext-t (λ ρ → refl)

Δ-app : ∀ {Γ₁ Γ₂ τ₁ τ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t₁ : Term Γ₁ (τ₁ ⇒ τ₂)) (t₂ : Term Γ₁ τ₁) →
  Δ {{Γ′}} (app t₁ t₂) ≈ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
Δ-app {{Γ′}} t₁ t₂ = ≈-sym (ext-t (λ ρ′ → let ρ = ⟦ Γ′ ⟧ ρ′ in
  begin
    ⟦ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂) ⟧ ρ′
  ≡⟨⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {{Γ′}} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨⟩
     ⟦ Δ {{Γ′}} (app t₁ t₂) ⟧ ρ′
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var {τ • Γ} this = this
derive-var {τ • Γ} (that x) = that (that (derive-var x))

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs {!!}
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) ({!Δ {Γ} (var this)!}))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term {τ ⇒ τ₁} = λ f₁ f₂ → {!diff-term (f₁ x) (f₂ x)!}
diff-term {bool} = _xor-term_

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = {!!}
apply-term {bool} = _xor-term_

derive-term : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ (Δ-Type τ)
derive-term {Γ₁} {{Γ′}} (abs {τ} t) = abs (abs (derive-term {τ • Γ₁} {{Γ″}} t))
  where Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term {{Γ′}} (app t₁ t₂) = app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
derive-term {{Γ′}} (var x) = var (lift Γ′ (derive-var x))
derive-term {{Γ′}} true = false
derive-term {{Γ′}} false = false
derive-term {{Γ′}} (if c t e) =
  if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} c))
    (diff-term (apply-term (derive-term {{Γ′}} e) (lift-term {{Γ′}} e)) (lift-term {{Γ′}} t))
    (if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} (! c)))
      (diff-term (apply-term (derive-term {{Γ′}} t) (lift-term {{Γ′}} t)) (lift-term {{Γ′}} e))
      (if (lift-term {{Γ′}} c)
        (derive-term {{Γ′}} t)
        (derive-term {{Γ′}} e)))
derive-term {{Γ′}} (Δ {{Γ″}} t) = Δ {{Γ′}} (derive-term {{Γ″}} t)

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → (t : Term Γ₁ τ) →
  Δ {{Γ′}} t ≈ derive-term {{Γ′}} t
derive-term-correct {Γ₁} {{Γ′}} (abs {τ} t) =
  begin
     Δ (abs t)
  ≈⟨  Δ-abs t  ⟩
     abs (abs (Δ {τ • Γ₁} t))
  ≈⟨  ≈-abs (≈-abs (derive-term-correct {τ • Γ₁} t))  ⟩
     abs (abs (derive-term {τ • Γ₁} t))
  ≡⟨⟩
     derive-term (abs t)
  ∎ where
      open ≈-Reasoning
      Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term-correct {Γ₁} {{Γ′}} (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨  Δ-app t₁ t₂  ⟩
     app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
  ≈⟨  ≈-app (≈-app (derive-term-correct {{Γ′}} t₁) ≈-refl) (derive-term-correct {{Γ′}} t₂)  ⟩
     app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
  ≡⟨⟩
    derive-term {{Γ′}} (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct {Γ₁} {{Γ′}} (var x) = ext-t (λ ρ →
  begin
    ⟦ Δ {{Γ′}} (var x) ⟧ ρ
  ≡⟨⟩
    diff
      (⟦ x ⟧ (update (⟦ Γ′ ⟧ ρ)))
      (⟦ x ⟧ (ignore (⟦ Γ′ ⟧ ρ)))
  ≡⟨  derive-var-correct {Γ₁} (⟦ Γ′ ⟧ ρ) x  ⟩
    ⟦ derive-var x ⟧Var (⟦ Γ′ ⟧ ρ)
  ≡⟨ sym (lift-sound Γ′ (derive-var x) ρ) ⟩
    ⟦ lift Γ′ (derive-var x) ⟧Var ρ
  ∎) where open ≡-Reasoning
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)