Implicit arguments are eagerly introduced again

{-# OPTIONS --without-K #-}
open import Level
open import Type.Param.Binary
open import Algebra.FunctionProperties

module Function.Param.Binary where

private
  ★_ = λ ℓ → Set ℓ
  ★₀ = Set₀
  ★₁ = Set₁
  ★₂ = Set₂

⟦Π⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

infixr 0 ⟦Π⟧
syntax ⟦Π⟧ Aᵣ (λ xᵣ → f) = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

⟦Π⟧e : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧e Aᵣ Bᵣ = λ f₁ f₂ → ∀ x₁ x₂ (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

⟦∀⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : {x : A₁} → B₁ x) (f₂ : {x : A₂} → B₂ x) → ★ _
⟦∀⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ {x₁}) (f₂ {x₂})

infixr 0 ⟦∀⟧
syntax ⟦∀⟧ Aᵣ (λ xᵣ → f) = ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

infixr 1 _⟦→⟧_
_⟦→⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
Aᵣ ⟦→⟧ Bᵣ = ⟦Π⟧ Aᵣ (λ _ → Bᵣ)

infixr 0 _⟦→⟧e_
_⟦→⟧e_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
_⟦→⟧e_ Aᵣ Bᵣ = ⟦Π⟧e Aᵣ (λ _ → Bᵣ)

infixr 1 _→⟧_
_→⟧_ : ∀ {a b₁ b₂ bᵣ} (A : ★ a) {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : ⟦★⟧ bᵣ B₁ B₂) → ⟦★⟧ _ (A → B₁) (A → B₂)
(A →⟧ Bᵣ) f₁ f₂ = ∀ (x : A) → Bᵣ (f₁ x) (f₂ x)

Π⟧ : ∀ {a b₁ b₂ bᵣ} (A : ★ a) {B₁ : A → ★ b₁} {B₂ : A → ★ b₂} (Bᵣ : (A →⟧ ⟦★⟧ bᵣ) B₁ B₂) → ⟦★⟧ _ ((x : A) → B₁ x) ((x : A) → B₂ x)
Π⟧ A Bᵣ f₁ f₂ = ∀ (x : A) → Bᵣ x (f₁ x) (f₂ x)

infixr 0 Π⟧
syntax Π⟧ A (λ x → f) = ⟨ x ∶ A ⟩→⟧ f

∀⟧ : ∀ {a} (A : ★ a)
       {b₁ b₂ bᵣ} {B₁ : A → ★ b₁} {B₂ : A → ★ b₂} (Bᵣ : ∀ x → B₁ x → B₂ x → ★ bᵣ)
       (f₁ : {x : A} → B₁ x) (f₂ : {x : A} → B₂ x) → ★ _
∀⟧ A Bᵣ f₁ f₂ = {x : A} → Bᵣ x (f₁ {x}) (f₂ {x})

infixr 0 ∀⟧
syntax ∀⟧ A (λ x → f) = ∀⟨ x ∶ A ⟩→⟧ f

-- Non universe polymorphic versions

infixr 1 _⟦₀→₀⟧_ _⟦₀→₁⟧_ _⟦₁→₂⟧_

_⟦₀→₀⟧_ : ∀ {A₁ A₂ : ★₀} (Aᵣ : A₁ → A₂ → ★₀)
          {B₁ B₂ : ★₀} (Bᵣ : B₁ → B₂ → ★₀)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★₀
_⟦₀→₀⟧_ {A₁} {A₂} Aᵣ {B₁} {B₂} Bᵣ f₁ f₂ =
          ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ (f₁ x₁) (f₂ x₂)

_⟦₀→₁⟧_ : ∀ {A₁ A₂ : ★₀} (Aᵣ : A₁ → A₂ → ★₀)
          {B₁ B₂ : ★₁} (Bᵣ : B₁ → B₂ → ★₁)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★₁
_⟦₀→₁⟧_ {A₁} {A₂} Aᵣ {B₁} {B₂} Bᵣ f₁ f₂ =
          ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ (f₁ x₁) (f₂ x₂)

_⟦₁→₂⟧_ : ∀ {A₁ A₂ : ★₁} (Aᵣ : A₁ → A₂ → ★₁)
          {B₁ B₂ : ★₂} (Bᵣ : B₁ → B₂ → ★₂)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★₂
_⟦₁→₂⟧_ {A₁} {A₂} Aᵣ {B₁} {B₂} Bᵣ f₁ f₂ =
          ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ (f₁ x₁) (f₂ x₂)

-- open import Relation.Unary.NP using (Pred)
private
  -- Flipped version of Relation.Unary.Pred which scale better
  -- to logical relation [Pred] and ⟦Pred⟧
  Pred : ∀ ℓ {a} (A : ★ a) → ★ (a ⊔ suc ℓ)
  Pred ℓ A = A → ★ ℓ

⟦Pred⟧ : ∀ {p₁ p₂} pᵣ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ _) (Pred p₁) (Pred p₂)
⟦Pred⟧ pᵣ Aᵣ = Aᵣ ⟦→⟧ ⟦★⟧ pᵣ

private
  -- from Relation.Binary
  REL : ∀ {a b} → Set a → Set b → (ℓ : Level) → Set (a ⊔ b ⊔ suc ℓ)
  REL A B ℓ = A → B → Set ℓ

  -- from Relation.Binary
  Rel : ∀ {a} → Set a → (ℓ : Level) → Set (a ⊔ suc ℓ)
  Rel A ℓ = REL A A ℓ

  REL′ : ∀ ℓ {a b} → ★ a → ★ b → ★ (a ⊔ b ⊔ suc ℓ)
  REL′ ℓ A B = A → B → ★ ℓ

  ⟦REL⟧′ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ r₁ r₂} rᵣ →
          (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ {b₁} {b₂} bᵣ ⟦→⟧ ⟦★⟧ _) (REL′ r₁) (REL′ r₂)
  ⟦REL⟧′ rᵣ Aᵣ Bᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦REL⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          {r₁ r₂} rᵣ (∼₁ : REL A₁ B₁ r₁) (∼₂ : REL A₂ B₂ r₂) → ★ _
⟦REL⟧ Aᵣ Bᵣ rᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦Rel⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {r₁ r₂} ℓᵣ (∼₁ : Rel A₁ r₁) (∼₂ : Rel A₂ r₂) → ★ _
⟦Rel⟧ Aᵣ rᵣ = ⟦REL⟧ Aᵣ Aᵣ rᵣ

⟦Op₁⟧ : ∀ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} (a₁ ⊔ a₂ ⊔ aᵣ) ⟦→⟧ ⟦★⟧ _) Op₁ Op₁
⟦Op₁⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ

⟦Op₂⟧ : ∀ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} (a₁ ⊔ a₂ ⊔ aᵣ) ⟦→⟧ ⟦★⟧ _) Op₂ Op₂
⟦Op₂⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ

{-# OPTIONS --without-K #-}
open import Level
open import Type.Param.Binary
open import Algebra.FunctionProperties

module Function.Param.Binary where

private
  ★_ = λ ℓ → Set ℓ
  ★₀ = Set₀
  ★₁ = Set₁
  ★₂ = Set₂

⟦Π⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

infixr 0 ⟦Π⟧
syntax ⟦Π⟧ Aᵣ (λ xᵣ → f) = ⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

⟦Π⟧e : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : (x : A₁) → B₁ x) (f₂ : (x : A₂) → B₂ x) → ★ _
⟦Π⟧e Aᵣ Bᵣ = λ f₁ f₂ → ∀ x₁ x₂ (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ x₁) (f₂ x₂)

⟦∀⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
         {b₁ b₂ bᵣ} {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂} (Bᵣ : ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → B₁ x₁ → B₂ x₂ → ★ bᵣ)
         (f₁ : {x : A₁} → B₁ x) (f₂ : {x : A₂} → B₂ x) → ★ _
⟦∀⟧ Aᵣ Bᵣ = λ f₁ f₂ → ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ xᵣ (f₁ {x₁}) (f₂ {x₂})

infixr 0 ⟦∀⟧
syntax ⟦∀⟧ Aᵣ (λ xᵣ → f) = ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ f

infixr 1 _⟦→⟧_
_⟦→⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
Aᵣ ⟦→⟧ Bᵣ = ⟦Π⟧ Aᵣ (λ _ → Bᵣ)

infixr 0 _⟦→⟧e_
_⟦→⟧e_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★ _
_⟦→⟧e_ Aᵣ Bᵣ = ⟦Π⟧e Aᵣ (λ _ → Bᵣ)

infixr 1 _→⟧_
_→⟧_ : ∀ {a b₁ b₂ bᵣ} (A : ★ a) {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : ⟦★⟧ bᵣ B₁ B₂) → ⟦★⟧ _ (A → B₁) (A → B₂)
(A →⟧ Bᵣ) f₁ f₂ = ∀ (x : A) → Bᵣ (f₁ x) (f₂ x)

Π⟧ : ∀ {a b₁ b₂ bᵣ} (A : ★ a) {B₁ : A → ★ b₁} {B₂ : A → ★ b₂} (Bᵣ : (A →⟧ ⟦★⟧ bᵣ) B₁ B₂) → ⟦★⟧ _ ((x : A) → B₁ x) ((x : A) → B₂ x)
Π⟧ A Bᵣ f₁ f₂ = ∀ (x : A) → Bᵣ x (f₁ x) (f₂ x)

infixr 0 Π⟧
syntax Π⟧ A (λ x → f) = ⟨ x ∶ A ⟩→⟧ f

∀⟧ : ∀ {a} (A : ★ a)
       {b₁ b₂ bᵣ} {B₁ : A → ★ b₁} {B₂ : A → ★ b₂} (Bᵣ : ∀ x → B₁ x → B₂ x → ★ bᵣ)
       (f₁ : {x : A} → B₁ x) (f₂ : {x : A} → B₂ x) → ★ _
∀⟧ A Bᵣ f₁ f₂ = {x : A} → Bᵣ x (f₁ {x}) (f₂ {x})

infixr 0 ∀⟧
syntax ∀⟧ A (λ x → f) = ∀⟨ x ∶ A ⟩→⟧ f

-- Non universe polymorphic versions

infixr 1 _⟦₀→₀⟧_ _⟦₀→₁⟧_ _⟦₁→₂⟧_

_⟦₀→₀⟧_ : ∀ {A₁ A₂ : ★₀} (Aᵣ : A₁ → A₂ → ★₀)
          {B₁ B₂ : ★₀} (Bᵣ : B₁ → B₂ → ★₀)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★₀
_⟦₀→₀⟧_ = λ {A₁} {A₂} Aᵣ {B₁} {B₂} Bᵣ f₁ f₂ →
          ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ (f₁ x₁) (f₂ x₂)

_⟦₀→₁⟧_ : ∀ {A₁ A₂ : ★₀} (Aᵣ : A₁ → A₂ → ★₀)
          {B₁ B₂ : ★₁} (Bᵣ : B₁ → B₂ → ★₁)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★₁
_⟦₀→₁⟧_ = λ {A₁} {A₂} Aᵣ {B₁} {B₂} Bᵣ f₁ f₂ →
          ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ (f₁ x₁) (f₂ x₂)

_⟦₁→₂⟧_ : ∀ {A₁ A₂ : ★₁} (Aᵣ : A₁ → A₂ → ★₁)
          {B₁ B₂ : ★₂} (Bᵣ : B₁ → B₂ → ★₂)
          (f₁ : A₁ → B₁) (f₂ : A₂ → B₂) → ★₂
_⟦₁→₂⟧_ = λ {A₁} {A₂} Aᵣ {B₁} {B₂} Bᵣ f₁ f₂ →
          ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) → Bᵣ (f₁ x₁) (f₂ x₂)

-- open import Relation.Unary.NP using (Pred)
private
  -- Flipped version of Relation.Unary.Pred which scale better
  -- to logical relation [Pred] and ⟦Pred⟧
  Pred : ∀ ℓ {a} (A : ★ a) → ★ (a ⊔ suc ℓ)
  Pred ℓ A = A → ★ ℓ

⟦Pred⟧ : ∀ {p₁ p₂} pᵣ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ _) (Pred p₁) (Pred p₂)
⟦Pred⟧ pᵣ Aᵣ = Aᵣ ⟦→⟧ ⟦★⟧ pᵣ

private
  -- from Relation.Binary
  REL : ∀ {a b} → Set a → Set b → (ℓ : Level) → Set (a ⊔ b ⊔ suc ℓ)
  REL A B ℓ = A → B → Set ℓ

  -- from Relation.Binary
  Rel : ∀ {a} → Set a → (ℓ : Level) → Set (a ⊔ suc ℓ)
  Rel A ℓ = REL A A ℓ

  REL′ : ∀ ℓ {a b} → ★ a → ★ b → ★ (a ⊔ b ⊔ suc ℓ)
  REL′ ℓ A B = A → B → ★ ℓ

  ⟦REL⟧′ : ∀ {a₁ a₂ aᵣ b₁ b₂ bᵣ r₁ r₂} rᵣ →
          (⟦★⟧ {a₁} {a₂} aᵣ ⟦→⟧ ⟦★⟧ {b₁} {b₂} bᵣ ⟦→⟧ ⟦★⟧ _) (REL′ r₁) (REL′ r₂)
  ⟦REL⟧′ rᵣ Aᵣ Bᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦REL⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          {r₁ r₂} rᵣ (∼₁ : REL A₁ B₁ r₁) (∼₂ : REL A₂ B₂ r₂) → ★ _
⟦REL⟧ Aᵣ Bᵣ rᵣ = Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ (⟦★⟧ rᵣ)

⟦Rel⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {r₁ r₂} ℓᵣ (∼₁ : Rel A₁ r₁) (∼₂ : Rel A₂ r₂) → ★ _
⟦Rel⟧ Aᵣ rᵣ = ⟦REL⟧ Aᵣ Aᵣ rᵣ

⟦Op₁⟧ : ∀ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} (a₁ ⊔ a₂ ⊔ aᵣ) ⟦→⟧ ⟦★⟧ _) Op₁ Op₁
⟦Op₁⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ

⟦Op₂⟧ : ∀ {a₁ a₂ aᵣ} → (⟦★⟧ {a₁} {a₂} (a₁ ⊔ a₂ ⊔ aᵣ) ⟦→⟧ ⟦★⟧ _) Op₂ Op₂
⟦Op₂⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ


New/Changes.intCA: define composition explicitly

Apparently the definition was *inferred* by unification O_O.

module New.Changes where

open import Data.Product public hiding (map)
open import Data.Sum public hiding (map)
open import Data.Unit.Base public

open import Relation.Binary.PropositionalEquality public hiding ([_])
open import Postulate.Extensionality public
open import Level

open import Theorem.Groups-Nehemiah public

record IsChAlg {ℓ : Level} (A : Set ℓ) (Ch : Set ℓ) : Set (suc ℓ) where
  field
    _⊕_ : A → Ch → A
    _⊝_ : A → A → Ch
    valid : A → Ch → Set ℓ
    _⊚[_]_ : Ch → A → Ch → Ch
    ⊝-valid : ∀ (a b : A) → valid a (b ⊝ a)
    ⊕-⊝ : (b a : A) → a ⊕ (b ⊝ a) ≡ b
    ⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ da1 ⊚[ a ] da2 ≡ a ⊕ da1 ⊕ da2
    ⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (da1 ⊚[ a ] da2)
  infixl 6 _⊕_ _⊝_

  Δ : A → Set ℓ
  Δ a = Σ[ da ∈ Ch ] (valid a da)

  update-diff = ⊕-⊝

  nil : A → Ch
  nil a = a ⊝ a
  nil-valid : (a : A) → valid a (nil a)
  nil-valid a = ⊝-valid a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  default-⊚ : Ch → A → Ch → Ch
  default-⊚ da1 a da2 = a ⊕ da1 ⊕ da2 ⊝ a
  default-⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (default-⊚ da1 a da2)
  default-⊚-valid a da1 ada1 da2 ada2 = ⊝-valid a (a ⊕ da1 ⊕ da2)
  default-⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ default-⊚ da1 a da2 ≡ a ⊕ da1 ⊕ da2
  default-⊚-correct a da1 ada1 da2 ada2 = update-diff (a ⊕ da1 ⊕ da2) a

record ChAlg {ℓ : Level} (A : Set ℓ) : Set (suc ℓ) where
  field
    Ch : Set ℓ
    isChAlg : IsChAlg A Ch
  open IsChAlg isChAlg public

open ChAlg {{...}} public hiding (Ch)
Ch : ∀ {ℓ} (A : Set ℓ) → {{CA : ChAlg A}} → Set ℓ
Ch A {{CA}} = ChAlg.Ch CA

-- Huge hack, but it does gives the output you want to see in all cases I've seen.

{-# DISPLAY IsChAlg.valid x = valid #-}
{-# DISPLAY ChAlg.valid x = valid #-}
{-# DISPLAY IsChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY ChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChAlg.nil x = nil #-}
{-# DISPLAY ChAlg.nil x = nil #-}
{-# DISPLAY IsChAlg._⊝_ x = _⊝_ #-}
{-# DISPLAY ChAlg._⊝_ x = _⊝_ #-}

module _ {ℓ₁} {ℓ₂}
  {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where
  open ≡-Reasoning
  open import Postulate.Extensionality
  instance
    funCA : ChAlg (A → B)
  private
    fCh = A → Ch A → Ch B
    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)
    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

  IsDerivative : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  IsDerivative f df = ∀ a da (v : valid a da) → f (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChangePoint : ∀ (f : A → B) → (df : fCh) → ∀ a da → Set ℓ₂
  WellDefinedFunChangePoint f df a da = (f f⊕ df) (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChange : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  WellDefinedFunChange f df = ∀ a da (ada : valid a da) → WellDefinedFunChangePoint f df a da

  private
    fvalid : (A → B) → fCh → Set (ℓ₁ ⊔ ℓ₂)
    fvalid =  λ f df → ∀ a da (ada : valid a da) →
        valid (f a) (df a da) ×
        WellDefinedFunChangePoint f df a da
    f⊝-valid : ∀ (f g : A → B) → fvalid f (g f⊝ f)
    f⊝-valid = λ f g a da (v : valid a da) →
         ⊝-valid (f a) (g (a ⊕ da))
        , ( begin
          f (a ⊕ da) ⊕ (g (a ⊕ da ⊕ nil (a ⊕ da)) ⊝ f (a ⊕ da))
        ≡⟨ cong (λ □ → f (a ⊕ da) ⊕ (g □ ⊝ f (a ⊕ da)))
             (update-nil (a ⊕ da)) ⟩
          f (a ⊕ da) ⊕ (g (a ⊕ da) ⊝ f (a ⊕ da))
        ≡⟨ update-diff (g (a ⊕ da)) (f (a ⊕ da)) ⟩
          g (a ⊕ da)
        ≡⟨ sym (update-diff (g (a ⊕ da)) (f a)) ⟩
          f a ⊕ (g (a ⊕ da) ⊝ f a)
        ∎)

    -- Two alternatives. Proofs on f⊚ are a bit easier.
    -- f⊚ is optimized relying on the incrementalization property for df2.
    f⊚ f⊚2 : fCh → (A → B) → fCh → fCh
    f⊚ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)
    f⊚-valid : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚ df1 f df2)
    f⊚-valid f df1 fdf1 df2 fdf2 a da ada
      rewrite ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      | ⊚-correct
        (f (a ⊕ da))
        (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
        (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
      =
        ⊚-valid (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      , proj₂ (fdf2 a da ada)

    -- f⊚2 is optimized relying on the incrementalization property for df1, so we need to use that property to rewrite some goals.
    f⊚2 df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))
    f⊚-valid2 : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚2 df1 f df2)
    f⊚-valid2 f df1 fdf1 df2 fdf2 = lemma
      where
        -- Prove that (df2 (a ⊕ da) (nil (a ⊕ da))) is valid for (f a ⊕ df1 a da).
        -- Using the incrementalization property for df1, that becomes (f ⊕ df1) (a ⊕ da).
        --
        -- Since df2 is valid for f ⊕ df1, it follows that (df2 (a ⊕ da) (nil (a ⊕ da)))
        -- is indeed valid for (f ⊕ df1) (a ⊕ da).
        valid-df2-a2-nila2 : ∀ a da → (valid a da) → valid (f a ⊕ df1 a da) (df2 (a ⊕ da) (nil (a ⊕ da)))
        valid-df2-a2-nila2 a da ada rewrite sym (proj₂ (fdf1 a da ada)) = proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da)))

        lemma : fvalid f (f⊚2 df1 f df2)
        lemma a da ada
          rewrite ⊚-correct
            (f a)
            (df1 a da) (proj₁ (fdf1 a da ada))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          | update-nil (a ⊕ da)
          | ⊚-correct
            (f (a ⊕ da))
            (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
          | proj₂ (fdf1 a da ada)
          = ⊚-valid (f a) (df1 a da) (proj₁ (fdf1 a da ada)) (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          , refl

    f⊚-correct : ∀ (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → (a : A) →
      (f f⊕ f⊚ df1 f df2) a ≡ ((f f⊕ df1) f⊕ df2) a
    f⊚-correct f df1 fdf1 df2 fdf2 a = ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a (nil a)) (proj₁ (fdf2 a (nil a) (nil-valid a)))

  private
    funUpdateDiff : ∀ g f a → (f f⊕ (g f⊝ f)) a ≡ g a
  funUpdateDiff g f a rewrite update-nil a = update-diff (g a) (f a)
  funCA = record
    { Ch = A → Ch A → Ch B
    ; isChAlg = record
      { _⊕_ = _f⊕_
      ; _⊝_ = _f⊝_
      ; valid = fvalid
      ; _⊚[_]_ = f⊚
      ; ⊝-valid = f⊝-valid
      ; ⊕-⊝ = λ g f → ext (funUpdateDiff g f)
      ; ⊚-correct = λ f df1 fdf1 df2 fdf2 → ext (f⊚-correct f df1 fdf1 df2 fdf2)
      ; ⊚-valid = f⊚-valid
      } }

  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pvalid : A × B → pCh → Set (ℓ₂ ⊔ ℓ₁)
    pvalid (a , b) (da , db) = valid a da × valid b db
    p⊝-valid : (p1 p2 : A × B) → pvalid p1 (p2 p⊝ p1)
    p⊝-valid (a1 , b1) (a2 , b2) = ⊝-valid a1 a2 , ⊝-valid b1 b2
    p⊕-⊝ : (p2 p1 : A × B) → p1 p⊕ (p2 p⊝ p1) ≡ p2
    p⊕-⊝ (a2 , b2) (a1 , b1) = cong₂ _,_ (⊕-⊝ a2 a1) (⊕-⊝ b2 b1)
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    p⊚-valid : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → pvalid p (dp1 p⊚[ p ] dp2)
    p⊚-valid (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) = ⊚-valid a da1 ada1 da2 ada2 , ⊚-valid b db1 bdb1 db2 bdb2
    p⊚-correct : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → p p⊕ (dp1 p⊚[ p ] dp2) ≡ (p p⊕ dp1) p⊕ dp2
    p⊚-correct (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) rewrite ⊚-correct a da1 ada1 da2 ada2 | ⊚-correct b db1 bdb1 db2 bdb2 = refl
  instance
    pairCA : ChAlg (A × B)
  pairCA = record
    { Ch = pCh
    ; isChAlg = record
    { _⊕_ = _p⊕_
    ; _⊝_ = _p⊝_
    ; valid = pvalid
    ; ⊝-valid = p⊝-valid
    ; ⊕-⊝ = p⊕-⊝
    ; _⊚[_]_ = _p⊚[_]_
    ; ⊚-valid = p⊚-valid
    ; ⊚-correct = p⊚-correct
    } }

  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set (ℓ₁ ⊔ ℓ₂) where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  data SValid : A ⊎ B → SumChange → Set (ℓ₁ ⊔ ℓ₂) where
    sv₁ : ∀ (a : A) (da : Ch A) (ada : valid a da) → SValid (inj₁ a) (convert₁ (ch₁ da))
    sv₂ : ∀ (b : B) (db : Ch B) (bdb : valid b db) → SValid (inj₂ b) (convert₁ (ch₂ db))
    svrp₁ : ∀ a1 b2 → SValid (inj₁ a1) (convert₁ (rp (inj₂ b2)))
    svrp₂ : ∀ b1 a2 → SValid (inj₂ b1) (convert₁ (rp (inj₁ a2)))

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    s⊕2 : A ⊎ B → SumChange2 → A ⊎ B
    s⊕2 (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    s⊕2 (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    s⊕2 (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    s⊕2 (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    s⊕2 s (rp s₁) = s₁

    s⊕ : A ⊎ B → SumChange → A ⊎ B
    s⊕ s ds = s⊕2 s (convert ds)

    s⊝2 : A ⊎ B → A ⊎ B → SumChange2
    s⊝2 (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    s⊝2 (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    s⊝2 s2 s1 = rp s2

    s⊝ : A ⊎ B → A ⊎ B → SumChange
    s⊝ s2 s1 = convert₁ (s⊝2 s2 s1)

    s⊝-valid : (a b : A ⊎ B) → SValid a (s⊝ b a)
    s⊝-valid (inj₁ x1) (inj₁ x2) = sv₁ x1 (x2 ⊝ x1) (⊝-valid x1 x2)
    s⊝-valid (inj₂ y1) (inj₂ y2) = sv₂ y1 (y2 ⊝ y1) (⊝-valid y1 y2)
    s⊝-valid s1@(inj₁ x) s2@(inj₂ y) = svrp₁ x y
    s⊝-valid s1@(inj₂ y) s2@(inj₁ x) = svrp₂ y x

    s⊕-⊝ : (b a : A ⊎ B) → s⊕ a (s⊝ b a) ≡ b
    s⊕-⊝ (inj₁ x2) (inj₁ x1) rewrite ⊕-⊝ x2 x1 = refl
    s⊕-⊝ (inj₁ x2) (inj₂ y1) = refl
    s⊕-⊝ (inj₂ y2) (inj₁ x1) = refl
    s⊕-⊝ (inj₂ y2) (inj₂ y1) rewrite ⊕-⊝ y2 y1 = refl
    {-# TERMINATING #-}
    isSumCA : IsChAlg (A ⊎ B) SumChange
    s⊚-valid : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      SValid a (IsChAlg.default-⊚ isSumCA da1 a da2)
    s⊚-correct : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      s⊕ a (IsChAlg.default-⊚ isSumCA da1 a da2) ≡
      s⊕ (s⊕ a da1) da2

  instance
    sumCA : ChAlg (A ⊎ B)
  isSumCA = record
    { _⊕_ = s⊕
    ; _⊝_ = s⊝
    ; valid = SValid
    ; ⊝-valid = s⊝-valid
    ; ⊕-⊝ = s⊕-⊝
    ; _⊚[_]_ = IsChAlg.default-⊚ isSumCA
    ; ⊚-valid = s⊚-valid
    ; ⊚-correct = s⊚-correct
    }

  s⊚-valid = IsChAlg.default-⊚-valid isSumCA
  s⊚-correct = IsChAlg.default-⊚-correct isSumCA

  sumCA = record
    { Ch = SumChange
    ; isChAlg = isSumCA }

open import Data.Integer

instance
  intCA : ChAlg ℤ
intCA = record
  { Ch = ℤ
  ; isChAlg = record
  { _⊕_ = _+_
  ; _⊝_ = _-_
  ; valid = λ a b → ⊤
  ; ⊝-valid = λ a b → tt
  ; ⊕-⊝ = λ b a → n+[m-n]=m {a} {b}
  ; ⊚-valid = λ a da1 _ da2 _ → tt
  ; _⊚[_]_ = λ da1 a da2 → da1 + da2
  ; ⊚-correct = λ a da1 _ da2 _ → sym (associative-int a da1 da2)
  } }

module New.Changes where

open import Data.Product public hiding (map)
open import Data.Sum public hiding (map)
open import Data.Unit.Base public

open import Relation.Binary.PropositionalEquality public hiding ([_])
open import Postulate.Extensionality public
open import Level

open import Theorem.Groups-Nehemiah public

record IsChAlg {ℓ : Level} (A : Set ℓ) (Ch : Set ℓ) : Set (suc ℓ) where
  field
    _⊕_ : A → Ch → A
    _⊝_ : A → A → Ch
    valid : A → Ch → Set ℓ
    _⊚[_]_ : Ch → A → Ch → Ch
    ⊝-valid : ∀ (a b : A) → valid a (b ⊝ a)
    ⊕-⊝ : (b a : A) → a ⊕ (b ⊝ a) ≡ b
    ⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ da1 ⊚[ a ] da2 ≡ a ⊕ da1 ⊕ da2
    ⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (da1 ⊚[ a ] da2)
  infixl 6 _⊕_ _⊝_

  Δ : A → Set ℓ
  Δ a = Σ[ da ∈ Ch ] (valid a da)

  update-diff = ⊕-⊝

  nil : A → Ch
  nil a = a ⊝ a
  nil-valid : (a : A) → valid a (nil a)
  nil-valid a = ⊝-valid a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  default-⊚ : Ch → A → Ch → Ch
  default-⊚ da1 a da2 = a ⊕ da1 ⊕ da2 ⊝ a
  default-⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (default-⊚ da1 a da2)
  default-⊚-valid a da1 ada1 da2 ada2 = ⊝-valid a (a ⊕ da1 ⊕ da2)
  default-⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ default-⊚ da1 a da2 ≡ a ⊕ da1 ⊕ da2
  default-⊚-correct a da1 ada1 da2 ada2 = update-diff (a ⊕ da1 ⊕ da2) a

record ChAlg {ℓ : Level} (A : Set ℓ) : Set (suc ℓ) where
  field
    Ch : Set ℓ
    isChAlg : IsChAlg A Ch
  open IsChAlg isChAlg public

open ChAlg {{...}} public hiding (Ch)
Ch : ∀ {ℓ} (A : Set ℓ) → {{CA : ChAlg A}} → Set ℓ
Ch A {{CA}} = ChAlg.Ch CA

-- Huge hack, but it does gives the output you want to see in all cases I've seen.

{-# DISPLAY IsChAlg.valid x = valid #-}
{-# DISPLAY ChAlg.valid x = valid #-}
{-# DISPLAY IsChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY ChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChAlg.nil x = nil #-}
{-# DISPLAY ChAlg.nil x = nil #-}
{-# DISPLAY IsChAlg._⊝_ x = _⊝_ #-}
{-# DISPLAY ChAlg._⊝_ x = _⊝_ #-}

module _ {ℓ₁} {ℓ₂}
  {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where
  open ≡-Reasoning
  open import Postulate.Extensionality
  instance
    funCA : ChAlg (A → B)
  private
    fCh = A → Ch A → Ch B
    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)
    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

  IsDerivative : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  IsDerivative f df = ∀ a da (v : valid a da) → f (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChangePoint : ∀ (f : A → B) → (df : fCh) → ∀ a da → Set ℓ₂
  WellDefinedFunChangePoint f df a da = (f f⊕ df) (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChange : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  WellDefinedFunChange f df = ∀ a da (ada : valid a da) → WellDefinedFunChangePoint f df a da

  private
    fvalid : (A → B) → fCh → Set (ℓ₁ ⊔ ℓ₂)
    fvalid =  λ f df → ∀ a da (ada : valid a da) →
        valid (f a) (df a da) ×
        WellDefinedFunChangePoint f df a da
    f⊝-valid : ∀ (f g : A → B) → fvalid f (g f⊝ f)
    f⊝-valid = λ f g a da (v : valid a da) →
         ⊝-valid (f a) (g (a ⊕ da))
        , ( begin
          f (a ⊕ da) ⊕ (g (a ⊕ da ⊕ nil (a ⊕ da)) ⊝ f (a ⊕ da))
        ≡⟨ cong (λ □ → f (a ⊕ da) ⊕ (g □ ⊝ f (a ⊕ da)))
             (update-nil (a ⊕ da)) ⟩
          f (a ⊕ da) ⊕ (g (a ⊕ da) ⊝ f (a ⊕ da))
        ≡⟨ update-diff (g (a ⊕ da)) (f (a ⊕ da)) ⟩
          g (a ⊕ da)
        ≡⟨ sym (update-diff (g (a ⊕ da)) (f a)) ⟩
          f a ⊕ (g (a ⊕ da) ⊝ f a)
        ∎)

    -- Two alternatives. Proofs on f⊚ are a bit easier.
    -- f⊚ is optimized relying on the incrementalization property for df2.
    f⊚ f⊚2 : fCh → (A → B) → fCh → fCh
    f⊚ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)
    f⊚-valid : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚ df1 f df2)
    f⊚-valid f df1 fdf1 df2 fdf2 a da ada
      rewrite ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      | ⊚-correct
        (f (a ⊕ da))
        (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
        (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
      =
        ⊚-valid (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      , proj₂ (fdf2 a da ada)

    -- f⊚2 is optimized relying on the incrementalization property for df1, so we need to use that property to rewrite some goals.
    f⊚2 df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))
    f⊚-valid2 : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚2 df1 f df2)
    f⊚-valid2 f df1 fdf1 df2 fdf2 = lemma
      where
        -- Prove that (df2 (a ⊕ da) (nil (a ⊕ da))) is valid for (f a ⊕ df1 a da).
        -- Using the incrementalization property for df1, that becomes (f ⊕ df1) (a ⊕ da).
        --
        -- Since df2 is valid for f ⊕ df1, it follows that (df2 (a ⊕ da) (nil (a ⊕ da)))
        -- is indeed valid for (f ⊕ df1) (a ⊕ da).
        valid-df2-a2-nila2 : ∀ a da → (valid a da) → valid (f a ⊕ df1 a da) (df2 (a ⊕ da) (nil (a ⊕ da)))
        valid-df2-a2-nila2 a da ada rewrite sym (proj₂ (fdf1 a da ada)) = proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da)))

        lemma : fvalid f (f⊚2 df1 f df2)
        lemma a da ada
          rewrite ⊚-correct
            (f a)
            (df1 a da) (proj₁ (fdf1 a da ada))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          | update-nil (a ⊕ da)
          | ⊚-correct
            (f (a ⊕ da))
            (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
          | proj₂ (fdf1 a da ada)
          = ⊚-valid (f a) (df1 a da) (proj₁ (fdf1 a da ada)) (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          , refl

    f⊚-correct : ∀ (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → (a : A) →
      (f f⊕ f⊚ df1 f df2) a ≡ ((f f⊕ df1) f⊕ df2) a
    f⊚-correct f df1 fdf1 df2 fdf2 a = ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a (nil a)) (proj₁ (fdf2 a (nil a) (nil-valid a)))

  private
    funUpdateDiff : ∀ g f a → (f f⊕ (g f⊝ f)) a ≡ g a
  funUpdateDiff g f a rewrite update-nil a = update-diff (g a) (f a)
  funCA = record
    { Ch = A → Ch A → Ch B
    ; isChAlg = record
      { _⊕_ = _f⊕_
      ; _⊝_ = _f⊝_
      ; valid = fvalid
      ; _⊚[_]_ = f⊚
      ; ⊝-valid = f⊝-valid
      ; ⊕-⊝ = λ g f → ext (funUpdateDiff g f)
      ; ⊚-correct = λ f df1 fdf1 df2 fdf2 → ext (f⊚-correct f df1 fdf1 df2 fdf2)
      ; ⊚-valid = f⊚-valid
      } }

  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pvalid : A × B → pCh → Set (ℓ₂ ⊔ ℓ₁)
    pvalid (a , b) (da , db) = valid a da × valid b db
    p⊝-valid : (p1 p2 : A × B) → pvalid p1 (p2 p⊝ p1)
    p⊝-valid (a1 , b1) (a2 , b2) = ⊝-valid a1 a2 , ⊝-valid b1 b2
    p⊕-⊝ : (p2 p1 : A × B) → p1 p⊕ (p2 p⊝ p1) ≡ p2
    p⊕-⊝ (a2 , b2) (a1 , b1) = cong₂ _,_ (⊕-⊝ a2 a1) (⊕-⊝ b2 b1)
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    p⊚-valid : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → pvalid p (dp1 p⊚[ p ] dp2)
    p⊚-valid (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) = ⊚-valid a da1 ada1 da2 ada2 , ⊚-valid b db1 bdb1 db2 bdb2
    p⊚-correct : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → p p⊕ (dp1 p⊚[ p ] dp2) ≡ (p p⊕ dp1) p⊕ dp2
    p⊚-correct (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) rewrite ⊚-correct a da1 ada1 da2 ada2 | ⊚-correct b db1 bdb1 db2 bdb2 = refl
  instance
    pairCA : ChAlg (A × B)
  pairCA = record
    { Ch = pCh
    ; isChAlg = record
    { _⊕_ = _p⊕_
    ; _⊝_ = _p⊝_
    ; valid = pvalid
    ; ⊝-valid = p⊝-valid
    ; ⊕-⊝ = p⊕-⊝
    ; _⊚[_]_ = _p⊚[_]_
    ; ⊚-valid = p⊚-valid
    ; ⊚-correct = p⊚-correct
    } }

  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set (ℓ₁ ⊔ ℓ₂) where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  data SValid : A ⊎ B → SumChange → Set (ℓ₁ ⊔ ℓ₂) where
    sv₁ : ∀ (a : A) (da : Ch A) (ada : valid a da) → SValid (inj₁ a) (convert₁ (ch₁ da))
    sv₂ : ∀ (b : B) (db : Ch B) (bdb : valid b db) → SValid (inj₂ b) (convert₁ (ch₂ db))
    svrp₁ : ∀ a1 b2 → SValid (inj₁ a1) (convert₁ (rp (inj₂ b2)))
    svrp₂ : ∀ b1 a2 → SValid (inj₂ b1) (convert₁ (rp (inj₁ a2)))

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    s⊕2 : A ⊎ B → SumChange2 → A ⊎ B
    s⊕2 (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    s⊕2 (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    s⊕2 (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    s⊕2 (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    s⊕2 s (rp s₁) = s₁

    s⊕ : A ⊎ B → SumChange → A ⊎ B
    s⊕ s ds = s⊕2 s (convert ds)

    s⊝2 : A ⊎ B → A ⊎ B → SumChange2
    s⊝2 (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    s⊝2 (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    s⊝2 s2 s1 = rp s2

    s⊝ : A ⊎ B → A ⊎ B → SumChange
    s⊝ s2 s1 = convert₁ (s⊝2 s2 s1)

    s⊝-valid : (a b : A ⊎ B) → SValid a (s⊝ b a)
    s⊝-valid (inj₁ x1) (inj₁ x2) = sv₁ x1 (x2 ⊝ x1) (⊝-valid x1 x2)
    s⊝-valid (inj₂ y1) (inj₂ y2) = sv₂ y1 (y2 ⊝ y1) (⊝-valid y1 y2)
    s⊝-valid s1@(inj₁ x) s2@(inj₂ y) = svrp₁ x y
    s⊝-valid s1@(inj₂ y) s2@(inj₁ x) = svrp₂ y x

    s⊕-⊝ : (b a : A ⊎ B) → s⊕ a (s⊝ b a) ≡ b
    s⊕-⊝ (inj₁ x2) (inj₁ x1) rewrite ⊕-⊝ x2 x1 = refl
    s⊕-⊝ (inj₁ x2) (inj₂ y1) = refl
    s⊕-⊝ (inj₂ y2) (inj₁ x1) = refl
    s⊕-⊝ (inj₂ y2) (inj₂ y1) rewrite ⊕-⊝ y2 y1 = refl
    {-# TERMINATING #-}
    isSumCA : IsChAlg (A ⊎ B) SumChange
    s⊚-valid : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      SValid a (IsChAlg.default-⊚ isSumCA da1 a da2)
    s⊚-correct : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      s⊕ a (IsChAlg.default-⊚ isSumCA da1 a da2) ≡
      s⊕ (s⊕ a da1) da2

  instance
    sumCA : ChAlg (A ⊎ B)
  isSumCA = record
    { _⊕_ = s⊕
    ; _⊝_ = s⊝
    ; valid = SValid
    ; ⊝-valid = s⊝-valid
    ; ⊕-⊝ = s⊕-⊝
    ; _⊚[_]_ = IsChAlg.default-⊚ isSumCA
    ; ⊚-valid = s⊚-valid
    ; ⊚-correct = s⊚-correct
    }

  s⊚-valid = IsChAlg.default-⊚-valid isSumCA
  s⊚-correct = IsChAlg.default-⊚-correct isSumCA

  sumCA = record
    { Ch = SumChange
    ; isChAlg = isSumCA }

open import Data.Integer

instance
  intCA : ChAlg ℤ
intCA = record
  { Ch = ℤ
  ; isChAlg = record
  { _⊕_ = _+_
  ; _⊝_ = _-_
  ; valid = λ a b → ⊤
  ; ⊝-valid = λ a b → tt
  ; ⊕-⊝ = λ b a → n+[m-n]=m {a} {b}
  ; ⊚-valid = λ a da1 _ da2 _ → tt
  ; ⊚-correct = λ a da1 _ da2 _ → sym (associative-int a da1 da2)
  } }


Messing around, not entirely productively, with ornamental agda.

{-# OPTIONS --universe-polymorphism #-}
module Ornament where

open import Data.Nat using (ℕ)
open import Data.Fin
open import Data.Bool
open import Data.Product
open import Data.Unit
open import Data.List

infix 4 _≡_

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

--

-- Modified from Conor's original HOAS presentation

data IndexParam {n} (I : Set) (N : Fin n) : Set₁ where
  -- read an indexed subnote; continue
  rec : I -> IndexParam I N -> IndexParam I N

  -- stop and return the node's index
  ret : I -> IndexParam I N

semantics : ∀{I} -> ∀{n : ℕ} -> IndexParam I (fromℕ n) -> (I -> Set) -> I -> Set
semantics = {!!}

record EmbedDataConstr : Set₁ where
  constructor embedDataConstr
  field arityTyping : {!!}

record EmbedDataTy (I A : Set) : Set₁ where
  constructor embedDataTy
  field indexes : List I
  field parameters : List A
  field constrs : List EmbedDataConstr

data Desc (I : Set) : Set₁ where
  -- read field in A; continue, given its value
  -- I don't think this is really what we want -- want parametricity
  arg : (a : Set) -> (a -> Desc I) -> Desc I

  -- read an indexed subnode; continue regardless
  rec : I -> Desc I -> Desc I

  -- stop reading and return the node’s index
  ret : I -> Desc I

  -- choice between n different constructors
  choice : (n : ℕ) -> (Fin n -> Desc I) -> Desc I

-- The semantics ("extension") of an indexed container
⟦_⟧ : ∀{I} -> Desc I -> (I -> Set) -> I -> Set
⟦ arg A D ⟧ R i = Σ A λ a → ⟦ D a ⟧ R i
⟦ rec h D ⟧ R i = R h × ⟦ D ⟧ R i
⟦ ret o ⟧ R i = o ≡ i
⟦ choice n D ⟧ R i =  Σ (Fin n) λ #n -> ⟦ D #n ⟧ R i

-- This is really the least fixpoint operator
data Data {I}(D : Desc I)(i : I) : Set where
  ⟨_⟩ : ⟦ D ⟧ (Data D) i -> Data D i

-- TODO think about codata / greatest fixed point
-- data CoData {I}(D : Desc I)(i : I) : Set where
--   ⟩_⟨ :

--

record DataConstr : Set where
  constructor dataConstr
  field arityTyping : {!!}

record DataTy : Set where
  constructor dataTy
  field indexes : List ℕ
  field parameters : List ℕ
  field constrs : List {!!}

--

NatChoiceDesc : Desc ⊤
NatChoiceDesc = choice 2 λ
  { zero -> ret tt
  ; (suc n) -> rec tt (ret tt)
  }

NatChoice : Set
NatChoice = Data NatChoiceDesc tt

zeChoice : NatChoice
zeChoice = ⟨ zero , refl ⟩

suChoice : NatChoice -> NatChoice
suChoice n = ⟨ suc zero , n , refl ⟩

--

NatDesc : Desc ⊤
NatDesc = arg Bool λ
  { true -> ret tt
  ; false -> rec tt (ret tt)
  }

Nat : Set
Nat = Data NatDesc tt

ze : Nat
ze = ⟨ true , refl ⟩

su : Nat -> Nat
su n = ⟨ false , n , refl ⟩

--

VecDesc : Set -> Desc Nat
VecDesc X = arg Bool λ
  { false -> ret ze
  ; true -> arg X λ _ -> arg Nat λ n -> rec n (ret (su n))
  }

Vec : Set -> Nat -> Set
Vec X n = Data (VecDesc X) n

nil : ∀{X} -> Vec X ze
nil = ⟨ false , refl ⟩

cons : ∀{X} -> (n : Nat) -> X -> Vec X n -> Vec X (su n)
cons n x xs = ⟨ true , x , n , xs , refl ⟩

{-# OPTIONS --universe-polymorphism #-}
module Ornament where

open import Data.Nat using (ℕ)
open import Data.Fin
open import Data.Bool
open import Data.Product
open import Data.Unit

infix 4 _≡_

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

--

-- Modified from Conor's original HOAS presentation

data Desc (I : Set) : Set₁ where
  -- read field in A; continue, given its value
  -- I don't think this is really what we want -- want parametricity
  arg : (a : Set) -> (a -> Desc I) -> Desc I

  -- read an indexed subnode; continue regardless
  rec : I -> Desc I -> Desc I

  -- stop reading and return the node’s index
  ret : I -> Desc I

  -- choice between n different constructors
  choice : (n : ℕ) -> (Fin n -> Desc I) -> Desc I

-- The semantics ("extension") of an indexed container
⟦_⟧ : ∀{I} -> Desc I -> (I -> Set) -> I -> Set
⟦ arg A D ⟧ R i = Σ A λ a → ⟦ D a ⟧ R i
⟦ rec h D ⟧ R i = R h × ⟦ D ⟧ R i
⟦ ret o ⟧ R i = o ≡ i
⟦ choice n D ⟧ R i =  Σ (Fin n) λ #n -> ⟦ D #n ⟧ R i

-- This is really the least fixpoint operator
data Data {I}(D : Desc I)(i : I) : Set where
  ⟨_⟩ : ⟦ D ⟧ (Data D) i -> Data D i

-- TODO think about codata / greatest fixed point
-- data CoData {I}(D : Desc I)(i : I) : Set where
--   ⟩_⟨ :

--

NatChoiceDesc : Desc ⊤
NatChoiceDesc = choice 2 λ
  { zero -> ret tt
  ; (suc n) -> rec tt (ret tt)
  }

NatChoice : Set
NatChoice = Data NatChoiceDesc tt

zeChoice : NatChoice
zeChoice = ⟨ zero , refl ⟩

suChoice : NatChoice -> NatChoice
suChoice n = ⟨ suc zero , n , refl ⟩

--

NatDesc : Desc ⊤
NatDesc = arg Bool λ
  { true -> ret tt
  ; false -> rec tt (ret tt)
  }

Nat : Set
Nat = Data NatDesc tt

ze : Nat
ze = ⟨ true , refl ⟩

su : Nat -> Nat
su n = ⟨ false , n , refl ⟩

--

VecDesc : Set -> Desc Nat
VecDesc X = arg Bool λ
  { false -> ret ze
  ; true -> arg X λ _ -> arg Nat λ n -> rec n (ret (su n))
  }

Vec : Set -> Nat -> Set
Vec X n = Data (VecDesc X) n

nil : ∀{X} -> Vec X ze
nil = ⟨ false , refl ⟩

cons : ∀{X} -> (n : Nat) -> X -> Vec X n -> Vec X (su n)
cons n x xs = ⟨ true , x , n , xs , refl ⟩


Fixed typo.

Fixed typo.

------------------------------------------------------------------------------
-- The FOTC types without use data, i.e. using Agda as a logical framework
------------------------------------------------------------------------------

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

module Predicates where

open import FOTC.Base

open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- The existential proyections.
∃-proj₁ : ∀ {A} → ∃ A → D
∃-proj₁ (x , _) = x

∃-proj₂ : ∀ {A} → (h : ∃ A) → A (∃-proj₁ h)
∃-proj₂ (_ , Ax) = Ax

------------------------------------------------------------------------------
-- The inductive FOTC types using postulates.

module Pure where

  -- The FOTC natural numbers type.
  postulate
    N     : D → Set
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- Example.
  one : D
  one = succ₁ zero

  oneN : N one
  oneN = nsucc nzero

  -- The FOTC lists type.
  postulate
    List  : D → Set
    lnil  : List []
    lcons : ∀ x {xs} → List xs → List (x ∷ xs)

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

  -- The FOTC list of natural numbers type.
  postulate
    ListN  : D → Set
    lnnil  : ListN []
    lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

  -- Example.
  ln : ListN (zero ∷ one ∷ [])
  ln = lncons nzero (lncons oneN lnnil)

------------------------------------------------------------------------------
-- The inductive FOTC types using data.

module Inductive where

  -- The FOTC natural numbers type.
  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- Example.
  one : D
  one = succ₁ zero

  oneN : N one
  oneN = nsucc nzero

  -- The FOTC lists type.
  data List : D → Set where
    lnil  :                      List []
    lcons : ∀ x {xs} → List xs → List (x ∷ xs)

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

  -- The FOTC list of natural numbers type.
  data ListN : D → Set where
    lnnil  :                             ListN []
    lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

  -- Example.
  ln : ListN (zero ∷ one ∷ [])
  ln = lncons nzero (lncons oneN lnnil)

------------------------------------------------------------------------------
-- The least fixed-point operator.

module LFP where

  postulate
    -- Least fixed-points correspond to inductively defined types.
    --
    -- N.B. We cannot write LFP in first-order logic. We should use an
    -- instance instead.
    LFP : ((D → Set) → D → Set) → D → Set

    -- In FOTC, we cannot use the equality on predicates, i.e. we
    -- cannot write
    --
    -- (f : (D → Set) → D → Set) → f (LFP f) ≡ LFP f  (1)
    --
    -- because the type of the equality is
    --
    -- _≡_ : D → D → Set,
    --
    -- therefore we postulate both directions of the conversion rule (1).

    LFP₁ : (f : (D → Set) → D → Set)(d : D) → LFP f d → f (LFP f) d
    LFP₂ : (f : (D → Set) → D → Set)(d : D) → f (LFP f) d → LFP f d

------------------------------------------------------------------------------
-- The greatest fixed-point operator.

-- N.B. At the moment, the definitions of LFP and GFP are the same.

module GFP where

  postulate
    -- Greatest fixed-points correspond to coinductively defined types.

    GFP : ((D → Set) → D → Set) → D → Set

    GFP₁ : (f : (D → Set) → D → Set)(d : D) → GFP f d → f (GFP f) d
    GFP₂ : (f : (D → Set) → D → Set)(d : D) → f (GFP f) d → GFP f d

------------------------------------------------------------------------------
-- The FOTC natural numbers type as the least fixed-point of a
-- functor.

module NLFP where

  open LFP

  -- Functor for the FOTC natural numbers type.

  -- From Peter: NatF if D was an inductive type
  -- NatF : (D → Set) → D → Set
  -- NatF X zero      = ⊤
  -- NatF X (succ₁ n) = X n

  -- From Peter: NatF in pure predicate logic.
  NatF : (D → Set) → D → Set
  NatF X n = n ≡ zero ∨ (∃ λ m → n ≡ succ₁ m ∧ X m)

  -- The FOTC natural numbers type using LFP.
  N : D → Set
  N = LFP NatF

  -- The data constructors of N.
  nzero : N zero
  nzero = LFP₂ NatF zero (inj₁ refl)

  nsucc : {n : D} → N n → N (succ₁ n)
  nsucc {n} Nn = LFP₂ NatF (succ₁ n) (inj₂ (n , (refl , Nn)))

  -- Example.
  one : D
  one = succ₁ zero

  oneN : N one
  oneN = nsucc nzero

------------------------------------------------------------------------------
-- The FOTC list type as the least fixed-point of a functor.

module ListLFT where

  open LFP

  -- Functor for the FOTC lists type.
  ListF : (D → Set) → D → Set
  ListF X ds = ds ≡ [] ∨ (∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ X es)

  -- The FOTC list type using LFP.
  List : D → Set
  List = LFP ListF

  -- The data constructors of List.
  lnil : List []
  lnil = LFP₂ ListF [] (inj₁ refl)

  lcons : ∀ x {xs} → List xs → List (x ∷ xs)
  lcons x {xs} Lxs = LFP₂ ListF (x ∷ xs) (inj₂ (x , xs , refl , Lxs))

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

------------------------------------------------------------------------------
-- The FOTC list of natural numbers type as the least fixed-point of a
-- functor.

module ListNLFT where

  open LFP
  open NLFP

  -- Functor for the FOTC list of natural numbers type.
  ListNF : (D → Set) → D → Set
  ListNF X ds = ds ≡ [] ∨ (∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ N e ∧ X es)

  -- The FOTC list type using LFP.
  ListN : D → Set
  ListN = LFP ListNF

  -- The data constructors of ListN.
  lnnil : ListN []
  lnnil = LFP₂ ListNF [] (inj₁ refl)

  lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)
  lncons {n} {ns} Nn LNns =
    LFP₂ ListNF (n ∷ ns) (inj₂ (n , ns , refl , Nn , LNns))

  -- Example.
  ln : ListN (zero ∷ one ∷ [])
  ln = lncons nzero (lncons oneN lnnil)

------------------------------------------------------------------------------
-- The FOTC Colist type as the greatest fixed-point of a functor.

module CoList where

  open GFP

  -- Functor for the FOTC Colists type (the same functor that for the
  -- List type).
  ColistF : (D → Set) → D → Set
  ColistF X ds = ds ≡ [] ∨ (∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ X es)

  -- The FOTC Colist type using GFP.
  Colist : D → Set
  Colist = GFP ColistF

  -- The data constructors of Colist.
  nilCL : Colist []
  nilCL = GFP₂ ColistF [] (inj₁ refl)

  consCL : ∀ x xs → Colist xs → Colist (x ∷ xs)
  consCL x xs CLxs = GFP₂ ColistF (x ∷ xs) (inj₂ (x , xs , refl , CLxs))

  -- Example (finite colist).
  l : Colist (zero ∷ true ∷ [])
  l = consCL zero (true ∷ []) (consCL true [] nilCL)

  -- TODO: Example (infinite colist).
  -- zerosCL : Colist {!!}
  -- zerosCL = consCL zero {!!} zerosCL

------------------------------------------------------------------------------
-- The FOTC Stream type as the greatest fixed-point of a functor.

module Stream₁ where

  open GFP

  -- Functor for the FOTC Stream type.
  StreamF : (D → Set) → D → Set
  StreamF X ds = ∃ λ e → X ds

  -- The FOTC Stream type using GFP.
  Stream : D → Set
  Stream = GFP StreamF

  -- The data constructor of Stream.
  -- Using StreamF we cannot define this data constructor
  -- consS : ∀ x xs → Stream xs → Stream (x ∷ xs)
  -- consS x xs Sxs = GFP₂ StreamF (x ∷ xs) {!!}

------------------------------------------------------------------------------
-- The FOTC Stream type as the greatest fixed-point of a functor.

module Stream₂ where

  open GFP

  -- Functor for the FOTC Stream type.
  StreamF : (D → Set) → D → Set
  StreamF X ds = ∃ λ e → ∃ λ es → X es

  -- The FOTC Stream type using GFP.
  Stream : D → Set
  Stream = GFP StreamF

  -- The data constructor of Stream.
  -- TODO: To use implicit arguments.
  consS : ∀ x xs → Stream xs → Stream (x ∷ xs)
  consS x xs Sxs = GFP₂ StreamF (x ∷ xs) (x , xs , Sxs)

  -- TODO: Example
  -- zerosS : Stream {!!}
  -- zerosS = consS zero {!!} zerosS

  headS : ∀ {x xs} → Stream (x ∷ xs) → D
  headS {x} _ = x

  tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
  tailS {x} {xs} S = GFP₂ StreamF xs (x , x ∷ xs , S)

  -- The functor StreamF does not link together the parts of the
  -- stream, so I can get a stream from any stream.
  bad : ∀ {xs ys} → Stream xs → Stream ys
  bad {xs} {ys} S = GFP₂ StreamF ys (ys , xs , S)

------------------------------------------------------------------------------
-- The FOTC Stream type as the greatest fixed-point of a functor.

module Stream₃ where

  open GFP

  -- Functor for the FOTC Stream type.
  StreamF : (D → Set) → D → Set
  StreamF X ds = ∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ X es

  -- The FOTC Stream type using GFP.
  Stream : D → Set
  Stream = GFP StreamF

  -- The data constructor of Stream.
  -- TODO: To use implicit arguments.
  consS : ∀ x xs → Stream xs → Stream (x ∷ xs)
  consS x xs Sxs = GFP₂ StreamF (x ∷ xs) (x , xs , refl , Sxs)

  -- TODO: Example
  -- zerosS : Stream {!!}
  -- zerosS = consS zero {!!} zerosS

  headS : ∀ {x xs} → Stream (x ∷ xs) → D
  headS {x} _ = x

  tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
  tailS {x} {xs} Sx∷xs = Sxs
    where
    unfoldS : StreamF (GFP StreamF) (x ∷ xs)
    unfoldS = GFP₁ StreamF (x ∷ xs) Sx∷xs

    e : D
    e = ∃-proj₁ unfoldS

    Pe : ∃ λ es → x ∷ xs ≡ e ∷ es ∧ GFP StreamF es
    Pe = ∃-proj₂ unfoldS

    es : D
    es = ∃-proj₁ Pe

    Pes : x ∷ xs ≡ e ∷ es ∧ GFP StreamF es
    Pes = ∃-proj₂ Pe

    xs≡es : xs ≡ es
    xs≡es = ∧-proj₂ (∷-injective (∧-proj₁ Pes))

    Sxs : GFP StreamF xs
    Sxs = subst (GFP StreamF) (sym xs≡es) (∧-proj₂ Pes)


Updated note on Leibniz's equality.

Updated note on Leibniz's equality.

Ignore-this: fcd2ac13bb245948e504e266cb17d380

darcs-hash:20120514131953-3bd4e-ea5dcb248c4efd0a6381518bc66d8209a3014571.gz

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

-- Tested with the development version of Agda on 14 May 2012.

module LeibnizEquality where

-- References:
--
-- • Martin Hofmman. Extensional concepts in intensional type
--   theory. PhD thesis, University of Edinburgh, 1995.

-- • Zhaohui Luo. Computation and Reasoning. A Type Theory for
--   Computer Science. Oxford University Press, 1994.

------------------------------------------------------------------------------
-- The identity type.
data _≡_ {A : Set}(x : A) : A → Set where
  refl : x ≡ x

-- Leibniz equality (see [Luo 1994, sec. 5.1.3])

-- (From Agda/examples/lib/Logic/Leibniz.agda)
_≐_ : {A : Set} → A → A → Set₁
x ≐ y = (P : _ → Set) → P x → P y

-- Properties
≐-refl : {A : Set}{x : A} → x ≐ x
≐-refl P Px = Px

≐-sym : {A : Set}{x y : A} → x ≐ y → y ≐ x
≐-sym {x = x} {y} h P Py = h (λ z → P z → P x) (λ Px → Px) Py

≐-trans : {A : Set}{x y z : A} → x ≐ y → y ≐ z → x ≐ z
≐-trans h₁ h₂ P Px = h₂ P (h₁ P Px)

≐-subst : {A : Set}(P : A → Set){x y : A} → x ≐ y → P x → P y
≐-subst P h = h P

------------------------------------------------------------------------------
-- Leibniz's equality and the identity type

-- "In the presence of a type of propositions "Prop" one can also
-- define propositional equality by Leibniz's principle." [Hofmman
-- 1995, p. 4]

≐→≡ : {A : Set}{x y : A} → x ≐ y → x ≡ y
≐→≡ {x = x} h = h (λ z → x ≡ z) refl

≡→≐ : {A : Set}{x y : A} → x ≡ y → x ≐ y
≡→≐ refl P Px = Px

-- Tested with Agda 2.2.11 on 18 November 2011.

module LeibnizEquality where

------------------------------------------------------------------------------
-- The identity type
data _≡_ {A : Set}(x : A) : A → Set where
  refl : x ≡ x

-- Leibniz equality (see [1, sec. 5.1.3])

-- [1] Zhaohui Luo. Computation and Reasoning. A Type Theory for
--     Computer Science. Oxford University Press, 1994.

-- (From Agda/examples/lib/Logic/Leibniz.agda)
_≐_ : {A : Set} → A → A → Set₁
x ≐ y = (P : _ → Set) → P x → P y

-- Properties
≐-refl : {A : Set}{x : A} → x ≐ x
≐-refl P Px = Px

≐-sym : {A : Set}(x y : A) → x ≐ y → y ≐ x
≐-sym x y x≐y P Py = x≐y (λ z → P z → P x) (λ Px → Px) Py

≐-trans : {A : Set}{x y z : A} → x ≐ y → y ≐ z → x ≐ z
≐-trans x≐y y≐z P Px = y≐z P (x≐y P Px)

≐-subst : {A : Set}(P : A → Set){x y : A} → x ≐ y → P x → P y
≐-subst P x≐y = x≐y P

------------------------------------------------------------------------------
-- Leibniz's equality and the identity type

-- "In the presence of a type of propositions "Prop" one can also
-- define propositional equality by Leibniz's principle." [2, p. 4]

-- [2] Martin Hofmman. Extensional concepts in intensional type
--     theory. PhD thesis, University of Edinburgh, 1995

≐→≡ : {A : Set}{x y : A} → x ≐ y → x ≡ y
≐→≡ {x = x} x≐y = x≐y (λ z → x ≡ z) refl

≡→≐ : {A : Set}{x y : A} → x ≡ y → x ≐ y
≡→≐ refl P Px = Px


Updated issue #11.

Updated issue #11.

------------------------------------------------------------------------------
-- All parameters are required in an ATP definition
------------------------------------------------------------------------------

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

module Issue11 where

postulate
  D          : Set
  false true : D

data Bool : D → Set where
  btrue  : Bool true
  bfalse : Bool false

OkBit : D → Set
OkBit b = Bool b
{-# ATP definition OkBit #-}

postulate foo : ∀ b → OkBit b → OkBit b
{-# ATP prove foo #-}

WrongBit : D → Set
WrongBit = Bool
{-# ATP definition WrongBit #-}

postulate bar : ∀ b → WrongBit b → WrongBit b
{-# ATP prove bar #-}

-- $ apia --check Issue11.agda
-- apia: tptp4X found an error in the file /tmp/Issue11/29-bar.tptp

------------------------------------------------------------------------------
-- All parameters are required in an ATP definition
------------------------------------------------------------------------------

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

module Issue11 where

postulate
  D          : Set
  false true : D

data Bool : D → Set where
  btrue  : Bool true
  bfalse : Bool false

OkBit : D → Set
OkBit b = Bool b
{-# ATP definition OkBit #-}

postulate foo : ∀ b → OkBit b → OkBit b
{-# ATP prove foo #-}

WrongBit : D → Set
WrongBit = Bool
{-# ATP definition WrongBit #-}

postulate bar : ∀ b → WrongBit b → WrongBit b
{-# ATP prove bar #-}

-- $ apia Issue11.agda
-- apia: tptp4X found an error in the file /tmp/Issue11/29-bar.tptp


GroupHomomorphism

GroupHomomorphism

{-# OPTIONS --without-K #-}
module Explore.GroupHomomorphism where

open import Level
open import Algebra.FunctionProperties
open import Data.Product
open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP hiding (_∙_)

open import Explore.Core
open import Explore.Properties
open import Explore.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc    : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)
         (f : A → B)
         (exploreA : Explore zero A)(f-homo : GroupHomomorphism GA GB f)
         ([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
         (explore-ext : ExploreExt exploreA)
         where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  {- How all this is related to elgamal

  the Group GA is ℤq with modular addition as operation
  the Group GB is the cyclic group with order q

  f is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the explore (for type A) function (should work with only summation)
  is Stable under addition of GA (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the explore function respects extensionality
  -}

  {-
   I had some problems with using the standard library definiton of Groups
   so I rolled my own, therefor I need some boring proofs first

  -}

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎
  {-
    While this proof looks complicated it basically just adds inverse of m₀ and then adds m₁ (from image of f)
    we need the homomorphic property to pull out the values.

  -}

  module _ {X}(z : X)(op : X → X → X)
           (sui : ∀ k → StableUnder' exploreA z op (flip (Group._∙_ GA) k))
    where
  -- this proof isn't actually any hard..
    thm : ∀ (O : B → X) m₀ m₁ → exploreA z op (λ x → O (f x * m₀)) ≡ exploreA z op (λ x → O (f x * m₁))
    thm O m₀ m₁ = explore (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) (λ x → O (f x * m₀)) ⟩
                   explore (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma1 x)) ⟩
                   explore (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) (O ∘ f) ⟩
                   explore (λ x → O (f (x + [f] m₁)))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma2 x)) ⟩
                   explore (λ x → O (f x * m₁))
                 ∎
     where
      open ≡-Reasoning
      explore = exploreA z op

      lemma1 : ∀ x → f (x + - [f] m₀) * m₀ ≡ f x
      lemma1 x rewrite f-homo x (- [f] m₀)
                     | f-pres-inv ([f] m₀)
                     | f-sur m₀
                     | Group.assoc GB (f x) (1/ m₀) m₀
                     | proj₁ (Group.inverse GB) m₀
                     | proj₂ (Group.identity GB) (f x) = refl

      lemma2 : ∀ x → f (x + [f] m₁) ≡ f x * m₁
      lemma2 x rewrite f-homo x ([f] m₁)
                     | f-sur m₁ = refl

{-# OPTIONS --without-K #-}
module Explore.GroupHomomorphism where

open import Level
open import Algebra.FunctionProperties
open import Data.Product
open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP hiding (_∙_)

open import Explore.Core
open import Explore.Properties
open import Explore.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc    : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)(f : A → B)(exploreA : Explore zero A)(f-homo : GroupHomomorphism GA GB f)([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
              (sui : ∀ k → StableUnder exploreA (flip (Group._∙_ GA) k))(explore-ext : ExploreExt exploreA) where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  {- How all this is related to elgamal

  the Group GA is ℤq with modular addition as operation
  the Group GB is the cyclic group with order q

  f is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the explore (for type A) function (should work with only summation)
  is Stable under addition of GA (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the explore function respects extensionality
  -}

  {-
   I had some problems with using the standard library definiton of Groups
   so I rolled my own, therefor I need some boring proofs first

  -}

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎
  {-
    While this proof looks complicated it basically just adds inverse of m₀ and then adds m₁ (from image of f)
    we need the homomorphic property to pull out the values.

  -}

  -- this proof isn't actually any hard..
  thm : ∀ {X}(z : X)(op : X → X → X)(O : B → X) m₀ m₁ → exploreA z op (λ x → O (f x * m₀)) ≡ exploreA z op (λ x → O (f x * m₁))
  thm z op O m₀ m₁ = explore (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) z op (λ x → O (f x * m₀)) ⟩
                   explore (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma1 x)) ⟩
                   explore (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) z op (O ∘ f) ⟩
                   explore (λ x → O (f (x + [f] m₁)))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma2 x)) ⟩
                   explore (λ x → O (f x * m₁))
                 ∎
    where
      open ≡-Reasoning
      explore = exploreA z op

      lemma1 : ∀ x → f (x + - [f] m₀) * m₀ ≡ f x
      lemma1 x rewrite f-homo x (- [f] m₀)
                     | f-pres-inv ([f] m₀)
                     | f-sur m₀
                     | Group.assoc GB (f x) (1/ m₀) m₀
                     | proj₁ (Group.inverse GB) m₀
                     | proj₂ (Group.identity GB) (f x) = refl

      lemma2 : ∀ x → f (x + [f] m₁) ≡ f x * m₁
      lemma2 x rewrite f-homo x ([f] m₁)
                     | f-sur m₁ = refl


ASL made Induction.* more universe-polymorphic.

------------------------------------------------------------------------------
-- Quicksort using the Bove-Capretta method
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
-- {-# OPTIONS --without-K #-}  -- No accepted!

module FOT.FOTC.Program.QuickSort.QuickSortBC where

open import Data.Bool
open import Data.List
open import Data.Nat
open import Data.Nat.Properties
open import Data.Sum

open import Induction
open import Induction.Nat
open import Induction.WellFounded

open import Relation.Binary
open import Relation.Nullary
open import Relation.Nullary.Decidable

module InvImg =
  Induction.WellFounded.Inverse-image {A = List ℕ} {ℕ} {_<′_} length

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

_≤′?_ : Decidable _≤′_
m ≤′? n with m ≤? n
... | yes p = yes (≤⇒≤′ p)
... | no ¬p = no (λ m≤′n → ¬p (≤′⇒≤ m≤′n))

-- Non-terminating quicksort.

{-# NO_TERMINATION_CHECK #-}
qsNT : List ℕ → List ℕ
qsNT []       = []
qsNT (x ∷ xs) = qsNT (filter (λ y → ⌊ y ≤′? x ⌋) xs) ++
                x ∷ qsNT (filter (λ y → not ⌊ y ≤′? x ⌋) xs)

-- Domain predicate for quicksort.
data QSDom : List ℕ → Set where
  qsDom-[] : QSDom []
  qsDom-∷  : ∀ {x xs} →
             (QSDom (filter (λ y → ⌊ y ≤′? x ⌋) xs)) →
             (QSDom (filter (λ y → not ⌊ y ≤′? x ⌋) xs)) →
             QSDom (x ∷ xs)

-- Induction principle associated to the domain predicate of quicksort.
-- (It was not necessary).
indQSDom : (P : List ℕ → Set) →
           P [] →
           (∀ {x xs} → QSDom (filter (λ y → ⌊ y ≤′? x ⌋) xs) →
                       P (filter (λ y → ⌊ y ≤′? x ⌋) xs) →
                       QSDom (filter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                       P (filter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                       P (x ∷ xs)) →
           (∀ {xs} → QSDom xs → P xs)
indQSDom P P[] ih qsDom-[]        = P[]
indQSDom P P[] ih (qsDom-∷ h₁ h₂) =
  ih h₁ (indQSDom P P[] ih h₁) h₂ (indQSDom P P[] ih h₂)

-- Well-founded relation on lists.
_⟪′_ : {A : Set} → List A → List A → Set
xs ⟪′ ys = length xs <′ length ys

wf-⟪′ : Well-founded _⟪′_
wf-⟪′ = InvImg.well-founded <-well-founded

-- The well-founded induction principle on _⟪′_.
-- postulate wfi-⟪′ : (P : List ℕ → Set) →
--                    (∀ xs → (∀ ys → ys ⟪′ xs → P ys) → P xs) →
--                    ∀ xs → P xs

-- The quicksort algorithm is total.

filter-length : {A : Set}(P : A → Bool) → ∀ xs →
                length (filter P xs) ≤′ length xs
filter-length P []       = ≤′-refl
filter-length P (x ∷ xs) with P x
... | true  = ≤⇒≤′ (s≤s (≤′⇒≤ (filter-length P xs)))
... | false = ≤′-step (filter-length P xs)

module AllWF = Induction.WellFounded.All wf-⟪′

allQSDom : ∀ xs → QSDom xs
-- If we use wfi-⟪′ then allQSDom =  wfi-⟪′ P ih
allQSDom = build (AllWF.wfRec-builder _) P ih
  where
  P : List ℕ → Set
  P = QSDom

  -- If we use wfi-⟪′ then
  -- ih : ∀ zs → (∀ ys → ys ⟪′ zs → P ys) → P zs
  ih :  ∀ zs → WfRec _⟪′_ P zs → P zs
  ih []       h = qsDom-[]
  ih (z ∷ zs) h = qsDom-∷ prf₁ prf₂
    where
    c₁ : ℕ → Bool
    c₁ = λ y → ⌊ y ≤′? z ⌋

    c₂ : ℕ → Bool
    c₂ = λ y → not ⌊ y ≤′? z ⌋

    f₁ : List ℕ
    f₁ = filter c₁ zs

    f₂ : List ℕ
    f₂ = filter c₂ zs

    prf₁ : QSDom (filter (λ y → ⌊ y ≤′? z ⌋) zs)
    prf₁ = h f₁ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₁ zs))))

    prf₂ : QSDom (filter (λ y → not ⌊ y ≤′? z ⌋) zs)
    prf₂ = h f₂ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₂ zs))))

-- Quicksort algorithm by structural recursion on the domain predicate.
qsDom : ∀ xs → QSDom xs → List ℕ
qsDom .[]      qsDom-[]        = []
qsDom (x ∷ xs) (qsDom-∷ h₁ h₂) =
  qsDom (filter (λ y → ⌊ y ≤′? x ⌋) xs) h₁ ++
  x ∷ qsDom (filter (λ y → not ⌊ y ≤′? x ⌋) xs) h₂

-- The quicksort algorithm.
qs : List ℕ → List ℕ
qs xs = qsDom xs (allQSDom xs)

-- Testing.
l₁ : List ℕ
l₁ = []
l₂ = 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ []
l₃ = 5 ∷ 4 ∷ 3 ∷ 2 ∷ 1 ∷ []
l₄ = 4 ∷ 1 ∷ 3 ∷ 5 ∷ 2 ∷ []

t₁ = qs l₁
t₂ = qs l₂
t₃ = qs l₃
t₄ = qs l₄

------------------------------------------------------------------------------
-- Quicksort using the Bove-Capretta method
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
-- {-# OPTIONS --without-K #-}  -- No accepted!

module FOT.FOTC.Program.QuickSort.QuickSortBC where

open import Data.Bool
open import Data.List
open import Data.Nat
open import Data.Nat.Properties
open import Data.Sum

open import Induction
open import Induction.Nat
open import Induction.WellFounded

open import Relation.Binary
open import Relation.Nullary
open import Relation.Nullary.Decidable

module InvImg =
  Induction.WellFounded.Inverse-image {A = List ℕ} {ℕ} {_<′_} length

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

_≤′?_ : Decidable _≤′_
m ≤′? n with m ≤? n
... | yes p = yes (≤⇒≤′ p)
... | no ¬p = no (λ m≤′n → ¬p (≤′⇒≤ m≤′n))

-- Non-terminating quicksort.

{-# NO_TERMINATION_CHECK #-}
qsNT : List ℕ → List ℕ
qsNT []       = []
qsNT (x ∷ xs) = qsNT (filter (λ y → ⌊ y ≤′? x ⌋) xs) ++
                x ∷ qsNT (filter (λ y → not ⌊ y ≤′? x ⌋) xs)

-- Domain predicate for quicksort.
data QSDom : List ℕ → Set where
  qsDom-[] : QSDom []
  qsDom-∷  : ∀ {x xs} →
             (QSDom (filter (λ y → ⌊ y ≤′? x ⌋) xs)) →
             (QSDom (filter (λ y → not ⌊ y ≤′? x ⌋) xs)) →
             QSDom (x ∷ xs)

-- Induction principle associated to the domain predicate of quicksort.
-- (It was not necessary).
indQSDom : (P : List ℕ → Set) →
           P [] →
           (∀ {x xs} → QSDom (filter (λ y → ⌊ y ≤′? x ⌋) xs) →
                       P (filter (λ y → ⌊ y ≤′? x ⌋) xs) →
                       QSDom (filter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                       P (filter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                       P (x ∷ xs)) →
           (∀ {xs} → QSDom xs → P xs)
indQSDom P P[] ih qsDom-[]        = P[]
indQSDom P P[] ih (qsDom-∷ h₁ h₂) =
  ih h₁ (indQSDom P P[] ih h₁) h₂ (indQSDom P P[] ih h₂)

-- Well-founded relation on lists.
_⟪′_ : {A : Set} → List A → List A → Set
xs ⟪′ ys = length xs <′ length ys

wf-⟪′ : Well-founded _⟪′_
wf-⟪′ = InvImg.well-founded <-well-founded

-- The well-founded induction principle on _⟪′_.
-- postulate wfi-⟪′ : (P : List ℕ → Set) →
--                    (∀ xs → (∀ ys → ys ⟪′ xs → P ys) → P xs) →
--                    ∀ xs → P xs

-- The quicksort algorithm is total.

filter-length : {A : Set}(P : A → Bool) → ∀ xs →
                length (filter P xs) ≤′ length xs
filter-length P []       = ≤′-refl
filter-length P (x ∷ xs) with P x
... | true  = ≤⇒≤′ (s≤s (≤′⇒≤ (filter-length P xs)))
... | false = ≤′-step (filter-length P xs)

module AllWF = Induction.WellFounded.All wf-⟪′

allQSDom : ∀ xs → QSDom xs
-- If we use wfi-⟪′ then allQSDom =  wfi-⟪′ P ih
allQSDom = build AllWF.wfRec-builder P ih
  where
  P : List ℕ → Set
  P = QSDom

  -- If we use wfi-⟪′ then
  -- ih : ∀ zs → (∀ ys → ys ⟪′ zs → P ys) → P zs
  ih :  ∀ zs → WfRec _⟪′_ P zs → P zs
  ih []       h = qsDom-[]
  ih (z ∷ zs) h = qsDom-∷ prf₁ prf₂
    where
    c₁ : ℕ → Bool
    c₁ = λ y → ⌊ y ≤′? z ⌋

    c₂ : ℕ → Bool
    c₂ = λ y → not ⌊ y ≤′? z ⌋

    f₁ : List ℕ
    f₁ = filter c₁ zs

    f₂ : List ℕ
    f₂ = filter c₂ zs

    prf₁ : QSDom (filter (λ y → ⌊ y ≤′? z ⌋) zs)
    prf₁ = h f₁ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₁ zs))))

    prf₂ : QSDom (filter (λ y → not ⌊ y ≤′? z ⌋) zs)
    prf₂ = h f₂ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₂ zs))))

-- Quicksort algorithm by structural recursion on the domain predicate.
qsDom : ∀ xs → QSDom xs → List ℕ
qsDom .[]      qsDom-[]        = []
qsDom (x ∷ xs) (qsDom-∷ h₁ h₂) =
  qsDom (filter (λ y → ⌊ y ≤′? x ⌋) xs) h₁ ++
  x ∷ qsDom (filter (λ y → not ⌊ y ≤′? x ⌋) xs) h₂

-- The quicksort algorithm.
qs : List ℕ → List ℕ
qs xs = qsDom xs (allQSDom xs)

-- Testing.
l₁ : List ℕ
l₁ = []
l₂ = 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ []
l₃ = 5 ∷ 4 ∷ 3 ∷ 2 ∷ 1 ∷ []
l₄ = 4 ∷ 1 ∷ 3 ∷ 5 ∷ 2 ∷ []

t₁ = qs l₁
t₂ = qs l₂
t₃ = qs l₃
t₄ = qs l₄


Show how badly reasoning for ≙ and ≡ combine

≡⟨ ... ⟩ is also available inside ≙-Reasoning, but it allows using
propositional equalities on the changes; while that's certainly correct,
it's not very useful. I'd like to be able to use equalities on base
values.

However, improving on might require invasive changes to EqReasoning.

Old-commit-hash: a64324daefc3c0f33c6d7eec0da95f5d16ba9ff7

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

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

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

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

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

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

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

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

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

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

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

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

  import Relation.Binary.EqReasoning as EqR

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

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

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

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

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

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

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

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

  open import Postulate.Extensionality

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

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

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

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

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

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

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

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

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

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

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

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

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

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

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

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

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

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

  import Relation.Binary.EqReasoning as EqR

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

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

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

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

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

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

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

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

  open import Postulate.Extensionality

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

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

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

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

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

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