Clarify that change algebra operations trivially preserve d.o.e.

Old-commit-hash: c11fb0c1abae938f0c7ec3dacff96f112f6bbee4

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

-- Extension Point: None (currently). Do we need to allow plugins to customize
-- this concept?
Structure : Set
Structure = Unit

module Structure (unused : Structure) where

  module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set a
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely.
    --
    -- * That should be be true for
    --   functions using changes parametrically.
    --
    -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
    --   this is proved below on both contexts at once by fun-change-respects.
    --
    -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
    --   it by definition, and ⊟ doesn't take change arguments - we will only
    --   need a proof for compose, when we define it.
    --
    -- Stating the general result, though, seems hard, we should
    -- rather have lemmas proving that certain classes of functions respect this
    -- equivalence.

  module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
    {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

    module FC = FunctionChanges A B {{CA}} {{CB}}
    open FC using (changeAlgebra; incrementalization)
    open FC.FunctionChange

    fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
      df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
    fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = lemma
      where
        open ≡-Reasoning
        open import Postulate.Extensionality
        -- This type signature just expands the goal manually a bit.
        lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
        -- Informally: use incrementalization on both sides and then apply
        -- congruence.
        lemma =
          begin
            f x ⊞ apply df₁ x dx₁
          ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
            (f ⊞ df₁) (x ⊞ dx₁)
          ≡⟨ cong (f ⊞ df₁) dx₁≙dx₂ ⟩
            (f ⊞ df₁) (x ⊞ dx₂)
          ≡⟨ cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
            (f ⊞ df₂) (x ⊞ dx₂)
          ≡⟨ incrementalization f df₂ x dx₂ ⟩
            f x ⊞ apply df₂ x dx₂
          ∎

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

-- Extension Point: None (currently). Do we need to allow plugins to customize
-- this concept?
Structure : Set
Structure = Unit

module Structure (unused : Structure) where

  module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set a
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely.
    --
    -- * That should be be true for
    --   functions using changes parametrically.
    --
    -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
    --   this is proved below on both contexts at once by fun-change-respects.
    --
    -- * Finally, change algebra operations should respect d.o.e.
    --
    -- Stating the general result, though, seems hard, we should
    -- rather have lemmas proving that certain classes of functions respect this
    -- equivalence.

  module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
    {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

    module FC = FunctionChanges A B {{CA}} {{CB}}
    open FC using (changeAlgebra; incrementalization)
    open FC.FunctionChange

    fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
      df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
    fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = lemma
      where
        open ≡-Reasoning
        open import Postulate.Extensionality
        -- This type signature just expands the goal manually a bit.
        lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
        -- Informally: use incrementalization on both sides and then apply
        -- congruence.
        lemma =
          begin
            f x ⊞ apply df₁ x dx₁
          ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
            (f ⊞ df₁) (x ⊞ dx₁)
          ≡⟨ cong (f ⊞ df₁) dx₁≙dx₂ ⟩
            (f ⊞ df₁) (x ⊞ dx₂)
          ≡⟨ cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
            (f ⊞ df₂) (x ⊞ dx₂)
          ≡⟨ incrementalization f df₂ x dx₂ ⟩
            f x ⊞ apply df₂ x dx₂
          ∎


Updated a note about the existential quantifier.

Ignore-this: 8ad5316e644cba628b19f41d007d533

darcs-hash:20111130164653-3bd4e-9e00b7c21e8e910b34ab599f2d86be3c0e7b3570.gz

-- Tested on 30 November 2011.

module Existential where

postulate
  D       : Set
  ∃       : (P : D → Set) → Set
  _,_     : {P : D → Set}(d : D) → P d → ∃ P
  ∃-proj₁ : {P : D → Set} → ∃ P → D
  ∃-proj₂ : {P : D → Set}(p : ∃ P) → P (∃-proj₁ p)

syntax ∃ (λ x → e) = ∃[ x ] e

postulate P : D → D → Set

∃∀ : ∃[ x ](∀ y → P x y) → ∀ y → ∃[ x ] P x y
∃∀ h y = ∃-proj₁ h , (∃-proj₂ h) y

module Existential where

postulate
  D       : Set
  ∃       : (P : D → Set) → Set
  _,_     : {P : D → Set}(d : D) → P d → ∃ P
  ∃-proj₁ : {P : D → Set} → ∃ P → D
  ∃-proj₂ : {P : D → Set}(p : ∃ P) → P (∃-proj₁ p)

postulate P : D → D → Set

∃∀ : (∃ λ x → ∀ y → P x y) → ∀ y → ∃ λ x → P x y
∃∀ h y = ∃-proj₁ h , (∃-proj₂ h) y


Improved some proofs.

Improved some proofs.

Ignore-this: e7e0889f7060eb9f3adde2de878ad1d3

darcs-hash:20100524023850-3bd4e-59dcde27415395528e46b6323c5698f04b5ddac0.gz

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

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n
-- {-# ATP hint x≥0 #-}

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

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<0 (sN Nn) Sn<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}

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

postulate
  ¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
{-# ATP prove ¬S≤0 #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
    postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
    {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
    postulate prf : ¬ (LT m m) → ⊥
    {-# ATP prove prf #-}

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn)          _     = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE m n →
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

x<y→Sx≤y : {m n : D} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm zN m<0 = ⊥-elim (¬x<0 Nm m<0)

x<y→Sx≤y zN (sN zN) _ = S0≤S0
  where
    postulate S0≤S0 : LE (succ zero) (succ zero)
    {-# ATP prove S0≤S0 #-}

x<y→Sx≤y zN (sN (sN {n} Nn)) _ = S0≤SSn
  where
    postulate S0≤SSn : LE (succ zero) (succ (succ n))
    {-# ATP prove S0≤SSn #-}
    -- trans (lt-SS (succ n) zero) (lt-S0 n)

x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→Sx≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE (succ m) n → LE (succ (succ m)) (succ n)
    {-# ATP prove prf #-}

Sx≤y→x<y : {m n : D} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim (¬S≤0 Sm≤0)
Sx≤y→x<y zN          (sN {n} Nn) _      = lt-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn = prf (Sx≤y→x<y Nm Nn Sm≤n)
  where
    postulate Sm≤n : LE (succ m) n
    {-# ATP prove Sm≤n #-}

    postulate prf : LT m n → LT (succ m) (succ n)
    {-# ATP prove prf #-}

<-trans : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
<-trans zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
<-trans zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
<-trans (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
<-trans (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  prf (<-trans Nm Nn No m<n n<o)

  where
    postulate prf : LT m o → LT (succ m) (succ o)
    {-# ATP prove prf #-}

    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate n<o : LT n o
    {-# ATP prove n<o #-}

≤-trans : {m n o : D} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim (¬S≤0 Sm≤0)
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim (¬S≤0 Sn≤0)
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  prf (≤-trans Nm Nn No m≤n n≤o)
    where
      postulate m≤n : LE m n
      {-# ATP prove m≤n #-}

      postulate n≤o : LE n o
      {-# ATP prove n≤o #-}

      postulate prf : LE m o → LE (succ m) (succ o)
      {-# ATP prove prf #-}

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

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
    postulate prf : LE m (m + n) → LE (succ m) (succ m + n)
    {-# ATP prove prf #-}

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

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

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
    postulate prf : LT (m - n) (succ m) →
                    LT (succ m - succ n) (succ (succ m))
    {-# ATP prove prf <-trans minus-N x<Sx sN #-}

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

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

    postulate prf : (m - n) + n ≡ m →
                    (succ m - succ n) + succ n ≡ succ m
    {-# ATP prove prf +-comm minus-N sN #-}

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

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

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

    postulate prf : (n - m) + m ≡ n →
                    (succ n - succ m) + succ m ≡ succ n
    {-# ATP prove prf +-comm minus-N sN #-}

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

postulate
  ¬xy<00 : {m n : D} → N m → N n → ¬ (LT₂ m n zero zero)
{-# ATP prove ¬xy<00 ¬x<0 #-}

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

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

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n
-- {-# ATP hint x≥0 #-}

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

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<0 (sN Nn) Sn<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf x≥0 #-}

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 Sd≤0 = ⊥-elim prf
  where
    -- The proof uses the axiom true≠false
    postulate prf : ⊥
    {-# ATP prove prf #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
    postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
    {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
    postulate prf : ¬ (LT m m) → ⊥
    {-# ATP prove prf #-}

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn)          _     = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE m n →
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

x<y→Sx≤y : {m n : D} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm zN m<0 = ⊥-elim (¬x<0 Nm m<0)

x<y→Sx≤y zN (sN zN) _ = S0≤S0
  where
    postulate S0≤S0 : LE (succ zero) (succ zero)
    {-# ATP prove S0≤S0 #-}

x<y→Sx≤y zN (sN (sN {n} Nn)) _ = S0≤SSn
  where
    postulate S0≤SSn : LE (succ zero) (succ (succ n))
    {-# ATP prove S0≤SSn #-}
    -- trans (lt-SS (succ n) zero) (lt-S0 n)

x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→Sx≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE (succ m) n → LE (succ (succ m)) (succ n)
    {-# ATP prove prf #-}

Sx≤y→x<y : {m n : D} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim (¬S≤0 Sm≤0)
Sx≤y→x<y zN          (sN {n} Nn) _      = lt-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn = prf (Sx≤y→x<y Nm Nn Sm≤n)
  where
    postulate Sm≤n : LE (succ m) n
    {-# ATP prove Sm≤n #-}

    postulate prf : LT m n → LT (succ m) (succ n)
    {-# ATP prove prf #-}

<-trans : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
<-trans zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
<-trans zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
<-trans (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
<-trans (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  prf (<-trans Nm Nn No m<n n<o)

  where
    postulate prf : LT m o → LT (succ m) (succ o)
    {-# ATP prove prf #-}

    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate n<o : LT n o
    {-# ATP prove n<o #-}

≤-trans : {m n o : D} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim (¬S≤0 Sm≤0)
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim (¬S≤0 Sn≤0)
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  prf (≤-trans Nm Nn No m≤n n≤o)
    where
      postulate m≤n : LE m n
      {-# ATP prove m≤n #-}

      postulate n≤o : LE n o
      {-# ATP prove n≤o #-}

      postulate prf : LE m o → LE (succ m) (succ o)
      {-# ATP prove prf #-}

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

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
    postulate prf : LE m (m + n) → LE (succ m) (succ m + n)
    {-# ATP prove prf #-}

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

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

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
    postulate prf : LT (m - n) (succ m) →
                    LT (succ m - succ n) (succ (succ m))
    {-# ATP prove prf <-trans minus-N x<Sx sN #-}

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

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

    postulate prf : (m - n) + n ≡ m →
                    (succ m - succ n) + succ n ≡ succ m
    {-# ATP prove prf +-comm minus-N sN #-}

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

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

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

    postulate prf : (n - m) + m ≡ n →
                    (succ n - succ m) + succ m ≡ succ n
    {-# ATP prove prf +-comm minus-N sN #-}

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

postulate
  ¬xy<00 : {m n : D} → N m → N n → ¬ (LT₂ m n zero zero)
{-# ATP prove ¬xy<00 ¬x<0 #-}

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}


Add Pullback

Add Pullback

{-# OPTIONS --without-K #-}
-- move this to propeq
module Relation.Binary.PropositionalEquality.NP where

open import Type hiding (★)
open import Data.One using (𝟙)
open import Data.Product using (Σ; _,_)
open import Relation.Binary.PropositionalEquality public hiding (module ≡-Reasoning)
open import Relation.Binary.NP
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
open import Relation.Nullary

private
  module Dummy {a} {A : ★ a} where
    open IsEquivalence (isEquivalence {a} {A}) public hiding (refl; sym; trans)
open Dummy public

PathOver : ∀ {i j} {A : ★ i} (B : A → ★ j)
  {x y : A} (p : x ≡ y) (u : B x) (v : B y) → ★ j
PathOver B refl u v = (u ≡ v)

syntax PathOver B p u v =
  u ≡ v [ B ↓ p ]

-- Some definitions with the names from Agda-HoTT
-- this is only a temporary state of affairs...
module _ {a} {A : ★ a} where

    idp : {x : A} → x ≡ x
    idp = refl

    infixr 8 _∙_ _∙'_

    _∙_ _∙'_ : {x y z : A} → (x ≡ y → y ≡ z → x ≡ z)

    refl ∙ q  = q
    q ∙' refl = q

    ! : {x y : A} → (x ≡ y → y ≡ x)
    ! refl = refl

ap↓ : ∀ {i j k} {A : ★ i} {B : A → ★ j} {C : A → ★ k}
  (g : {a : A} → B a → C a) {x y : A} {p : x ≡ y}
  {u : B x} {v : B y}
  → (u ≡ v [ B ↓ p ] → g u ≡ g v [ C ↓ p ])
ap↓ g {p = refl} refl = refl

ap : ∀ {i j} {A : ★ i} {B : ★ j} (f : A → B) {x y : A}
  → (x ≡ y → f x ≡ f y)
ap f p = ap↓ {A = 𝟙} f {p = refl} p

apd : ∀ {i j} {A : ★ i} {B : A → ★ j} (f : (a : A) → B a) {x y : A}
  → (p : x ≡ y) → f x ≡ f y [ B ↓ p ]
apd f refl = refl

coe : ∀ {i} {A B : ★ i} (p : A ≡ B) → A → B
coe refl x = x

coe! : ∀ {i} {A B : ★ i} (p : A ≡ B) → B → A
coe! refl x = x

cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
          (f : A → B → C → D) {a₁ a₂ b₁ b₂ c₁ c₂}
        → a₁ ≡ a₂ → b₁ ≡ b₂ → c₁ ≡ c₂ → f a₁ b₁ c₁ ≡ f a₂ b₂ c₂
cong₃ f refl refl refl = refl

_≗₂_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c} (f g : A → B → C) → ★ _
f ≗₂ g = ∀ x y → f x y ≡ g x y

module _ {a} {A : ★ a} where
  injective : InjectiveRel A _≡_
  injective p q = p ∙ ! q

  surjective : SurjectiveRel A _≡_
  surjective p q = ! p ∙ q

  bijective : BijectiveRel A _≡_
  bijective = record { injectiveREL = injective; surjectiveREL = surjective }

  Equalizer : ∀ {b} {B : A → ★ b} (f g : (x : A) → B x) → ★ _
  Equalizer f g = Σ A (λ x → f x ≡ g x)
  {- In a category theory context this type would the object 'E'
     and 'proj₁' would be the morphism 'eq : E → A' such that
     given any object O, and morphism 'm : O → A', there exists
     a unique morphism 'u : O → E' such that 'eq ∘ u ≡ m'.
  -}

  Pullback : ∀ {b c} {B : ★ b} {C : ★ c} (f : A → C) (g : B → C) → ★ _
  Pullback {B = B} f g = Σ A (λ x → Σ B (λ y → f x ≡ g y))

module ≡-Reasoning {a} {A : ★ a} where
  open Setoid-Reasoning (setoid A) public renaming (_≈⟨_⟩_ to _≡⟨_⟩_)

module ≗-Reasoning {a b} {A : ★ a} {B : ★ b} where
  open Setoid-Reasoning (A →-setoid B) public renaming (_≈⟨_⟩_ to _≗⟨_⟩_)

data ⟦≡⟧ {a₁ a₂ aᵣ}
         {A₁ A₂} (Aᵣ : ⟦★⟧ {a₁} {a₂} aᵣ A₁ A₂)
         {x₁ x₂} (xᵣ : Aᵣ x₁ x₂)
       : (Aᵣ ⟦→⟧ ⟦★⟧ aᵣ) (_≡_ x₁) (_≡_ x₂) where
    -- : ∀ {y₁ y₂} (yᵣ : Aᵣ y₁ y₂) → x₁ ≡ y₁ → x₂ ≡ y₂ → ★
  ⟦refl⟧ : ⟦≡⟧ Aᵣ xᵣ xᵣ refl refl

-- Double checking level 0 with a direct ⟦_⟧ encoding
private
  ⟦≡⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦★₀⟧) _≡_ _≡_
  ⟦≡⟧′ = ⟦≡⟧

  ⟦refl⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟦≡⟧ Aᵣ xᵣ xᵣ) refl refl
  ⟦refl⟧′ _ _ = ⟦refl⟧

{-# OPTIONS --without-K #-}
-- move this to propeq
module Relation.Binary.PropositionalEquality.NP where

open import Type hiding (★)
open import Data.One using (𝟙)
open import Data.Product using (Σ; _,_)
open import Relation.Binary.PropositionalEquality public hiding (module ≡-Reasoning)
open import Relation.Binary.NP
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
open import Relation.Nullary

private
  module Dummy {a} {A : ★ a} where
    open IsEquivalence (isEquivalence {a} {A}) public hiding (refl; sym; trans)
open Dummy public

PathOver : ∀ {i j} {A : ★ i} (B : A → ★ j)
  {x y : A} (p : x ≡ y) (u : B x) (v : B y) → ★ j
PathOver B refl u v = (u ≡ v)

syntax PathOver B p u v =
  u ≡ v [ B ↓ p ]

-- Some definitions with the names from Agda-HoTT
-- this is only a temporary state of affairs...
module _ {a} {A : ★ a} where

    idp : {x : A} → x ≡ x
    idp = refl

    infixr 8 _∙_ _∙'_

    _∙_ _∙'_ : {x y z : A} → (x ≡ y → y ≡ z → x ≡ z)

    refl ∙ q  = q
    q ∙' refl = q

    ! : {x y : A} → (x ≡ y → y ≡ x)
    ! refl = refl

ap↓ : ∀ {i j k} {A : ★ i} {B : A → ★ j} {C : A → ★ k}
  (g : {a : A} → B a → C a) {x y : A} {p : x ≡ y}
  {u : B x} {v : B y}
  → (u ≡ v [ B ↓ p ] → g u ≡ g v [ C ↓ p ])
ap↓ g {p = refl} refl = refl

ap : ∀ {i j} {A : ★ i} {B : ★ j} (f : A → B) {x y : A}
  → (x ≡ y → f x ≡ f y)
ap f p = ap↓ {A = 𝟙} f {p = refl} p

apd : ∀ {i j} {A : ★ i} {B : A → ★ j} (f : (a : A) → B a) {x y : A}
  → (p : x ≡ y) → f x ≡ f y [ B ↓ p ]
apd f refl = refl

coe : ∀ {i} {A B : ★ i} (p : A ≡ B) → A → B
coe refl x = x

coe! : ∀ {i} {A B : ★ i} (p : A ≡ B) → B → A
coe! refl x = x

cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
          (f : A → B → C → D) {a₁ a₂ b₁ b₂ c₁ c₂}
        → a₁ ≡ a₂ → b₁ ≡ b₂ → c₁ ≡ c₂ → f a₁ b₁ c₁ ≡ f a₂ b₂ c₂
cong₃ f refl refl refl = refl

_≗₂_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c} (f g : A → B → C) → ★ _
f ≗₂ g = ∀ x y → f x y ≡ g x y

module _ {a} {A : ★ a} where
  injective : InjectiveRel A _≡_
  injective p q = p ∙ ! q

  surjective : SurjectiveRel A _≡_
  surjective p q = ! p ∙ q

  bijective : BijectiveRel A _≡_
  bijective = record { injectiveREL = injective; surjectiveREL = surjective }

  Equalizer : ∀ {b} {B : A → ★ b} (f g : (x : A) → B x) → ★ _
  Equalizer f g = Σ A (λ x → f x ≡ g x)
  {- In a category theory context this type would the object 'E'
     and 'proj₁' would be the morphism 'eq : E → A' such that
     given any object O, and morphism 'm : O → A', there exists
     a unique morphism 'u : O → E' such that 'eq ∘ u ≡ m'.
  -}

module ≡-Reasoning {a} {A : ★ a} where
  open Setoid-Reasoning (setoid A) public renaming (_≈⟨_⟩_ to _≡⟨_⟩_)

module ≗-Reasoning {a b} {A : ★ a} {B : ★ b} where
  open Setoid-Reasoning (A →-setoid B) public renaming (_≈⟨_⟩_ to _≗⟨_⟩_)

data ⟦≡⟧ {a₁ a₂ aᵣ}
         {A₁ A₂} (Aᵣ : ⟦★⟧ {a₁} {a₂} aᵣ A₁ A₂)
         {x₁ x₂} (xᵣ : Aᵣ x₁ x₂)
       : (Aᵣ ⟦→⟧ ⟦★⟧ aᵣ) (_≡_ x₁) (_≡_ x₂) where
    -- : ∀ {y₁ y₂} (yᵣ : Aᵣ y₁ y₂) → x₁ ≡ y₁ → x₂ ≡ y₂ → ★
  ⟦refl⟧ : ⟦≡⟧ Aᵣ xᵣ xᵣ refl refl

-- Double checking level 0 with a direct ⟦_⟧ encoding
private
  ⟦≡⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦★₀⟧) _≡_ _≡_
  ⟦≡⟧′ = ⟦≡⟧

  ⟦refl⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟦≡⟧ Aᵣ xᵣ xᵣ) refl refl
  ⟦refl⟧′ _ _ = ⟦refl⟧


Added k+x<k+y→x<y, x+k<y+k→x<y, x≤y→k+x≤k+y, and x≤y→x+k≤y+k (by Ana Bove).

Ignore-this: 19939ad70cf6f4e2b6769c003e6cac94

darcs-hash:20110211223354-3bd4e-20a00dcb2be3438bc3743b5a7c5fb70375b9d550.gz

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

module LTC.Data.Nat.Inequalities.PropertiesATP where

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

open import Common.Function using ( _$_ )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

postulate
  x>y→x≤y→⊥ : ∀ {m n} → N m → N n → GT m n → LE m n → ⊥
{-# ATP prove x>y→x≤y→⊥ x>y→x≰y #-}

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

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

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

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

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

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

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

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

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

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

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

k+x<k+y→x<y : ∀ {m n k} → N m → N n → N k → LT (k + m) (k + n) → LT m n
k+x<k+y→x<y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LT m n
    {-# ATP prove prf0 #-}
k+x<k+y→x<y {m} {n} Nm Nn (sN {k} Nk) h = k+x<k+y→x<y Nm Nn Nk prfS
  where
    postulate prfS : LT (k + m) (k + n)
    {-# ATP prove prfS #-}

postulate x+k<y+k→x<y : ∀ {m n k} → N m → N n → N k →
                        LT (m + k) (n + k) → LT m n
{-# ATP prove x+k<y+k→x<y k+x<k+y→x<y +-comm #-}

x≤y→k+x≤k+y : ∀ {m n k} → N m → N n → N k → LE m n → LE (k + m) (k + n)
x≤y→k+x≤k+y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LE (zero + m) (zero + n)
    {-# ATP prove prf0 #-}
x≤y→k+x≤k+y {m} {n} Nm Nn (sN {k} Nk) h = prfS (x≤y→k+x≤k+y Nm Nn Nk h)
  where
    postulate prfS : LE (k + m) (k + n) → LE (succ k + m) (succ k + n)
    {-# ATP prove prfS #-}

postulate x≤y→x+k≤y+k : ∀ {m n k} → N m → N n → N k → LE m n →
                        LE (m + k) (n + k)
{-# ATP prove x≤y→x+k≤y+k x≤y→k+x≤k+y +-comm #-}

x<y→Sx-y≡0 : ∀ {m n} → N m → N n → LT m n → succ m ∸ n ≡ zero
x<y→Sx-y≡0 Nm zN h = ⊥-elim (¬x<0 Nm h)
x<y→Sx-y≡0 zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : succ zero ∸ succ n ≡ zero
    {-# ATP prove prf0S ∸-0x #-}
x<y→Sx-y≡0 (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→Sx-y≡0 Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : succ m ∸ n ≡ zero → succ (succ m) ∸ succ n ≡ zero
    {-# ATP prove prfSS #-}

postulate x≤y→x-y≡0 : ∀ {m n} → N m → N n → LE m n → (m ∸ n) ≡ zero
{-# ATP prove x≤y→x-y≡0 x<y→Sx-y≡0 #-}

x<y→0<x-y : ∀ {m n} → N m → N n → LT m n → LT zero (n ∸ m)
x<y→0<x-y Nm zN h = ⊥-elim (¬x<0 Nm h)
x<y→0<x-y zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : LT zero (succ n ∸ zero)
    {-# ATP prove prf0S #-}

x<y→0<x-y (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→0<x-y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : LT zero (n ∸ m) → LT zero (succ n ∸ succ m)
    {-# ATP prove prfSS #-}

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

0<x-y→0<Sx-y zN (sN {n} Nn) h = ⊥-elim (¬x<0 zN h')
  where
    postulate h' : LT zero zero
    {-# ATP prove h' #-}

0<x-y→0<Sx-y (sN {m} Nm) (sN {n} Nn) h = prfSS (0<x-y→0<Sx-y Nm Nn 0<m-n)
  where
    postulate 0<m-n : LT zero (m ∸ n)
    {-# ATP prove 0<m-n #-}

    postulate prfSS : LT zero (succ m ∸ n) → LT zero (succ (succ m) ∸ succ n)
    {-# ATP prove prfSS <-trans #-}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module LTC.Data.Nat.Inequalities.PropertiesATP where

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

open import Common.Function using ( _$_ )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

postulate
  x>y→x≤y→⊥ : ∀ {m n} → N m → N n → GT m n → LE m n → ⊥
{-# ATP prove x>y→x≤y→⊥ x>y→x≰y #-}

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

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

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

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

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

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

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

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

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

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

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

x<y→Sx-y≡0 : ∀ {m n} → N m → N n → LT m n → succ m ∸ n ≡ zero
x<y→Sx-y≡0 Nm zN h = ⊥-elim (¬x<0 Nm h)
x<y→Sx-y≡0 zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : succ zero ∸ succ n ≡ zero
    {-# ATP prove prf0S ∸-0x #-}
x<y→Sx-y≡0 (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→Sx-y≡0 Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : succ m ∸ n ≡ zero → succ (succ m) ∸ succ n ≡ zero
    {-# ATP prove prfSS #-}

postulate x≤y→x-y≡0 : ∀ {m n} → N m → N n → LE m n → (m ∸ n) ≡ zero
{-# ATP prove x≤y→x-y≡0 x<y→Sx-y≡0 #-}

x<y→0<x-y : ∀ {m n} → N m → N n → LT m n → LT zero (n ∸ m)
x<y→0<x-y Nm zN h = ⊥-elim (¬x<0 Nm h)
x<y→0<x-y zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : LT zero (succ n ∸ zero)
    {-# ATP prove prf0S #-}

x<y→0<x-y (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→0<x-y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : LT zero (n ∸ m) → LT zero (succ n ∸ succ m)
    {-# ATP prove prfSS #-}

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

0<x-y→0<Sx-y zN (sN {n} Nn) h = ⊥-elim (¬x<0 zN h')
  where
    postulate h' : LT zero zero
    {-# ATP prove h' #-}

0<x-y→0<Sx-y (sN {m} Nm) (sN {n} Nn) h = prfSS (0<x-y→0<Sx-y Nm Nn 0<m-n)
  where
    postulate 0<m-n : LT zero (m ∸ n)
    {-# ATP prove 0<m-n #-}

    postulate prfSS : LT zero (succ m ∸ n) → LT zero (succ (succ m) ∸ succ n)
    {-# ATP prove prfSS <-trans #-}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Added _,′_.

Added _,′_.

Ignore-this: 34840168d583b411434a67ebf23718cd

darcs-hash:20110527133955-3bd4e-2f779c560176c046f7fa6fe1f150539215ad6c34.gz

------------------------------------------------------------------------------
-- Products
------------------------------------------------------------------------------

module Common.Data.Product where

open import Common.Universe using ( D )

-- We add 3 to the fixities of the standard library.
infixr 7 _,_ _,′_
infixr 5 _∧_

------------------------------------------------------------------------------
-- The conjunction data type.

-- It is not necessary to add the data constructor _,_ as an
-- axiom because the ATPs implement it.
data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

-- It is not strictly necessary define the projections ∧-proj₁ and
-- ∧-proj₂ because the ATPs implement them. For the same reason, it is
-- not necessary to add them as (general/local) hints.
∧-proj₁ : {A B : Set} → A ∧ B → A
∧-proj₁ (x , y) = x

∧-proj₂ : {A B : Set} → A ∧ B → B
∧-proj₂ (x , y) = y

_,′_ : ∀ {A B : Set} → A → B → A ∧ B
_,′_ = _,_

-- The existential quantifier type on D.
data ∃ (P : D → Set) : Set where
  _,_ : (witness : D) → P witness → ∃ P

∃-proj₁ : {P : D → Set} → ∃ P → D
∃-proj₁ (x , _) = x

∃-proj₂ : {P : D → Set}(∃p : ∃ P) → P (∃-proj₁ ∃p)
∃-proj₂ (_ , px) = px

------------------------------------------------------------------------------
-- Products
------------------------------------------------------------------------------

module Common.Data.Product where

open import Common.Universe using ( D )

-- We add 3 to the fixities of the standard library.
infixr 7 _,_
infixr 5 _∧_

------------------------------------------------------------------------------
-- The conjunction data type.

-- It is not necessary to add the data constructor _,_ as an
-- axiom because the ATPs implement it.
data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

-- It is not strictly necessary define the projections ∧-proj₁ and
-- ∧-proj₂ because the ATPs implement them. For the same reason, it is
-- not necessary to add them as (general/local) hints.
∧-proj₁ : {A B : Set} → A ∧ B → A
∧-proj₁ (x , y) = x

∧-proj₂ : {A B : Set} → A ∧ B → B
∧-proj₂ (x , y) = y

-- The existential quantifier type on D.
data ∃ (P : D → Set) : Set where
  _,_ : (witness : D) → P witness → ∃ P

∃-proj₁ : {P : D → Set} → ∃ P → D
∃-proj₁ (x , _) = x

∃-proj₂ : {P : D → Set}(∃p : ∃ P) → P (∃-proj₁ ∃p)
∃-proj₂ (_ , px) = px


Rename by-definition combinator for eq-reasoning

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

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

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

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

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

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

  open IsEquivalence isEquivalence public

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

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

-- Equational reasoning combinators.

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

  infix  2 finally
  infixr 2 _≈⟨_⟩_

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

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

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

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

  open Trans-Reasoning _≈_ trans public hiding (finally)
  infix  2 _∎

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

  infixr 2 _≈⟨by-definition⟩_

  _≈⟨by-definition⟩_ : ∀ x {y : A} → x ≈ y → x ≈ y
  _ ≈⟨by-definition⟩ x≈y = x≈y

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

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

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

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

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

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

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

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

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

  open IsEquivalence isEquivalence public

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

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

-- Equational reasoning combinators.

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

  infix  2 finally
  infixr 2 _≈⟨_⟩_

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

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

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

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

  open Trans-Reasoning _≈_ trans public hiding (finally)
  infix  2 _∎

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

  infixr 2 _≈⟨-by-definition-⟩_

  _≈⟨-by-definition-⟩_ : ∀ x {y : A} → x ≈ y → x ≈ y
  _ ≈⟨-by-definition-⟩ x≈y = x≈y

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

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

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


Relation.Binary.Refl-Trans-Reasoning

Relation.Binary.Refl-Trans-Reasoning

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

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

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

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

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

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

  open IsEquivalence isEquivalence public

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

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

-- Equational reasoning combinators.

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

  infix  2 finally
  infixr 2 _≈⟨_⟩_

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

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

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

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

  open Trans-Reasoning _≈_ trans public hiding (finally)
  infix  2 _∎

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

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

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

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

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

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

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

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

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

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

  open IsEquivalence isEquivalence public

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

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

-- Equational reasoning combinators.

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

  infix  2 finally
  infixr 2 _≈⟨_⟩_

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

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

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

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

  infix  2 _∎

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

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

  infix  2 _∎

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

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


Correct code in comment

Correct code in comment

map-IVT does not exist currently (not sure it ever did, I did not
investigate); what we want and does not work is simply map. Hence, fix
the comment to clarify it.

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

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

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

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

open import Base.Denotation.Notation

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open import Base.Denotation.Notation

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

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

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

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

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

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

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

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

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

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

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


Equivalence: Prepare for splitting

Equivalence: Prepare for splitting

The file has become too big.

Splitting the anonymous modules requires more work out of type inference
and introduces one type inference failure, which is fixed in this commmit.

Old-commit-hash: 32f42f80b60cd3dd45e879d7a367b4fe933bb9d8

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- Delta-observational equivalence: these asserts that two changes
  -- give the same result when applied to a base value.

  -- To avoid unification problems, use a one-field record.
  record _≙_ dx dy : Set a where
    -- doe = Delta-Observational Equivalence.
    constructor doe
    field
      proof : x ⊞ dx ≡ x ⊞ dy

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

  -- _≙_ is indeed an equivalence relation:
  ≙-refl : ∀ {dx} → dx ≙ dx
  ≙-refl = doe refl

  ≙-sym : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
  ≙-sym ≙ = doe $ sym $ proof ≙

  ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
  ≙-trans ≙₁ ≙₂ = doe $ trans (proof ≙₁) (proof ≙₂)

  -- That's standard congruence applied to ≙
  ≙-cong  : ∀ {b} {B : Set b}
       (f : A → B) {dx dy} → dx ≙ dy → f (x ⊞ dx) ≡ f (x ⊞ dy)
  ≙-cong f da≙db = cong f $ proof da≙db

  ≙-isEquivalence : IsEquivalence (_≙_)
  ≙-isEquivalence = record
    { refl  = ≙-refl
    ; sym   = ≙-sym
    ; trans = ≙-trans
    }

  ≙-setoid : Setoid ℓ a
  ≙-setoid = record
    { Carrier       = Δ x
    ; _≈_           = _≙_
    ; isEquivalence = ≙-isEquivalence
    }

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  ------------------------------------------------------------------------
  -- Convenient syntax for equational reasoning

  import Relation.Binary.EqReasoning as EqR

  module ≙-Reasoning where
    open EqR (≙-setoid {x = x}) public
      renaming (_≈⟨_⟩_ to _≙⟨_⟩_)

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- By update-nil, if dx = nil x, then x ⊞ dx ≡ x.
  -- As a consequence, if dx ≙ nil x, then x ⊞ dx ≡ x
  nil-is-⊞-unit : ∀ dx → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ proof dx≙nil-x ⟩
      x ⊞ (nil x)
    ≡⟨ update-nil x ⟩
      x
    ∎
    where
      open ≡-Reasoning

  -- Here we prove the inverse:
  ⊞-unit-is-nil : ∀ dx → x ⊞ dx ≡ x → dx ≙ nil x
  ⊞-unit-is-nil dx x⊞dx≡x = doe $
    begin
      x ⊞ dx
    ≡⟨ x⊞dx≡x ⟩
      x
    ≡⟨ sym (update-nil x) ⟩
      x ⊞ nil x
    ∎
    where
      open ≡-Reasoning

  -- TODO: we want to show that all functions of interest respect
  -- delta-observational equivalence, so that two d.o.e. changes can be
  -- substituted for each other freely.
  --
  -- * That should be be true for
  --   functions using changes parametrically.
  --
  -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
  --   this is proved below on both contexts at once by fun-change-respects.
  --
  -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
  --   it by definition, and ⊟ doesn't take change arguments - we will only
  --   need a proof for compose, when we define it.
  --
  -- Stating the general result, though, seems hard, we should
  -- rather have lemmas proving that certain classes of functions respect this
  -- equivalence.

  -- This results pairs with update-diff.
  diff-update : ∀ {dx} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = doe lemma
    where
      lemma : x ⊞ (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff (x ⊞ dx) x

module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
  {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

  module FC = FunctionChanges A B {{CA}} {{CB}}
  open FC using (changeAlgebra; incrementalization)
  open FC.FunctionChange

  fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
    df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = doe lemma
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
      -- Informally: use incrementalization on both sides and then apply
      -- congruence.
      lemma =
        begin
          f x ⊞ apply df₁ x dx₁
        ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
          (f ⊞ df₁) (x ⊞ dx₁)
        ≡⟨ ≙-cong (f ⊞ df₁) dx₁≙dx₂ ⟩
          (f ⊞ df₁) (x ⊞ dx₂)
        ≡⟨ ≙-cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
          (f ⊞ df₂) (x ⊞ dx₂)
        ≡⟨ incrementalization f df₂ x dx₂ ⟩
          f x ⊞ apply df₂ x dx₂
        ∎

  open import Postulate.Extensionality

  -- An extensionality principle for delta-observational equivalence: if
  -- applying two function changes to the same base value and input change gives
  -- a d.o.e. result, then the two function changes are d.o.e. themselves.

  delta-ext : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx → apply df x dx ≙ apply dg x dx) → df ≙ dg
  delta-ext {f} {df} {dg} df-x-dx≙dg-x-dx = doe lemma₂
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma₁ : ∀ x dx → f x ⊞ apply df x dx ≡ f x ⊞ apply dg x dx
      lemma₁ x dx = proof $ df-x-dx≙dg-x-dx x dx
      lemma₂ : f ⊞ df ≡ f ⊞ dg
      lemma₂ = ext (λ x → lemma₁ x (nil x))

  -- We know that Derivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> Derivative f (apply df).
  -- Now, we try to prove that if Derivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    Derivative f (apply df) → f ⊞ df ≡ f
  derivative-is-⊞-unit {f} df fdf =
    begin
      f ⊞ df
    ≡⟨⟩
      (λ x → f x ⊞ apply df x (nil x))
    ≡⟨ ext (λ x → fdf x (nil x)) ⟩
      (λ x → f (x ⊞ nil x))
    ≡⟨ ext (λ x → cong f (update-nil x)) ⟩
      (λ x → f x)
    ≡⟨⟩
      f
    ∎
    where
      open ≡-Reasoning

  -- We can restate the above as "df is a nil change".

  derivative-is-nil : ∀ {f : A → B} df →
    Derivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  -- If we have two derivatives, they're both nil, hence they're equal.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → Derivative f (apply df) → Derivative f (apply dg) → df ≙ dg
  derivative-unique {f} {df} {dg} fdf fdg =
    begin
      df
    ≙⟨ derivative-is-nil df fdf ⟩
      nil f
    ≙⟨ ≙-sym (derivative-is-nil dg fdg) ⟩
      dg
    ∎
    where
      open ≙-Reasoning

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- Delta-observational equivalence: these asserts that two changes
  -- give the same result when applied to a base value.

  -- To avoid unification problems, use a one-field record.
  record _≙_ dx dy : Set a where
    -- doe = Delta-Observational Equivalence.
    constructor doe
    field
      proof : x ⊞ dx ≡ x ⊞ dy

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

  -- _≙_ is indeed an equivalence relation:
  ≙-refl : ∀ {dx} → dx ≙ dx
  ≙-refl = doe refl

  ≙-sym : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
  ≙-sym ≙ = doe $ sym $ proof ≙

  ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
  ≙-trans ≙₁ ≙₂ = doe $ trans (proof ≙₁) (proof ≙₂)

  -- That's standard congruence applied to ≙
  ≙-cong  : ∀ {b} {B : Set b}
       (f : A → B) {dx dy} → dx ≙ dy → f (x ⊞ dx) ≡ f (x ⊞ dy)
  ≙-cong f da≙db = cong f $ proof da≙db

  ≙-isEquivalence : IsEquivalence (_≙_)
  ≙-isEquivalence = record
    { refl  = ≙-refl
    ; sym   = ≙-sym
    ; trans = ≙-trans
    }

  ≙-setoid : Setoid ℓ a
  ≙-setoid = record
    { Carrier       = Δ x
    ; _≈_           = _≙_
    ; isEquivalence = ≙-isEquivalence
    }

  ------------------------------------------------------------------------
  -- Convenient syntax for equational reasoning

  import Relation.Binary.EqReasoning as EqR

  module ≙-Reasoning where
    open EqR ≙-setoid public
      renaming (_≈⟨_⟩_ to _≙⟨_⟩_)

  -- By update-nil, if dx = nil x, then x ⊞ dx ≡ x.
  -- As a consequence, if dx ≙ nil x, then x ⊞ dx ≡ x
  nil-is-⊞-unit : ∀ dx → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ proof dx≙nil-x ⟩
      x ⊞ (nil x)
    ≡⟨ update-nil x ⟩
      x
    ∎
    where
      open ≡-Reasoning

  -- Here we prove the inverse:
  ⊞-unit-is-nil : ∀ dx → x ⊞ dx ≡ x → dx ≙ nil x
  ⊞-unit-is-nil dx x⊞dx≡x = doe $
    begin
      x ⊞ dx
    ≡⟨ x⊞dx≡x ⟩
      x
    ≡⟨ sym (update-nil x) ⟩
      x ⊞ nil x
    ∎
    where
      open ≡-Reasoning

  -- TODO: we want to show that all functions of interest respect
  -- delta-observational equivalence, so that two d.o.e. changes can be
  -- substituted for each other freely.
  --
  -- * That should be be true for
  --   functions using changes parametrically.
  --
  -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
  --   this is proved below on both contexts at once by fun-change-respects.
  --
  -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
  --   it by definition, and ⊟ doesn't take change arguments - we will only
  --   need a proof for compose, when we define it.
  --
  -- Stating the general result, though, seems hard, we should
  -- rather have lemmas proving that certain classes of functions respect this
  -- equivalence.

  -- This results pairs with update-diff.
  diff-update : ∀ {dx} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = doe lemma
    where
      lemma : x ⊞ (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff (x ⊞ dx) x

module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
  {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

  module FC = FunctionChanges A B {{CA}} {{CB}}
  open FC using (changeAlgebra; incrementalization)
  open FC.FunctionChange

  fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
    df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = doe lemma
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
      -- Informally: use incrementalization on both sides and then apply
      -- congruence.
      lemma =
        begin
          f x ⊞ apply df₁ x dx₁
        ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
          (f ⊞ df₁) (x ⊞ dx₁)
        ≡⟨ ≙-cong (f ⊞ df₁) dx₁≙dx₂ ⟩
          (f ⊞ df₁) (x ⊞ dx₂)
        ≡⟨ ≙-cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
          (f ⊞ df₂) (x ⊞ dx₂)
        ≡⟨ incrementalization f df₂ x dx₂ ⟩
          f x ⊞ apply df₂ x dx₂
        ∎

  open import Postulate.Extensionality

  -- An extensionality principle for delta-observational equivalence: if
  -- applying two function changes to the same base value and input change gives
  -- a d.o.e. result, then the two function changes are d.o.e. themselves.

  delta-ext : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx → apply df x dx ≙ apply dg x dx) → df ≙ dg
  delta-ext {f} {df} {dg} df-x-dx≙dg-x-dx = doe lemma₂
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma₁ : ∀ x dx → f x ⊞ apply df x dx ≡ f x ⊞ apply dg x dx
      lemma₁ x dx = proof $ df-x-dx≙dg-x-dx x dx
      lemma₂ : f ⊞ df ≡ f ⊞ dg
      lemma₂ = ext (λ x → lemma₁ x (nil x))

  -- We know that Derivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> Derivative f (apply df).
  -- Now, we try to prove that if Derivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    Derivative f (apply df) → f ⊞ df ≡ f
  derivative-is-⊞-unit {f} df fdf =
    begin
      f ⊞ df
    ≡⟨⟩
      (λ x → f x ⊞ apply df x (nil x))
    ≡⟨ ext (λ x → fdf x (nil x)) ⟩
      (λ x → f (x ⊞ nil x))
    ≡⟨ ext (λ x → cong f (update-nil x)) ⟩
      (λ x → f x)
    ≡⟨⟩
      f
    ∎
    where
      open ≡-Reasoning

  -- We can restate the above as "df is a nil change".

  derivative-is-nil : ∀ {f : A → B} df →
    Derivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  -- If we have two derivatives, they're both nil, hence they're equal.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → Derivative f (apply df) → Derivative f (apply dg) → df ≙ dg
  derivative-unique {f} {df} {dg} fdf fdg =
    begin
      df
    ≙⟨ derivative-is-nil df fdf ⟩
      nil f
    ≙⟨ ≙-sym (derivative-is-nil dg fdg) ⟩
      dg
    ∎
    where
      open ≙-Reasoning