Algebra: missing constructor

Algebra: missing constructor

open import Type using (Type_)
open import Function.NP
open import Data.Nat.Base using (ℕ) renaming (suc to 1+_)
open import Data.Integer using (ℤ; +_; -[1+_])
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)

module Algebra.Raw where

record Magma {ℓ}(A : Type ℓ) : Type ℓ where
  constructor ⟨_⟩
  infixl 7 _∙_

  field
    _∙_ : A → A → A

  infix 8 _² _³ _⁴

  _² : A → A
  x ² = x ∙ x

  _³ : A → A
  x ³ = x ² ∙ x

  _⁴ : A → A
  x ⁴ = x ³ ∙ x

  infix 8 _^¹⁺_
  _^¹⁺_ : A → ℕ → A
  x ^¹⁺ n = nest n (_∙_ x) x

  module _ {x x' y y'}(p : x ≡ x')(q : y ≡ y') where
    ∙= : x ∙ y ≡ x' ∙ y'
    ∙= = ap (_∙_ x) q ♦ ap (λ z → z ∙ y') p

record Monoid-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  constructor _,_
  infixl 7 _∙_

  field
    _∙_ : A → A → A
    ε   : A

  ∙-magma : Magma A
  ∙-magma = ⟨ _∙_ ⟩

  open Magma ∙-magma public hiding (_∙_)

  infix 8 _^⁺_
  _^⁺_ : A → ℕ → A
  x ^⁺ n = nest n (_∙_ x) ε

-- A renaming of Monoid-Ops with additive notation
module Additive-Monoid-Ops {ℓ}{M : Set ℓ} (mon : Monoid-Ops M) where
  private
   module M = Monoid-Ops mon
    using    ()
    renaming ( _∙_ to _+_
             ; ε to 0#
             ; _² to 2⊗_
             ; _³ to 3⊗_
             ; _⁴ to 4⊗_
             ; _^¹⁺_ to _⊗¹⁺_
             ; _^⁺_ to _⊗⁺_
             ; ∙= to +=
             )
  open M public using (0#; +=)
  infixl 6 _+_
  infixl 7 _⊗¹⁺_ _⊗⁺_ 2⊗_ 3⊗_ 4⊗_
  _+_   = M._+_
  _⊗¹⁺_ = M._⊗¹⁺_
  _⊗⁺_  = M._⊗⁺_
  2⊗_   = M.2⊗_
  3⊗_   = M.3⊗_
  4⊗_   = M.4⊗_

-- A renaming of Monoid-Ops with multiplicative notation
module Multiplicative-Monoid-Ops {ℓ}{M : Type ℓ} (mon-ops : Monoid-Ops M)
  = Monoid-Ops mon-ops
    renaming ( _∙_ to _*_
             ; ε to 1#
             ; ∙= to *=
             )

record Group-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  constructor _,_

  field
    mon-ops : Monoid-Ops A
    _⁻¹     : A → A

  open Monoid-Ops mon-ops public

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

  infixl 7 _/_

  _/_ : A → A → A
  x / y = x ∙ y ⁻¹

  /-magma : Magma A
  /-magma = ⟨ _/_ ⟩

  open Magma /-magma public using () renaming (∙= to /=)

  _^⁻_ _^⁻′_ : A → ℕ → A
  x ^⁻ n = (x ^⁺ n)⁻¹
  x ^⁻′ n = (x ⁻¹)^⁺ n

  _^_ : A → ℤ → A
  x ^ -[1+ n ] = x ^⁻(1+ n)
  x ^ (+ n)    = x ^⁺ n

-- A renaming of Group-Ops with additive notation
module Additive-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) where
  private
   module M = Group-Ops grp
    using    ()
    renaming ( _⁻¹ to 0−_
             ; ⁻¹= to 0−=
             ; _/_ to _−_
             ; _^⁻_ to _⊗⁻_
             ; _^_ to _⊗_
             ; mon-ops to +-mon-ops
             ; /= to −=)
  open M public using (0−_; +-mon-ops; −=; 0−=)
  open Additive-Monoid-Ops +-mon-ops public
  infixl 6 _−_
  infixl 7 _⊗⁻_ _⊗_
  _−_   = M._−_
  _⊗⁻_  = M._⊗⁻_
  _⊗_   = M._⊗_

-- A renaming of Group-Ops with multiplicative notation
module Multiplicative-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) = Group-Ops grp
    using    ( _^⁺_; _²; _³; _⁴; _⁻¹; _/_; /=; _^⁻_; _^_; /-magma; ⁻¹= )
    renaming ( _∙_ to _*_; ε to 1#; mon-ops to *-mon-ops; ∙= to *= )

record Ring-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  constructor _,_
  infixl 6 2+_

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

  open Additive-Group-Ops        +-grp-ops public
    renaming (2⊗_ to 2*_)
  open Multiplicative-Monoid-Ops *-mon-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 ] = nest n suc 1#

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

  -- TODO use _^⁺_ and _^_ from group/monoid
  _^ℕ_ : A → ℕ → A
  b ^ℕ 0      = 1#
  b ^ℕ (1+ n) = nest n (_*_ b) b

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

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  constructor _,_

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

  open Multiplicative-Group-Ops *-grp-ops public
    using ( _⁻¹; ⁻¹=; _/_; /-magma; /=; _^⁻_; _^_; *-mon-ops )

  rng-ops : Ring-Ops A
  rng-ops = +-grp-ops , *-mon-ops

  open Ring-Ops rng-ops public
    hiding (+-grp-ops; *-mon-ops)

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

open import Type using (Type_)
open import Function.NP
open import Data.Nat using (ℕ) renaming (suc to 1+_)
open import Data.Integer using (ℤ; +_; -[1+_])
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)

module Algebra.Raw where

record Magma {ℓ}(A : Type ℓ) : Type ℓ where
  constructor ⟨_⟩
  infixl 7 _∙_

  field
    _∙_ : A → A → A

  infix 8 _² _³ _⁴

  _² : A → A
  x ² = x ∙ x

  _³ : A → A
  x ³ = x ² ∙ x

  _⁴ : A → A
  x ⁴ = x ³ ∙ x

  infix 8 _^¹⁺_
  _^¹⁺_ : A → ℕ → A
  x ^¹⁺ n = nest n (_∙_ x) x

  module _ {x x' y y'}(p : x ≡ x')(q : y ≡ y') where
    ∙= : x ∙ y ≡ x' ∙ y'
    ∙= = ap (_∙_ x) q ♦ ap (λ z → z ∙ y') p

record Monoid-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  constructor _,_
  infixl 7 _∙_

  field
    _∙_ : A → A → A
    ε   : A

  ∙-magma : Magma A
  ∙-magma = ⟨ _∙_ ⟩

  open Magma ∙-magma public hiding (_∙_)

  infix 8 _^⁺_
  _^⁺_ : A → ℕ → A
  x ^⁺ n = nest n (_∙_ x) ε

-- A renaming of Monoid-Ops with additive notation
module Additive-Monoid-Ops {ℓ}{M : Set ℓ} (mon : Monoid-Ops M) where
  private
   module M = Monoid-Ops mon
    using    ()
    renaming ( _∙_ to _+_
             ; ε to 0#
             ; _² to 2⊗_
             ; _³ to 3⊗_
             ; _⁴ to 4⊗_
             ; _^¹⁺_ to _⊗¹⁺_
             ; _^⁺_ to _⊗⁺_
             ; ∙= to +=
             )
  open M public using (0#; +=)
  infixl 6 _+_
  infixl 7 _⊗¹⁺_ _⊗⁺_ 2⊗_ 3⊗_ 4⊗_
  _+_   = M._+_
  _⊗¹⁺_ = M._⊗¹⁺_
  _⊗⁺_  = M._⊗⁺_
  2⊗_   = M.2⊗_
  3⊗_   = M.3⊗_
  4⊗_   = M.4⊗_

-- A renaming of Monoid-Ops with multiplicative notation
module Multiplicative-Monoid-Ops {ℓ}{M : Type ℓ} (mon-ops : Monoid-Ops M)
  = Monoid-Ops mon-ops
    renaming ( _∙_ to _*_
             ; ε to 1#
             ; ∙= to *=
             )

record Group-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  constructor _,_

  field
    mon-ops : Monoid-Ops A
    _⁻¹     : A → A

  open Monoid-Ops mon-ops public

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

  infixl 7 _/_

  _/_ : A → A → A
  x / y = x ∙ y ⁻¹

  /-magma : Magma A
  /-magma = ⟨ _/_ ⟩

  open Magma /-magma public using () renaming (∙= to /=)

  _^⁻_ _^⁻′_ : A → ℕ → A
  x ^⁻ n = (x ^⁺ n)⁻¹
  x ^⁻′ n = (x ⁻¹)^⁺ n

  _^_ : A → ℤ → A
  x ^ -[1+ n ] = x ^⁻(1+ n)
  x ^ (+ n)    = x ^⁺ n

-- A renaming of Group-Ops with additive notation
module Additive-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) where
  private
   module M = Group-Ops grp
    using    ()
    renaming ( _⁻¹ to 0−_
             ; ⁻¹= to 0−=
             ; _/_ to _−_
             ; _^⁻_ to _⊗⁻_
             ; _^_ to _⊗_
             ; mon-ops to +-mon-ops
             ; /= to −=)
  open M public using (0−_; +-mon-ops; −=; 0−=)
  open Additive-Monoid-Ops +-mon-ops public
  infixl 6 _−_
  infixl 7 _⊗⁻_ _⊗_
  _−_   = M._−_
  _⊗⁻_  = M._⊗⁻_
  _⊗_   = M._⊗_

-- A renaming of Group-Ops with multiplicative notation
module Multiplicative-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) = Group-Ops grp
    using    ( _^⁺_; _²; _³; _⁴; _⁻¹; _/_; /=; _^⁻_; _^_; /-magma; ⁻¹= )
    renaming ( _∙_ to _*_; ε to 1#; mon-ops to *-mon-ops; ∙= to *= )

record Ring-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  constructor _,_
  infixl 6 2+_

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

  open Additive-Group-Ops        +-grp-ops public
    renaming (2⊗_ to 2*_)
  open Multiplicative-Monoid-Ops *-mon-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 ] = nest n suc 1#

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

  -- TODO use _^⁺_ and _^_ from group/monoid
  _^ℕ_ : A → ℕ → A
  b ^ℕ 0      = 1#
  b ^ℕ (1+ n) = nest n (_*_ b) b

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

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where

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

  open Multiplicative-Group-Ops *-grp-ops public
    using ( _⁻¹; ⁻¹=; _/_; /-magma; /=; _^⁻_; _^_; *-mon-ops )

  rng-ops : Ring-Ops A
  rng-ops = +-grp-ops , *-mon-ops

  open Ring-Ops rng-ops public
    hiding (+-grp-ops; *-mon-ops)

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


Data.Nat

Data.Nat

{-# OPTIONS --without-K #-}
module Data.Nat.NP where

open import Type hiding (★)
import Algebra
open import Algebra.FunctionProperties.Eq
open import Data.Two.Base hiding (_==_; _²)
open import Data.Product using (∃; _,_) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum renaming (map to ⊎-map)
open import Data.Zero using (𝟘-elim; 𝟘)
open import Data.One using (𝟙)
open import Function.NP
open import Function.Extensionality
open import Relation.Nullary
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_; _≗_; module ≡-Reasoning; !_; _∙_; ap; ap₂; coe)
       renaming (refl to idp)
open import HoTT
open Equivalences

open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties

pattern 1+_ x = suc x
pattern 2+_ x = 1+ suc x
pattern 3+_ x = 2+ suc x
pattern 4+_ x = 3+ suc x

⟨0↔1⟩ : ℕ → ℕ
⟨0↔1⟩ 0 = 1
⟨0↔1⟩ 1 = 0
⟨0↔1⟩ n = n

private
  _² : ∀ {A : ★₀} → Endo (Endo A)
  f ² = f ∘ f

⟨0↔1⟩-involutive : ⟨0↔1⟩ ∘ ⟨0↔1⟩ ≗ id
⟨0↔1⟩-involutive 0             = idp
⟨0↔1⟩-involutive 1             = idp
⟨0↔1⟩-involutive (suc (suc _)) = idp

⇑⟨_⟩ : (ℕ → ℕ) → (ℕ → ℕ)
⇑⟨ f ⟩ zero    = zero
⇑⟨ f ⟩ (suc n) = suc (f n)

⟨0↔1+_⟩ : ℕ → ℕ → ℕ
⟨0↔1+ 0     ⟩ = ⟨0↔1⟩
⟨0↔1+ suc n ⟩ = ⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩ ∘ ⟨0↔1⟩

⟨_↔+1⟩ : ℕ → ℕ → ℕ
⟨ 0     ↔+1⟩ = ⟨0↔1⟩
⟨ suc n ↔+1⟩ 0       = 0
⟨ suc n ↔+1⟩ (suc m) = suc (⟨ n ↔+1⟩ m)

⟨_↔+1⟩-involutive : ∀ n → ⟨ n ↔+1⟩ ∘ ⟨ n ↔+1⟩ ≗ id
⟨_↔+1⟩-involutive 0 = ⟨0↔1⟩-involutive
⟨_↔+1⟩-involutive (suc _) 0       = idp
⟨_↔+1⟩-involutive (suc n) (suc m) = ap suc (⟨ n ↔+1⟩-involutive m)

⟨_↔+1⟩-equiv : ℕ → ℕ ≃ ℕ
⟨ n ↔+1⟩-equiv = self-inv-equiv ⟨ n ↔+1⟩ ⟨ n ↔+1⟩-involutive

⇑⟨_⟩-involutive : ∀ {f} → f ² ≗ id → ⇑⟨ f ⟩ ² ≗ id
⇑⟨ f²id ⟩-involutive zero    = idp
⇑⟨ f²id ⟩-involutive (suc x) = ap suc (f²id x)

⟨0↔1+_⟩-involutive : ∀ n → ⟨0↔1+ n ⟩ ² ≗ id
⟨0↔1+_⟩-involutive zero = ⟨0↔1⟩-involutive
⟨0↔1+_⟩-involutive (suc n) x = ap (⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩) (⟨0↔1⟩-involutive (⇑⟨ ⟨0↔1+ n ⟩ ⟩ (⟨0↔1⟩ x)))
  ∙ ap ⟨0↔1⟩ (⇑⟨ ⟨0↔1+ n ⟩-involutive ⟩-involutive (⟨0↔1⟩ x)) ∙ ⟨0↔1⟩-involutive x

module _ {{_ : UA}} where
    ⟨_↔+1⟩-eq : ℕ → ℕ ≡ ℕ
    ⟨_↔+1⟩-eq = ua ∘ ⟨_↔+1⟩-equiv

    ⟨_↔+1⟩-eq-β : ∀ n m → coe ⟨ n ↔+1⟩-eq m ≡ ⟨ n ↔+1⟩ m
    ⟨_↔+1⟩-eq-β = coe-β ∘ ⟨_↔+1⟩-equiv

ℕˢ = ≡.setoid ℕ

module ℕcmp = StrictTotalOrder strictTotalOrder
module ℕ≤   = DecTotalOrder decTotalOrder
module ℕ°   = Algebra.CommutativeSemiring commutativeSemiring
module ℕ+   = Algebra.CommutativeMonoid ℕ°.+-commutativeMonoid
module ℕ+′  = Algebra.Monoid ℕ°.+-monoid
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne
module ℕˢ   = Setoid ℕˢ

infixr 8 _∙≤_
_∙≤_ = ℕ≤.trans
_∙cmp_ = ℕcmp.trans
_∙<_ = <-trans

[P:_zero:_suc:_] : ∀ {p} (P : ℕ → ★ p) → P zero → (∀ {n} → P n → P (suc n)) → ∀ n → P n
[P: _ zero: z suc: _ ] zero    = z
[P: P zero: z suc: s ] (suc n) = s ([P: P zero: z suc: s ] n)

[zero:_suc:_] : ∀ {a} {A : ★ a} → A → (ℕ → A → A) → ℕ → A
[zero: z suc: s ] = [P: _ zero: z suc: (λ {n} → s n) ]

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ idp ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → ℕ.suc n ≡ suc m → n ≡ m
suc-injective = ap pred

+-≤-inj : ∀ x {y z} → x + y ≤ x + z → y ≤ z
+-≤-inj zero    = id
+-≤-inj (suc x) = +-≤-inj x ∘ ≤-pred

infixl 6 _+°_
infixl 7 _*°_ _⊓°_
infixl 6 _∸°_ _⊔°_

_+°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f +° g) x = f x + g x

_∸°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ∸° g) x = f x ∸ g x

_*°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f *° g) x = f x * g x

_⊔°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊔° g) x = f x ⊔ g x

_⊓°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊓° g) x = f x ⊓ g x

-- this one is not completly in line with the
-- others
_≤°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → ★ a
f ≤° g = ∀ x → f x ≤ g x

sucx≰x : ∀ x → suc x ≰ x
sucx≰x zero    = λ()
sucx≰x (suc x) = sucx≰x x ∘ ≤-pred

total-≤ : ∀ a b → a ≤ b ⊎ b ≤ a
total-≤ zero b = inj₁ z≤n
total-≤ (suc a) zero = inj₂ z≤n
total-≤ (suc a) (suc b) with total-≤ a b
... | inj₁ p = inj₁ (s≤s p)
... | inj₂ p = inj₂ (s≤s p)

a≡a⊓b+a∸b : ∀ a b → a ≡ a ⊓ b + (a ∸ b)
a≡a⊓b+a∸b zero zero = idp
a≡a⊓b+a∸b zero (suc b) = idp
a≡a⊓b+a∸b (suc a) zero = idp
a≡a⊓b+a∸b (suc a) (suc b) rewrite ! a≡a⊓b+a∸b a b = idp

¬n≤x<n : ∀ n {x} → n ≤ x → x < n → 𝟘
¬n≤x<n n p q = sucx≰x _ (q ∙≤ p)

¬n+≤y<n : ∀ n {x y} → n + x ≤ y → y < n → 𝟘
¬n+≤y<n n p q = sucx≰x _ (q ∙≤ ℕ≤.reflexive (ℕ°.+-comm 0 n) ∙≤ ℕ≤.refl {n} +-mono z≤n ∙≤ p)

fold : ∀ {a} {A : ★ a} → A → Endo A → ℕ → A
fold x f n = nest n f x

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = idp
  nest₁ : nest 1 f ≡ f
  nest₁ = idp
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = idp
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = idp

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = idp
  nest-+ (suc m) n = ap (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ap (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = idp
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ idp ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ap (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ idp ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ idp ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

+-inj-over-∸ : ∀ x y z → (x + y) ∸ (x + z) ≡ y ∸ z
+-inj-over-∸ = [i+j]∸[i+k]≡j∸k

2*_ : ℕ → ℕ
2* x = x + x

2*-spec : ∀ n → 2* n ≡ 2 * n
2*-spec n rewrite ℕ°.+-comm n 0 = idp

_==_ : (x y : ℕ) → 𝟚
zero   == zero   = 1₂
zero   == suc _  = 0₂
suc _  == zero   = 0₂
suc m  == suc n  = m == n

open FromAssocComm _+_ (λ {x}{y}{z} → ℕ°.+-assoc x y z) (λ {x}{y} → ℕ°.+-comm x y)
  renaming ( assoc-comm to +-assoc-comm
           ; interchange to +-interchange
           ; !assoc-comm to +-!assoc-comm
           ; comm= to +-comm=
           ; assoc= to +-assoc=
           ; !assoc= to +-!assoc=
           ; inner= to +-inner=
           ; outer= to +-outer=
           )
  public

open FromAssocComm _*_ (λ {x}{y}{z} → ℕ°.*-assoc x y z) (λ {x}{y} → ℕ°.*-comm x y)
  renaming ( assoc-comm to *-assoc-comm
           ; interchange to *-interchange
           ; !assoc-comm to *-!assoc-comm
           ; comm= to *-comm=
           ; inner= to *-inner=
           ; outer= to *-outer=
           ; assoc= to *-assoc=
           ; !assoc= to *-!assoc=
           )
  public

a+b≡a⊔b+a⊓b : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
a+b≡a⊔b+a⊓b zero    b       rewrite ℕ°.+-comm b 0 = idp
a+b≡a⊔b+a⊓b (suc a) zero    = idp
a+b≡a⊔b+a⊓b (suc a) (suc b) rewrite +-assoc-comm {a} {1} {b}
                                  | +-assoc-comm {a ⊔ b} {1} {a ⊓ b}
                                  | a+b≡a⊔b+a⊓b a b
                                  = idp

a⊓b≡a : ∀ {a b} → a ≤ b → a ⊓ b ≡ a
a⊓b≡a z≤n = idp
a⊓b≡a (s≤s a≤b) rewrite a⊓b≡a a≤b = idp

⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
⊔≤+ zero b          = ℕ≤.refl
⊔≤+ (suc a) zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 a))
⊔≤+ (suc a) (suc b) = s≤s (⊔≤+ a b ∙≤ ≤-step ℕ≤.refl ∙≤ ℕ≤.reflexive (+-assoc-comm {1} {a} {b}))

2*′_ : ℕ → ℕ
2*′_ = fold 0 (suc ∘′ suc)

2*′-spec : ∀ n → 2*′ n ≡ 2* n
2*′-spec zero = idp
2*′-spec (suc n) rewrite 2*′-spec n | +-assoc-comm {1} {n} {n} = idp

2^⟨_⟩* : ℕ → ℕ → ℕ
2^⟨ n ⟩* x = fold x 2*_ n

⟨2^_*_⟩ : ℕ → ℕ → ℕ
⟨2^ n * x ⟩ = 2^⟨ n ⟩* x

2*′-inj : ∀ {m n} → 2*′ m ≡ 2*′ n → m ≡ n
2*′-inj {zero}  {zero}  _ = idp
2*′-inj {zero}  {suc _} ()
2*′-inj {suc _} {zero}  ()
2*′-inj {suc m} {suc n} p = ap suc (2*′-inj (suc-injective (suc-injective p)))

2*-inj : ∀ {m n} → 2* m ≡ 2* n → m ≡ n
2*-inj {m} {n} p rewrite ! 2*′-spec m
                       | ! 2*′-spec n
                       = 2*′-inj p

2^-inj : ∀ k {m n} → ⟨2^ k * m ⟩ ≡ ⟨2^ k * n ⟩ → m ≡ n
2^-inj zero    = id
2^-inj (suc k) = 2^-inj k ∘ 2*-inj

2*-distrib : ∀ x y → 2* x + 2* y ≡ 2* (x + y)
2*-distrib x y = +-interchange {x} {x} {y} {y}

2^*-distrib : ∀ k x y → ⟨2^ k * (x + y)⟩ ≡ ⟨2^ k * x ⟩ + ⟨2^ k * y ⟩
2^*-distrib zero x y = idp
2^*-distrib (suc k) x y rewrite 2^*-distrib k x y = ! 2*-distrib ⟨2^ k * x ⟩ ⟨2^ k * y ⟩

2^*-2*-comm : ∀ k x → ⟨2^ k * 2* x ⟩ ≡ 2* ⟨2^ k * x ⟩
2^*-2*-comm k x = 2^*-distrib k x x

2*-mono : ∀ {a b} → a ≤ b → 2* a ≤ 2* b
2*-mono pf = pf +-mono pf

2^*-mono : ∀ k {a b} → a ≤ b → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩
2^*-mono zero    pf = pf
2^*-mono (suc k) pf = 2*-mono (2^*-mono k pf)

2*-mono′ : ∀ {a b} → 2* a ≤ 2* b → a ≤ b
2*-mono′ {zero} pf = z≤n
2*-mono′ {suc a} {zero} ()
2*-mono′ {suc a} {suc b} pf rewrite +-assoc-comm {a} {1} {a}
                                  | +-assoc-comm {b} {1} {b} = s≤s (2*-mono′ (≤-pred (≤-pred pf)))

2^*-mono′ : ∀ k {a b} → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩ → a ≤ b
2^*-mono′ zero    = id
2^*-mono′ (suc k) = 2^*-mono′ k ∘ 2*-mono′

2^-comm : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ y * ⟨2^ x * z ⟩ ⟩
2^-comm zero y z = idp
2^-comm (suc x) y z rewrite 2^-comm x y z = ! 2^*-2*-comm y ⟨2^ x * z ⟩

2^-+ : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ (x + y) * z ⟩
2^-+ zero    y z = idp
2^-+ (suc x) y z = ap 2*_ (2^-+ x y z)

cancel-*-left : ∀ i j {k} → suc k * i ≡ suc k * j → i ≡ j
cancel-*-left i j {k}
  rewrite ℕ°.*-comm (suc k) i
        | ℕ°.*-comm (suc k) j = cancel-*-right i j {k}

2ⁿ*0≡0 : ∀ n → ⟨2^ n * 0 ⟩ ≡ 0
2ⁿ*0≡0 zero    = idp
2ⁿ*0≡0 (suc n) = ap₂ _+_ (2ⁿ*0≡0 n) (2ⁿ*0≡0 n)

0∸_≡0 : ∀ x → 0 ∸ x ≡ 0
0∸ zero  ≡0 = idp
0∸ suc x ≡0 = idp

2*-∸ : ∀ x y → 2* x ∸ 2* y ≡ 2* (x ∸ y)
2*-∸ _       zero    = idp
2*-∸ zero    (suc _) = idp
2*-∸ (suc x) (suc y) rewrite ! 2*-∸ x y | ℕ°.+-comm x (1 + x) | ℕ°.+-comm y (1 + y) = idp

n+k∸m : ∀ {m n} k → m ≤ n → n + k ∸ m ≡ (n ∸ m) + k
n+k∸m k z≤n = idp
n+k∸m k (s≤s m≤n) = n+k∸m k m≤n

factor-+-∸ : ∀ {b x y} → x ≤ b → y ≤ b → (b ∸ x) + (b ∸ y) ≡ 2* b ∸ (x + y)
factor-+-∸ {b} {zero} {y} z≤n y≤b rewrite ℕ°.+-comm b (b ∸ y) = ! n+k∸m b y≤b
factor-+-∸ (s≤s {x} {b} x≤b) z≤n             rewrite ℕ°.+-comm x 0 = ! n+k∸m (suc b) x≤b
factor-+-∸ (s≤s {x} {b} x≤b) (s≤s {y} y≤b)   rewrite factor-+-∸ x≤b y≤b
                                              | ℕ°.+-comm b (suc b)
                                              | ℕ°.+-comm x (suc y)
                                              | n+k∸m (suc y) x≤b
                                              | ℕ°.+-comm x y = idp

_*′_ : ℕ → ℕ → ℕ
0 *′ n = 0
1 *′ n = n
m *′ 0 = 0
m *′ 1 = m
m *′ n = m * n

*′-spec : ∀ m n → m *′ n ≡ m * n
*′-spec 0             n = idp
*′-spec 1             n = ℕ°.+-comm 0 n
*′-spec (suc (suc m)) 0 = ℕ°.*-comm 0 m
*′-spec (suc (suc m)) 1 = ap (suc ∘′ suc) (! snd ℕ°.*-identity m)
*′-spec (suc (suc m)) (suc (suc n)) = idp

≤→≢1+ : ∀ {x y} → x ≤ y → x ≢ suc y
≤→≢1+ z≤n     ()
≤→≢1+ (s≤s p) q = ≤→≢1+ p (suc-injective q)

<→≢ : ∀ {x y} → x < y → x ≢ y
<→≢ (s≤s p) = ≤→≢1+ p

∸-assoc-+ : ∀ x y z → x ∸ y ∸ z ≡ x ∸ (y + z)
∸-assoc-+ x       zero    z       = idp
∸-assoc-+ zero    (suc y) zero    = idp
∸-assoc-+ zero    (suc y) (suc z) = idp
∸-assoc-+ (suc x) (suc y) z       = ∸-assoc-+ x y z

_∸-tone_ : ∀ {x y t u} → x ≤ y → t ≤ u → t ∸ y ≤ u ∸ x
_∸-tone_ {y = y} z≤n t≤u = n∸m≤n y _ ∙≤ t≤u
s≤s x≤y ∸-tone z≤n = z≤n
s≤s x≤y ∸-tone s≤s t≤u = x≤y ∸-tone t≤u

∸-mono' : ∀ k {x y} → x ≤ y → x ∸ k ≤ y ∸ k
∸-mono' k = _∸-tone_ (ℕ≤.refl {k})

∸-anti : ∀ k {x y} → x ≤ y → k ∸ y ≤ k ∸ x
∸-anti k x≤y = _∸-tone_ x≤y (ℕ≤.refl {k})

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

module ^-Props where
  open ≡-Reasoning

  ^1-id : ∀ n → n ^ 1 ≡ n
  ^1-id = snd ℕ°.*-identity

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b 0 n = ! snd ℕ°.+-identity (b ^ n)
  ^-+ b (1+ m) n rewrite ^-+ b m n = ! ℕ°.*-assoc b (b ^ m) (b ^ n)

  ^-* : ∀ b m n → b ^(m * n) ≡ (b ^ n) ^ m
  ^-* b 0   n = idp
  ^-* b (1+ m) n
    = b ^ (n + m * n)      ≡⟨ ^-+ b n (m * n) ⟩
      b ^ n * b ^(m * n)   ≡⟨ ap (_*_ (b ^ n)) (^-* b m n) ⟩
      b ^ n * (b ^ n) ^ m  ∎

_^2 : ℕ → ℕ
n ^2 = n * n

^2-spec : ∀ n → n ^2 ≡ n ^ 2
^2-spec n rewrite snd ℕ°.*-identity n = idp

2^_ : ℕ → ℕ
2^ n = ⟨2^ n * 1 ⟩

2^-spec : ∀ n → 2^ n ≡ 2 ^ n
2^-spec zero = idp
2^-spec (suc n) rewrite 2^-spec n | 2*-spec (2 ^ n) = idp

2^*-spec : ∀ m n → 2^⟨ m ⟩* n ≡ 2 ^ m * n
2^*-spec zero    n rewrite ℕ°.+-comm n 0 = idp
2^*-spec (suc m) n rewrite 2^*-spec m n
                         | ℕ°.*-assoc 2 (2 ^ m) n
                         | ℕ°.+-comm (2 ^ m * n) 0 = idp

1≤2^ : ∀ n → 2^ n ≥ 1
1+≤2^ : ∀ n → 2^ n ≥ 1 + n
1+≤2^ zero    = s≤s z≤n
1+≤2^ (suc n) = (1≤2^ n) +-mono (1+≤2^ n)

1≤2^ n  = s≤s z≤n ∙≤ 1+≤2^ n

≤-steps′ : ∀ {x} y → x ≤ x + y
≤-steps′ {x} y rewrite ℕ°.+-comm x y = ≤-steps y ℕ≤.refl

≤⇒∃ : ∀ {m n} → m ≤ n → ∃ λ k → m + k ≡ n
≤⇒∃ z≤n      = _ , idp
≤⇒∃ (s≤s pf) = _ , ap suc (snd (≤⇒∃ pf))

is0? : ℕ → 𝟚
is0? zero    = 1₂
is0? (suc n) = 0₂

module _ {{_ : UA}} where
    open Equivalences
    ∃-is0?-uniq : ∃ (✓ ∘ is0?) ≡ 𝟙
    ∃-is0?-uniq = ua (equiv _ (const (0 , _)) (const idp)
                            λ { (0 , _) → idp ; (suc _ , ()) })

{-
module GeneralisedArithmetic {a} {A : ★ a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → ★₀
  m ≈ n = ✓ (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → ✓ (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p idp

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → ★₀ where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → 𝟚
zero   <= _      = 1₂
suc _  <= zero   = 0₂
suc m  <= suc n  = m <= n

module <= where
  ℛ : ℕ → ℕ → ★₀
  ℛ x y = ✓ (x <= y)

  sound : ∀ m n → ℛ m n → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → ℛ m n
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

  isTotalOrder : IsTotalOrder _≡_ ℛ
  isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total x y) }
   where
    reflexive : ∀ {i j} → i ≡ j → ℛ i j
    reflexive {i} idp = complete (ℕ≤.refl {i})
    trans : Transitive ℛ
    trans {x} {y} {z} p q = complete (ℕ≤.trans (sound x y p) (sound y z q))
    isPreorder : IsPreorder _≡_ ℛ
    isPreorder = record { isEquivalence = ≡.isEquivalence
                        ; reflexive = reflexive
                        ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
    antisym : Antisymmetric _≡_ ℛ
    antisym {x} {y} p q = ℕ≤.antisym (sound x y p) (sound y x q)
    isPartialOrder : IsPartialOrder _≡_ ℛ
    isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }

  open IsTotalOrder isTotalOrder public

<=-steps′ : ∀ {x} y → ✓ (x <= (x + y))
<=-steps′ {x} y = <=.complete (≤-steps′ {x} y)

sucx∸y≤suc⟨x∸y⟩ : ∀ x y → suc x ∸ y ≤ suc (x ∸ y)
sucx∸y≤suc⟨x∸y⟩ x zero = ℕ≤.refl
sucx∸y≤suc⟨x∸y⟩ zero (suc y) rewrite 0∸n≡0 y = z≤n
sucx∸y≤suc⟨x∸y⟩ (suc x) (suc y) = sucx∸y≤suc⟨x∸y⟩ x y

x≤2y′→x∸y≤y : ∀ x y → x ≤ 2*′ y → x ∸ y ≤ y
x≤2y′→x∸y≤y x zero p = p
x≤2y′→x∸y≤y zero (suc y) p = z≤n
x≤2y′→x∸y≤y (suc zero) (suc y) (s≤s p) rewrite 0∸n≡0 y = z≤n
x≤2y′→x∸y≤y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = sucx∸y≤suc⟨x∸y⟩ x y ∙≤ s≤s (x≤2y′→x∸y≤y x y p)

x<2y′→x∸y<y : ∀ x y → x < 2*′ y → x ∸ y < y
x<2y′→x∸y<y x zero p = p
x<2y′→x∸y<y zero (suc y) p = s≤s z≤n
x<2y′→x∸y<y (suc zero) (suc y) (s≤s (s≤s p)) rewrite 0∸n≡0 y = s≤s z≤n
x<2y′→x∸y<y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = s≤s (sucx∸y≤suc⟨x∸y⟩ x y) ∙≤ s≤s (x<2y′→x∸y<y x y p)

x<2y→x∸y<y : ∀ x y → x < 2* y → x ∸ y < y
x<2y→x∸y<y x y p rewrite ! 2*′-spec y = x<2y′→x∸y<y x y p

≰→< : ∀ x y → x ≰ y → y < x
≰→< x y p with ℕcmp.compare (suc y) x
≰→< x y p | tri< a ¬b ¬c = s≤s (≤-step ℕ≤.refl) ∙≤ a
≰→< x y p | tri≈ ¬a b ¬c = ℕ≤.reflexive b
≰→< x y p | tri> ¬a ¬b c = 𝟘-elim (p (≤-pred c))

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = 𝟘-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (! eq)
... | tri> _ _ 1+n≤m = ≤-pred (≤-steps 1 1+n≤m)

not<=→< : ∀ x y → ✓ (not (x <= y)) → ✓ (suc y <= x)
not<=→< x y p = <=.complete (≰→< x y (✓-not-¬ p ∘ <=.complete))

even? odd? : ℕ → 𝟚
even? zero    = 1₂
even? (suc n) = odd? n
odd? n = not (even? n)
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Data.Nat.NP where

open import Type hiding (★)
import Algebra
open import Algebra.FunctionProperties.Eq
open import Data.Two.Base hiding (_==_; _²)
open import Data.Product using (∃; _,_) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum renaming (map to ⊎-map)
open import Data.Zero using (𝟘-elim; 𝟘)
open import Data.One using (𝟙)
open import Function.NP
open import Function.Extensionality
open import Relation.Nullary
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_; _≗_; module ≡-Reasoning; !_; _∙_; ap; ap₂; coe)
       renaming (refl to idp)
open import HoTT
open Equivalences

open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties

pattern 1+_ x = suc x
pattern 2+_ x = 1+ suc x
pattern 3+_ x = 2+ suc x
pattern 4+_ x = 3+ suc x

⟨0↔1⟩ : ℕ → ℕ
⟨0↔1⟩ 0 = 1
⟨0↔1⟩ 1 = 0
⟨0↔1⟩ n = n

private
  _² : ∀ {A : ★₀} → Endo (Endo A)
  f ² = f ∘ f

⟨0↔1⟩-involutive : ⟨0↔1⟩ ∘ ⟨0↔1⟩ ≗ id
⟨0↔1⟩-involutive 0             = idp
⟨0↔1⟩-involutive 1             = idp
⟨0↔1⟩-involutive (suc (suc _)) = idp

⇑⟨_⟩ : (ℕ → ℕ) → (ℕ → ℕ)
⇑⟨ f ⟩ zero    = zero
⇑⟨ f ⟩ (suc n) = suc (f n)

⟨0↔1+_⟩ : ℕ → ℕ → ℕ
⟨0↔1+ 0     ⟩ = ⟨0↔1⟩
⟨0↔1+ suc n ⟩ = ⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩ ∘ ⟨0↔1⟩

⟨_↔+1⟩ : ℕ → ℕ → ℕ
⟨ 0     ↔+1⟩ = ⟨0↔1⟩
⟨ suc n ↔+1⟩ 0       = 0
⟨ suc n ↔+1⟩ (suc m) = suc (⟨ n ↔+1⟩ m)

⟨_↔+1⟩-involutive : ∀ n → ⟨ n ↔+1⟩ ∘ ⟨ n ↔+1⟩ ≗ id
⟨_↔+1⟩-involutive 0 = ⟨0↔1⟩-involutive
⟨_↔+1⟩-involutive (suc _) 0       = idp
⟨_↔+1⟩-involutive (suc n) (suc m) = ap suc (⟨ n ↔+1⟩-involutive m)

⟨_↔+1⟩-equiv : ℕ → ℕ ≃ ℕ
⟨ n ↔+1⟩-equiv = self-inv-equiv ⟨ n ↔+1⟩ ⟨ n ↔+1⟩-involutive

⇑⟨_⟩-involutive : ∀ {f} → f ² ≗ id → ⇑⟨ f ⟩ ² ≗ id
⇑⟨ f²id ⟩-involutive zero    = idp
⇑⟨ f²id ⟩-involutive (suc x) = ap suc (f²id x)

⟨0↔1+_⟩-involutive : ∀ n → ⟨0↔1+ n ⟩ ² ≗ id
⟨0↔1+_⟩-involutive zero = ⟨0↔1⟩-involutive
⟨0↔1+_⟩-involutive (suc n) x = ap (⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩) (⟨0↔1⟩-involutive (⇑⟨ ⟨0↔1+ n ⟩ ⟩ (⟨0↔1⟩ x)))
  ∙ ap ⟨0↔1⟩ (⇑⟨ ⟨0↔1+ n ⟩-involutive ⟩-involutive (⟨0↔1⟩ x)) ∙ ⟨0↔1⟩-involutive x

module _ {{_ : UA}} where
    ⟨_↔+1⟩-eq : ℕ → ℕ ≡ ℕ
    ⟨_↔+1⟩-eq = ua ∘ ⟨_↔+1⟩-equiv

    ⟨_↔+1⟩-eq-β : ∀ n m → coe ⟨ n ↔+1⟩-eq m ≡ ⟨ n ↔+1⟩ m
    ⟨_↔+1⟩-eq-β = coe-β ∘ ⟨_↔+1⟩-equiv

ℕˢ = ≡.setoid ℕ

module ℕcmp = StrictTotalOrder strictTotalOrder
module ℕ≤   = DecTotalOrder decTotalOrder
module ℕ°   = Algebra.CommutativeSemiring commutativeSemiring
module ℕ+   = Algebra.CommutativeMonoid ℕ°.+-commutativeMonoid
module ℕ+′  = Algebra.Monoid ℕ°.+-monoid
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne
module ℕˢ   = Setoid ℕˢ

infixr 8 _∙≤_
_∙≤_ = ℕ≤.trans
_∙cmp_ = ℕcmp.trans
_∙<_ = <-trans

[P:_zero:_suc:_] : ∀ {p} (P : ℕ → ★ p) → P zero → (∀ {n} → P n → P (suc n)) → ∀ n → P n
[P: _ zero: z suc: _ ] zero    = z
[P: P zero: z suc: s ] (suc n) = s ([P: P zero: z suc: s ] n)

[zero:_suc:_] : ∀ {a} {A : ★ a} → A → (ℕ → A → A) → ℕ → A
[zero: z suc: s ] = [P: _ zero: z suc: (λ {n} → s n) ]

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ idp ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → ℕ.suc n ≡ suc m → n ≡ m
suc-injective = ap pred

+-≤-inj : ∀ x {y z} → x + y ≤ x + z → y ≤ z
+-≤-inj zero    = id
+-≤-inj (suc x) = +-≤-inj x ∘ ≤-pred

infixl 6 _+°_
infixl 7 _*°_ _⊓°_
infixl 6 _∸°_ _⊔°_

_+°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f +° g) x = f x + g x

_∸°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ∸° g) x = f x ∸ g x

_*°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f *° g) x = f x * g x

_⊔°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊔° g) x = f x ⊔ g x

_⊓°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊓° g) x = f x ⊓ g x

-- this one is not completly in line with the
-- others
_≤°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → ★ a
f ≤° g = ∀ x → f x ≤ g x

sucx≰x : ∀ x → suc x ≰ x
sucx≰x zero    = λ()
sucx≰x (suc x) = sucx≰x x ∘ ≤-pred

total-≤ : ∀ a b → a ≤ b ⊎ b ≤ a
total-≤ zero b = inj₁ z≤n
total-≤ (suc a) zero = inj₂ z≤n
total-≤ (suc a) (suc b) with total-≤ a b
... | inj₁ p = inj₁ (s≤s p)
... | inj₂ p = inj₂ (s≤s p)

a≡a⊓b+a∸b : ∀ a b → a ≡ a ⊓ b + (a ∸ b)
a≡a⊓b+a∸b zero zero = idp
a≡a⊓b+a∸b zero (suc b) = idp
a≡a⊓b+a∸b (suc a) zero = idp
a≡a⊓b+a∸b (suc a) (suc b) rewrite ! a≡a⊓b+a∸b a b = idp

¬n≤x<n : ∀ n {x} → n ≤ x → x < n → 𝟘
¬n≤x<n n p q = sucx≰x _ (q ∙≤ p)

¬n+≤y<n : ∀ n {x y} → n + x ≤ y → y < n → 𝟘
¬n+≤y<n n p q = sucx≰x _ (q ∙≤ ℕ≤.reflexive (ℕ°.+-comm 0 n) ∙≤ ℕ≤.refl {n} +-mono z≤n ∙≤ p)

fold : ∀ {a} {A : ★ a} → A → Endo A → ℕ → A
fold x f n = nest n f x

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = idp
  nest₁ : nest 1 f ≡ f
  nest₁ = idp
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = idp
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = idp

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = idp
  nest-+ (suc m) n = ap (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ap (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = idp
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ idp ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ap (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ idp ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ idp ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

+-inj-over-∸ : ∀ x y z → (x + y) ∸ (x + z) ≡ y ∸ z
+-inj-over-∸ = [i+j]∸[i+k]≡j∸k

2*_ : ℕ → ℕ
2* x = x + x

2*-spec : ∀ n → 2* n ≡ 2 * n
2*-spec n rewrite ℕ°.+-comm n 0 = idp

_==_ : (x y : ℕ) → 𝟚
zero   == zero   = 1₂
zero   == suc _  = 0₂
suc _  == zero   = 0₂
suc m  == suc n  = m == n

open FromAssocComm _+_ (λ {x}{y}{z} → ℕ°.+-assoc x y z) (λ {x}{y} → ℕ°.+-comm x y)
  renaming ( assoc-comm to +-assoc-comm
           ; interchange to +-interchange
           )

open FromAssocComm _*_ (λ {x}{y}{z} → ℕ°.*-assoc x y z) (λ {x}{y} → ℕ°.*-comm x y)
  renaming ( assoc-comm to *-assoc-comm
           ; interchange to *-interchange
           )

a+b≡a⊔b+a⊓b : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
a+b≡a⊔b+a⊓b zero    b       rewrite ℕ°.+-comm b 0 = idp
a+b≡a⊔b+a⊓b (suc a) zero    = idp
a+b≡a⊔b+a⊓b (suc a) (suc b) rewrite +-assoc-comm {a} {1} {b}
                                  | +-assoc-comm {a ⊔ b} {1} {a ⊓ b}
                                  | a+b≡a⊔b+a⊓b a b
                                  = idp

a⊓b≡a : ∀ {a b} → a ≤ b → a ⊓ b ≡ a
a⊓b≡a z≤n = idp
a⊓b≡a (s≤s a≤b) rewrite a⊓b≡a a≤b = idp

⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
⊔≤+ zero b          = ℕ≤.refl
⊔≤+ (suc a) zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 a))
⊔≤+ (suc a) (suc b) = s≤s (⊔≤+ a b ∙≤ ≤-step ℕ≤.refl ∙≤ ℕ≤.reflexive (+-assoc-comm {1} {a} {b}))

2*′_ : ℕ → ℕ
2*′_ = fold 0 (suc ∘′ suc)

2*′-spec : ∀ n → 2*′ n ≡ 2* n
2*′-spec zero = idp
2*′-spec (suc n) rewrite 2*′-spec n | +-assoc-comm {1} {n} {n} = idp

2^⟨_⟩* : ℕ → ℕ → ℕ
2^⟨ n ⟩* x = fold x 2*_ n

⟨2^_*_⟩ : ℕ → ℕ → ℕ
⟨2^ n * x ⟩ = 2^⟨ n ⟩* x

2*′-inj : ∀ {m n} → 2*′ m ≡ 2*′ n → m ≡ n
2*′-inj {zero}  {zero}  _ = idp
2*′-inj {zero}  {suc _} ()
2*′-inj {suc _} {zero}  ()
2*′-inj {suc m} {suc n} p = ap suc (2*′-inj (suc-injective (suc-injective p)))

2*-inj : ∀ {m n} → 2* m ≡ 2* n → m ≡ n
2*-inj {m} {n} p rewrite ! 2*′-spec m
                       | ! 2*′-spec n
                       = 2*′-inj p

2^-inj : ∀ k {m n} → ⟨2^ k * m ⟩ ≡ ⟨2^ k * n ⟩ → m ≡ n
2^-inj zero    = id
2^-inj (suc k) = 2^-inj k ∘ 2*-inj

2*-distrib : ∀ x y → 2* x + 2* y ≡ 2* (x + y)
2*-distrib x y = +-interchange {x} {x} {y} {y}

2^*-distrib : ∀ k x y → ⟨2^ k * (x + y)⟩ ≡ ⟨2^ k * x ⟩ + ⟨2^ k * y ⟩
2^*-distrib zero x y = idp
2^*-distrib (suc k) x y rewrite 2^*-distrib k x y = ! 2*-distrib ⟨2^ k * x ⟩ ⟨2^ k * y ⟩

2^*-2*-comm : ∀ k x → ⟨2^ k * 2* x ⟩ ≡ 2* ⟨2^ k * x ⟩
2^*-2*-comm k x = 2^*-distrib k x x

2*-mono : ∀ {a b} → a ≤ b → 2* a ≤ 2* b
2*-mono pf = pf +-mono pf

2^*-mono : ∀ k {a b} → a ≤ b → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩
2^*-mono zero    pf = pf
2^*-mono (suc k) pf = 2*-mono (2^*-mono k pf)

2*-mono′ : ∀ {a b} → 2* a ≤ 2* b → a ≤ b
2*-mono′ {zero} pf = z≤n
2*-mono′ {suc a} {zero} ()
2*-mono′ {suc a} {suc b} pf rewrite +-assoc-comm {a} {1} {a}
                                  | +-assoc-comm {b} {1} {b} = s≤s (2*-mono′ (≤-pred (≤-pred pf)))

2^*-mono′ : ∀ k {a b} → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩ → a ≤ b
2^*-mono′ zero    = id
2^*-mono′ (suc k) = 2^*-mono′ k ∘ 2*-mono′

2^-comm : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ y * ⟨2^ x * z ⟩ ⟩
2^-comm zero y z = idp
2^-comm (suc x) y z rewrite 2^-comm x y z = ! 2^*-2*-comm y ⟨2^ x * z ⟩

2^-+ : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ (x + y) * z ⟩
2^-+ zero    y z = idp
2^-+ (suc x) y z = ap 2*_ (2^-+ x y z)

cancel-*-left : ∀ i j {k} → suc k * i ≡ suc k * j → i ≡ j
cancel-*-left i j {k}
  rewrite ℕ°.*-comm (suc k) i
        | ℕ°.*-comm (suc k) j = cancel-*-right i j {k}

2ⁿ*0≡0 : ∀ n → ⟨2^ n * 0 ⟩ ≡ 0
2ⁿ*0≡0 zero    = idp
2ⁿ*0≡0 (suc n) = ap₂ _+_ (2ⁿ*0≡0 n) (2ⁿ*0≡0 n)

0∸_≡0 : ∀ x → 0 ∸ x ≡ 0
0∸ zero  ≡0 = idp
0∸ suc x ≡0 = idp

2*-∸ : ∀ x y → 2* x ∸ 2* y ≡ 2* (x ∸ y)
2*-∸ _       zero    = idp
2*-∸ zero    (suc _) = idp
2*-∸ (suc x) (suc y) rewrite ! 2*-∸ x y | ℕ°.+-comm x (1 + x) | ℕ°.+-comm y (1 + y) = idp

n+k∸m : ∀ {m n} k → m ≤ n → n + k ∸ m ≡ (n ∸ m) + k
n+k∸m k z≤n = idp
n+k∸m k (s≤s m≤n) = n+k∸m k m≤n

factor-+-∸ : ∀ {b x y} → x ≤ b → y ≤ b → (b ∸ x) + (b ∸ y) ≡ 2* b ∸ (x + y)
factor-+-∸ {b} {zero} {y} z≤n y≤b rewrite ℕ°.+-comm b (b ∸ y) = ! n+k∸m b y≤b
factor-+-∸ (s≤s {x} {b} x≤b) z≤n             rewrite ℕ°.+-comm x 0 = ! n+k∸m (suc b) x≤b
factor-+-∸ (s≤s {x} {b} x≤b) (s≤s {y} y≤b)   rewrite factor-+-∸ x≤b y≤b
                                              | ℕ°.+-comm b (suc b)
                                              | ℕ°.+-comm x (suc y)
                                              | n+k∸m (suc y) x≤b
                                              | ℕ°.+-comm x y = idp

_*′_ : ℕ → ℕ → ℕ
0 *′ n = 0
1 *′ n = n
m *′ 0 = 0
m *′ 1 = m
m *′ n = m * n

*′-spec : ∀ m n → m *′ n ≡ m * n
*′-spec 0             n = idp
*′-spec 1             n = ℕ°.+-comm 0 n
*′-spec (suc (suc m)) 0 = ℕ°.*-comm 0 m
*′-spec (suc (suc m)) 1 = ap (suc ∘′ suc) (! snd ℕ°.*-identity m)
*′-spec (suc (suc m)) (suc (suc n)) = idp

≤→≢1+ : ∀ {x y} → x ≤ y → x ≢ suc y
≤→≢1+ z≤n     ()
≤→≢1+ (s≤s p) q = ≤→≢1+ p (suc-injective q)

<→≢ : ∀ {x y} → x < y → x ≢ y
<→≢ (s≤s p) = ≤→≢1+ p

∸-assoc-+ : ∀ x y z → x ∸ y ∸ z ≡ x ∸ (y + z)
∸-assoc-+ x       zero    z       = idp
∸-assoc-+ zero    (suc y) zero    = idp
∸-assoc-+ zero    (suc y) (suc z) = idp
∸-assoc-+ (suc x) (suc y) z       = ∸-assoc-+ x y z

_∸-tone_ : ∀ {x y t u} → x ≤ y → t ≤ u → t ∸ y ≤ u ∸ x
_∸-tone_ {y = y} z≤n t≤u = n∸m≤n y _ ∙≤ t≤u
s≤s x≤y ∸-tone z≤n = z≤n
s≤s x≤y ∸-tone s≤s t≤u = x≤y ∸-tone t≤u

∸-mono' : ∀ k {x y} → x ≤ y → x ∸ k ≤ y ∸ k
∸-mono' k = _∸-tone_ (ℕ≤.refl {k})

∸-anti : ∀ k {x y} → x ≤ y → k ∸ y ≤ k ∸ x
∸-anti k x≤y = _∸-tone_ x≤y (ℕ≤.refl {k})

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

module ^-Props where
  open ≡-Reasoning

  ^1-id : ∀ n → n ^ 1 ≡ n
  ^1-id = snd ℕ°.*-identity

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b 0 n = ! snd ℕ°.+-identity (b ^ n)
  ^-+ b (1+ m) n rewrite ^-+ b m n = ! ℕ°.*-assoc b (b ^ m) (b ^ n)

  ^-* : ∀ b m n → b ^(m * n) ≡ (b ^ n) ^ m
  ^-* b 0   n = idp
  ^-* b (1+ m) n
    = b ^ (n + m * n)      ≡⟨ ^-+ b n (m * n) ⟩
      b ^ n * b ^(m * n)   ≡⟨ ap (_*_ (b ^ n)) (^-* b m n) ⟩
      b ^ n * (b ^ n) ^ m  ∎

_^2 : ℕ → ℕ
n ^2 = n * n

^2-spec : ∀ n → n ^2 ≡ n ^ 2
^2-spec n rewrite snd ℕ°.*-identity n = idp

2^_ : ℕ → ℕ
2^ n = ⟨2^ n * 1 ⟩

2^-spec : ∀ n → 2^ n ≡ 2 ^ n
2^-spec zero = idp
2^-spec (suc n) rewrite 2^-spec n | 2*-spec (2 ^ n) = idp

2^*-spec : ∀ m n → 2^⟨ m ⟩* n ≡ 2 ^ m * n
2^*-spec zero    n rewrite ℕ°.+-comm n 0 = idp
2^*-spec (suc m) n rewrite 2^*-spec m n
                         | ℕ°.*-assoc 2 (2 ^ m) n
                         | ℕ°.+-comm (2 ^ m * n) 0 = idp

1≤2^ : ∀ n → 2^ n ≥ 1
1+≤2^ : ∀ n → 2^ n ≥ 1 + n
1+≤2^ zero    = s≤s z≤n
1+≤2^ (suc n) = (1≤2^ n) +-mono (1+≤2^ n)

1≤2^ n  = s≤s z≤n ∙≤ 1+≤2^ n

≤-steps′ : ∀ {x} y → x ≤ x + y
≤-steps′ {x} y rewrite ℕ°.+-comm x y = ≤-steps y ℕ≤.refl

≤⇒∃ : ∀ {m n} → m ≤ n → ∃ λ k → m + k ≡ n
≤⇒∃ z≤n      = _ , idp
≤⇒∃ (s≤s pf) = _ , ap suc (snd (≤⇒∃ pf))

is0? : ℕ → 𝟚
is0? zero    = 1₂
is0? (suc n) = 0₂

module _ {{_ : UA}} where
    open Equivalences
    ∃-is0?-uniq : ∃ (✓ ∘ is0?) ≡ 𝟙
    ∃-is0?-uniq = ua (equiv _ (const (0 , _)) (const idp)
                            λ { (0 , _) → idp ; (suc _ , ()) })

{-
module GeneralisedArithmetic {a} {A : ★ a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → ★₀
  m ≈ n = ✓ (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → ✓ (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p idp

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → ★₀ where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → 𝟚
zero   <= _      = 1₂
suc _  <= zero   = 0₂
suc m  <= suc n  = m <= n

module <= where
  ℛ : ℕ → ℕ → ★₀
  ℛ x y = ✓ (x <= y)

  sound : ∀ m n → ℛ m n → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → ℛ m n
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

  isTotalOrder : IsTotalOrder _≡_ ℛ
  isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total x y) }
   where
    reflexive : ∀ {i j} → i ≡ j → ℛ i j
    reflexive {i} idp = complete (ℕ≤.refl {i})
    trans : Transitive ℛ
    trans {x} {y} {z} p q = complete (ℕ≤.trans (sound x y p) (sound y z q))
    isPreorder : IsPreorder _≡_ ℛ
    isPreorder = record { isEquivalence = ≡.isEquivalence
                        ; reflexive = reflexive
                        ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
    antisym : Antisymmetric _≡_ ℛ
    antisym {x} {y} p q = ℕ≤.antisym (sound x y p) (sound y x q)
    isPartialOrder : IsPartialOrder _≡_ ℛ
    isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }

  open IsTotalOrder isTotalOrder public

<=-steps′ : ∀ {x} y → ✓ (x <= (x + y))
<=-steps′ {x} y = <=.complete (≤-steps′ {x} y)

sucx∸y≤suc⟨x∸y⟩ : ∀ x y → suc x ∸ y ≤ suc (x ∸ y)
sucx∸y≤suc⟨x∸y⟩ x zero = ℕ≤.refl
sucx∸y≤suc⟨x∸y⟩ zero (suc y) rewrite 0∸n≡0 y = z≤n
sucx∸y≤suc⟨x∸y⟩ (suc x) (suc y) = sucx∸y≤suc⟨x∸y⟩ x y

x≤2y′→x∸y≤y : ∀ x y → x ≤ 2*′ y → x ∸ y ≤ y
x≤2y′→x∸y≤y x zero p = p
x≤2y′→x∸y≤y zero (suc y) p = z≤n
x≤2y′→x∸y≤y (suc zero) (suc y) (s≤s p) rewrite 0∸n≡0 y = z≤n
x≤2y′→x∸y≤y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = sucx∸y≤suc⟨x∸y⟩ x y ∙≤ s≤s (x≤2y′→x∸y≤y x y p)

x<2y′→x∸y<y : ∀ x y → x < 2*′ y → x ∸ y < y
x<2y′→x∸y<y x zero p = p
x<2y′→x∸y<y zero (suc y) p = s≤s z≤n
x<2y′→x∸y<y (suc zero) (suc y) (s≤s (s≤s p)) rewrite 0∸n≡0 y = s≤s z≤n
x<2y′→x∸y<y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = s≤s (sucx∸y≤suc⟨x∸y⟩ x y) ∙≤ s≤s (x<2y′→x∸y<y x y p)

x<2y→x∸y<y : ∀ x y → x < 2* y → x ∸ y < y
x<2y→x∸y<y x y p rewrite ! 2*′-spec y = x<2y′→x∸y<y x y p

≰→< : ∀ x y → x ≰ y → y < x
≰→< x y p with ℕcmp.compare (suc y) x
≰→< x y p | tri< a ¬b ¬c = s≤s (≤-step ℕ≤.refl) ∙≤ a
≰→< x y p | tri≈ ¬a b ¬c = ℕ≤.reflexive b
≰→< x y p | tri> ¬a ¬b c = 𝟘-elim (p (≤-pred c))

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = 𝟘-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (! eq)
... | tri> _ _ 1+n≤m = ≤-pred (≤-steps 1 1+n≤m)

not<=→< : ∀ x y → ✓ (not (x <= y)) → ✓ (suc y <= x)
not<=→< x y p = <=.complete (≰→< x y (✓-not-¬ p ∘ <=.complete))

even? odd? : ℕ → 𝟚
even? zero    = 1₂
even? (suc n) = odd? n
odd? n = not (even? n)
-- -}
-- -}
-- -}
-- -}


Typo.

Typo.

Ignore-this: f7a1648b47497cbe77ab2c3533bc1860

darcs-hash:20100701205739-3bd4e-a68be27acd723ef23490c840a10a894694e127a7.gz

------------------------------------------------------------------------------
-- The division satisfies the specification
------------------------------------------------------------------------------

-- This module formalizes the division algorithm following [1].
-- [1] Peter Dybjer. Program verification in a logical theory of
-- constructions. In Jean-Pierre Jouannaud, editor. Functional
-- Programming Languages and Computer Architecture, volume 201 of
-- LNCS, 1985, pages 334-349. Appears in revised form as Programming
-- Methodology Group Report 26, June 1986.

module Examples.Division.IsDIV-PCF where

open import LTC.Minimal

open import Examples.DivisionPCF
open import Examples.Division.EquationsPCF
open import Examples.Division.IsCorrectPCF
open import Examples.Division.IsN-PCF
open import Examples.Division.SpecificationPCF

open import LTC.Data.N
open import LTC.Data.N.Induction.WellFoundedPCF
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF
open import LTC.Relation.InequalitiesPCF
open import LTC.Relation.Inequalities.PropertiesPCF

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

-- The division result satifies the specification DIV
-- when the dividend is less than the divisor
div-x<y-DIV : {i j : D} → N i → N j -> LT i j → DIV i j (div i j)
div-x<y-DIV Ni Nj i<j = div-x<y-N i<j , div-x<y-correct Ni Nj i<j

-- The division result satisfies the specification DIV when the
-- dividend is greater or equal than the divisor.
div-x≥y-DIV : {i j : D} → N i -> N j →
              ({i' : D} → N i' → LT i' i → DIV i' j (div i' j)) →
              GT j zero →
              GE i j →
              DIV i j (div i j)
div-x≥y-DIV {i} {j} Ni Nj accH j>0 i≥j =
  (div-x≥y-N ih i≥j) , div-x≥y-correct Ni Nj ih i≥j

    where
    -- The inductive hypothesis on 'i - j'.
    ih : DIV (i - j) j (div (i - j) j)
    ih = accH {i - j}
              (minus-N Ni Nj )
              (x≥y→y>0→x-y<x Ni Nj i≥j j>0)

------------------------------------------------------------------------------
-- The division satisfies the specification

-- We do the well-founded induction on 'i' and we keep 'j' fixed.
div-DIV : {i j : D} → N i → N j → GT j zero → DIV i j (div i j)
div-DIV {j = j} Ni Nj j>0 = wfIndN-LT P iStep Ni

   where
     P : D → Set
     P d = DIV d j (div d j)

     -- The inductive step doesn't use the variable 'i'
     -- (nor 'Ni'). To make this
     -- clear we write down the inductive step using the variables
     -- 'm' and 'n'.
     iStep : {n : D} → N n →
             (accH : {m : D} → N m → LT m n → P m) →
             P n
     iStep {n} Nn accH =
       [ div-x<y-DIV Nn Nj , div-x≥y-DIV Nn Nj accH j>0 ] (x<y∨x≥y Nn Nj)

------------------------------------------------------------------------------
-- The division satisfies the specification
------------------------------------------------------------------------------

-- This module formalize the division algorithm following [1].
-- [1] Peter Dybjer. Program verification in a logical theory of
-- constructions. In Jean-Pierre Jouannaud, editor. Functional
-- Programming Languages and Computer Architecture, volume 201 of
-- LNCS, 1985, pages 334-349. Appears in revised form as Programming
-- Methodology Group Report 26, June 1986.

module Examples.Division.IsDIV-PCF where

open import LTC.Minimal

open import Examples.DivisionPCF
open import Examples.Division.EquationsPCF
open import Examples.Division.IsCorrectPCF
open import Examples.Division.IsN-PCF
open import Examples.Division.SpecificationPCF

open import LTC.Data.N
open import LTC.Data.N.Induction.WellFoundedPCF
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF
open import LTC.Relation.InequalitiesPCF
open import LTC.Relation.Inequalities.PropertiesPCF

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

-- The division result satifies the specification DIV
-- when the dividend is less than the divisor
div-x<y-DIV : {i j : D} → N i → N j -> LT i j → DIV i j (div i j)
div-x<y-DIV Ni Nj i<j = div-x<y-N i<j , div-x<y-correct Ni Nj i<j

-- The division result satisfies the specification DIV when the
-- dividend is greater or equal than the divisor.
div-x≥y-DIV : {i j : D} → N i -> N j →
              ({i' : D} → N i' → LT i' i → DIV i' j (div i' j)) →
              GT j zero →
              GE i j →
              DIV i j (div i j)
div-x≥y-DIV {i} {j} Ni Nj accH j>0 i≥j =
  (div-x≥y-N ih i≥j) , div-x≥y-correct Ni Nj ih i≥j

    where
    -- The inductive hypothesis on 'i - j'.
    ih : DIV (i - j) j (div (i - j) j)
    ih = accH {i - j}
              (minus-N Ni Nj )
              (x≥y→y>0→x-y<x Ni Nj i≥j j>0)

------------------------------------------------------------------------------
-- The division satisfies the specification

-- We do the well-founded induction on 'i' and we keep 'j' fixed.
div-DIV : {i j : D} → N i → N j → GT j zero → DIV i j (div i j)
div-DIV {j = j} Ni Nj j>0 = wfIndN-LT P iStep Ni

   where
     P : D → Set
     P d = DIV d j (div d j)

     -- The inductive step doesn't use the variable 'i'
     -- (nor 'Ni'). To make this
     -- clear we write down the inductive step using the variables
     -- 'm' and 'n'.
     iStep : {n : D} → N n →
             (accH : {m : D} → N m → LT m n → P m) →
             P n
     iStep {n} Nn accH =
       [ div-x<y-DIV Nn Nj , div-x≥y-DIV Nn Nj accH j>0 ] (x<y∨x≥y Nn Nj)


Monoid: add the Pointwise construction

Monoid: add the Pointwise construction

{-# OPTIONS --without-K #-}
open import Type using (Type_)
open import Function.NP
open import Function.Extensionality
open import Data.Product.NP
open import Relation.Binary.PropositionalEquality.NP using (_≡_; idp; ap; ap₂)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits

module Algebra.Monoid where

record Monoid-Ops {ℓ} (M : Type ℓ) : Type ℓ where
  constructor _,_
  infixl 7 _∙_

  field
    _∙_ : M → M → M
    ε   : M

  open From-Op₂ _∙_ public renaming (op= to ∙=)
  open From-Monoid-Ops ε _∙_ public

record Monoid-Struct {ℓ} {M : Type ℓ} (mon-ops : Monoid-Ops M) : Type ℓ where
  constructor _,_
  open Monoid-Ops mon-ops

  -- laws
  field
    assocs   : Associative _∙_ × Associative (flip _∙_)
    identity : Identity  ε _∙_

  ε∙-identity : LeftIdentity ε _∙_
  ε∙-identity = fst identity

  ∙ε-identity : RightIdentity ε _∙_
  ∙ε-identity = snd identity

  assoc  = fst assocs
  !assoc = snd assocs

  open From-Assoc assoc public hiding (assocs)
  open From-Assoc-LeftIdentity  assoc ε∙-identity public
  open From-Assoc-RightIdentity assoc ∙ε-identity public

record Monoid {ℓ}(M : Type ℓ) : Type ℓ where
  constructor _,_
  field
    mon-ops    : Monoid-Ops M
    mon-struct : Monoid-Struct mon-ops
  open Monoid-Ops    mon-ops    public
  open Monoid-Struct mon-struct public

-- A renaming of Monoid-Ops with additive notation
module Additive-Monoid-Ops {ℓ}{M : Set ℓ} (mon : Monoid-Ops M) where
  private
   module M = Monoid-Ops mon
    using    ()
    renaming ( _∙_ to _+_
             ; ε to 0#
             ; _² to 2⊗_
             ; _³ to 3⊗_
             ; _⁴ to 4⊗_
             ; _^¹⁺_ to _⊗¹⁺_
             ; _^⁺_ to _⊗⁺_
             ; ∙= to +=
             )
  open M public using (0#; +=)
  infixl 6 _+_
  infixl 7 _⊗¹⁺_ _⊗⁺_ 2⊗_ 3⊗_ 4⊗_
  _+_   = M._+_
  _⊗¹⁺_ = M._⊗¹⁺_
  _⊗⁺_  = M._⊗⁺_
  2⊗_   = M.2⊗_
  3⊗_   = M.3⊗_
  4⊗_   = M.4⊗_

-- A renaming of Monoid-Struct with additive notation
module Additive-Monoid-Struct {ℓ}{M : Type ℓ}{mon-ops : Monoid-Ops M}
                              (mon-struct : Monoid-Struct mon-ops)
  = Monoid-Struct mon-struct
    renaming ( identity to +-identity
             ; ε∙-identity to 0+-identity
             ; ∙ε-identity to +0-identity
             ; assocs to +-assocs
             ; assoc to +-assoc
             ; !assoc to +-!assoc
             ; assoc= to +-assoc=
             ; !assoc= to +-!assoc=
             ; inner= to +-inner=
             )

-- A renaming of Monoid with additive notation
module Additive-Monoid {ℓ}{M : Type ℓ} (mon : Monoid M) where
  open Additive-Monoid-Ops    (Monoid.mon-ops    mon) public
  open Additive-Monoid-Struct (Monoid.mon-struct mon) public

-- A renaming of Monoid-Ops with multiplicative notation
module Multiplicative-Monoid-Ops {ℓ}{M : Type ℓ} (mon-ops : Monoid-Ops M)
  = Monoid-Ops mon-ops
    renaming ( _∙_ to _*_
             ; ε to 1#
             ; ∙= to *=
             )

-- A renaming of Monoid-Struct with multiplicative notation
module Multiplicative-Monoid-Struct {ℓ}{M : Type ℓ}{mon-ops : Monoid-Ops M}
                                    (mon-struct : Monoid-Struct mon-ops)
  = Monoid-Struct mon-struct
    renaming ( identity to *-identity
             ; ε∙-identity to 1*-identity
             ; ∙ε-identity to *1-identity
             ; assocs to *-assocs
             ; assoc to *-assoc
             ; !assoc to *-!assoc
             ; assoc= to *-assoc=
             ; !assoc= to *-!assoc=
             ; inner= to *-inner=
             )

-- A renaming of Monoid with multiplicative notation
module Multiplicative-Monoid {ℓ}{M : Type ℓ} (mon : Monoid M) where
  open Multiplicative-Monoid-Ops    (Monoid.mon-ops    mon) public
  open Multiplicative-Monoid-Struct (Monoid.mon-struct mon) public

module Monoidᵒᵖ {ℓ}{M : Type ℓ} where
  _ᵒᵖ-ops : Monoid-Ops M → Monoid-Ops M
  (_∙_ , ε) ᵒᵖ-ops = flip _∙_ , ε

  _ᵒᵖ-struct : {mon : Monoid-Ops M} → Monoid-Struct mon → Monoid-Struct (mon ᵒᵖ-ops)
  (assocs , identities) ᵒᵖ-struct = (swap assocs , swap identities)

  _ᵒᵖ : Monoid M → Monoid M
  (ops , struct)ᵒᵖ = _ , struct ᵒᵖ-struct

  ᵒᵖ∘ᵒᵖ-id : ∀ {mon} → (mon ᵒᵖ) ᵒᵖ ≡ mon
  ᵒᵖ∘ᵒᵖ-id = idp

module _ {a}{A : Type a}(_∙_ : Op₂ A)(assoc : Associative _∙_) where
  from-assoc = From-Op₂.From-Assoc.assocs _∙_ assoc

--import Data.Vec.NP as V
{-
module _ {A B : Type} where
  (f : Vec  : Vec M n) → f ⊛ x (∀ i → )

module VecMonoid {M : Type} (mon : Monoid M) where
  open V
  open Monoid mon

  module _ n where
    ×-mon-ops : Monoid-Ops (Vec M n)
    ×-mon-ops = zipWith _∙_ , replicate ε

    ×-mon-struct : Monoid-Struct ×-mon-ops
    ×-mon-struct = (λ {x}{y}{z} → {!replicate ? ⊛ ?!}) , {!!} , {!!}
-}

-- The monoidal structure of endomorphisms
module _ {a}(A : Type a) where
  ∘-mon-ops : Monoid-Ops (Endo A)
  ∘-mon-ops = _∘′_ , id

  ∘-mon-struct : Monoid-Struct ∘-mon-ops
  ∘-mon-struct = (idp , idp) , (idp , idp)

  ∘-mon : Monoid (Endo A)
  ∘-mon = ∘-mon-ops , ∘-mon-struct

module Product {a}{A : Type a}{b}{B : Type b}
               (𝔸 : Monoid A)(𝔹 : Monoid B) where
  open Additive-Monoid 𝔸
  open Multiplicative-Monoid 𝔹

  ×-mon-ops    : Monoid-Ops (A × B)
  ×-mon-ops    = zip _+_ _*_ , 0# , 1#

  ×-mon-struct : Monoid-Struct ×-mon-ops
  ×-mon-struct = (ap₂ _,_ +-assoc *-assoc , ap₂ _,_ +-!assoc *-!assoc)
               , ap₂ _,_ (fst +-identity) (fst *-identity)
               , ap₂ _,_ (snd +-identity) (snd *-identity)

  ×-mon : Monoid (A × B)
  ×-mon = ×-mon-ops , ×-mon-struct

  open Monoid ×-mon public

{-
This module shows how properties of a monoid 𝕄 are carried on
functions from any type A to 𝕄.
However since the function type can be dependent, this also generalises
the product of monoids (since Π 𝟚 [ A , B ] ≃ A × B).
-}
module Pointwise {{_ : FunExt}}{a}(A : Type a){m}{M : A → Type m}
                 (𝕄 : (x : A) → Monoid (M x)) where
  private
    module 𝕄 {x} = Monoid (𝕄 x)
  open 𝕄 hiding (mon-ops; mon-struct)

  ⟨ε⟩ : Π A M
  ⟨ε⟩ = λ _ → ε

  _⟨∙⟩_ : Op₂ (Π A M)
  (f ⟨∙⟩ g) x = f x ∙ g x

  mon-ops : Monoid-Ops (Π A M)
  mon-ops = _⟨∙⟩_ , ⟨ε⟩

  mon-struct : Monoid-Struct mon-ops
  mon-struct = (λ=ⁱ assoc , λ=ⁱ !assoc) , λ=ⁱ ε∙-identity , λ=ⁱ ∙ε-identity

  mon : Monoid (Π A M)
  mon = mon-ops , mon-struct

  open Monoid mon public hiding (mon-ops; mon-struct)

-- Non-dependent version of Pointwise′
module Pointwise′ {{_ : FunExt}}{a}(A : Type a){m}{M : Type m}(𝕄 : Monoid M) =
  Pointwise A (λ _ → 𝕄)
  {- OR
  open Monoid 𝕄 hiding (mon-ops; mon-struct)

  ⟨ε⟩ : A → M
  ⟨ε⟩ = λ _ → ε

  _⟨∙⟩_ : Op₂ (A → M)
  (f ⟨∙⟩ g) x = f x ∙ g x

  mon-ops : Monoid-Ops (A → M)
  mon-ops = _⟨∙⟩_ , ⟨ε⟩

  mon-struct : Monoid-Struct mon-ops
  mon-struct = (λ=ⁱ assoc , λ=ⁱ !assoc) , λ=ⁱ ε∙-identity , λ=ⁱ ∙ε-identity

  mon : Monoid (A → M)
  mon = mon-ops , mon-struct

  open Monoid mon public hiding (mon-ops; mon-struct)
  -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type using () renaming (Type_ to Type)
open import Level.NP
open import Function.NP
open import Data.Product.NP
open import Data.Nat
  using    (ℕ; zero)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; suc to 1+_)
import Data.Nat.Properties.Simple as ℕ°
open import Data.Integer.NP
  using    (ℤ; +_; -[1+_]; _⊖_; -_; module ℤ°)
  renaming ( _+_ to _+ℤ_; _-_ to _−ℤ_; _*_ to _*ℤ_
           ; suc to sucℤ; pred to predℤ
           )
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open ≡-Reasoning

module Algebra.Monoid where

record Monoid-Ops {ℓ} (M : Type ℓ) : Type ℓ where
  constructor _,_
  infixl 7 _∙_

  field
    _∙_ : M → M → M
    ε   : M

  open From-Op₂ _∙_ public renaming (op= to ∙=)
  open From-Monoid-Ops ε _∙_ public

record Monoid-Struct {ℓ} {M : Type ℓ} (mon-ops : Monoid-Ops M) : Type ℓ where
  constructor _,_
  open Monoid-Ops mon-ops

  -- laws
  field
    assocs   : Associative _∙_ × Associative (flip _∙_)
    identity : Identity  ε _∙_

  ε∙-identity : LeftIdentity ε _∙_
  ε∙-identity = fst identity

  ∙ε-identity : RightIdentity ε _∙_
  ∙ε-identity = snd identity

  assoc  = fst assocs
  !assoc = snd assocs

  open From-Assoc assoc public hiding (assocs)
  open From-Assoc-LeftIdentity  assoc ε∙-identity public
  open From-Assoc-RightIdentity assoc ∙ε-identity public

record Monoid {ℓ}(M : Type ℓ) : Type ℓ where
  constructor _,_
  field
    mon-ops    : Monoid-Ops M
    mon-struct : Monoid-Struct mon-ops
  open Monoid-Ops    mon-ops    public
  open Monoid-Struct mon-struct public

-- A renaming of Monoid-Ops with additive notation
module Additive-Monoid-Ops {ℓ}{M : Set ℓ} (mon : Monoid-Ops M) where
  private
   module M = Monoid-Ops mon
    using    ()
    renaming ( _∙_ to _+_
             ; ε to 0#
             ; _² to 2⊗_
             ; _³ to 3⊗_
             ; _⁴ to 4⊗_
             ; _^¹⁺_ to _⊗¹⁺_
             ; _^⁺_ to _⊗⁺_
             ; ∙= to +=
             )
  open M public using (0#; +=)
  infixl 6 _+_
  infixl 7 _⊗¹⁺_ _⊗⁺_ 2⊗_ 3⊗_ 4⊗_
  _+_   = M._+_
  _⊗¹⁺_ = M._⊗¹⁺_
  _⊗⁺_  = M._⊗⁺_
  2⊗_   = M.2⊗_
  3⊗_   = M.3⊗_
  4⊗_   = M.4⊗_

-- A renaming of Monoid-Struct with additive notation
module Additive-Monoid-Struct {ℓ}{M : Type ℓ}{mon-ops : Monoid-Ops M}
                              (mon-struct : Monoid-Struct mon-ops)
  = Monoid-Struct mon-struct
    renaming ( identity to +-identity
             ; ε∙-identity to 0+-identity
             ; ∙ε-identity to +0-identity
             ; assocs to +-assocs
             ; assoc to +-assoc
             ; !assoc to +-!assoc
             ; assoc= to +-assoc=
             ; !assoc= to +-!assoc=
             ; inner= to +-inner=
             )

-- A renaming of Monoid with additive notation
module Additive-Monoid {ℓ}{M : Type ℓ} (mon : Monoid M) where
  open Additive-Monoid-Ops    (Monoid.mon-ops    mon) public
  open Additive-Monoid-Struct (Monoid.mon-struct mon) public

-- A renaming of Monoid-Ops with multiplicative notation
module Multiplicative-Monoid-Ops {ℓ}{M : Type ℓ} (mon-ops : Monoid-Ops M)
  = Monoid-Ops mon-ops
    renaming ( _∙_ to _*_
             ; ε to 1#
             ; ∙= to *=
             )

-- A renaming of Monoid-Struct with multiplicative notation
module Multiplicative-Monoid-Struct {ℓ}{M : Type ℓ}{mon-ops : Monoid-Ops M}
                                    (mon-struct : Monoid-Struct mon-ops)
  = Monoid-Struct mon-struct
    renaming ( identity to *-identity
             ; ε∙-identity to 1*-identity
             ; ∙ε-identity to *1-identity
             ; assocs to *-assocs
             ; assoc to *-assoc
             ; !assoc to *-!assoc
             ; assoc= to *-assoc=
             ; !assoc= to *-!assoc=
             ; inner= to *-inner=
             )

-- A renaming of Monoid with multiplicative notation
module Multiplicative-Monoid {ℓ}{M : Type ℓ} (mon : Monoid M) where
  open Multiplicative-Monoid-Ops    (Monoid.mon-ops    mon) public
  open Multiplicative-Monoid-Struct (Monoid.mon-struct mon) public

module Monoidᵒᵖ {ℓ}{M : Type ℓ} where
  _ᵒᵖ-ops : Monoid-Ops M → Monoid-Ops M
  (_∙_ , ε) ᵒᵖ-ops = flip _∙_ , ε

  _ᵒᵖ-struct : {mon : Monoid-Ops M} → Monoid-Struct mon → Monoid-Struct (mon ᵒᵖ-ops)
  (assocs , identities) ᵒᵖ-struct = (swap assocs , swap identities)

  _ᵒᵖ : Monoid M → Monoid M
  (ops , struct)ᵒᵖ = _ , struct ᵒᵖ-struct

  ᵒᵖ∘ᵒᵖ-id : ∀ {mon} → (mon ᵒᵖ) ᵒᵖ ≡ mon
  ᵒᵖ∘ᵒᵖ-id = idp

module _ {a}{A : Type a}(_∙_ : Op₂ A)(assoc : Associative _∙_) where
  from-assoc = From-Op₂.From-Assoc.assocs _∙_ assoc

--import Data.Vec.NP as V
{-
module _ {A B : Type} where
  (f : Vec  : Vec M n) → f ⊛ x (∀ i → )

module VecMonoid {M : Type} (mon : Monoid M) where
  open V
  open Monoid mon

  module _ n where
    ×-mon-ops : Monoid-Ops (Vec M n)
    ×-mon-ops = zipWith _∙_ , replicate ε

    ×-mon-struct : Monoid-Struct ×-mon-ops
    ×-mon-struct = (λ {x}{y}{z} → {!replicate ? ⊛ ?!}) , {!!} , {!!}
-}

module MonoidProduct {a}{A : Type a}{b}{B : Type b}
                     (monA0+ : Monoid A)(monB1* : Monoid B) where
  open Additive-Monoid monA0+
  open Multiplicative-Monoid monB1*

  ×-mon-ops    : Monoid-Ops (A × B)
  ×-mon-ops    = zip _+_ _*_ , 0# , 1#

  ×-mon-struct : Monoid-Struct ×-mon-ops
  ×-mon-struct = (ap₂ _,_ +-assoc *-assoc , ap₂ _,_ +-!assoc *-!assoc)
               , ap₂ _,_ (fst +-identity) (fst *-identity)
               , ap₂ _,_ (snd +-identity) (snd *-identity)

  ×-mon : Monoid (A × B)
  ×-mon = ×-mon-ops , ×-mon-struct

  open Monoid ×-mon public
-- -}
-- -}
-- -}
-- -}


first cut at making rule names and variable choices match up with the TeX

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  -- used to mark which dhexp holes have been evaluated
  data mark : Set where
    ✓ : mark
    ✗ : mark

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst × mark) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst × mark) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  -- todo: this probably belongs in contexts, but need to abstract it.
  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × (tctx × htyp))
  u ::[ Γ ] τ = u , (Γ , τ)

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of u?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of u?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts? should this
  -- be judgemental rather than functional?

  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ1 τ2 Δ2} →
                -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ ⦇⦈ ] d :: ⦇⦈ ==> τ ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) (xd∈σ : (x , d) ∈ σ) →
            Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ m} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ , m ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ m} →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ , m ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  -- substitution
  [_/_]_ : dhexp → Nat → dhexp → dhexp
  [ d / y ] c = c
  [ d / y ] X x
    with natEQ x y
  [ d / y ] X .y | Inl refl = d
  [ d / y ] X x  | Inr neq = X y
  [ d / y ] (·λ x [ x₁ ] d') = ·λ x [ x₁ ] ( [ d / y ] d') -- TODO: i *think* barendrecht's saves us here, or at least i want it to. may need to reformulat this as a relation --> set
  [ d / y ] ⦇⦈⟨ u , σ , m ⟩ = ⦇⦈⟨ u , σ , m ⟩
  [ d / y ] ⦇ d' ⦈⟨ u , σ , m ⟩ =  ⦇ [ d / y ] d' ⦈⟨ u , σ , m ⟩
  [ d / y ] (d1 ∘ d2) =  ([ d / y ] d1) ∘ ([ d / y ] d2)
  [ d / y ] (< τ > d') = < τ > ([ d / y ] d')

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ , ✓ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ , ✓ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

  -- error
  data _⊢_err : (Δ : hctx) (d : dhexp) → Set where
    ECastError : ∀{ Δ d τ1 τ2 } →
                 Δ , ∅ ⊢ d :: τ2 →
                 τ1 ~̸ τ2 →
                 Δ ⊢ (< τ1 > d) err
    EAp1 : ∀{ Δ d1 d2} →
           Δ ⊢ d1 err →
           Δ ⊢ (d1 ∘ d2) err
    EAp2 : ∀{ Δ d1 d2} →
           Δ ⊢ d2 err →
           Δ ⊢ (d1 ∘ d2) err
    ENEHole : ∀{ Δ d u σ m} →
           Δ ⊢ d err →
           Δ ⊢ (⦇ d ⦈⟨ (u , σ , m)⟩) err
    ECastProp : ∀{ Δ d τ} →
                Δ ⊢ d err →
                Δ ⊢ (< τ > d) err
    EConst : ∀{ Δ τ } → Δ ⊢ (< τ > c) err

  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    ·λ_[_]_ : Nat → htyp → ectx → ectx
    _∘₁_ : dhexp → ectx → ectx
    _∘₂_ : ectx → dhexp → ectx
    ⦇_⦈⟨_⟩ : ectx → (Nat × subst × mark) → ectx
    <_>_   : htyp → ectx → ectx

 --ε is an evaluation context
  data _evalctx : (ε : ectx) → Set where
    ECDot : ⊙ evalctx
    ECLam : ∀{ε x τ} →
            ε evalctx →
            (·λ x [ τ ] ε) evalctx
    ECAp1 : ∀{d ε} →
            d final →
            ε evalctx →
            (d ∘₁ ε) evalctx
    ECAp2 : ∀{d ε} →
            ε evalctx →
            (ε ∘₂ d) evalctx
    ECNEHole : ∀{ε m u σ} →
               ε evalctx →
               ⦇ ε ⦈⟨ u , σ , m ⟩ evalctx
    ECCast : ∀{ ε τ } →
             ε evalctx →
             (< τ > ε ) evalctx

  -- d is the result of filling the hole in ε with d'
  data _==_⟦_⟧ : (d : dhexp) (ε : ectx) (d' : dhexp) → Set where
    FDot : ∀{d : dhexp} →
            d == ⊙ ⟦ d ⟧
    FLam : ∀{ d d' ε x τ } →
           d == ε ⟦ d' ⟧ →
           (·λ x [ τ ] d) == (·λ x [ τ ] ε) ⟦ d' ⟧
    FAp1 : ∀{d1 d2 d2' ε} →
           d1 final →
           d2 == ε ⟦ d2' ⟧ →
           (d1 ∘ d2) == (d1 ∘₁ ε) ⟦ d2' ⟧
    FAp2 : ∀{d1 d1' d2 ε} →
           d1 == ε ⟦ d1' ⟧ →
           (d1 ∘ d2) == (ε ∘₂ d2) ⟦ d1' ⟧
    FNEHole : ∀{ d d1 ε u σ m} →
              d1 == ε ⟦ d ⟧ →
              ⦇ d1 ⦈⟨ (u , σ , m) ⟩ ==  ⦇ ε ⦈⟨ (u , σ , m) ⟩ ⟦ d ⟧
    FCast : ∀{ d d' ε τ } →
            d == ε ⟦ d' ⟧ →
            (< τ > d) == < τ > ε ⟦ d' ⟧

  -- instruction transition judgement
  data _⊢_→>_ : (Δ : hctx) (d d' : dhexp) → Set where
    ITLam : ∀{ Δ x τ d1 d2 } →
            d2 final →
            Δ ⊢ ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) -- this is very unlikely to work long term
    ITCast : ∀{d Δ τ1 τ2 } →
             d final →
             Δ , ∅ ⊢ d :: τ2 →
             τ1 ~ τ2 → -- maybe?
             Δ ⊢ < τ1 > d →> d
    ITEHole : ∀{ Δ u σ} →
              Δ ⊢ ⦇⦈⟨ u , σ , ✗ ⟩ →> ⦇⦈⟨ u , σ , ✓ ⟩
    ITNEHole : ∀{ Δ u σ d } →
               d final →
               Δ ⊢ ⦇ d ⦈⟨ u , σ , ✗ ⟩ →> ⦇ d ⦈⟨ u , σ , ✓ ⟩

  data _⊢_↦_ : (Δ : hctx) (d d' : dhexp) → Set where
    Step : ∀{ d d0 d' d0' Δ ε} →
           d == ε ⟦ d0 ⟧ →
           Δ ⊢ d0 →> d0' → -- should this Δ be ∅?
           d' == ε ⟦ d0' ⟧ → -- why is this the same ε
           Δ ⊢ d ↦ d

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  -- used to mark which dhexp holes have been evaluated
  data mark : Set where
    ✓ : mark
    ✗ : mark

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst × mark) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst × mark) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  -- todo: this probably belongs in contexts, but need to abstract it.
  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × (tctx × htyp))
  u ::[ Γ ] τ = u , (Γ , τ)

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of u?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of u?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts? should this
  -- be judgemental rather than functional?

  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ1 τ2 Δ2} →
                -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ ⦇⦈ ] d :: ⦇⦈ ==> τ ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ , ✗ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) (xd∈σ : (x , d) ∈ σ) →
            Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ m} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ , m ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ m} →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ , m ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  -- substitution
  [_/_]_ : dhexp → Nat → dhexp → dhexp
  [ d / y ] c = c
  [ d / y ] X x
    with natEQ x y
  [ d / y ] X .y | Inl refl = d
  [ d / y ] X x  | Inr neq = X y
  [ d / y ] (·λ x [ x₁ ] d') = ·λ x [ x₁ ] ( [ d / y ] d') -- TODO: i *think* barendrecht's saves us here, or at least i want it to. may need to reformulat this as a relation --> set
  [ d / y ] ⦇⦈⟨ u , σ , m ⟩ = ⦇⦈⟨ u , σ , m ⟩
  [ d / y ] ⦇ d' ⦈⟨ u , σ , m ⟩ =  ⦇ [ d / y ] d' ⦈⟨ u , σ , m ⟩
  [ d / y ] (d1 ∘ d2) =  ([ d / y ] d1) ∘ ([ d / y ] d2)
  [ d / y ] (< τ > d') = < τ > ([ d / y ] d')

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ , ✓ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ , ✓ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

  -- error
  data _⊢_err : (Δ : hctx) (d : dhexp) → Set where
    ECastError : ∀{ Δ d τ1 τ2 } →
                 Δ , ∅ ⊢ d :: τ2 →
                 τ1 ~̸ τ2 →
                 Δ ⊢ (< τ1 > d) err
    EAp1 : ∀{ Δ d1 d2} →
           Δ ⊢ d1 err →
           Δ ⊢ (d1 ∘ d2) err
    EAp2 : ∀{ Δ d1 d2} →
           Δ ⊢ d2 err →
           Δ ⊢ (d1 ∘ d2) err
    ENEHole : ∀{ Δ d u σ m} →
           Δ ⊢ d err →
           Δ ⊢ (⦇ d ⦈⟨ (u , σ , m)⟩) err
    ECastProp : ∀{ Δ d τ} →
                Δ ⊢ d err →
                Δ ⊢ (< τ > d) err
    EConst : ∀{ Δ τ } → Δ ⊢ (< τ > c) err

  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    ·λ_[_]_ : Nat → htyp → ectx → ectx
    _∘₁_ : dhexp → ectx → ectx
    _∘₂_ : ectx → dhexp → ectx
    ⦇_⦈⟨_⟩ : ectx → (Nat × subst × mark) → ectx
    <_>_   : htyp → ectx → ectx

  -- instruction transition judgement
  data _⊢_→>_ : (Δ : hctx) (d d' : dhexp) → Set where
    ITLam : ∀{ Δ x τ d1 d2 } →
            d2 final →
            Δ ⊢ ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) -- this is very unlikely to work long term
    ITCast : ∀{d Δ τ1 τ2 } →
             d final →
             Δ , ∅ ⊢ d :: τ2 →
             τ1 ~ τ2 → -- maybe?
             Δ ⊢ < τ1 > d →> d
    ITEHole : ∀{ Δ u σ} →
              Δ ⊢ ⦇⦈⟨ u , σ , ✗ ⟩ →> ⦇⦈⟨ u , σ , ✓ ⟩
    ITNEHole : ∀{ Δ u σ d } →
               d final →
               Δ ⊢ ⦇ d ⦈⟨ u , σ , ✗ ⟩ →> ⦇ d ⦈⟨ u , σ , ✓ ⟩

  data _ectxt : (ε : ectx) → Set where
    ECDot : ⊙ ectxt
    ECLam : ∀{ε x τ} →
            ε ectxt →
            (·λ x [ τ ] ε) ectxt
    ECAp1 : ∀{d ε} →
            d final →
            ε ectxt →
            (d ∘₁ ε) ectxt
    ECAp2 : ∀{d ε} →
            ε ectxt →
            (ε ∘₂ d) ectxt
    ECNEHole : ∀{ε m u σ} →
               ε ectxt →
               ⦇ ε ⦈⟨ u , σ , m ⟩ ectxt
    ECCast : ∀{ ε τ } →
             ε ectxt →
             (< τ > ε ) ectxt

  data _==_⟦_⟧ : (d : dhexp) (ε : ectx) (d' : dhexp) → Set where
    FRefl : ∀{d : dhexp} →
            d == ⊙ ⟦ d ⟧
    FLam : ∀{ d d1 ε x τ } →
           d1 == ε ⟦ d ⟧ →
           (·λ x [ τ ] d1) == (·λ x [ τ ] ε) ⟦ d ⟧
    FAp1 : ∀{ d1 d2 d ε} →
           d1 final →
           d2 == ε ⟦ d ⟧ →
           (d1 ∘ d2) == (d1 ∘₁ ε) ⟦ d ⟧
    FAp2 : ∀{ d1 d2 d ε} →
           d2 == ε ⟦ d ⟧ →
           (d1 ∘ d2) == (ε ∘₂ d2) ⟦ d ⟧
    FNEHole : ∀{ d d1 ε u σ m} →
              d1 == ε ⟦ d ⟧ →
              ⦇ d1 ⦈⟨ (u , σ , m) ⟩ ==  ⦇ ε ⦈⟨ (u , σ , m) ⟩ ⟦ d ⟧
    FCast : ∀{ d d1 ε τ } →
            d1 == ε ⟦ d ⟧ →
            (< τ > d1) == < τ > ε ⟦ d ⟧

  data _⊢_↦_ : (Δ : hctx) (d d' : dhexp) → Set where
    Step : ∀{ d d0 d' d0' Δ ε} →
           d == ε ⟦ d0 ⟧ →
           Δ ⊢ d0 →> d0' → -- should this Δ be ∅?
           d' == ε ⟦ d0' ⟧ → -- why is this the same ε
           Δ ⊢ d ↦ d