CachingEvaluation: switch to M{Type,Term}

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

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

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

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

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality

module Structure where
  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but instead of producing object language terms, we
  -- produce host language terms to take advantage of the richer type system of
  -- the host language (in particular, here we need the unit type, product types
  -- and *existentials*).
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit

  -- A semantics for empty caching semantics
  ⟦_⟧Type2 : (τ : Type) → Set
  ⟦ base ι ⟧Type2 = ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧Type2 = ⟦ σ ⟧Type → (⟦ τ ⟧Type × ⊤)

  open import Level

  {-
  -- Hidden cache semantics, try 1.
  --
  -- Wrong: even the inputs should be extended.
  -- It's just that extension on base values does nothing interesting.

  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache =  ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )
  -- This type would be cooler, but it also places "excessive" requirements on
  -- the object language compared to what we formalize - e.g., unit types.
  --
  --⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Type ] ⟦ τ ⟧Type × ⟦ τ₁ ⟧Type )

  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache
  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → ⊤ , (extend (v x) , tt)

  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v x)))

  -- Wrong type signature:
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = {!!}
  -- Oh. We don't even know what to return without matching on the type. That's
  -- also true in our term transformation: we need to eta-expand also
  -- non-primitives (higher-order arguments) for everything to possibly work.
  -- Hm... or we need to have extended values in the environment - where the extension is again just for functions.
  ⟦_⟧TermCache (var x) ρ = extend (⟦ var x ⟧ ρ)
  -- XXX: this delegates to standard evaluation, I'm not sure whether we should do that.
  -- In fact, we should use our evaluation and select from the result.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧Term ρ)))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache (x • ρ) , tt)

  -- Wrong type definitions: functions get argument of transformed types.
  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

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

  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = {!!}
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (dropCache (⟦ t ⟧TermCache2 ρ))))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache2 (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache2 ((extend x) • ρ) , tt)
  -}

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  open import Parametric.Syntax.MType as MType
  open MType.Structure Base
  open import Parametric.Syntax.MTerm as MTerm
  open MTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

  ⟦ U c ⟧ValType = ⟦ c ⟧CompType
  ⟦ B ι ⟧ValType = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValType = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType × ⟦ τ₂ ⟧ValType
  ⟦ τ₁ v+ τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType ⊎ ⟦ τ₂ ⟧ValType

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType

  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCacheWrong × τ₁ )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set₁

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = Lift ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCache × τ₁ )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set₁
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- Now, let us define a caching semantics for terms.

  -- This proves to be hard, because we need to insert and remove caches where
  -- we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  --
  -- Inserting and removing caches --
  --

  -- Implementation note: The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → , (extend (v (dropCache x)) , tt)

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ

  -- It seems odd (a probable bug?) that the result of t needn't be stripped of
  -- its cache.
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (⟦ t ⟧TermCache2 ρ)))

  -- Provide an empty cache!
  ⟦_⟧TermCache2 (abs t) ρ x = , (⟦ t ⟧TermCache2 (x • ρ) , tt)

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values (where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things)!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache2, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

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

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

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

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality

module Structure where
  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but instead of producing object language terms, we
  -- produce host language terms to take advantage of the richer type system of
  -- the host language (in particular, here we need the unit type, product types
  -- and *existentials*).
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit

  -- A semantics for empty caching semantics
  ⟦_⟧Type2 : (τ : Type) → Set
  ⟦ base ι ⟧Type2 = ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧Type2 = ⟦ σ ⟧Type → (⟦ τ ⟧Type × ⊤)

  open import Level

  {-
  -- Hidden cache semantics, try 1.
  --
  -- Wrong: even the inputs should be extended.
  -- It's just that extension on base values does nothing interesting.

  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache =  ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )
  -- This type would be cooler, but it also places "excessive" requirements on
  -- the object language compared to what we formalize - e.g., unit types.
  --
  --⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Type ] ⟦ τ ⟧Type × ⟦ τ₁ ⟧Type )

  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache
  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → ⊤ , (extend (v x) , tt)

  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v x)))

  -- Wrong type signature:
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = {!!}
  -- Oh. We don't even know what to return without matching on the type. That's
  -- also true in our term transformation: we need to eta-expand also
  -- non-primitives (higher-order arguments) for everything to possibly work.
  -- Hm... or we need to have extended values in the environment - where the extension is again just for functions.
  ⟦_⟧TermCache (var x) ρ = extend (⟦ var x ⟧ ρ)
  -- XXX: this delegates to standard evaluation, I'm not sure whether we should do that.
  -- In fact, we should use our evaluation and select from the result.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧Term ρ)))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache (x • ρ) , tt)

  -- Wrong type definitions: functions get argument of transformed types.
  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

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

  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = {!!}
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (dropCache (⟦ t ⟧TermCache2 ρ))))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache2 (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache2 ((extend x) • ρ) , tt)
  -}

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  open import Parametric.Syntax.CBPVType as CBPVType
  open CBPVType.Structure Base
  open import Parametric.Syntax.CBPVTerm as CBPVTerm
  open CBPVTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

  ⟦ U c ⟧ValType = ⟦ c ⟧CompType
  ⟦ B ι ⟧ValType = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValType = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType × ⟦ τ₂ ⟧ValType
  ⟦ τ₁ v+ τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType ⊎ ⟦ τ₂ ⟧ValType

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType
  ⟦ τ₁ Π τ₂ ⟧CompType = ⟦ τ₁ ⟧CompType × ⟦ τ₂ ⟧CompType

  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.>
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCacheWrong × τ₁ )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set₁

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = Lift ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCache × τ₁ )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦ τ₁ Π τ₂ ⟧CompTypeHidCache = ⟦ τ₁ ⟧CompTypeHidCache × ⟦ τ₂ ⟧CompTypeHidCache

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set₁
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- Now, let us define a caching semantics for terms.

  -- This proves to be hard, because we need to insert and remove caches where
  -- we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  --
  -- Inserting and removing caches --
  --

  -- Implementation note: The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → , (extend (v (dropCache x)) , tt)

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ

  -- It seems odd (a probable bug?) that the result of t needn't be stripped of
  -- its cache.
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (⟦ t ⟧TermCache2 ρ)))

  -- Provide an empty cache!
  ⟦_⟧TermCache2 (abs t) ρ x = , (⟦ t ⟧TermCache2 (x • ρ) , tt)

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values (where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things)!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cProduce v) ρ = , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)

  -- But if we alter _into_ as described above, composing the caches works!

  ⟦_⟧CompTermCache (v₁ into2 v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cProduce time, we just need the nested into2 to do their job, because as I
  -- said intermediate results are a a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using into2 for the same reasons - which makes
  -- sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into2 case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache2, we don't need to invent an empty cache,
  -- that's moved into the handling of cProduce. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)


Fix a note

Fix a note

-- NOTO with-K
module Solver.Linear where

open import FunUniverse.Types
open import FunUniverse.Rewiring.Linear
open import Data.Two hiding (_≟_)
open import Data.Nat as ℕ using (ℕ)
import Solver.Linear.Syntax as LinSyn
open import Relation.Nullary.Decidable
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl; _≢_)
open import Relation.Nullary
import Data.String as String
module String≤ = StrictTotalOrder String.strictTotalOrder
open import Data.Fin using (Fin)
open import Data.Fin.Props using (strictTotalOrder) renaming (_≟_ to _≟ᶠ_)
open import Data.Vec using (Vec; lookup)
open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
open import Data.Vec using (allFin) renaming (map to vmap)

module Syntax
  {Var : Set}
  (_≤V₂_ : Var → Var → 𝟚)
  (_≟V_ : Decidable (_≡_ {A = Var}))
  {a} {A : Set a}
  {funU : FunUniverse A}
  (linRewiring : LinRewiring funU)
  (Γ : Var → A)
 where

  open FunUniverse funU
  open LinRewiring linRewiring
  open LinSyn Var

  eval : Syn → A
  eval (var x) = Γ x
  eval tt = `⊤
  eval (s , s₁) = eval s `× eval s₁

  EvalEq : Eq → Set
  EvalEq e = eval (LHS e) `→ eval (RHS e)

  data R : Syn → Syn → Set a where
    _``∻_ : ∀ {A B C} → R A B → R B C → R A C
    `<id,tt>⁻¹ : ∀ {A} → R (A , tt) A
    `<tt,id>⁻¹ : ∀ {A} → R (tt , A) A
    `<tt,id> : ∀ {A} → R A (tt , A)
    `<id,tt> : ∀ {A} → R A (A , tt)
    ⟨_``×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    `assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    `assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    `id : ∀ {A} → R A A
    `swap : ∀ {A B} → R (A , B) (B , A)

  `⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  `⟨ `id × `id ⟩ = `id
  `⟨ r₁  ×  r₂ ⟩ = ⟨ r₁ ``× r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  `id ∻ r₂ = r₂
  r₁ ∻ `id = r₁
  `<tt,id>⁻¹ ∻ `<tt,id> = `id
  `<id,tt>⁻¹ ∻ `<id,tt> = `id
  `<tt,id> ∻ `<tt,id>⁻¹ = `id
  `<id,tt> ∻ `<id,tt>⁻¹ = `id
  `swap ∻ `<id,tt>⁻¹ = `<tt,id>⁻¹
  `swap ∻ `<tt,id>⁻¹ = `<id,tt>⁻¹
  `<id,tt> ∻ `swap = `<tt,id>
  `<tt,id> ∻ `swap = `<id,tt>
  `assoc ∻ `assoc⁻¹ = `id
  `assoc ∻ (`assoc⁻¹ ``∻ r) = r
  `assoc⁻¹ ∻ `assoc = `id
  `assoc⁻¹ ∻ (`assoc ``∻ r) = r
  `swap ∻ `swap = `id
  `swap ∻ (`swap ``∻ r) = r
  (r₁ ``∻ r₂) ∻ r₃ = r₁ ``∻ (r₂ ∻ r₃)
  ⟨ r₁ ``× r₂ ⟩ ∻ ⟨ r₃ ``× r₄ ⟩ = ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ⟨ r₁ ``× r₂ ⟩ ∻ ( ⟨ r₃ ``× r₄ ⟩ ``∻ r₅) with ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ... | `id = r₅
  ... | r₆ = r₆ ``∻ r₅
  r₁ ∻ r₂ = r₁ ``∻ r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ``∻ r₁) = sym r₁ ∻ sym r
  sym `<id,tt> = `<id,tt>⁻¹
  sym `<tt,id> = `<tt,id>⁻¹
  sym `<id,tt>⁻¹ = `<id,tt>
  sym `<tt,id>⁻¹ = `<tt,id>
  sym ⟨ r ``× r₁ ⟩ = ⟨ sym r ``× sym r₁ ⟩
  sym `assoc = `assoc⁻¹
  sym `assoc⁻¹ = `assoc
  sym `id = `id
  sym `swap = `swap

  proof₁ : ∀ {S S'} → R S S' → eval S `→ eval S'
  proof₁ (r ``∻ r₁) = proof₁ r ⁏ proof₁ r₁
  proof₁ `<id,tt> = <id,tt>
  proof₁ `<tt,id> = <tt,id>
  proof₁ `<id,tt>⁻¹ = fst<,tt>
  proof₁ `<tt,id>⁻¹ = snd<tt,>
  proof₁ ⟨ `id ``× r ⟩ = second (proof₁ r)
  proof₁ ⟨ r ``× `id ⟩ = first  (proof₁ r)
  proof₁ ⟨ r ``× r₁ ⟩  = < proof₁ r × proof₁ r₁ >
  proof₁ `assoc = assoc′
  proof₁ `assoc⁻¹ = assoc
  proof₁ `id = id
  proof₁ `swap = swap

  proof₂ : ∀ {S S'} → R S S' → eval S' `→ eval S
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set a where
    tt : NF tt
    var : ∀ x → NF (var x)
    var_::_ : ∀ {S} i → NF S → NF (var i , S)

  record NFP S : Set a where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ `<tt,id>
  merge (var i) n2 = (var i :: n2) ⊢ `id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ `assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ `id
  norm tt = tt ⊢ `id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 ``× p2 ⟩)

  insert : ∀ {S} x → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ `<id,tt>
  insert y (var i) with y ≤V₂ i
  ... | 1₂ = (var y :: var i) ⊢ `id
  ... | 0₂ = (var i :: var y) ⊢ `swap
  insert y (var i :: n1) with y ≤V₂ i
  ... | 1₂ = (var y :: (var i :: n1)) ⊢ `id
  ... | 0₂ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ (`assoc ∻ (⟨ `swap ``× `id ⟩ ∻ `assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ `id
  sort (var i) = var i ⊢ `id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ `id ``× p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = `id

  var-inj : ∀ {i j} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x ≟V x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  data equation-not-ok : Set where

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = equation-not-ok

  EqOk? : Eq → Set
  EqOk? e = CHECK (NFP.S' (normal (LHS e))) (NFP.S' (normal (RHS e)))

  rewire : (e : Eq) {prf : EqOk? e} → EvalEq e
  rewire (s₁ ↦ s₂) {eq} with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire (_ ↦ _) {()} | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

module Syntaxᶠ {a} {A : Set a} {funU : FunUniverse A} (linRewiring : LinRewiring funU) where
  module _ {n} where
    open LinSyn (Fin n) public

  module _ {n} (Γ : Vec A n)
           (f : N-ary n (LinSyn.Syn (Fin n)) (LinSyn.Eq (Fin n)))
           where
    open Syntax {Fin n} ((λ x y → ⌊ StrictTotalOrder._<?_ (strictTotalOrder n) x y ⌋))
                _≟ᶠ_ {a} {A} {funU} linRewiring (λ i → lookup i Γ) public

    private
      e = f $ⁿ vmap Syn.var (allFin n)

    rewireᶠ : {e-ok : EqOk? e} → EvalEq e
    rewireᶠ {e-ok} = rewire e {e-ok}

module Syntaxˢ {a} {A} {funU} linRewiring Γ where
  open Syntax (λ x y → ⌊ String≤._<?_ x y ⌋) String._≟_ {a} {A} {funU} linRewiring Γ public
  open import Solver.Linear.Parser

  rewireˢ : ∀ s {s-ok} →
            let e = parseEqˢ s {s-ok} in
            {e-ok : EqOk? e} → EvalEq e
  rewireˢ s {s-ok} {e-ok} = rewire (parseEqˢ s {s-ok}) {e-ok}
-- -}
-- -}
-- -}

-- NOTE with-K
module Solver.Linear where

open import FunUniverse.Types
open import FunUniverse.Rewiring.Linear
open import Data.Two hiding (_≟_)
open import Data.Nat as ℕ using (ℕ)
import Solver.Linear.Syntax as LinSyn
open import Relation.Nullary.Decidable
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl; _≢_)
open import Relation.Nullary
import Data.String as String
module String≤ = StrictTotalOrder String.strictTotalOrder
open import Data.Fin using (Fin)
open import Data.Fin.Props using (strictTotalOrder) renaming (_≟_ to _≟ᶠ_)
open import Data.Vec using (Vec; lookup)
open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
open import Data.Vec using (allFin) renaming (map to vmap)

module Syntax
  {Var : Set}
  (_≤V₂_ : Var → Var → 𝟚)
  (_≟V_ : Decidable (_≡_ {A = Var}))
  {a} {A : Set a}
  {funU : FunUniverse A}
  (linRewiring : LinRewiring funU)
  (Γ : Var → A)
 where

  open FunUniverse funU
  open LinRewiring linRewiring
  open LinSyn Var

  eval : Syn → A
  eval (var x) = Γ x
  eval tt = `⊤
  eval (s , s₁) = eval s `× eval s₁

  EvalEq : Eq → Set
  EvalEq e = eval (LHS e) `→ eval (RHS e)

  data R : Syn → Syn → Set a where
    _``∻_ : ∀ {A B C} → R A B → R B C → R A C
    `<id,tt>⁻¹ : ∀ {A} → R (A , tt) A
    `<tt,id>⁻¹ : ∀ {A} → R (tt , A) A
    `<tt,id> : ∀ {A} → R A (tt , A)
    `<id,tt> : ∀ {A} → R A (A , tt)
    ⟨_``×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    `assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    `assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    `id : ∀ {A} → R A A
    `swap : ∀ {A B} → R (A , B) (B , A)

  `⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  `⟨ `id × `id ⟩ = `id
  `⟨ r₁  ×  r₂ ⟩ = ⟨ r₁ ``× r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  `id ∻ r₂ = r₂
  r₁ ∻ `id = r₁
  `<tt,id>⁻¹ ∻ `<tt,id> = `id
  `<id,tt>⁻¹ ∻ `<id,tt> = `id
  `<tt,id> ∻ `<tt,id>⁻¹ = `id
  `<id,tt> ∻ `<id,tt>⁻¹ = `id
  `swap ∻ `<id,tt>⁻¹ = `<tt,id>⁻¹
  `swap ∻ `<tt,id>⁻¹ = `<id,tt>⁻¹
  `<id,tt> ∻ `swap = `<tt,id>
  `<tt,id> ∻ `swap = `<id,tt>
  `assoc ∻ `assoc⁻¹ = `id
  `assoc ∻ (`assoc⁻¹ ``∻ r) = r
  `assoc⁻¹ ∻ `assoc = `id
  `assoc⁻¹ ∻ (`assoc ``∻ r) = r
  `swap ∻ `swap = `id
  `swap ∻ (`swap ``∻ r) = r
  (r₁ ``∻ r₂) ∻ r₃ = r₁ ``∻ (r₂ ∻ r₃)
  ⟨ r₁ ``× r₂ ⟩ ∻ ⟨ r₃ ``× r₄ ⟩ = ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ⟨ r₁ ``× r₂ ⟩ ∻ ( ⟨ r₃ ``× r₄ ⟩ ``∻ r₅) with ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ... | `id = r₅
  ... | r₆ = r₆ ``∻ r₅
  r₁ ∻ r₂ = r₁ ``∻ r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ``∻ r₁) = sym r₁ ∻ sym r
  sym `<id,tt> = `<id,tt>⁻¹
  sym `<tt,id> = `<tt,id>⁻¹
  sym `<id,tt>⁻¹ = `<id,tt>
  sym `<tt,id>⁻¹ = `<tt,id>
  sym ⟨ r ``× r₁ ⟩ = ⟨ sym r ``× sym r₁ ⟩
  sym `assoc = `assoc⁻¹
  sym `assoc⁻¹ = `assoc
  sym `id = `id
  sym `swap = `swap

  proof₁ : ∀ {S S'} → R S S' → eval S `→ eval S'
  proof₁ (r ``∻ r₁) = proof₁ r ⁏ proof₁ r₁
  proof₁ `<id,tt> = <id,tt>
  proof₁ `<tt,id> = <tt,id>
  proof₁ `<id,tt>⁻¹ = fst<,tt>
  proof₁ `<tt,id>⁻¹ = snd<tt,>
  proof₁ ⟨ `id ``× r ⟩ = second (proof₁ r)
  proof₁ ⟨ r ``× `id ⟩ = first  (proof₁ r)
  proof₁ ⟨ r ``× r₁ ⟩  = < proof₁ r × proof₁ r₁ >
  proof₁ `assoc = assoc′
  proof₁ `assoc⁻¹ = assoc
  proof₁ `id = id
  proof₁ `swap = swap

  proof₂ : ∀ {S S'} → R S S' → eval S' `→ eval S
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set a where
    tt : NF tt
    var : ∀ x → NF (var x)
    var_::_ : ∀ {S} i → NF S → NF (var i , S)

  record NFP S : Set a where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ `<tt,id>
  merge (var i) n2 = (var i :: n2) ⊢ `id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ `assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ `id
  norm tt = tt ⊢ `id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 ``× p2 ⟩)

  insert : ∀ {S} x → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ `<id,tt>
  insert y (var i) with y ≤V₂ i
  ... | 1₂ = (var y :: var i) ⊢ `id
  ... | 0₂ = (var i :: var y) ⊢ `swap
  insert y (var i :: n1) with y ≤V₂ i
  ... | 1₂ = (var y :: (var i :: n1)) ⊢ `id
  ... | 0₂ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ (`assoc ∻ (⟨ `swap ``× `id ⟩ ∻ `assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ `id
  sort (var i) = var i ⊢ `id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ `id ``× p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = `id

  var-inj : ∀ {i j} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x ≟V x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  data equation-not-ok : Set where

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = equation-not-ok

  EqOk? : Eq → Set
  EqOk? e = CHECK (NFP.S' (normal (LHS e))) (NFP.S' (normal (RHS e)))

  rewire : (e : Eq) {prf : EqOk? e} → EvalEq e
  rewire (s₁ ↦ s₂) {eq} with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire (_ ↦ _) {()} | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

module Syntaxᶠ {a} {A : Set a} {funU : FunUniverse A} (linRewiring : LinRewiring funU) where
  module _ {n} where
    open LinSyn (Fin n) public

  module _ {n} (Γ : Vec A n)
           (f : N-ary n (LinSyn.Syn (Fin n)) (LinSyn.Eq (Fin n)))
           where
    open Syntax {Fin n} ((λ x y → ⌊ StrictTotalOrder._<?_ (strictTotalOrder n) x y ⌋))
                _≟ᶠ_ {a} {A} {funU} linRewiring (λ i → lookup i Γ) public

    private
      e = f $ⁿ vmap Syn.var (allFin n)

    rewireᶠ : {e-ok : EqOk? e} → EvalEq e
    rewireᶠ {e-ok} = rewire e {e-ok}

module Syntaxˢ {a} {A} {funU} linRewiring Γ where
  open Syntax (λ x y → ⌊ String≤._<?_ x y ⌋) String._≟_ {a} {A} {funU} linRewiring Γ public
  open import Solver.Linear.Parser

  rewireˢ : ∀ s {s-ok} →
            let e = parseEqˢ s {s-ok} in
            {e-ok : EqOk? e} → EvalEq e
  rewireˢ s {s-ok} {e-ok} = rewire (parseEqˢ s {s-ok}) {e-ok}
-- -}
-- -}
-- -}


Cosmetic changes.

Cosmetic changes.

Ignore-this: 24dc33dfbb72399aa465f5826dda43ee

darcs-hash:20110511135414-3bd4e-b7772086e62e149171f7da14329c07df8eb500c3.gz

------------------------------------------------------------------------------
-- FOTC natural numbers (added for the Collatz function example)

-- (We don't want populate the FOTC library with more FOL axioms)
------------------------------------------------------------------------------

module FOTC.Program.Collatz.Data.Nat where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.UnaryNumbers

infixr 12 _^_
infixl 10 _/_

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

postulate
  _/_   : D → D → D
  /-x<y : ∀ {m n} → LT m n → m / n ≡ zero
  /-x≥y : ∀ {m n} → GE m n → m / n ≡ succ ((m ∸ n) / n)
{-# ATP axiom /-x<y #-}
{-# ATP axiom /-x≥y #-}

postulate
  _^_ : D → D → D
  ^-0 : ∀ n →   n ^ zero   ≡ one
  ^-S : ∀ m n → m ^ succ n ≡ m * m ^ n
{-# ATP axiom ^-0 #-}
{-# ATP axiom ^-S #-}

-- Some predicates

Even : D → Set
Even n = ∃ λ k → n ≡ two * k

Odd : D → Set
Odd n = ∃ λ k → n ≡ two * k + one

------------------------------------------------------------------------------
-- FOTC natural numbers (added for the Collatz function example)

-- (We don't want populate the FOTC library with more FOL axioms)
------------------------------------------------------------------------------

module FOTC.Program.Collatz.Data.Nat where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.UnaryNumbers

infixr 12 _^_
infixl 10 _/_

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

postulate
  _/_   : D → D → D
  /-x<y : ∀ {m n} → LT m n → m / n ≡ zero
  /-x≥y : ∀ {m n} → GE m n → m / n ≡ succ ((m ∸ n) / n)
{-# ATP axiom /-x<y #-}
{-# ATP axiom /-x≥y #-}

postulate
  _^_ : D → D → D
  ^-0 : ∀ n →   n ^ zero   ≡ one
  ^-S : ∀ m n → m ^ succ n ≡ m * m ^ n
{-# ATP axiom ^-0 #-}
{-# ATP axiom ^-S #-}

-- Some predicates
Even : D → Set
Even n = ∃ (λ k → n ≡ two * k)

Odd : D → Set
Odd n = ∃ (λ k → n ≡ two * k + one)


Field: add /1-id

Field: add /1-id

{-# OPTIONS --without-K #-}
open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Function.Extensionality
open import Data.Product.NP
open import Data.Nat.NP using (ℕ; zero; fold) renaming (suc to 1+)
open import Data.Integer using (ℤ; +_; -[1+_])
open import Algebra.Monoid
open import Algebra.Monoid.Commutative
open import Algebra.Group
open import Algebra.Group.Abelian
open import HoTT

module Algebra.Field where

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  infixl 6 2+_

  field
    +-grp-ops : Group-Ops A
    *-grp-ops : Group-Ops A

  open Additive-Group-Ops       +-grp-ops public
    renaming (2⊗_ to 2*_)
  open Multiplicative-Group-Ops *-grp-ops public

  suc : A → A
  suc = _+_ `1

  pred : A → A
  pred x = x − `1

  `2 `3 `-0 `-1 : A
  `2  = suc `1
  `3  = suc `2
  `-0 = 0− `0
  `-1 = 0− `1

  ℕ[_] : ℕ → A
  ℕ[ 0    ] = `0
  ℕ[ 1+ n ] = fold `1 suc n

  ℤ[_] : ℤ → A
  ℤ[ + x      ] = ℕ[ x ]
  ℤ[ -[1+ x ] ] = 0− ℕ[ 1+ x ]

  -- TODO use _^⁺_ and _^_ from group/monoid
  _^ℕ_ : A → ℕ → A
  b ^ℕ 0      = `1
  b ^ℕ (1+ e) = fold b (_*_ b) e

  _^ℤ_ : A → ℤ → A
  b ^ℤ (+ x)    = b ^ℕ x
  b ^ℤ -[1+ x ] = (b ^ℕ (1+ x))⁻¹

  2+_ : A → A
  2+ x = `2 + x

record Field-Struct {ℓ} {A : Set ℓ} (field-ops : Field-Ops A) : Set ℓ where
  open Field-Ops field-ops public
  open ≡-Reasoning

  field
    0≢1                  : `0 ≢ `1
    +-abelian-grp-struct : Abelian-Group-Struct +-grp-ops

    *-comm-mon-struct    : Commutative-Monoid-Struct *-mon-ops
    ⁻¹-inverse           : InverseNonZero `0 `1 _⁻¹ _*_
    *-+-distrs           : _*_ DistributesOver _+_

  open Additive-Abelian-Group-Struct +-abelian-grp-struct public
  -- 0−-involutive   : Involutive 0−_
  -- cancels-+-left  : LeftCancel _+_
  -- cancels-+-right : RightCancel _+_
  -- ...

  open Multiplicative-Commutative-Monoid-Struct *-comm-mon-struct public

  +-grp-struct : Group-Struct +-grp-ops
  +-grp-struct = Abelian-Group-Struct.grp-struct +-abelian-grp-struct

  +-abelian-grp : Abelian-Group A
  +-abelian-grp = +-grp-ops , +-abelian-grp-struct

  +-grp : Group A
  +-grp = +-grp-ops , +-grp-struct

  -- Since the Abelian-Group module includes all what Group and
  -- Monoid provide, we can expose a single module.
  module +-Grp = Abelian-Group +-abelian-grp

  *-mon-struct : Monoid-Struct *-mon-ops
  *-mon-struct = Commutative-Monoid-Struct.mon-struct *-comm-mon-struct

  *-mon : Monoid A
  *-mon = *-mon-ops , *-mon-struct

  *-comm-mon : Commutative-Monoid A
  *-comm-mon = *-mon-ops , *-comm-mon-struct

  module *-Mon = Commutative-Monoid *-comm-mon

  1≢0 : `1 ≢ `0
  1≢0 e = 0≢1 (! e)

  NonZero : A → Set ℓ
  NonZero x = x ≢ `0

  A/0 = Σ A NonZero

  ⁻¹-left-inverse : LeftInverseNonZero `0 `1 _⁻¹ _*_
  ⁻¹-left-inverse = fst ⁻¹-inverse

  ⁻¹-right-inverse : RightInverseNonZero `0 `1 _⁻¹ _*_
  ⁻¹-right-inverse = snd ⁻¹-inverse

  *-+-distr : _*_ DistributesOverˡ _+_
  *-+-distr = fst *-+-distrs

  *0-zero : RightZero `0 _*_
  *0-zero = cancels-+-right  (+= idp (! *1-identity) ∙ ! *-+-distr
                            ∙ *= idp 0+-identity ∙ *1-identity ∙ ! 0+-identity)

  0*-zero : LeftZero `0 _*_
  0*-zero = *-comm ∙ *0-zero

  c⁻¹*c*x : ∀ {c x} → c ≢ `0 → c ⁻¹ * c * x ≡ x
  c⁻¹*c*x c≢0 = *= (⁻¹-left-inverse c≢0) idp ∙ 1*-identity

  cancels-*-left : LeftCancelNonZero `0 _*_
  cancels-*-left c≢0 p = ! c⁻¹*c*x c≢0 ∙ *-!assoc= p ∙ c⁻¹*c*x c≢0

  cancels-*-right : RightCancelNonZero `0 _*_
  cancels-*-right c≢0 p = cancels-*-left c≢0 (*-comm= p)

  unique-0 : ∀ {x y} → x ≢ `0 → x * y ≡ `0 → y ≡ `0
  unique-0 nx xy≡0 = cancels-*-left nx (xy≡0 ∙ ! *0-zero)

  no-zero-divisor : ∀ {x y} → x ≢ `0 → y ≢ `0 → x * y ≢ `0
  no-zero-divisor nx ny x*y≡0 = ny (unique-0 nx x*y≡0)

  _*/0_ : A/0 → A/0 → A/0
  (x , x≢0) */0 (y , y≢0) = x * y , no-zero-divisor x≢0 y≢0

  ``1 : A/0
  ``1 = `1 , 1≢0

  *-mon-ops/0 : Monoid-Ops A/0
  *-mon-ops/0 = _*/0_ , ``1

  ⁻¹-non-zero : ∀ {x} → x ≢ `0 → x ⁻¹ ≢ `0
  ⁻¹-non-zero x≢0 = λ p → 0≢1 (! 0*-zero ∙ *= (! p) idp ∙ ⁻¹-left-inverse x≢0)

  _⁻¹/0 : A/0 → A/0
  (x , x≢0) ⁻¹/0 = x ⁻¹ , ⁻¹-non-zero x≢0

  *-grp-ops/0 : Group-Ops A/0
  *-grp-ops/0 = *-mon-ops/0 , _⁻¹/0

  module _ {{_ : FunExt}} where
    A/0= : {x y : A/0}(p : fst x ≡ fst y) → x ≡ y
    A/0= p = pair= p (¬-has-all-paths _ _)

    *-mon-struct/0 : Monoid-Struct *-mon-ops/0
    *-mon-struct/0 = (A/0= *-assoc , A/0= *-!assoc)
                   , A/0= 1*-identity , A/0= *1-identity

    ⁻¹-left-inverse/0 : LeftInverse ``1 _⁻¹/0 _*/0_
    ⁻¹-left-inverse/0 {x , x≢0} = A/0= (⁻¹-left-inverse x≢0)

    *-grp-struct/0 : Group-Struct *-grp-ops/0
    *-grp-struct/0 = *-mon-struct/0
                   , (λ {x} → ⁻¹-left-inverse/0 {x}) ,
                     (λ {x} → A/0= (⁻¹-right-inverse (snd x)))

    *-grp/0 : Group A/0
    *-grp/0 = *-grp-ops/0 , *-grp-struct/0

    *-abelian-grp-struct/0 : Abelian-Group-Struct *-grp-ops/0
    *-abelian-grp-struct/0 = *-grp-struct/0 , A/0= *-comm

    *-abelian-grp/0 : Abelian-Group A/0
    *-abelian-grp/0 = *-grp-ops/0 , *-abelian-grp-struct/0
    -- module *-Grp/0 = Abelian-Group *-abelian-grp/0

  0−-left-inverse : LeftInverse `0 0−_ _+_
  0−-left-inverse = fst 0−-inverse

  0−-right-inverse : RightInverse `0 0−_ _+_
  0−-right-inverse = snd 0−-inverse

  0−= : ∀ {x y} → x ≡ y → 0− x ≡ 0− y
  0−= = ap 0−_

  ⁻¹= : ∀ {x y} → x ≡ y → x ⁻¹ ≡ y ⁻¹
  ⁻¹= = ap _⁻¹

  *-+-distrʳ : _*_ DistributesOverʳ _+_
  *-+-distrʳ = *-comm ∙ *-+-distr ∙ += *-comm *-comm

  /-+-distrʳ : _/_ DistributesOverʳ _+_
  /-+-distrʳ = *-+-distrʳ

  0−c+c+x : ∀ {c x} → 0− c + c + x ≡ x
  0−c+c+x = += 0−-left-inverse idp ∙ 0+-identity

  -0≡0 : `-0 ≡ `0
  -0≡0 = 0−0≡0

  0≢-1 : `0 ≢ `-1
  0≢-1 0≡-1 = 0≢1 (! 0−-left-inverse ∙ +-comm ∙ ! ap suc 0≡-1 ∙ +0-identity)

  0−-*-distr : ∀ {x y} → 0−(x * y) ≡ (0− x) * y
  0−-*-distr = cancels-+-right (0−-left-inverse ∙ ! 0*-zero ∙ *= (! 0−-left-inverse) idp ∙ *-+-distrʳ)

  -1*-neg : ∀ {x} → `-1 * x ≡ 0− x
  -1*-neg = ! 0−-*-distr ∙ 0−= 1*-identity

  1⁻¹≡1 : `1 ⁻¹ ≡ `1
  1⁻¹≡1 = ! *1-identity ∙ ⁻¹-left-inverse (λ p → 0≢1 (! p))

  /1-id : ∀ {x} → x / `1 ≡ x
  /1-id = *= idp 1⁻¹≡1 ∙ *1-identity

  2*-spec : ∀ {n} → 2* n ≡ `2 * n
  2*-spec = ! += 1*-identity 1*-identity ∙ ! *-+-distrʳ

  *-unique-inverse : ∀ {x y} → x ≢ `0 → x * y ≡ `1 → y ≡ x ⁻¹
  *-unique-inverse x≢0 xy=1 = ! 1*-identity ∙ *= (! ⁻¹-left-inverse x≢0) idp ∙ *-assoc ∙ *= idp xy=1 ∙ *1-identity

  ⁻¹-involutive : ∀ {x} → x ≢ `0 → x ⁻¹ ⁻¹ ≡ x
  ⁻¹-involutive x≢0 = ! *-unique-inverse (⁻¹-non-zero x≢0) (⁻¹-left-inverse x≢0)

  ⁻¹*-distr : ∀ {x y} → x ≢ `0 → y ≢ `0 → (x * y)⁻¹ ≡ x ⁻¹  / y
  ⁻¹*-distr x≢0 y≢0 =
    ! (*-unique-inverse (no-zero-divisor x≢0 y≢0) (*= idp *-comm ∙ *-assoc ∙ *= idp (! *-assoc ∙ *= (⁻¹-right-inverse y≢0) idp ∙ 1*-identity) ∙ ⁻¹-right-inverse x≢0))

  +-quotient : ∀ {a b a' b'} → b ≢ `0 → b' ≢ `0
    → (a / b) + (a' / b') ≡ (a * b' + a' * b) / (b * b')
  +-quotient b b'
    = += (*= (! *1-identity ∙ *= idp (! ⁻¹-left-inverse b') ∙ *= idp *-comm ∙ ! *-assoc) idp ∙
          *-assoc ∙ *= idp (! ⁻¹*-distr b' b ∙ ⁻¹= *-comm))
         (*= (! *1-identity ∙ *= idp (! ⁻¹-left-inverse b ) ∙ *= idp *-comm) idp ∙
          *-!assoc= *-assoc ∙ *= idp (! ⁻¹*-distr b b'))
    ∙ ! /-+-distrʳ

  −-quotient : ∀ {a b a' b'} → b ≢ `0 → b' ≢ `0
    → (a / b) − (a' / b') ≡ (a * b' − a' * b) / (b * b')
  −-quotient b b' = += idp 0−-*-distr ∙ +-quotient b b' ∙ /= (+= idp (! 0−-*-distr)) idp

  *-quotient : ∀ {a b a' b'} → b ≢ `0 → b' ≢ `0
    → (a / b) * (a' / b') ≡ (a * a') / (b * b')
  *-quotient b≢0 b'≢0 = *-interchange ∙ *= idp (! ⁻¹*-distr b≢0 b'≢0)

  /-quotient : ∀ {a b a' b'} → a' ≢ `0 → b ≢ `0 → b' ≢ `0
     → (a / b) / (a' / b') ≡ (a * b') / (b * a')
  /-quotient a' b b' = *= idp (⁻¹*-distr a' (⁻¹-non-zero b') ∙ *= idp (⁻¹-involutive b') ∙ *-comm)
    ∙ *-interchange ∙ *= idp (! ⁻¹*-distr b a')

  0−-*-distr' : ∀ {x y} → 0−(x * y) ≡ x * (0− y)
  0−-*-distr' = 0−= *-comm ∙ 0−-*-distr ∙ *-comm

  *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
  *-−-distr = *-+-distr ∙ += idp (! 0−-*-distr')

  0−-+-distr : ∀ {x y} → 0−(x + y) ≡ 0− x − y
  0−-+-distr = 0−-hom

  ²-*-distr : ∀ {x y} → (x * y)² ≡ x ² * y ²
  ²-*-distr = *-interchange

  ²-0−-distr : ∀ {x} → (0− x)² ≡ x ²
  ²-0−-distr {x} = ! 0−-*-distr ∙ 0−= (! 0−-*-distr') ∙ 0−-involutive

  2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
  2*-*-distr = ! *-+-distrʳ

  ²-+-distr : ∀ {x y} → (x + y)² ≡ x ² + y ² + 2* x * y
  ²-+-distr {x} {y} = (x + y)²
                    ≡⟨ *-+-distr ⟩
                      (x + y) * x + (x + y) * y
                    ≡⟨ += *-+-distrʳ *-+-distrʳ ⟩
                      x ² + y * x + (x * y + y ²)
                    ≡⟨ += (+= idp *-comm) +-comm ∙ +-interchange ⟩
                      x ² + y ² + 2*(x * y)
                    ≡⟨ += idp 2*-*-distr ⟩
                       x ² + y ² + 2* x * y
                    ∎

  ²-−-distr : ∀ {x y} → (x − y)² ≡ x ² + y ² − 2* x * y
  ²-−-distr = ²-+-distr ∙ += (+= idp ²-0−-distr) (*-comm ∙ ! 0−-*-distr ∙ 0−= *-comm)

record Field {ℓ} (A : Set ℓ) : Set ℓ where
  field
    field-ops    : Field-Ops A
    field-struct : Field-Struct field-ops
  open Field-Struct field-struct public
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Function.Extensionality
open import Data.Product.NP
open import Data.Nat.NP using (ℕ; zero; fold) renaming (suc to 1+)
open import Data.Integer using (ℤ; +_; -[1+_])
open import Algebra.Monoid
open import Algebra.Monoid.Commutative
open import Algebra.Group
open import Algebra.Group.Abelian
open import HoTT

module Algebra.Field where

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  infixl 6 2+_

  field
    +-grp-ops : Group-Ops A
    *-grp-ops : Group-Ops A

  open Additive-Group-Ops       +-grp-ops public
    renaming (2⊗_ to 2*_)
  open Multiplicative-Group-Ops *-grp-ops public

  suc : A → A
  suc = _+_ `1

  pred : A → A
  pred x = x − `1

  `2 `3 `-0 `-1 : A
  `2  = suc `1
  `3  = suc `2
  `-0 = 0− `0
  `-1 = 0− `1

  ℕ[_] : ℕ → A
  ℕ[ 0    ] = `0
  ℕ[ 1+ n ] = fold `1 suc n

  ℤ[_] : ℤ → A
  ℤ[ + x      ] = ℕ[ x ]
  ℤ[ -[1+ x ] ] = 0− ℕ[ 1+ x ]

  -- TODO use _^⁺_ and _^_ from group/monoid
  _^ℕ_ : A → ℕ → A
  b ^ℕ 0      = `1
  b ^ℕ (1+ e) = fold b (_*_ b) e

  _^ℤ_ : A → ℤ → A
  b ^ℤ (+ x)    = b ^ℕ x
  b ^ℤ -[1+ x ] = (b ^ℕ (1+ x))⁻¹

  2+_ : A → A
  2+ x = `2 + x

record Field-Struct {ℓ} {A : Set ℓ} (field-ops : Field-Ops A) : Set ℓ where
  open Field-Ops field-ops public
  open ≡-Reasoning

  field
    0≢1                  : `0 ≢ `1
    +-abelian-grp-struct : Abelian-Group-Struct +-grp-ops

    *-comm-mon-struct    : Commutative-Monoid-Struct *-mon-ops
    ⁻¹-inverse           : InverseNonZero `0 `1 _⁻¹ _*_
    *-+-distrs           : _*_ DistributesOver _+_

  open Additive-Abelian-Group-Struct +-abelian-grp-struct public
  -- 0−-involutive   : Involutive 0−_
  -- cancels-+-left  : LeftCancel _+_
  -- cancels-+-right : RightCancel _+_
  -- ...

  open Multiplicative-Commutative-Monoid-Struct *-comm-mon-struct public

  +-grp-struct : Group-Struct +-grp-ops
  +-grp-struct = Abelian-Group-Struct.grp-struct +-abelian-grp-struct

  +-abelian-grp : Abelian-Group A
  +-abelian-grp = +-grp-ops , +-abelian-grp-struct

  +-grp : Group A
  +-grp = +-grp-ops , +-grp-struct

  -- Since the Abelian-Group module includes all what Group and
  -- Monoid provide, we can expose a single module.
  module +-Grp = Abelian-Group +-abelian-grp

  *-mon-struct : Monoid-Struct *-mon-ops
  *-mon-struct = Commutative-Monoid-Struct.mon-struct *-comm-mon-struct

  *-mon : Monoid A
  *-mon = *-mon-ops , *-mon-struct

  *-comm-mon : Commutative-Monoid A
  *-comm-mon = *-mon-ops , *-comm-mon-struct

  module *-Mon = Commutative-Monoid *-comm-mon

  1≢0 : `1 ≢ `0
  1≢0 e = 0≢1 (! e)

  NonZero : A → Set ℓ
  NonZero x = x ≢ `0

  A/0 = Σ A NonZero

  ⁻¹-left-inverse : LeftInverseNonZero `0 `1 _⁻¹ _*_
  ⁻¹-left-inverse = fst ⁻¹-inverse

  ⁻¹-right-inverse : RightInverseNonZero `0 `1 _⁻¹ _*_
  ⁻¹-right-inverse = snd ⁻¹-inverse

  *-+-distr : _*_ DistributesOverˡ _+_
  *-+-distr = fst *-+-distrs

  *0-zero : RightZero `0 _*_
  *0-zero = cancels-+-right  (+= idp (! *1-identity) ∙ ! *-+-distr
                            ∙ *= idp 0+-identity ∙ *1-identity ∙ ! 0+-identity)

  0*-zero : LeftZero `0 _*_
  0*-zero = *-comm ∙ *0-zero

  c⁻¹*c*x : ∀ {c x} → c ≢ `0 → c ⁻¹ * c * x ≡ x
  c⁻¹*c*x c≢0 = *= (⁻¹-left-inverse c≢0) idp ∙ 1*-identity

  cancels-*-left : LeftCancelNonZero `0 _*_
  cancels-*-left c≢0 p = ! c⁻¹*c*x c≢0 ∙ *-!assoc= p ∙ c⁻¹*c*x c≢0

  cancels-*-right : RightCancelNonZero `0 _*_
  cancels-*-right c≢0 p = cancels-*-left c≢0 (*-comm= p)

  unique-0 : ∀ {x y} → x ≢ `0 → x * y ≡ `0 → y ≡ `0
  unique-0 nx xy≡0 = cancels-*-left nx (xy≡0 ∙ ! *0-zero)

  no-zero-divisor : ∀ {x y} → x ≢ `0 → y ≢ `0 → x * y ≢ `0
  no-zero-divisor nx ny x*y≡0 = ny (unique-0 nx x*y≡0)

  _*/0_ : A/0 → A/0 → A/0
  (x , x≢0) */0 (y , y≢0) = x * y , no-zero-divisor x≢0 y≢0

  ``1 : A/0
  ``1 = `1 , 1≢0

  *-mon-ops/0 : Monoid-Ops A/0
  *-mon-ops/0 = _*/0_ , ``1

  ⁻¹-non-zero : ∀ {x} → x ≢ `0 → x ⁻¹ ≢ `0
  ⁻¹-non-zero x≢0 = λ p → 0≢1 (! 0*-zero ∙ *= (! p) idp ∙ ⁻¹-left-inverse x≢0)

  _⁻¹/0 : A/0 → A/0
  (x , x≢0) ⁻¹/0 = x ⁻¹ , ⁻¹-non-zero x≢0

  *-grp-ops/0 : Group-Ops A/0
  *-grp-ops/0 = *-mon-ops/0 , _⁻¹/0

  module _ {{_ : FunExt}} where
    A/0= : {x y : A/0}(p : fst x ≡ fst y) → x ≡ y
    A/0= p = pair= p (¬-has-all-paths _ _)

    *-mon-struct/0 : Monoid-Struct *-mon-ops/0
    *-mon-struct/0 = (A/0= *-assoc , A/0= *-!assoc)
                   , A/0= 1*-identity , A/0= *1-identity

    ⁻¹-left-inverse/0 : LeftInverse ``1 _⁻¹/0 _*/0_
    ⁻¹-left-inverse/0 {x , x≢0} = A/0= (⁻¹-left-inverse x≢0)

    *-grp-struct/0 : Group-Struct *-grp-ops/0
    *-grp-struct/0 = *-mon-struct/0
                   , (λ {x} → ⁻¹-left-inverse/0 {x}) ,
                     (λ {x} → A/0= (⁻¹-right-inverse (snd x)))

    *-grp/0 : Group A/0
    *-grp/0 = *-grp-ops/0 , *-grp-struct/0

    *-abelian-grp-struct/0 : Abelian-Group-Struct *-grp-ops/0
    *-abelian-grp-struct/0 = *-grp-struct/0 , A/0= *-comm

    *-abelian-grp/0 : Abelian-Group A/0
    *-abelian-grp/0 = *-grp-ops/0 , *-abelian-grp-struct/0
    -- module *-Grp/0 = Abelian-Group *-abelian-grp/0

  0−-left-inverse : LeftInverse `0 0−_ _+_
  0−-left-inverse = fst 0−-inverse

  0−-right-inverse : RightInverse `0 0−_ _+_
  0−-right-inverse = snd 0−-inverse

  0−= : ∀ {x y} → x ≡ y → 0− x ≡ 0− y
  0−= = ap 0−_

  ⁻¹= : ∀ {x y} → x ≡ y → x ⁻¹ ≡ y ⁻¹
  ⁻¹= = ap _⁻¹

  *-+-distrʳ : _*_ DistributesOverʳ _+_
  *-+-distrʳ = *-comm ∙ *-+-distr ∙ += *-comm *-comm

  /-+-distrʳ : _/_ DistributesOverʳ _+_
  /-+-distrʳ = *-+-distrʳ

  0−c+c+x : ∀ {c x} → 0− c + c + x ≡ x
  0−c+c+x = += 0−-left-inverse idp ∙ 0+-identity

  -0≡0 : `-0 ≡ `0
  -0≡0 = 0−0≡0

  0≢-1 : `0 ≢ `-1
  0≢-1 0≡-1 = 0≢1 (! 0−-left-inverse ∙ +-comm ∙ ! ap suc 0≡-1 ∙ +0-identity)

  0−-*-distr : ∀ {x y} → 0−(x * y) ≡ (0− x) * y
  0−-*-distr = cancels-+-right (0−-left-inverse ∙ ! 0*-zero ∙ *= (! 0−-left-inverse) idp ∙ *-+-distrʳ)

  -1*-neg : ∀ {x} → `-1 * x ≡ 0− x
  -1*-neg = ! 0−-*-distr ∙ 0−= 1*-identity

  1⁻¹≡1 : `1 ⁻¹ ≡ `1
  1⁻¹≡1 = ! *1-identity ∙ ⁻¹-left-inverse (λ p → 0≢1 (! p))

  2*-spec : ∀ {n} → 2* n ≡ `2 * n
  2*-spec = ! += 1*-identity 1*-identity ∙ ! *-+-distrʳ

  *-unique-inverse : ∀ {x y} → x ≢ `0 → x * y ≡ `1 → y ≡ x ⁻¹
  *-unique-inverse x≢0 xy=1 = ! 1*-identity ∙ *= (! ⁻¹-left-inverse x≢0) idp ∙ *-assoc ∙ *= idp xy=1 ∙ *1-identity

  ⁻¹-involutive : ∀ {x} → x ≢ `0 → x ⁻¹ ⁻¹ ≡ x
  ⁻¹-involutive x≢0 = ! *-unique-inverse (⁻¹-non-zero x≢0) (⁻¹-left-inverse x≢0)

  ⁻¹*-distr : ∀ {x y} → x ≢ `0 → y ≢ `0 → (x * y)⁻¹ ≡ x ⁻¹  / y
  ⁻¹*-distr x≢0 y≢0 =
    ! (*-unique-inverse (no-zero-divisor x≢0 y≢0) (*= idp *-comm ∙ *-assoc ∙ *= idp (! *-assoc ∙ *= (⁻¹-right-inverse y≢0) idp ∙ 1*-identity) ∙ ⁻¹-right-inverse x≢0))

  +-quotient : ∀ {a b a' b'} → b ≢ `0 → b' ≢ `0
    → (a / b) + (a' / b') ≡ (a * b' + a' * b) / (b * b')
  +-quotient b b'
    = += (*= (! *1-identity ∙ *= idp (! ⁻¹-left-inverse b') ∙ *= idp *-comm ∙ ! *-assoc) idp ∙
          *-assoc ∙ *= idp (! ⁻¹*-distr b' b ∙ ⁻¹= *-comm))
         (*= (! *1-identity ∙ *= idp (! ⁻¹-left-inverse b ) ∙ *= idp *-comm) idp ∙
          *-!assoc= *-assoc ∙ *= idp (! ⁻¹*-distr b b'))
    ∙ ! /-+-distrʳ

  −-quotient : ∀ {a b a' b'} → b ≢ `0 → b' ≢ `0
    → (a / b) − (a' / b') ≡ (a * b' − a' * b) / (b * b')
  −-quotient b b' = += idp 0−-*-distr ∙ +-quotient b b' ∙ /= (+= idp (! 0−-*-distr)) idp

  *-quotient : ∀ {a b a' b'} → b ≢ `0 → b' ≢ `0
    → (a / b) * (a' / b') ≡ (a * a') / (b * b')
  *-quotient b≢0 b'≢0 = *-interchange ∙ *= idp (! ⁻¹*-distr b≢0 b'≢0)

  /-quotient : ∀ {a b a' b'} → a' ≢ `0 → b ≢ `0 → b' ≢ `0
     → (a / b) / (a' / b') ≡ (a * b') / (b * a')
  /-quotient a' b b' = *= idp (⁻¹*-distr a' (⁻¹-non-zero b') ∙ *= idp (⁻¹-involutive b') ∙ *-comm)
    ∙ *-interchange ∙ *= idp (! ⁻¹*-distr b a')

  0−-*-distr' : ∀ {x y} → 0−(x * y) ≡ x * (0− y)
  0−-*-distr' = 0−= *-comm ∙ 0−-*-distr ∙ *-comm

  *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
  *-−-distr = *-+-distr ∙ += idp (! 0−-*-distr')

  0−-+-distr : ∀ {x y} → 0−(x + y) ≡ 0− x − y
  0−-+-distr = 0−-hom

  ²-*-distr : ∀ {x y} → (x * y)² ≡ x ² * y ²
  ²-*-distr = *-interchange

  ²-0−-distr : ∀ {x} → (0− x)² ≡ x ²
  ²-0−-distr {x} = ! 0−-*-distr ∙ 0−= (! 0−-*-distr') ∙ 0−-involutive

  2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
  2*-*-distr = ! *-+-distrʳ

  ²-+-distr : ∀ {x y} → (x + y)² ≡ x ² + y ² + 2* x * y
  ²-+-distr {x} {y} = (x + y)²
                    ≡⟨ *-+-distr ⟩
                      (x + y) * x + (x + y) * y
                    ≡⟨ += *-+-distrʳ *-+-distrʳ ⟩
                      x ² + y * x + (x * y + y ²)
                    ≡⟨ += (+= idp *-comm) +-comm ∙ +-interchange ⟩
                      x ² + y ² + 2*(x * y)
                    ≡⟨ += idp 2*-*-distr ⟩
                       x ² + y ² + 2* x * y
                    ∎

  ²-−-distr : ∀ {x y} → (x − y)² ≡ x ² + y ² − 2* x * y
  ²-−-distr = ²-+-distr ∙ += (+= idp ²-0−-distr) (*-comm ∙ ! 0−-*-distr ∙ 0−= *-comm)

record Field {ℓ} (A : Set ℓ) : Set ℓ where
  field
    field-ops    : Field-Ops A
    field-struct : Field-Struct field-ops
  open Field-Struct field-struct public
-- -}
-- -}
-- -}
-- -}
-- -}


a couple of cases of progress

a couple of cases of progress

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

module progress where

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

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ → ok d Δ
  progress TAConst = V VConst
  progress (TAVar x) = abort (somenotnone (! x))
  progress (TALam D) = V VLam
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
  progress (TAAp TAConst () D2) | V VConst | V x₁
  progress {Δ = Δ} (TAAp D1 x₂ D2) | V VLam | V x₁ = S {Δ = Δ} (_ , Step FRefl (ITLam (FVal x₁)) FRefl)
  progress (TAAp TAConst () D2) | V VConst | I x₁
  progress (TAAp (TALam D1) MAArr D2) | V VLam | I x₁ = S (_ , Step (FAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!})
  progress (TAAp D1 x₂ D2) | V x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | V x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | S x₁ = {!!}
  progress (TAEHole x x₁) = I IEHole
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V VConst = I (INEHole (FVal VConst))
  progress (TANEHole x₁ (TALam D) x₂) | V VLam = I (INEHole (FVal VLam))
  progress (TANEHole x₁ D x₂) | I x = I (INEHole (FIndet x))
  progress (TANEHole x₁ D x₂) | E x = E {!!}
  progress (TANEHole x₃ D x₄) | S (d , Step x x₁ x₂) = S (_ , (Step (FNEHole x) x₁ (FNEHole x₂)))
  progress (TACast D x)
    with progress D
  progress (TACast TAConst TCRefl)  | V VConst = E {!!}
  progress (TACast TAConst TCHole2) | V VConst = E {!!}
  progress (TACast D x₁) | V VLam = E {!!}
  progress (TACast D x₁) | I x = I (ICast x)
  progress (TACast D x₁) | E x = E {!!}
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S ( _ , Step (FCast x) x₁ (FCast x₂))

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

module progress where

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

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ → ok d Δ
  progress TAConst = V VConst
  progress (TAVar x) = abort (somenotnone (! x))
  progress (TALam D) = V VLam
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
  progress (TAAp TAConst () D2) | V VConst | V x₁
  progress {Δ = Δ} (TAAp D1 x₂ D2) | V VLam | V x₁ = S {Δ = Δ} (_ , Step FRefl (ITLam (FVal x₁)) FRefl)
  progress (TAAp D1 x₂ D2) | V x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | V x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | V x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | S x₁ = {!!}
  progress (TAEHole x x₁) = I IEHole
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V x = {!!}
  progress (TANEHole x₁ D x₂) | I x = {!!}
  progress (TANEHole x₁ D x₂) | E x = {!!}
  progress (TANEHole x₁ D x₂) | S x = {!!}
  progress (TACast D x)
    with progress D
  progress (TACast TAConst TCRefl)  | V VConst = E {!!}
  progress (TACast TAConst TCHole2) | V VConst = E {!!}
  progress (TACast D x₁) | V VLam = {!!}
  progress (TACast D x₁) | I x = {!!}
  progress (TACast D x₁) | E x = {!!}
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = {!!}


Removed unnecessary local hint.

Removed unnecessary local hint.

Ignore-this: 20861fa0526b90dd5a4befd9057767da

darcs-hash:20110215033029-3bd4e-49b903264c9a8debc8c99919549787d57ab29f20.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))

-- TODO: To move to LTC.Data.Nat.Inequalities.Properties.
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 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} → 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} → 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 → x<y→y≡z→x<z m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)

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))

-- TODO: To move to LTC.Data.Nat.Inequalities.Properties.
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} → 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} → 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 → x<y→y≡z→x<z m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)

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.