Agda upgrade

Agda upgrade

module Spire.Type where

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

data ⊥ : Set where
record ⊤ : Set where constructor tt
data Bool : Set where true false : Bool

data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ
{-# BUILTIN NATURAL ℕ    #-}

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁
open Σ public

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

const : {A : Set₁} {B : Set} → A → B → A
const a _ = a

uncurry : {A : Set} {B : A → Set} {C : Σ A B → Set} →
  ((a : A) → (b : B a) → C (a , b)) →
  ((p : Σ A B) → C p)
uncurry f (a , b) = f a b

_∘_ : {A B C : Set₁} → (B → C) → (A → B) → A → C
_∘_ g f x = g (f x)

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

elim⊥ : {A : Set} → ⊥ → A
elim⊥ ()

elimBool : (P : Bool → Set)
  (pt : P true)
  (pf : P false)
  (b : Bool) → P b
elimBool P pt pf true = pt
elimBool P pt pf false = pf

if_then_else_ : {C : Set} → Bool → C → C → C
if b then c₁ else c₂ = elimBool _ c₁ c₂ b

elimℕ : (P : ℕ → Set)
  (pz : P zero)
  (ps : (n : ℕ) → P n → P (suc n))
  (n : ℕ) → P n
elimℕ P pz ps zero = pz
elimℕ P pz ps (suc n) = ps n (elimℕ P pz ps n)

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

record Universe : Set₁ where
  field
    Codes : Set
    Meaning : Codes → Set

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

data DescForm (U : Universe) : Set where
  `⊤ `X : DescForm U
  `Π `Σ : (A : Universe.Codes U)
    (D : Universe.Meaning U A → DescForm U)
    → DescForm U

⟦_/_⟧ᵈ : (U : Universe) → DescForm U → Set → Set
⟦ U / `⊤ ⟧ᵈ X = ⊤
⟦ U / `X ⟧ᵈ X = X
⟦ U / `Π A D ⟧ᵈ X =
  (a : Universe.Meaning U A) → ⟦ U / D a ⟧ᵈ X
⟦ U / `Σ A D ⟧ᵈ X =
  Σ (Universe.Meaning U A) (λ a → ⟦ U / D a ⟧ᵈ X)

data μ {U : Universe} (D : DescForm U) : Set where
  con : ⟦ U / D ⟧ᵈ (μ D) → μ D

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

data TypeForm (U : Universe) : Set
⟦_/_⟧ : (U : Universe) → TypeForm U → Set

data TypeForm U where
  `⊥ `⊤ `Bool `ℕ `Desc `Type : TypeForm U
  `Π `Σ : (A : TypeForm U)
    (B : ⟦ U / A ⟧ → TypeForm U)
    → TypeForm U
  `⟦_⟧ : Universe.Codes U → TypeForm U
  `⟦_⟧ᵈ : DescForm U → TypeForm U → TypeForm U
  `μ : DescForm U → TypeForm U

⟦ U / `⊥ ⟧ = ⊥
⟦ U / `⊤ ⟧ = ⊤
⟦ U / `Bool ⟧ = Bool
⟦ U / `ℕ ⟧ = ℕ
⟦ U / `Π A B ⟧ = (a : ⟦ U / A ⟧) → ⟦ U / B a ⟧
⟦ U / `Σ A B ⟧ = Σ ⟦ U / A ⟧ (λ a → ⟦ U / B a ⟧)
⟦ U / `Type ⟧ = Universe.Codes U
⟦ U / `⟦ A ⟧ ⟧ = Universe.Meaning U A
⟦ U / `Desc ⟧ = DescForm U
⟦ U / `⟦ D ⟧ᵈ X ⟧ = ⟦ U / D ⟧ᵈ ⟦ U / X ⟧
⟦ U / `μ D ⟧ = μ D

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

_`→_ : ∀{U} (A B : TypeForm U) → TypeForm U
A `→ B = `Π A (λ _ → B)

Level : (ℓ : ℕ) → Universe
Level zero = record { Codes = ⊥ ; Meaning = λ() }
Level (suc ℓ) = record { Codes = TypeForm (Level ℓ)
                       ; Meaning = ⟦_/_⟧ (Level ℓ) }

Type : ℕ → Set
Type ℓ = TypeForm (Level ℓ)

Desc : ℕ → Set
Desc ℓ = DescForm (Level ℓ)

infix 0 ⟦_∣_⟧
⟦_∣_⟧ : (ℓ : ℕ) → Type ℓ → Set
⟦ ℓ ∣ A ⟧ = ⟦ Level ℓ / A ⟧

⟦_∣_⟧ᵈ : (ℓ : ℕ) → Desc ℓ → Set → Set
⟦ ℓ ∣ D ⟧ᵈ X = ⟦ Level ℓ / D ⟧ᵈ X

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

elimDesc : (P : (ℓ : ℕ) → Desc ℓ → Set)
  → ((ℓ : ℕ) → P ℓ `⊤)
  → ((ℓ : ℕ) → P ℓ `X)
  → ((ℓ : ℕ) (A : Type ℓ) (D : ⟦ ℓ ∣ A ⟧ → Desc (suc ℓ))
    (rec : (a : ⟦ ℓ ∣ A ⟧) → P (suc ℓ) (D a))
    → P (suc ℓ) (`Π A D))
  → ((ℓ : ℕ) (A : Type ℓ) (D : ⟦ ℓ ∣ A ⟧ → Desc (suc ℓ))
    (rec : (a : ⟦ ℓ ∣ A ⟧) → P (suc ℓ) (D a))
    → P (suc ℓ) (`Σ A D))
  → (ℓ : ℕ) (D : Desc ℓ) → P ℓ D
elimDesc P p⊤ pX pΠ pΣ ℓ `⊤ = p⊤ ℓ
elimDesc P p⊤ pX pΠ pΣ ℓ `X = pX ℓ
elimDesc P p⊤ pX pΠ pΣ zero (`Π () D)
elimDesc P p⊤ pX pΠ pΣ (suc ℓ) (`Π A D) =
  let f = elimDesc P p⊤ pX pΠ pΣ (suc ℓ)
  in pΠ ℓ A D (λ a → f (D a))
elimDesc P p⊤ pX pΠ pΣ zero (`Σ () D)
elimDesc P p⊤ pX pΠ pΣ (suc ℓ) (`Σ A D) =
  let f = elimDesc P p⊤ pX pΠ pΣ (suc ℓ)
  in pΣ ℓ A D (λ a → f (D a))

des : ∀{ℓ} {D : Desc ℓ} → μ D → ⟦ ℓ ∣ D ⟧ᵈ (μ D)
des (con x) = x

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

elimType : (P : (ℓ : ℕ) → Type ℓ → Set)
  → ((ℓ : ℕ) → P ℓ `⊥)
  → ((ℓ : ℕ) → P ℓ `⊤)
  → ((ℓ : ℕ) → P ℓ `Bool)
  → ((ℓ : ℕ) → P ℓ `ℕ)
  → ((ℓ : ℕ) (A : Type ℓ) (B : ⟦ ℓ ∣ A ⟧ → Type ℓ)
    (rec₁ : P ℓ A)
    (rec₂ : (a : ⟦ ℓ ∣ A ⟧) → P ℓ (B a))
    → P ℓ (`Π A B))
  → ((ℓ : ℕ) (A : Type ℓ) (B : ⟦ ℓ ∣ A ⟧ → Type ℓ)
    (rec₁ : P ℓ A)
    (rec₂ : (a : ⟦ ℓ ∣ A ⟧) → P ℓ (B a))
    → P ℓ (`Σ A B))
  → ((ℓ : ℕ) → P ℓ `Desc)
  → ((ℓ : ℕ) (D : Desc ℓ) (X : Type ℓ) (rec : P ℓ X) → P ℓ (`⟦ D ⟧ᵈ X))
  → ((ℓ : ℕ) (D : Desc ℓ) → P ℓ (`μ D))
  → ((ℓ : ℕ) → P ℓ `Type)
  → ((ℓ : ℕ) (A : Type ℓ) (rec : P ℓ A) → P (suc ℓ) `⟦ A ⟧)
  → (ℓ : ℕ) (A : Type ℓ) → P ℓ A

elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `⊥ = p⊥ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `⊤ = p⊤ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Bool = pBool ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `ℕ = pℕ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`Π A B) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in pΠ ℓ A B (f A) (λ a → f (B a))
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`Σ A B) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in pΣ ℓ A B (f A) (λ a → f (B a))
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Type = pType ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Desc = pDesc ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`⟦ D ⟧ᵈ X) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in p⟦D⟧ᵈ ℓ D X (f X)
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`μ D) = pμ ℓ D
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  zero `⟦ () ⟧
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  (suc ℓ) `⟦ A ⟧ =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in p⟦A⟧ ℓ A (f A)

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

module Spire.Type where

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

data ⊥ : Set where
record ⊤ : Set where constructor tt
data Bool : Set where true false : Bool

data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ
{-# BUILTIN NATURAL ℕ    #-}
{-# BUILTIN ZERO    zero #-}
{-# BUILTIN SUC     suc  #-}

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁
open Σ public

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

const : {A : Set₁} {B : Set} → A → B → A
const a _ = a

uncurry : {A : Set} {B : A → Set} {C : Σ A B → Set} →
  ((a : A) → (b : B a) → C (a , b)) →
  ((p : Σ A B) → C p)
uncurry f (a , b) = f a b

_∘_ : {A B C : Set₁} → (B → C) → (A → B) → A → C
_∘_ g f x = g (f x)

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

elim⊥ : {A : Set} → ⊥ → A
elim⊥ ()

elimBool : (P : Bool → Set)
  (pt : P true)
  (pf : P false)
  (b : Bool) → P b
elimBool P pt pf true = pt
elimBool P pt pf false = pf

if_then_else_ : {C : Set} → Bool → C → C → C
if b then c₁ else c₂ = elimBool _ c₁ c₂ b

elimℕ : (P : ℕ → Set)
  (pz : P zero)
  (ps : (n : ℕ) → P n → P (suc n))
  (n : ℕ) → P n
elimℕ P pz ps zero = pz
elimℕ P pz ps (suc n) = ps n (elimℕ P pz ps n)

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

record Universe : Set₁ where
  field
    Codes : Set
    Meaning : Codes → Set

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

data DescForm (U : Universe) : Set where
  `⊤ `X : DescForm U
  `Π `Σ : (A : Universe.Codes U)
    (D : Universe.Meaning U A → DescForm U)
    → DescForm U

⟦_/_⟧ᵈ : (U : Universe) → DescForm U → Set → Set
⟦ U / `⊤ ⟧ᵈ X = ⊤
⟦ U / `X ⟧ᵈ X = X
⟦ U / `Π A D ⟧ᵈ X =
  (a : Universe.Meaning U A) → ⟦ U / D a ⟧ᵈ X
⟦ U / `Σ A D ⟧ᵈ X =
  Σ (Universe.Meaning U A) (λ a → ⟦ U / D a ⟧ᵈ X)

data μ {U : Universe} (D : DescForm U) : Set where
  con : ⟦ U / D ⟧ᵈ (μ D) → μ D

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

data TypeForm (U : Universe) : Set
⟦_/_⟧ : (U : Universe) → TypeForm U → Set

data TypeForm U where
  `⊥ `⊤ `Bool `ℕ `Desc `Type : TypeForm U
  `Π `Σ : (A : TypeForm U)
    (B : ⟦ U / A ⟧ → TypeForm U)
    → TypeForm U
  `⟦_⟧ : Universe.Codes U → TypeForm U
  `⟦_⟧ᵈ : DescForm U → TypeForm U → TypeForm U
  `μ : DescForm U → TypeForm U

⟦ U / `⊥ ⟧ = ⊥
⟦ U / `⊤ ⟧ = ⊤
⟦ U / `Bool ⟧ = Bool
⟦ U / `ℕ ⟧ = ℕ
⟦ U / `Π A B ⟧ = (a : ⟦ U / A ⟧) → ⟦ U / B a ⟧
⟦ U / `Σ A B ⟧ = Σ ⟦ U / A ⟧ (λ a → ⟦ U / B a ⟧)
⟦ U / `Type ⟧ = Universe.Codes U
⟦ U / `⟦ A ⟧ ⟧ = Universe.Meaning U A
⟦ U / `Desc ⟧ = DescForm U
⟦ U / `⟦ D ⟧ᵈ X ⟧ = ⟦ U / D ⟧ᵈ ⟦ U / X ⟧
⟦ U / `μ D ⟧ = μ D

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

_`→_ : ∀{U} (A B : TypeForm U) → TypeForm U
A `→ B = `Π A (λ _ → B)

Level : (ℓ : ℕ) → Universe
Level zero = record { Codes = ⊥ ; Meaning = λ() }
Level (suc ℓ) = record { Codes = TypeForm (Level ℓ)
                       ; Meaning = ⟦_/_⟧ (Level ℓ) }

Type : ℕ → Set
Type ℓ = TypeForm (Level ℓ)

Desc : ℕ → Set
Desc ℓ = DescForm (Level ℓ)

infix 0 ⟦_∣_⟧
⟦_∣_⟧ : (ℓ : ℕ) → Type ℓ → Set
⟦ ℓ ∣ A ⟧ = ⟦ Level ℓ / A ⟧

⟦_∣_⟧ᵈ : (ℓ : ℕ) → Desc ℓ → Set → Set
⟦ ℓ ∣ D ⟧ᵈ X = ⟦ Level ℓ / D ⟧ᵈ X

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

elimDesc : (P : (ℓ : ℕ) → Desc ℓ → Set)
  → ((ℓ : ℕ) → P ℓ `⊤)
  → ((ℓ : ℕ) → P ℓ `X)
  → ((ℓ : ℕ) (A : Type ℓ) (D : ⟦ ℓ ∣ A ⟧ → Desc (suc ℓ))
    (rec : (a : ⟦ ℓ ∣ A ⟧) → P (suc ℓ) (D a))
    → P (suc ℓ) (`Π A D))
  → ((ℓ : ℕ) (A : Type ℓ) (D : ⟦ ℓ ∣ A ⟧ → Desc (suc ℓ))
    (rec : (a : ⟦ ℓ ∣ A ⟧) → P (suc ℓ) (D a))
    → P (suc ℓ) (`Σ A D))
  → (ℓ : ℕ) (D : Desc ℓ) → P ℓ D
elimDesc P p⊤ pX pΠ pΣ ℓ `⊤ = p⊤ ℓ
elimDesc P p⊤ pX pΠ pΣ ℓ `X = pX ℓ
elimDesc P p⊤ pX pΠ pΣ zero (`Π () D)
elimDesc P p⊤ pX pΠ pΣ (suc ℓ) (`Π A D) =
  let f = elimDesc P p⊤ pX pΠ pΣ (suc ℓ)
  in pΠ ℓ A D (λ a → f (D a))
elimDesc P p⊤ pX pΠ pΣ zero (`Σ () D)
elimDesc P p⊤ pX pΠ pΣ (suc ℓ) (`Σ A D) =
  let f = elimDesc P p⊤ pX pΠ pΣ (suc ℓ)
  in pΣ ℓ A D (λ a → f (D a))

des : ∀{ℓ} {D : Desc ℓ} → μ D → ⟦ ℓ ∣ D ⟧ᵈ (μ D)
des (con x) = x

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

elimType : (P : (ℓ : ℕ) → Type ℓ → Set)
  → ((ℓ : ℕ) → P ℓ `⊥)
  → ((ℓ : ℕ) → P ℓ `⊤)
  → ((ℓ : ℕ) → P ℓ `Bool)
  → ((ℓ : ℕ) → P ℓ `ℕ)
  → ((ℓ : ℕ) (A : Type ℓ) (B : ⟦ ℓ ∣ A ⟧ → Type ℓ)
    (rec₁ : P ℓ A)
    (rec₂ : (a : ⟦ ℓ ∣ A ⟧) → P ℓ (B a))
    → P ℓ (`Π A B))
  → ((ℓ : ℕ) (A : Type ℓ) (B : ⟦ ℓ ∣ A ⟧ → Type ℓ)
    (rec₁ : P ℓ A)
    (rec₂ : (a : ⟦ ℓ ∣ A ⟧) → P ℓ (B a))
    → P ℓ (`Σ A B))
  → ((ℓ : ℕ) → P ℓ `Desc)
  → ((ℓ : ℕ) (D : Desc ℓ) (X : Type ℓ) (rec : P ℓ X) → P ℓ (`⟦ D ⟧ᵈ X))
  → ((ℓ : ℕ) (D : Desc ℓ) → P ℓ (`μ D))
  → ((ℓ : ℕ) → P ℓ `Type)
  → ((ℓ : ℕ) (A : Type ℓ) (rec : P ℓ A) → P (suc ℓ) `⟦ A ⟧)
  → (ℓ : ℕ) (A : Type ℓ) → P ℓ A

elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `⊥ = p⊥ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `⊤ = p⊤ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Bool = pBool ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `ℕ = pℕ ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`Π A B) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in pΠ ℓ A B (f A) (λ a → f (B a))
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`Σ A B) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in pΣ ℓ A B (f A) (λ a → f (B a))
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Type = pType ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ `Desc = pDesc ℓ
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`⟦ D ⟧ᵈ X) =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in p⟦D⟧ᵈ ℓ D X (f X)
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  ℓ (`μ D) = pμ ℓ D
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  zero `⟦ () ⟧
elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧
  (suc ℓ) `⟦ A ⟧ =
  let f = elimType P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ ℓ
  in p⟦A⟧ ℓ A (f A)

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


Atlas: fix bug in `union` by postulating conjunction

Old-commit-hash: 69ed9a83b2b162709e5dfcf541f9d0bf18c7e970

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

open import Syntax.Language.Calculus

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

data Atlas-const : Set where

  true  : Atlas-const
  false : Atlas-const
  xor   : Atlas-const

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
  update : ∀ {κ ι : Atlas-type} → Atlas-const
  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const

Atlas-lookup : Atlas-const → Type Atlas-type

Atlas-lookup true  = base Bool
Atlas-lookup false = base Bool
Atlas-lookup xor   = base Bool ⇒ base Bool ⇒ base Bool

Atlas-lookup (empty {κ} {ι}) = base (Map κ ι)

-- `update key val my-map` would
-- - insert if `key` is not present in `my-map`
-- - delete if `val` is the neutral element
-- - make an update otherwise
Atlas-lookup (update {κ} {ι}) =
  base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι)

-- Model of zip = Haskell Data.List.zipWith
-- zipWith :: (a → b → c) → [a] → [b] → [c]
Atlas-lookup (zip {κ} {a} {b} {c}) =
  (base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
  base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c)

Atlas-Δbase : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δbase Bool = Bool
-- change to a map is change to its values
Atlas-Δbase (Map key val) = (Map key (Atlas-Δbase val))

Atlas-Δtype : Type Atlas-type → Type Atlas-type
Atlas-Δtype = lift-Δtype₀ Atlas-Δbase

Atlas-context : Set
Atlas-context = Context {Type Atlas-type}

Atlas-term : Atlas-context → Type Atlas-type → Set
Atlas-term = Term {Atlas-type} {Atlas-const} {Atlas-lookup}

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

neutral-term : ∀ {ι Γ} → Atlas-term Γ (base ι)
neutral-term {Bool}   = const (neutral {Bool})
neutral-term {Map κ ι} = const (neutral {Map κ ι})

nil-const : ∀ {ι : Atlas-type} → Atlas-const
nil-const {ι} = neutral {Atlas-Δbase ι}

nil-term : ∀ {ι Γ} → Atlas-term Γ (base (Atlas-Δbase ι))
nil-term {Bool}   = const (nil-const {Bool})
nil-term {Map κ ι} = const (nil-const {Map κ ι})

-- Shorthands of constants
--
-- There's probably a uniform way to lift constants
-- into term constructors.
--
-- TODO: write this and call it Syntax.Term.Plotkin.lift-term

zip! : ∀ {κ a b c Γ} →
  Atlas-term Γ (base κ ⇒ base a ⇒ base b ⇒ base c) →
  Atlas-term Γ (base (Map κ a)) → Atlas-term Γ (base (Map κ b)) →
  Atlas-term Γ (base (Map κ c))

zip! f m₁ m₂ = app (app (app (const zip) f) m₁) m₂

lookup! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base ι)

lookup! = {!!} -- TODO: add constant `lookup`

-- diff-term and apply-term

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Atlas-term Γ (base ι ⇒ base ι ⇒ Atlas-Δtype (base ι))
Atlas-diff {Bool} = const xor
Atlas-diff {Map κ ι} = app (const zip) (abs Atlas-diff)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Atlas-term Γ (Atlas-Δtype (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = const xor
Atlas-apply {Map κ ι} = app (const zip) (abs Atlas-apply)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Atlas-term Γ τ → Atlas-term Γ τ →
  Atlas-term Γ (Atlas-Δtype τ)
diff s t = app (app (lift-diff Atlas-diff Atlas-apply) s) t

apply : ∀ {τ Γ} →
  Atlas-term Γ (Atlas-Δtype τ) → Atlas-term Γ τ →
  Atlas-term Γ τ
apply s t = app (app (lift-apply Atlas-diff Atlas-apply) s) t

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

update! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base (Map κ ι))

update! k v m = app (app (app (const update) k) v) m

insert : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  -- last argument is the change accumulator
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

-- The binary operator such that
-- union t t ≡ t

-- To implement union, we need for each non-map base-type
-- an operator such that `op v v = v` on all values `v`.
-- for Booleans, conjunction is good enough.
--
-- TODO (later): support conjunction, probably by Boolean
-- elimination form if-then-else

postulate
  and! : ∀ {Γ} →
    Atlas-term Γ (base Bool) → Atlas-term Γ (base Bool) →
    Atlas-term Γ (base Bool)

union : ∀ {ι Γ} →
  Atlas-term Γ (base ι) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base ι)
union {Bool} s t = and! s t
union {Map κ ι} s t =
  let
    union-term = abs (abs (union (var (that this)) (var this)))
  in
    zip! (abs union-term) s t

-- Shorthand for 4-way zip
zip4! : ∀ {κ a b c d e Γ} →
  let
    t:_ = λ ι → Atlas-term Γ (base ι)
  in
    Atlas-term Γ
      (base κ ⇒ base a ⇒ base b ⇒ base c ⇒ base d ⇒ base e) →
    t: Map κ a → t: Map κ b → t: Map κ c → t: Map κ d → t: Map κ e

zip4! f m₁ m₂ m₃ m₄ =
  let
    v₁ = var (that this)
    v₂ = var this
    v₃ = var (that this)
    v₄ = var this
    k₁₂ = var (that (that this))
    k₃₄ = var (that (that this))
    f₁₂ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₁₂) v₁) v₂)
      (lookup! k₁₂ (weaken₃ m₃))) (lookup! k₁₂ (weaken₃ m₄)))))
    f₃₄ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₃₄)
      (lookup! k₃₄ (weaken₃ m₁)))
      (lookup! k₃₄ (weaken₃ m₂))) v₃) v₄)))
  in
    -- A correct but inefficient implementation.
    -- May want to speed it up after constants are finalized.
    union (zip! f₁₂ m₁ m₂) (zip! f₃₄ m₃ m₄)

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ} → (c : Atlas-const) →
  Atlas-term Γ (Atlas-Δtype (Atlas-lookup c))

Atlas-Δconst true  = const false
Atlas-Δconst false = const false

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (app (app (const xor) Δx) Δy))))

Atlas-Δconst empty = const empty

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update =
  let
    k  = var (that (that (that (that (that this)))))
    Δk = var (that (that (that (that this))))
    v  = var (that (that (that this)))
    Δv = var (that (that this))
    -- m = var (that this) -- unused parameter
    Δm = var this
  in
    abs (abs (abs (abs (abs (abs
      (insert (apply Δk k) (apply Δv v)
        (delete k v Δm)))))))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip =
  let
    Δf = var (that (that (that (that this))))
    m₁  = var (that (that (that this)))
    Δm₁ = var (that (that this))
    m₂  = var (that this)
    Δm₂ = var this
    g = abs (app (app (weaken₁ Δf) (var this)) nil-term)
  in
    abs (abs (abs (abs (abs (abs (zip4! g m₁ Δm₁ m₂ Δm₂))))))

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-lookup
  Atlas-Δtype
  Atlas-Δconst

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

open import Syntax.Language.Calculus

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

data Atlas-const : Set where

  true  : Atlas-const
  false : Atlas-const
  xor   : Atlas-const

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
  update : ∀ {κ ι : Atlas-type} → Atlas-const
  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const

Atlas-lookup : Atlas-const → Type Atlas-type

Atlas-lookup true  = base Bool
Atlas-lookup false = base Bool
Atlas-lookup xor   = base Bool ⇒ base Bool ⇒ base Bool

Atlas-lookup (empty {κ} {ι}) = base (Map κ ι)

-- `update key val my-map` would
-- - insert if `key` is not present in `my-map`
-- - delete if `val` is the neutral element
-- - make an update otherwise
Atlas-lookup (update {κ} {ι}) =
  base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι)

-- Model of zip = Haskell Data.List.zipWith
-- zipWith :: (a → b → c) → [a] → [b] → [c]
Atlas-lookup (zip {κ} {a} {b} {c}) =
  (base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
  base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c)

Atlas-Δbase : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δbase Bool = Bool
-- change to a map is change to its values
Atlas-Δbase (Map key val) = (Map key (Atlas-Δbase val))

Atlas-Δtype : Type Atlas-type → Type Atlas-type
Atlas-Δtype = lift-Δtype₀ Atlas-Δbase

Atlas-context : Set
Atlas-context = Context {Type Atlas-type}

Atlas-term : Atlas-context → Type Atlas-type → Set
Atlas-term = Term {Atlas-type} {Atlas-const} {Atlas-lookup}

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

neutral-term : ∀ {ι Γ} → Atlas-term Γ (base ι)
neutral-term {Bool}   = const (neutral {Bool})
neutral-term {Map κ ι} = const (neutral {Map κ ι})

nil-const : ∀ {ι : Atlas-type} → Atlas-const
nil-const {ι} = neutral {Atlas-Δbase ι}

nil-term : ∀ {ι Γ} → Atlas-term Γ (base (Atlas-Δbase ι))
nil-term {Bool}   = const (nil-const {Bool})
nil-term {Map κ ι} = const (nil-const {Map κ ι})

-- Shorthands of constants
--
-- There's probably a uniform way to lift constants
-- into term constructors.
--
-- TODO: write this and call it Syntax.Term.Plotkin.lift-term

zip! : ∀ {κ a b c Γ} →
  Atlas-term Γ (base κ ⇒ base a ⇒ base b ⇒ base c) →
  Atlas-term Γ (base (Map κ a)) → Atlas-term Γ (base (Map κ b)) →
  Atlas-term Γ (base (Map κ c))

zip! f m₁ m₂ = app (app (app (const zip) f) m₁) m₂

lookup! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base ι)

lookup! = {!!} -- TODO: add constant `lookup`

-- diff-term and apply-term

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Atlas-term Γ (base ι ⇒ base ι ⇒ Atlas-Δtype (base ι))
Atlas-diff {Bool} = const xor
Atlas-diff {Map κ ι} = app (const zip) (abs Atlas-diff)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Atlas-term Γ (Atlas-Δtype (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = const xor
Atlas-apply {Map κ ι} = app (const zip) (abs Atlas-apply)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Atlas-term Γ τ → Atlas-term Γ τ →
  Atlas-term Γ (Atlas-Δtype τ)
diff s t = app (app (lift-diff Atlas-diff Atlas-apply) s) t

apply : ∀ {τ Γ} →
  Atlas-term Γ (Atlas-Δtype τ) → Atlas-term Γ τ →
  Atlas-term Γ τ
apply s t = app (app (lift-apply Atlas-diff Atlas-apply) s) t

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

update! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base (Map κ ι))

update! k v m = app (app (app (const update) k) v) m

insert : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  -- last argument is the change accumulator
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

-- The binary operator with which all base-type values
-- form a group

union : ∀ {ι Γ} →
  Atlas-term Γ (base ι) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base ι)
union {Bool} s t = app (app (const xor) s) t
union {Map κ ι} s t =
  let
    union-term = abs (abs (union (var (that this)) (var this)))
  in
    zip! (abs union-term) s t

-- Shorthand for 4-way zip
zip4! : ∀ {κ a b c d e Γ} →
  let
    t:_ = λ ι → Atlas-term Γ (base ι)
  in
    Atlas-term Γ
      (base κ ⇒ base a ⇒ base b ⇒ base c ⇒ base d ⇒ base e) →
    t: Map κ a → t: Map κ b → t: Map κ c → t: Map κ d → t: Map κ e

zip4! f m₁ m₂ m₃ m₄ =
  let
    v₁ = var (that this)
    v₂ = var this
    v₃ = var (that this)
    v₄ = var this
    k₁₂ = var (that (that this))
    k₃₄ = var (that (that this))
    f₁₂ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₁₂) v₁) v₂)
      (lookup! k₁₂ (weaken₃ m₃))) (lookup! k₁₂ (weaken₃ m₄)))))
    f₃₄ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₃₄)
      (lookup! k₃₄ (weaken₃ m₁)))
      (lookup! k₃₄ (weaken₃ m₂))) v₃) v₄)))
  in
    -- A correct but inefficient implementation.
    -- May want to speed it up after constants are finalized.
    union (zip! f₁₂ m₁ m₂) (zip! f₃₄ m₃ m₄)

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ} → (c : Atlas-const) →
  Atlas-term Γ (Atlas-Δtype (Atlas-lookup c))

Atlas-Δconst true  = const false
Atlas-Δconst false = const false

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (app (app (const xor) Δx) Δy))))

Atlas-Δconst empty = const empty

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update =
  let
    k  = var (that (that (that (that (that this)))))
    Δk = var (that (that (that (that this))))
    v  = var (that (that (that this)))
    Δv = var (that (that this))
    -- m = var (that this) -- unused parameter
    Δm = var this
  in
    abs (abs (abs (abs (abs (abs
      (insert (apply Δk k) (apply Δv v)
        (delete k v Δm)))))))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip =
  let
    Δf = var (that (that (that (that this))))
    m₁  = var (that (that (that this)))
    Δm₁ = var (that (that this))
    m₂  = var (that this)
    Δm₂ = var this
    g = abs (app (app (weaken₁ Δf) (var this)) nil-term)
  in
    abs (abs (abs (abs (abs (abs (zip4! g m₁ Δm₁ m₂ Δm₂))))))

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-lookup
  Atlas-Δtype
  Atlas-Δconst


Sum: untag

Sum: untag

-- NOTE with-K
module Data.Sum.NP where

open import Data.Sum public renaming (inj₁ to inl; inj₂ to inr)

open import Type hiding (★)
open import Level.NP
open import Function
open import Data.Nat using (ℕ; zero; suc)
open import Data.Zero
open import Data.One
open import Relation.Binary
open import Relation.Binary.Logical
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_;_≢_;_≗_)
open import Data.Two hiding (twist)
open ≡ using (→-to-⟶)

[inl:_,inr:_] = [_,_]

inl-inj : ∀ {a b} {A : ★ a} {B : ★ b} {x y : A} → inl {B = B} x ≡ inl y → x ≡ y
inl-inj ≡.refl = ≡.refl

inr-inj : ∀ {a b} {A : ★ a} {B : ★ b} {x y : B} → inr {A = A} x ≡ inr y → x ≡ y
inr-inj ≡.refl = ≡.refl

module _ {a} {A : ★ a} where
    untag : A ⊎ A → A
    untag = [inl: id ,inr: id ]

module _ {a₁ a₂ b₁ b₂}
         {A₁ : ★ a₁} {A₂ : ★ a₂}
         {B₁ : ★ b₁} {B₂ : ★ b₂}
         {c} {C : ★ c} (f : A₁ ⊎ B₁ → A₂ ⊎ B₂ → C) where
    on-inl = λ i j → f (inl i) (inl j)
    on-inr = λ i j → f (inr i) (inr j)

[,]-assoc : ∀ {a₁ a₂ b₁ b₂ c} {A₁ : ★ a₁} {A₂ : ★ a₂}
              {B₁ : ★ b₁} {B₂ : ★ b₂} {C : ★ c}
              {f₁ : B₁ → C} {g₁ : A₁ → B₁} {f₂ : B₂ → C} {g₂ : A₂ → B₂} →
              [ f₁ , f₂ ] ∘′ map g₁ g₂ ≗ [ f₁ ∘ g₁ , f₂ ∘ g₂ ]
[,]-assoc (inl _) = ≡.refl
[,]-assoc (inr _) = ≡.refl

[,]-factor : ∀ {a₁ a₂ b c} {A₁ : ★ a₁} {A₂ : ★ a₂} {B : ★ b} {C : ★ c}
              {f : B → C} {g₁ : A₁ → B} {g₂ : A₂ → B} →
              [ f ∘ g₁ , f ∘ g₂ ] ≗ f ∘ [ g₁ , g₂ ]
[,]-factor (inl _) = ≡.refl
[,]-factor (inr _) = ≡.refl

map-assoc : ∀ {a₁ a₂ b₁ b₂ c₁ c₂} {A₁ : ★ a₁} {A₂ : ★ a₂}
              {B₁ : ★ b₁} {B₂ : ★ b₂} {C₁ : ★ c₁} {C₂ : ★ c₂}
              {f₁ : B₁ → C₁} {g₁ : A₁ → B₁} {f₂ : B₂ → C₂} {g₂ : A₂ → B₂} →
              map f₁ f₂ ∘′ map g₁ g₂ ≗ map (f₁ ∘ g₁) (f₂ ∘ g₂)
map-assoc = [,]-assoc

open import Data.Product
open import Function.Inverse
open import Function.LeftInverse

{- bad names
⊎-fst : ∀ {a b} {A : ★ a} {B : ★ b} → A ⊎ B → 𝟚
⊎-fst (inl _) = 0₂
⊎-fst (inr _) = 1₂

⊎-snd : ∀ {ℓ} {A B : ★ ℓ} (x : A ⊎ B) → case ⊎-fst x 0: A 1: B
⊎-snd (inl x) = x
⊎-snd (inr x) = x
-}

-- Function.Related.TypeIsomorphisms.NP for the A ⊎ B, Σ 𝟚 [0: A 1: B ] iso.

𝟙⊎^ : ℕ → ★₀
𝟙⊎^ zero    = 𝟘
𝟙⊎^ (suc n) = 𝟙 ⊎ 𝟙⊎^ n

module _ {a b} {A : ★ a} {B : ★ b} where
    twist : A ⊎ B → B ⊎ A
    twist = [inl: inr ,inr: inl ]

-- NOTE with-K
module Data.Sum.NP where

open import Data.Sum public renaming (inj₁ to inl; inj₂ to inr)

open import Type hiding (★)
open import Level.NP
open import Function
open import Data.Nat using (ℕ; zero; suc)
open import Data.Zero
open import Data.One
open import Relation.Binary
open import Relation.Binary.Logical
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_;_≢_;_≗_)
open import Data.Two hiding (twist)
open ≡ using (→-to-⟶)

[inl:_,inr:_] = [_,_]

inl-inj : ∀ {a b} {A : ★ a} {B : ★ b} {x y : A} → inl {B = B} x ≡ inl y → x ≡ y
inl-inj ≡.refl = ≡.refl

inr-inj : ∀ {a b} {A : ★ a} {B : ★ b} {x y : B} → inr {A = A} x ≡ inr y → x ≡ y
inr-inj ≡.refl = ≡.refl

module _ {a₁ a₂ b₁ b₂}
         {A₁ : ★ a₁} {A₂ : ★ a₂}
         {B₁ : ★ b₁} {B₂ : ★ b₂}
         {c} {C : ★ c} (f : A₁ ⊎ B₁ → A₂ ⊎ B₂ → C) where
    on-inl = λ i j → f (inl i) (inl j)
    on-inr = λ i j → f (inr i) (inr j)

[,]-assoc : ∀ {a₁ a₂ b₁ b₂ c} {A₁ : ★ a₁} {A₂ : ★ a₂}
              {B₁ : ★ b₁} {B₂ : ★ b₂} {C : ★ c}
              {f₁ : B₁ → C} {g₁ : A₁ → B₁} {f₂ : B₂ → C} {g₂ : A₂ → B₂} →
              [ f₁ , f₂ ] ∘′ map g₁ g₂ ≗ [ f₁ ∘ g₁ , f₂ ∘ g₂ ]
[,]-assoc (inl _) = ≡.refl
[,]-assoc (inr _) = ≡.refl

[,]-factor : ∀ {a₁ a₂ b c} {A₁ : ★ a₁} {A₂ : ★ a₂} {B : ★ b} {C : ★ c}
              {f : B → C} {g₁ : A₁ → B} {g₂ : A₂ → B} →
              [ f ∘ g₁ , f ∘ g₂ ] ≗ f ∘ [ g₁ , g₂ ]
[,]-factor (inl _) = ≡.refl
[,]-factor (inr _) = ≡.refl

map-assoc : ∀ {a₁ a₂ b₁ b₂ c₁ c₂} {A₁ : ★ a₁} {A₂ : ★ a₂}
              {B₁ : ★ b₁} {B₂ : ★ b₂} {C₁ : ★ c₁} {C₂ : ★ c₂}
              {f₁ : B₁ → C₁} {g₁ : A₁ → B₁} {f₂ : B₂ → C₂} {g₂ : A₂ → B₂} →
              map f₁ f₂ ∘′ map g₁ g₂ ≗ map (f₁ ∘ g₁) (f₂ ∘ g₂)
map-assoc = [,]-assoc

open import Data.Product
open import Function.Inverse
open import Function.LeftInverse

{- bad names
⊎-fst : ∀ {a b} {A : ★ a} {B : ★ b} → A ⊎ B → 𝟚
⊎-fst (inl _) = 0₂
⊎-fst (inr _) = 1₂

⊎-snd : ∀ {ℓ} {A B : ★ ℓ} (x : A ⊎ B) → case ⊎-fst x 0: A 1: B
⊎-snd (inl x) = x
⊎-snd (inr x) = x
-}

-- Function.Related.TypeIsomorphisms.NP for the A ⊎ B, Σ 𝟚 [0: A 1: B ] iso.

𝟙⊎^ : ℕ → ★₀
𝟙⊎^ zero    = 𝟘
𝟙⊎^ (suc n) = 𝟙 ⊎ 𝟙⊎^ n

module _ {a b} {A : ★ a} {B : ★ b} where
    twist : A ⊎ B → B ⊎ A
    twist = [inl: inr ,inr: inl ]


Iso attepmt for fin

Iso attepmt for fin

{-# OPTIONS --without-K #-}

open import Level.NP
open import Type
open import Function
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Fin using (Fin; zero; suc)
open import Data.Zero
open import Data.One
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Function.Related.TypeIsomorphisms.NP
import Function.Inverse.NP as Inv
open Inv using (_↔_; sym; id; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
open import Relation.Binary.NP
open import Explore.Type
open import Explore.Explorable
import Explore.Isomorphism as Iso
--open import Explore.Explorable.Maybe

module Explore.Fin where

𝟙⊎^ : ℕ → ★₀
𝟙⊎^ zero    = 𝟘
𝟙⊎^ (suc n) = 𝟙 ⊎ 𝟙⊎^ n

Fin↔𝟙⊎^𝟘 : ∀ n → Fin n ↔ 𝟙⊎^ n
Fin↔𝟙⊎^𝟘 zero    = Fin0↔𝟘
Fin↔𝟙⊎^𝟘 (suc n) = {!{!Inv.id!} ⊎-cong ?!} Inv.∘ Fin∘suc↔𝟙⊎Fin

{-
Maybe^𝟘↔Fin
open Iso (Fin

{-
module _ {ℓ} where
    Finᵉ : ∀ n → Explore ℓ (Fin n)
    Finᵉ zero    z _∙_ f = z
    Finᵉ (suc n) z _∙_ f = f zero ∙ Finᵉ n z _∙_ (f ∘ suc)

    Finⁱ : ∀ {p} n → ExploreInd p (Finᵉ n)
    Finⁱ zero    P z _∙_ f = z
    Finⁱ (suc n) P z _∙_ f = f zero ∙ Finⁱ n Psuc z _∙_ (f ∘ suc)
      where Psuc = λ e → P (λ z op f → e z op (f ∘ suc))

module _ {ℓ} where
    Finˡ : ∀ n → Lookup {ℓ} (Finᵉ n)
    Finˡ (suc _) (b , _)  zero    = b
    Finˡ (suc n) (_ , xs) (suc x) = Finˡ n xs x

    Finᶠ : ∀ n → Focus {ℓ} (Finᵉ n)
    Finᶠ (suc n) (zero   , b) = inj₁ b
    Finᶠ (suc n) (suc x  , b) = inj₂ (Finᶠ n (x , b))

module _ n where
    open Explorable₀  (Finⁱ n) public using () renaming (sum     to Finˢ; product to Finᵖ)
    open Explorable₁₀ (Finⁱ n) public using () renaming (reify   to Finʳ)
    open Explorable₁₁ (Finⁱ n) public using () renaming (unfocus to Finᵘ)

postulate
  Postulate-Finˢ-ok : ★
  Postulate-FinFunˢ-ok : ★

  Finˢ-ok : ∀ {{_ : Postulate-Finˢ-ok}} n → AdequateSum (Finˢ n)

{-
Finᵖ-ok : ∀ n → AdequateProduct (Finᵖ n)
-}

module _ {A : ★}(μA : Explorable A) where

  eᴬ = explore μA

  extend : ∀ {n} → A → (Fin n → A) → Fin (suc n) → A
  extend x g zero    = x
  extend x g (suc i) = g i

  ¬Fin0 : Fin 0 → A
  ¬Fin0 ()

  -- There is one function Fin 0 → A (called abs) so this should be fine
  -- if not there is a version below that forces the domain to be non-empty
  FinFunᵉ : ∀ n → Explore _ (Fin n → A)
  FinFunᵉ zero    z op f = f ¬Fin0
  FinFunᵉ (suc n) z op f = eᴬ z op (λ x → FinFunᵉ n z op (f ∘ extend x))

  FinFunⁱ : ∀ n → ExploreInd _ (FinFunᵉ n)
  FinFunⁱ zero    P Pz P∙ Pf = Pf _
  FinFunⁱ (suc n) P Pz P∙ Pf =
    explore-ind μA (λ sa → P (λ z op f → sa z op (λ x → FinFunᵉ n z op (f ∘ extend x))))
      Pz P∙
      (λ x → FinFunⁱ n (λ sf → P (λ z op f → sf z op (f ∘ extend x)))
        Pz P∙ (Pf ∘ extend x))

  FinFunˢ : ∀ n → Sum (Fin n → A)
  FinFunˢ n = FinFunᵉ n 0 _+_

  postulate
    FinFunˢ-ok : ∀ {{_ : Postulate-FinFunˢ-ok}} n → AdequateSum (FinFunˢ n)

  μFinFun : ∀ {{_ : Postulate-FinFunˢ-ok}} {n} → Explorable (Fin n → A)
  μFinFun = mk _ (FinFunⁱ _) (FinFunˢ-ok _)

μFin : ∀ {{_ : Postulate-Finˢ-ok}} n → Explorable (Fin n)
μFin n = mk _ (Finⁱ n) (Finˢ-ok n)

{-
μFinSUI : ∀ {n} → SumStableUnderInjection (sum (μFin n))
-}

module BigDistr
  {{_ : Postulate-Finˢ-ok}}
  {{_ : Postulate-FinFunˢ-ok}}
  {A : ★}(μA : Explorable A)
  (cm           : CommutativeMonoid ₀ ₀)
  -- we want (open CMon cm) !!!
  (_◎_          : let open CMon cm in C → C → C)
  (ε-◎          : let open CMon cm in Zero _≈_ ε _◎_)
  (distrib      : let open CMon cm in _DistributesOver_ _≈_ _◎_ _∙_)
  (_◎-cong_     : let open CMon cm in _◎_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where

  open CMon cm renaming (sym to ≈-sym)

  μF→A = μFinFun μA

  -- Sum over A
  Σᴬ = explore μA ε _∙_

  -- Sum over (Fin(1+I)→A) functions
  Σ' : ∀ {I} → ((Fin I → A) → C) → C
  Σ' = explore μF→A ε _∙_

  -- Product over Fin(1+I) values
  Π' = λ I → explore (μFin I) ε _◎_

  bigDistr : ∀ I F → Π' I (Σᴬ ∘ F) ≈ Σ' (Π' I ∘ _ˢ_ F)
  bigDistr zero    _ = refl
  bigDistr (suc I) F
    = Σᴬ (F zero) ◎ Π' I (Σᴬ ∘ F ∘ suc)
    ≈⟨ refl ◎-cong bigDistr I (F ∘ suc) ⟩
      Σᴬ (F zero) ◎ Σ' (Π' I ∘ _ˢ_ (F ∘ suc))
    ≈⟨ ≈-sym (explore-linʳ μA monoid _◎_ (F zero) (Σ' (Π' I ∘ _ˢ_ (F ∘ suc))) (proj₁ ε-◎ _) (proj₂ distrib)) ⟩
      Σᴬ (λ j → F zero j ◎ Σ' (Π' I ∘ _ˢ_ (F ∘ suc)))
    ≈⟨ explore-mon-ext μA monoid (λ j → ≈-sym (explore-linˡ μF→A monoid _◎_ (Π' I ∘ _ˢ_ (F ∘ suc)) (F zero j) (proj₂ ε-◎ _) (proj₁ distrib))) ⟩
      (Σᴬ λ j → Σ' λ f → F zero j ◎ Π' I ((F ∘ suc) ˢ f))
    ∎

module _
  {{_ : Postulate-Finˢ-ok}}
  {{_ : Postulate-FinFunˢ-ok}} where

  FinDist : ∀ {n} → DistFun (μFin n) (λ μX → μFinFun μX)
  FinDist μB c ◎ distrib ◎-cong f = BigDistr.bigDistr μB c ◎ distrib ◎-cong f _
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}

open import Level.NP
open import Type
open import Function
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Fin using (Fin; zero; suc)
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Function.Related.TypeIsomorphisms.NP
import Function.Inverse.NP as Inv
open Inv using (_↔_; sym; id; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
open import Relation.Binary.NP
open import Explore.Type
open import Explore.Explorable
open import Explore.Isomorphism
--open import Explore.Explorable.Maybe

module Explore.Fin where

module _ {ℓ} where
    Finᵉ : ∀ n → Explore ℓ (Fin n)
    Finᵉ zero    z _∙_ f = z
    Finᵉ (suc n) z _∙_ f = f zero ∙ Finᵉ n z _∙_ (f ∘ suc)

    Finⁱ : ∀ {p} n → ExploreInd p (Finᵉ n)
    Finⁱ zero    P z _∙_ f = z
    Finⁱ (suc n) P z _∙_ f = f zero ∙ Finⁱ n Psuc z _∙_ (f ∘ suc)
      where Psuc = λ e → P (λ z op f → e z op (f ∘ suc))

module _ {ℓ} where
    Finˡ : ∀ n → Lookup {ℓ} (Finᵉ n)
    Finˡ (suc _) (b , _)  zero    = b
    Finˡ (suc n) (_ , xs) (suc x) = Finˡ n xs x

    Finᶠ : ∀ n → Focus {ℓ} (Finᵉ n)
    Finᶠ (suc n) (zero   , b) = inj₁ b
    Finᶠ (suc n) (suc x  , b) = inj₂ (Finᶠ n (x , b))

module _ n where
    open Explorable₀  (Finⁱ n) public using () renaming (sum     to Finˢ; product to Finᵖ)
    open Explorable₁₀ (Finⁱ n) public using () renaming (reify   to Finʳ)
    open Explorable₁₁ (Finⁱ n) public using () renaming (unfocus to Finᵘ)

postulate
  Postulate-Finˢ-ok : ★
  Postulate-FinFunˢ-ok : ★

  Finˢ-ok : ∀ {{_ : Postulate-Finˢ-ok}} n → AdequateSum (Finˢ n)

{-
Finᵖ-ok : ∀ n → AdequateProduct (Finᵖ n)
-}

module _ {A : ★}(μA : Explorable A) where

  eᴬ = explore μA

  extend : ∀ {n} → A → (Fin n → A) → Fin (suc n) → A
  extend x g zero    = x
  extend x g (suc i) = g i

  ¬Fin0 : Fin 0 → A
  ¬Fin0 ()

  -- There is one function Fin 0 → A (called abs) so this should be fine
  -- if not there is a version below that forces the domain to be non-empty
  FinFunᵉ : ∀ n → Explore _ (Fin n → A)
  FinFunᵉ zero    z op f = f ¬Fin0
  FinFunᵉ (suc n) z op f = eᴬ z op (λ x → FinFunᵉ n z op (f ∘ extend x))

  FinFunⁱ : ∀ n → ExploreInd _ (FinFunᵉ n)
  FinFunⁱ zero    P Pz P∙ Pf = Pf _
  FinFunⁱ (suc n) P Pz P∙ Pf =
    explore-ind μA (λ sa → P (λ z op f → sa z op (λ x → FinFunᵉ n z op (f ∘ extend x))))
      Pz P∙
      (λ x → FinFunⁱ n (λ sf → P (λ z op f → sf z op (f ∘ extend x)))
        Pz P∙ (Pf ∘ extend x))

  FinFunˢ : ∀ n → Sum (Fin n → A)
  FinFunˢ n = FinFunᵉ n 0 _+_

  postulate
    FinFunˢ-ok : ∀ {{_ : Postulate-FinFunˢ-ok}} n → AdequateSum (FinFunˢ n)

  μFinFun : ∀ {{_ : Postulate-FinFunˢ-ok}} {n} → Explorable (Fin n → A)
  μFinFun = mk _ (FinFunⁱ _) (FinFunˢ-ok _)

μFin : ∀ {{_ : Postulate-Finˢ-ok}} n → Explorable (Fin n)
μFin n = mk _ (Finⁱ n) (Finˢ-ok n)

{-
μFinSUI : ∀ {n} → SumStableUnderInjection (sum (μFin n))
-}

module BigDistr
  {{_ : Postulate-Finˢ-ok}}
  {{_ : Postulate-FinFunˢ-ok}}
  {A : ★}(μA : Explorable A)
  (cm           : CommutativeMonoid ₀ ₀)
  -- we want (open CMon cm) !!!
  (_◎_          : let open CMon cm in C → C → C)
  (ε-◎          : let open CMon cm in Zero _≈_ ε _◎_)
  (distrib      : let open CMon cm in _DistributesOver_ _≈_ _◎_ _∙_)
  (_◎-cong_     : let open CMon cm in _◎_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where

  open CMon cm renaming (sym to ≈-sym)

  μF→A = μFinFun μA

  -- Sum over A
  Σᴬ = explore μA ε _∙_

  -- Sum over (Fin(1+I)→A) functions
  Σ' : ∀ {I} → ((Fin I → A) → C) → C
  Σ' = explore μF→A ε _∙_

  -- Product over Fin(1+I) values
  Π' = λ I → explore (μFin I) ε _◎_

  bigDistr : ∀ I F → Π' I (Σᴬ ∘ F) ≈ Σ' (Π' I ∘ _ˢ_ F)
  bigDistr zero    _ = refl
  bigDistr (suc I) F
    = Σᴬ (F zero) ◎ Π' I (Σᴬ ∘ F ∘ suc)
    ≈⟨ refl ◎-cong bigDistr I (F ∘ suc) ⟩
      Σᴬ (F zero) ◎ Σ' (Π' I ∘ _ˢ_ (F ∘ suc))
    ≈⟨ ≈-sym (explore-linʳ μA monoid _◎_ (F zero) (Σ' (Π' I ∘ _ˢ_ (F ∘ suc))) (proj₁ ε-◎ _) (proj₂ distrib)) ⟩
      Σᴬ (λ j → F zero j ◎ Σ' (Π' I ∘ _ˢ_ (F ∘ suc)))
    ≈⟨ explore-mon-ext μA monoid (λ j → ≈-sym (explore-linˡ μF→A monoid _◎_ (Π' I ∘ _ˢ_ (F ∘ suc)) (F zero j) (proj₂ ε-◎ _) (proj₁ distrib))) ⟩
      (Σᴬ λ j → Σ' λ f → F zero j ◎ Π' I ((F ∘ suc) ˢ f))
    ∎

module _
  {{_ : Postulate-Finˢ-ok}}
  {{_ : Postulate-FinFunˢ-ok}} where

  FinDist : ∀ {n} → DistFun (μFin n) (λ μX → μFinFun μX)
  FinDist μB c ◎ distrib ◎-cong f = BigDistr.bigDistr μB c ◎ distrib ◎-cong f _
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


adding new files to the """cm file"""

adding new files to the """cm file"""

open import List
open import Nat
open import Prelude

open import core
-- open import correspondence
-- open import expandability
-- open import expansion-unicity
-- open import preservation
-- open import progress
-- open import type-assignment-unicity
-- open import typed-expansion


scraps

scraps

open import List
open import Nat
open import Prelude

open import contexts
open import core

open import lemmas-gcomplete

open import lemmas-disjointness
--open import disjointness -- working here

open import structural-assumptions

open import focus-formation
open import ground-decidable
open import matched-ground-invariant
open import finality

--open import lemmas-subst-ta -- working here
open import lemmas-ground
open import lemmas-consistency
open import lemmas-matching
open import synth-unicity
open import htype-decidable

--open import expansion-generality -- depend on disjointness
--open import expandability -- ditto
open import expansion-unicity
open import type-assignment-unicity
open import typed-expansion

open import canonical-value-forms
open import canonical-boxed-forms
open import canonical-indeterminate-forms

open import lemmas-progress-checks
open import progress-checks
open import progress
open import preservation

open import lemmas-complete
open import cast-inert
open import complete-preservation
open import complete-progress
open import complete-expansion

open import weakening
open import exchange
open import lemmas-freshness
open import contraction

open import List
open import Nat
open import Prelude

open import contexts
open import core

open import lemmas-gcomplete

open import lemmas-disjointness
open import disjointness -- work here

open import structural-assumptions

open import focus-formation
open import ground-decidable
open import matched-ground-invariant
open import finality

open import lemmas-subst-ta -- work here
open import lemmas-ground
open import lemmas-consistency
open import lemmas-matching
open import synth-unicity
open import htype-decidable

open import expansion-generality
open import expandability
open import expansion-unicity
open import type-assignment-unicity
open import typed-expansion

open import canonical-value-forms
open import canonical-boxed-forms
open import canonical-indeterminate-forms

open import lemmas-progress-checks
open import progress-checks
open import progress
open import preservation

open import lemmas-complete
open import cast-inert
open import complete-preservation
open import complete-progress
open import complete-expansion

open import weakening
open import exchange
open import lemmas-freshness
open import contraction


agda : wouter : predicate transformer

agda : wouter : predicate transformer

{-# OPTIONS --type-in-type   #-} -- NOT SOUND!

open import Data.Empty      using (⊥)
open import Data.Nat        renaming (ℕ to Nat)
open import Data.Nat.DivMod
open import Data.Product    hiding (map)
open import Data.Unit       using (⊤)
------------------------------------------------------------------------------
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

module x where

{-
https://webspace.science.uu.nl/~swier004/publications/2019-icfp-submission-a.pdf

A predicate transformer semantics for effects

WOUTER SWIERSTRA and TIM BAANEN, Universiteit Utrecht

abstract

reasoning about effectful code harder than pure code

predicate transformer (PT) semantics gives a refinement relation that can be used to
- relate a program to its specification, or
- calculate effectful programs that are correct by construction

INTRODUCTION

key techniques
- syntax of effectful computations represented as free monads
  - assigning meaning to these monads gives meaning to the syntactic ops each effect provides
- paper shows how to assign PT semantics to computations arising from Kleisli arrows on free monads
  - enables computing the weakest precondition associated with a given postcondition
- using weakest precondition semantics
  - define refinement on computations
  - show how to
    - use this refinement relation to show a program satisfies its specification, or
    - calculate a program from its specification.
- show how programs and specifications may be mixed,
  enabling verified programs to be calculated from their specification one step at a time

2 BACKGROUND

Free monads
-}

-- C          : type of commands
-- Free C R   : returns an 'a' or issues command c : C
-- For each c : C, there is a set of responses R c
-- 2nd arg of Step is continuation : how to proceed after receiving response R c
data Free (C : Set) (R : C → Set) (a : Set) : Set where
  Pure :                           a  → Free C R a
  Step : (c : C) → (R c → Free C R a) → Free C R a

-- show that 'Free' is a monad:

map : ∀ {a b C : Set} {R : C → Set} → (a → b) → Free C R a → Free C R b
map f (Pure x)   = Pure (f x)
map f (Step c k) = Step c (λ r → map f (k r))

return : ∀ {a C : Set} {R : C → Set} → a → Free C R a
return = Pure

_>>=_ : ∀ {a b C : Set} {R : C → Set} → Free C R a → (a → Free C R b) → Free C R b
Pure   x >>= f = f x
Step c x >>= f = Step c (λ r → x r >>= f)

{-
different effects choose C and R differently, depending on their ops

Weakest precondition semantics

idea of associating weakest precondition semantics with imperative programs
dates to Dijkstra’s Guarded Command Language [1975]

ways to specify behaviour of function f : a → b
- reference implementation
- define a relation R : a → b → Set
- write contracts and test cases
- PT semantics

call values of type a → Set : predicate on type a

PTs are functions between predicates
e.g., weakest precondition:
-}

-- "maps"
-- function f : a → b and
-- desired postcondition on the function’s output, b → Set
-- to weakest precondition a → Set on function’s input that ensures postcondition satisfied
--
-- note: definition is just reverse function composition
-- wp0 : ∀ {a b : Set} → (f : a → b) → (b → Set) → (a → Set)
wp0 : ∀ {a : Set} {b :     Set} (f :      a  → b)   →           (b   → Set) → (a → Set)
wp0 f P = λ x → P   (f x)
{-
above wp semantics is sometimes too restrictive
- no way to specify that output is related to input
- fix via making f dependent:
-}
wp  : ∀ {a : Set} {b : a → Set} (f : (x : a) → b x) → ((x : a) → b x → Set) → (a → Set)
wp  f P = λ x → P x (f x)

-- shorthand for working with predicates and predicates transformers
_⊆_ : ∀ {a : Set} → (a → Set) → (a → Set) → Set
P ⊆ Q = ∀ x → P x → Q x

-- refinement relation defined between PTs
_⊑_ : ∀ {a : Set} {b : a → Set} → (pt1 pt2 : ((x : a) → b x → Set) → (a → Set)) → Set₁
pt1 ⊑ pt2 = ∀ P → pt1 P ⊆ pt2 P

{-
use refinement relation
- to relate PT semantics between programs and specifications
- to show a program satisfies its specification; or
- to show that one program is somehow ‘better’ than another,
  where ‘better’ is defined by choice of PT semantics

in pure setting, this refinement relation is not interesting:
the refinement relation corresponds to extensional equality between functions:

lemma follows from the ‘Leibniz rule’ for equality in intensional type theory:
refinement : ∀ (f g : a → b) → (wp f ⊑ wp g) ↔ (∀ x → f x ≡ g x)

this paper defines PT semantics for Kleisli arrows of form

    a → Free C R b

could use 'wp' to assign semantics to these computations directly,
but typically not interested in syntactic equality between free monads

rather want to study semantics of effectful programs they represent

to define a PT semantics for effects
define a function with form:

  -- how to lift a predicate on 'a' over effectful computation returning 'a'
  pt : (a → Set) → Free C R a → Set

'pt' def depends on semantics desired for a particulr free monad

Crucially,
choice of pt and weakest precondition semantics, wp, together
give a way to assign weakest precondition semantics to Kleisli arrows
representing effectful computations

3 PARTIALITY

Partial computations : i.e., 'Maybe'

make choices for commands C and responses R
-}

data C : Set where
  Abort : C -- no continuation

R : C → Set
R Abort = ⊥ -- since C has no continuation, valid responses is empty

Partial : Set → Set
Partial = Free C R

-- smart constructor for failure:
abort : ∀ {a : Set} → Partial a
abort = Step Abort (λ ())

{-
computation of type Partial a will either
- return a value of type a or
- fail, issuing abort command

Note that responses to Abort command are empty;
abort smart constructor abort uses this to discharge the continuation
in the second argument of the Step constructor

Example: division

expression language, closed under division and natural numbers:
-}

data Expr : Set where
  Val : Nat  → Expr
  Div : Expr → Expr → Expr

exv : Expr
exv = Val 3
exd : Expr
exd = Div (Val 3) (Val 3)

-- semantics specified using inductively defined RELATION:
-- def rules out erroneous results by requiring the divisor evaluates to non-zero
data _⇓_ : Expr → Nat → Set where
  Base : ∀ {x : Nat}
       → Val x ⇓ x
  Step : ∀ {l r : Expr} {v1 v2 : Nat}
       →     l   ⇓  v1
       →       r ⇓         (suc v2)
       → Div l r ⇓ (v1 div (suc v2))

exb : Val 3 ⇓ 3
exb = Base

exs : Div (Val 3) (Val 3) ⇓ 1
exs = Step Base Base

-- Alternatively
-- evaluate Expr via monadic INTERPRETER, using Partial to handle division-by-zero

-- op used by ⟦_⟧ interpreter
_÷_ : Nat → Nat → Partial Nat
n ÷ zero    = abort
n ÷ (suc k) = return (n div (suc k))

⟦_⟧ : Expr → Partial Nat
⟦ Val x ⟧     = return x
⟦ Div e1 e2 ⟧ = ⟦ e1 ⟧ >>= λ v1 → ⟦ e2 ⟧ >>= λ v2 → v1 ÷ v2

evv   : Free C R Nat
evv   = ⟦ Val 3 ⟧
evv'  : evv ≡ Pure 3
evv'  = refl

evd   : Free C R Nat
evd   = ⟦ Div (Val 3) (Val 3) ⟧
evd'  : evd ≡ Pure 1
evd'  = refl

evd0  : Free C R Nat
evd0  = ⟦ Div (Val 3) (Val 0) ⟧
evd0' : evd0 ≡ Step Abort (λ ())
evd0' = refl

{-
How to relate two definitions:
- std lib 'div' requires implicit proof that divisor is non-zero
  - ⇓ relation generates via pattern matching
  - _÷_ does explicit check
- interpreter uses _÷_
  - fails explicitly with abort when divisor is zero

Assign a weakest precondition semantics to Kleisli arrows of the form

    a → Partial b
-}

wpPartial : ∀ {a : Set} {b : a → Set}
          → (f : (x : a) → Partial (b x))
          → (P : (x : a) →          b x → Set)
          → (a → Set)
wpPartial f P = wp f (mustPT P)
 where
  mustPT : ∀ {a : Set} {b : a → Set}
         → (P : (x : a) → b x → Set)
         →      (x : a)
         → Partial       (b x) → Set
  mustPT P _ (Pure y)       = P _ y
  mustPT P _ (Step Abort _) = ⊥
{-
To call 'wp', must show how to transform
-      predicate                  P :         b → Set
- to a predicate on partial results : Partial b → Set
Done via proposition 'mustPT P c'
- holds when computation c of type Partial b successfully returns a 'b' that satisfies P

particular PT semantics of partial computations determined by def mustPT
here: rule out failure entirely
- so case Abort returns empty type

Given this PT semantics for Kleisli arrows in general,
can now study semantics of above monadic interpreter
via passing
- interpreter: ⟦_⟧
- desired postcondition : _⇓_
as arguments to wpPartial:

  wpPartial ⟦_⟧ _⇓_ : Expr → Set

resulting in a predicate on expressions

for all expressions satisfying this predicate,
the monadic interpreter and the relational specification, _⇓_,
must agree on the result of evaluation

What does this say about correctness of interpreter?
To understand the predicate better, consider defining this predicate on expressions:
-}

SafeDiv : Expr → Set
SafeDiv (Val x)     = ⊤
SafeDiv (Div e1 e2) = (e2 ⇓ zero → ⊥) {-∧-} × SafeDiv e1 {-∧-} × SafeDiv e2

{-
Expect : any expr e for which SafeDiv e holds
can be evaluated without division-by-zero

can prove SafeDiv is sufficient condition for two notions of evaluation to coincide:

-- lemma relates the two semantics
-- expressed as a relation and an evaluator
-- for those expressions that satisfy the SafeDiv property
correct : SafeDiv ⊆ wpPartial ⟦_⟧ _⇓_

Instead of manually defining SafeDiv, define more general predicate
characterising the domain of a partial function:
-}

dom : ∀ {a : Set} {b : a → Set}
    → ((x : a)
    → Partial (b x))
    → (a → Set)
dom f = wpPartial f (λ _ _ → ⊤)

{-
can show that the two semantics agree precisely on the domain of the interpreter:

sound    : dom       ⟦_⟧ ⊆ wpPartial ⟦_⟧ _⇓_
complete : wpPartial ⟦_⟧ _⇓_ ⊆ dom ⟦_⟧

both proofs proceed by induction on the argument expression

Refinement

weakest precondition semantics on partial computations give rise
to a refinement relation on Kleisli arrows of the form a → Partial b

can characterise this relation by proving:

refinement : (f g : a → Maybe b)
           → (wpPartial f ⊑ wpPartial g) ↔ (∀ x → (f x ≡ g x) ∨ (f x ≡ Nothing))

use refinement to relate Kleisli morphisms,
and to relate a program to a specification given by a pre- and postcondition

Example: Add (interpreter for stack machine)

add top two elements; can fail fail if stack has too few elements

below shows how to prove the definition meets its specification

Define specification in terms of a pre/post condition.
The specification of a function of type (x : a) → b x consists of
-}
record Spec (a : Set) (b : a → Set) : Set where
  constructor [_,_]
  field
    pre  : a → Set             -- a precondition on a, and
    post : (x : a) → b x → Set -- a postcondition relating inputs that satisfy this precondition
                               -- and the corresponding outputs

{-# OPTIONS --type-in-type   #-} -- NOT SOUND!

open import Data.Empty      using (⊥)
open import Data.Nat        renaming (ℕ to Nat)
open import Data.Nat.DivMod
open import Data.Product    hiding (map)
open import Data.Unit       using (⊤)

module x where

{-
https://webspace.science.uu.nl/~swier004/publications/2019-icfp-submission-a.pdf

A predicate transformer semantics for effects

WOUTER SWIERSTRA and TIM BAANEN, Universiteit Utrecht

abstract

reasoning about effectful code harder than pure code

predicate transformer (PT) semantics gives a refinement relation that can be used to
- relate a program to its specification, or
- calculate effectful programs that are correct by construction

INTRODUCTION

key techniques
- syntax of effectful computations represented as free monads
  - assigning meaning to these monads gives meaning to the syntactic ops each effect provides
- paper shows how to assign PT semantics to computations arising
  from Kleisli arrows on free monads
  - enables computing the weakest precondition associated with a given postcondition
- using weakest precondition semantics
  - define refinement on computations
  - show how to
    - use this refinement relation to show a program satisfies its specification, or
    - calculate a program from its specification.
- show how programs and specifications may be mixed,
  enabling verified programs to be calculated from their specification one step at a time

2 BACKGROUND

Free monads
-}

-- C          : type of commands
-- Free C R   : returns an 'a' or issues command c : C
-- For each c : C, there is a set of responses R c
-- 2nd arg of Step is continuation : how to proceed after receiving response R c
data Free (C : Set) (R : C → Set) (a : Set) : Set where
  Pure :                           a  → Free C R a
  Step : (c : C) → (R c → Free C R a) → Free C R a

-- show that 'Free' is a monad:

map : ∀ {a b C : Set} {R : C → Set} → (a → b) → Free C R a → Free C R b
map f (Pure x)   = Pure (f x)
map f (Step c k) = Step c (λ r → map f (k r))

return : ∀ {a C : Set} {R : C → Set} → a → Free C R a
return = Pure

_>>=_ : ∀ {a b C : Set} {R : C → Set} → Free C R a → (a → Free C R b) → Free C R b
Pure   x >>= f = f x
Step c x >>= f = Step c (λ r → x r >>= f)

{-
different effects choose C and R differently, depending on their ops

Weakest precondition semantics

idea of associating weakest precondition semantics with imperative programs
dates to Dijkstra’s Guarded Command Language [1975]

ways to specify behaviour of function f : a → b
- reference implementation
- define a relation R : a → b → Set
- write contracts and test cases
- PT semantics

call values of type a → Set : predicate on type a

PTs are functions between predicates
e.g., weakest precondition:
-}

-- "maps"
-- function f : a → b and
-- desired postcondition on the function’s output, b → Set
-- to weakest precondition a → Set on function’s input that ensures postcondition satisfied
--
-- note: definition is just reverse function composition
-- wp0 : ∀ {a b : Set} → (f : a → b) → (b → Set) → (a → Set)
wp0 : ∀ {a : Set} {b :     Set} (f :       a → b)   →           (b   → Set) → (a → Set)
wp0 f P = λ x → P   (f x)
{-
above wp semantics is sometimes too restrictive
- no way to specify that output is related to input
- fix via making f dependent:
-}
wp  : ∀ {a : Set} {b : a → Set} (f : (x : a) → b x) → ((x : a) → b x → Set) → (a → Set)
wp  f P = λ x → P x (f x)

-- shorthand for working with predicates and predicates transformers
_⊆_ : ∀ {a : Set} → (a → Set) → (a → Set) → Set
P ⊆ Q = ∀ x → P x → Q x

-- refinement relation defined between PTs
_⊑_ : ∀ {a : Set} {b : a → Set} → (pt1 pt2 : ((x : a) → b x → Set) → (a → Set)) → Set₁
pt1 ⊑ pt2 = ∀ P → pt1 P ⊆ pt2 P

{-
use refinement relation
- to relate PT semantics between programs and specifications
- to show a program satisfies its specification; or
- to show that one program is somehow ‘better’ than another,
  where ‘better’ is defined by choice of PT semantics

in pure setting, this refinement relation is not interesting:
the refinement relation corresponds to extensional equality between functions:

lemma follows from the ‘Leibniz rule’ for equality in intensional type theory:
refinement : ∀ (f g : a → b) → (wp f ⊑ wp g) ↔ (∀ x → f x ≡ g x)

this paper defines PT semantics for Kleisli arrows of form

    a → Free C R b

could use 'wp' to assign semantics to these computations directly,
but typically not interested in syntactic equality between free monads

rather want to study semantics of effectful programs they represent

to define a PT semantics for effects
define a function with form:

  -- how to lift a predicate on 'a' over effectful computation returning 'a'
  pt : (a → Set) → Free C R a → Set

'pt' def depends on semantics desired for a particulr free monad

Crucially,
choice of pt and weakest precondition semantics, wp, together
give a way to assign weakest precondition semantics to Kleisli arrows
representing effectful computations

3 PARTIALITY

Partial computations : i.e., 'Maybe'

make choices for commands C and responses R
-}

data C : Set where
  Abort : C -- no continuation

R : C → Set
R Abort = ⊥ -- since C has no continuation, valid responses is empty

Partial : Set → Set
Partial = Free C R

-- smart constructor for failure:
abort : ∀ {a : Set} → Partial a
abort = Step Abort (λ ())

{-
computation of type Partial a will either
- return a value of type a or
- fail, issuing abort command

Note that responses to Abort command are empty;
abort smart constructor abort uses this to discharge the continuation
in the second argument of the Step constructor

Example: division

expression language, closed under division and natural numbers:
-}

data Expr : Set where
  Val : Nat  → Expr
  Div : Expr → Expr → Expr

-- semantics specified using inductively defined RELATION:
-- def rules out erroneous results by requiring the divisor evaluates to non-zero
data _⇓_ : Expr → Nat → Set where
  Base : ∀ {x : Nat}
       → Val x ⇓ x
  Step : ∀ {l r : Expr} {v1 v2 : Nat}
       →       l ⇓  v1
       →       r ⇓         (suc v2)
       → Div l r ⇓ (v1 div (suc v2))

-- Alternatively
-- evaluate Expr via monadic INTERPRETER, using Partial to handle division-by-zero

-- op used by ⟦_⟧ interpreter
_÷_ : Nat → Nat → Partial Nat
n ÷ zero    = abort
n ÷ (suc k) = return (n div (suc k))

⟦_⟧ : Expr → Partial Nat
⟦ Val x ⟧     = return x
⟦ Div e1 e2 ⟧ = ⟦ e1 ⟧ >>= λ v1 → ⟦ e2 ⟧ >>= λ v2 → v1 ÷ v2

{-
std lib 'div' requires implicit proof that divisor is non-zero

when divisor is zero, interpreter fail explicitly with abort

How to relate these two definitions?

Assign a weakest precondition semantics to Kleisli arrows of the form

    a → Partial b
-}

wpPartial : ∀ {a : Set} {b : a → Set}
          → (f : (x : a) → Partial (b x))
          → (P : (x : a) →          b x → Set)
          → (a → Set)
wpPartial f P = wp f (mustPT P)
 where
  mustPT : ∀ {a : Set} {b : a → Set}
         → (P : (x : a) → b x → Set)
         →      (x : a)
         → Partial       (b x) → Set
  mustPT P _ (Pure y)       = P _ y
  mustPT P _ (Step Abort _) = ⊥
{-
To call 'wp', must show how to transform
-      predicate                  P :         b → Set
- to a predicate on partial results : Partial b → Set
Done via proposition 'mustPT P c'
- holds when computation c of type Partial b successfully returns a 'b' that satisfies P

particular PT semantics of partial computations determined by def mustPT
here: rule out failure entirely
- so case Abort returns empty type

Given this PT semantics for Kleisli arrows in general,
can now study semantics of above monadic interpreter
via passing
- interpreter: ⟦_⟧
- desired postcondition : _⇓_
as arguments to wpPartial:

  wpPartial ⟦_⟧ _⇓_ : Expr → Set

resulting in a predicate on expressions

for all expressions satisfying this predicate,
the monadic interpreter and the relational specification, _⇓_,
must agree on the result of evaluation

What does this say about correctness of interpreter?
To understand the predicate better, consider defining this predicate on expressions:
-}

SafeDiv : Expr → Set
SafeDiv (Val x)     = ⊤
SafeDiv (Div e1 e2) = (e2 ⇓ zero → ⊥) {-∧-} × SafeDiv e1 {-∧-} × SafeDiv e2

{-
Expect : any expr e for which SafeDiv e holds
can be evaluated without division-by-zero

can prove SafeDiv is sufficient condition for two notions of evaluation to coincide:

-- lemma relates the two semantics
-- expressed as a relation and an evaluator
-- for those expressions that satisfy the SafeDiv property
correct : SafeDiv ⊆ wpPartial ⟦_⟧ _⇓_

Instead of manually defining SafeDiv, define more general predicate
characterising the domain of a partial function:
-}

dom : ∀ {a : Set} {b : a → Set}
    → ((x : a)
    → Partial (b x))
    → (a → Set)
dom f = wpPartial f (λ _ _ → ⊤)

{-
can show that the two semantics agree precisely on the domain of the interpreter:

sound    : dom       ⟦_⟧ ⊆ wpPartial ⟦_⟧ _⇓_
complete : wpPartial ⟦_⟧ _⇓_ ⊆ dom ⟦_⟧

both proofs proceed by induction on the argument expression

Refinement

weakest precondition semantics on partial computations give rise
to a refinement relation on Kleisli arrows of the form a → Partial b

can characterise this relation by proving:

refinement : (f g : a → Maybe b)
           → (wpPartial f ⊑ wpPartial g) ↔ (∀ x → (f x ≡ g x) ∨ (f x ≡ Nothing))

use refinement to relate Kleisli morphisms,
and to relate a program to a specification given by a pre- and postcondition

Example: Add (interpreter for stack machine)

add top two elements; can fail fail if stack has too few elements

below shows how to prove the definition meets its specification

Define specification in terms of a pre/post condition.
The specification of a function of type (x : a) → b x consists of
-}
record Spec (a : Set) (b : a → Set) : Set where
  constructor [_,_]
  field
    pre  : a → Set             -- a precondition on a, and
    post : (x : a) → b x → Set -- a postcondition relating inputs that satisfy this precondition
                               -- and the corresponding outputs


Only white spaces.

Only white spaces.

Ignore-this: 6ca18b898d016f181623e766c9dcebeb

darcs-hash:20100727155339-3bd4e-b1c40a641d81f05c0e0291cedb65fa69721cfd7d.gz


Data.Bits: →ᵇ

Data.Bits: →ᵇ

module Data.Bits where

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

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

Bit : Set
Bit = Bool

module Defs where
  0b = false
  1b = true
module Patterns where
  pattern 0b = false
  pattern 1b = true
open Patterns

Bits : ℕ → Set
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → Set
i →ᵇ o = Bits i → Bits o

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

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

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

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

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

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

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

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

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

vnot∘vnot≗id : ∀ {n} → vnot {n} ∘ vnot ≗ id
vnot∘vnot≗id [] = refl
vnot∘vnot≗id (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot≗id xs)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open M public

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

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

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

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

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

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

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open Defs public

module Data.Bits where

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

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

Bit : Set
Bit = Bool

module Defs where
  0b = false
  1b = true
module Patterns where
  pattern 0b = false
  pattern 1b = true
open Patterns

Bits : ℕ → Set
Bits = Vec Bit

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

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

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

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

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

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

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

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

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

vnot∘vnot≗id : ∀ {n} → vnot {n} ∘ vnot ≗ id
vnot∘vnot≗id [] = refl
vnot∘vnot≗id (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot≗id xs)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open M public

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

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

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

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

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

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

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open Defs public


Updated installation instructions.

Updated installation instructions.

Ignore-this: efdef7acbf124dd693f607adbc492261

darcs-hash:20110507165243-3bd4e-964560d62ba745ad1c29061ecd3f5ccbc02b505f.gz

------------------------------------------------------------------------------
-- FOT (First Order Theories)
------------------------------------------------------------------------------

-- Code accompanying the paper "Combining Interactive and Automatic
-- Reasoning about Functional Programs" by Ana Bove, Peter Dybjer, and
-- Andrés Sicard-Ramírez.

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

module README where

------------------------------------------------------------------------------
-- Description
------------------------------------------------------------------------------

-- Examples of the formalization of first order theories showing the
-- combination of interactive proofs with automatics proofs carried
-- out by first order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- Prerequisites and use
------------------------------------------------------------------------------

-- See http://www1.eafit.edu.co/asicard/code/fotc/.

------------------------------------------------------------------------------
-- First order theories
------------------------------------------------------------------------------

-- Conventions

-- The following modules show the formalization of some first order
-- theories. If the module's name ends in 'I' the module contains
-- interactive proofs, if it ends in 'ATP' the module contains
-- combined proofs, otherwise the module contains definions and/or
-- interactive proofs that are used by the interactive and combined
-- proofs.

------------------------------------------------------------------------------
-- 1. Predicate logic

-- 1.1 Definition of the connectives and quantifiers
open import Common.LogicalConstants
open import PredicateLogic.Constants

-- 1.2 The law of the excluded middle
open import PredicateLogic.ClassicalATP

-- 1.3 Non-empty domains
open import PredicateLogic.NonEmptyDomain.TheoremsATP
open import PredicateLogic.NonEmptyDomain.TheoremsI

-- 1.4 Logical schemas
open import PredicateLogic.SchemasATP

-- 1.5 Propositional logic theorems
open import PredicateLogic.Propositional.TheoremsATP
open import PredicateLogic.Propositional.TheoremsI

-- 1.6 Predicate logic theorems
open import PredicateLogic.TheoremsATP
open import PredicateLogic.TheoremsI

------------------------------------------------------------------------------
-- 2. Equality

-- 2.1 Definition of equality and some properties about it
open import Common.Relation.Binary.PropositionalEquality

-- 2.2 The equality reasoning
open import Common.Relation.Binary.PreorderReasoning

------------------------------------------------------------------------------
-- 3. Group theory

-- 3.1 The axioms
open import GroupTheory.Base

-- 3.2 Basic properties
open import GroupTheory.PropertiesATP
open import GroupTheory.PropertiesI

-- 3.3 Commutator properties
open import GroupTheory.Commutator.PropertiesATP
open import GroupTheory.Commutator.PropertiesI

-- 3.4 Abelian groups
open import GroupTheory.AbelianGroup.PropertiesATP

------------------------------------------------------------------------------
-- 4. Stanovský example (distributive laws on a binary operation)

-- We prove the proposition 2 (task B) of [1]. Let _·_ be a
-- left-associative binary operation, the task B consist in given the
-- left and right distributive axioms

--   ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
--   ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z)

-- to prove the theorem

--   ∀ u x y z → (x ∙ y ∙ (z ∙ u)) ∙
--               (( x ∙ y ∙ ( z ∙ u)) ∙ (x ∙ z ∙ (y ∙ u))) ≡
--               x ∙ z ∙ (y ∙ u)

-- [1] David Stanovský. Distributive groupoids are symmetrical-by-medial:
--     An elementary proof. Commentations Mathematicae Universitatis
--     Carolinae, 49(4):541–546, 2008.

-- 4.1 The ATPs could not prove the theorem
open import DistributiveLaws.TaskB-ATP

-- 4.2 The interactive and combined proofs
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP

------------------------------------------------------------------------------
-- 5. Peano arithmetic (PA)

-- We write two formalizations of PA. In the axiomatic formalization
-- we use Agda postulates for Peano's axioms. In the inductive
-- formalization, we use Agda data types and primitive recursive
-- functions.

-- 5.1 Axiomatic PA
-- 5.1.1 The axioms
open import PA.Axiomatic.Base

-- 5.1.2 Some properties
open import PA.Axiomatic.PropertiesATP
open import PA.Axiomatic.PropertiesI

open import PA.Axiomatic.Relation.Binary.PropositionalEqualityATP
open import PA.Axiomatic.Relation.Binary.PropositionalEqualityI

-- 5.2. Inductive PA
-- 5.2.1 Some properties
open import PA.Inductive.Properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI

------------------------------------------------------------------------------
-- 6. FOTC

-- Formalization of (a version of) Azcel's First Order Theory of Combinators.

-- 6.1 The axioms
open import FOTC.Base

-- 6.2 Booleans

-- 6.2.2 The axioms
open import FOTC.Data.Bool

-- 6.2.3 Properties
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.PropertiesI

-- 6.3. Natural numbers

-- 6.3.1 The axioms
open import FOTC.Data.Nat

-- 6.3.2 Properties
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.PropertiesI

open import FOTC.Data.Nat.PropertiesByInductionATP
open import FOTC.Data.Nat.PropertiesByInductionI

-- 6.3.3 Divisibility relation
open import FOTC.Data.Nat.Divisibility.PropertiesATP
open import FOTC.Data.Nat.Divisibility.PropertiesI

-- 6.3.4 Induction
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI

-- 6.3.5 Inequalites
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesI

-- 6.3.6 Unary numbers
open import FOTC.Data.Nat.UnaryNumbers.IsN-ATP
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP

-- 6.4 Lists

-- 6.4.1 The axioms
open import FOTC.Data.List

-- 6.4.2 Properties
open import FOTC.Data.List.PropertiesATP
open import FOTC.Data.List.PropertiesI

-- 6.4.3 Well-founded induction
open import FOTC.Data.List.LT-Cons.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Cons.PropertiesI
open import FOTC.Data.List.LT-Length.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Length.PropertiesI

-- 6.4.4 Lists of natural numbers
open import FOTC.Data.Nat.List.PropertiesATP
open import FOTC.Data.Nat.List.PropertiesI

-- 6.5 Programs

-- 6.5.1 The Collatz function: A function without a termination proof
open import FOTC.Program.Collatz.PropertiesATP
open import FOTC.Program.Collatz.PropertiesI

-- 6.5.2 The GCD algorithm: A non-structurally recursive algorithm
open import FOTC.Program.GCD.ProofSpecificationATP
open import FOTC.Program.GCD.ProofSpecificationI

-- 6.5.3 The McCarthy 91 function: A function with nested recursion
open import FOTC.Program.McCarthy91.Properties.MainATP

-- 6.5.4 The mirror function: A function with higher-order recursion
open import FOTC.Program.Mirror.PropertiesATP
open import FOTC.Program.Mirror.PropertiesI

-- 6.5.5 Burstall's sort list algorithm: A structurally recursive algorithm
open import FOTC.Program.SortList.ProofSpecificationATP
open import FOTC.Program.SortList.ProofSpecificationI

------------------------------------------------------------------------------
-- ATPs failures
------------------------------------------------------------------------------

-- The ATPs (E, Equinox, Metis and Vampire) could not prove some
-- theorems.

-- This module was imported in the Stanovský example
-- open import DistributiveLaws.TaskB-ATP
open import LTC-PCF.Program.GCD.EquationsATP
open import PA.Axiomatic.PropertiesATP

------------------------------------------------------------------------------
-- Agsy examples
------------------------------------------------------------------------------

-- We cannot import the Agsy examples because some modules contain
-- unsolved metas, therefore see src/Agsy/README.txt

------------------------------------------------------------------------------
-- Other theories
------------------------------------------------------------------------------

-- 1. LTC-PCF
-- Formalization of a version of Azcel's Logical Theory of Constructions.
-- N.B. This was the theory shown in our PLPV'09 paper.

-- 1.1. The axioms
open import LTC-PCF.Base

-- 1.2 Natural numberes

-- 1.2.1 The axioms
open import LTC-PCF.Data.Nat

-- 1.2.2 Properties
open import LTC-PCF.Data.Nat.PropertiesATP
open import LTC-PCF.Data.Nat.PropertiesI

-- 1.2.3 Divisibility relation
open import LTC-PCF.Data.Nat.Divisibility.Properties
open import LTC-PCF.Data.Nat.Divisibility.PropertiesATP
open import LTC-PCF.Data.Nat.Divisibility.PropertiesI

-- 1.2.4 Induction
open import LTC-PCF.Data.Nat.Induction.NonAcc.LexicographicI
open import LTC-PCF.Data.Nat.Induction.NonAcc.WellFoundedInductionI

-- 1.2.5 Inequalites
open import LTC-PCF.Data.Nat.Inequalities.PropertiesATP
open import LTC-PCF.Data.Nat.Inequalities.PropertiesI

-- 1.2.6 The recursive operator
open import LTC-PCF.Data.Nat.Rec.EquationsATP
open import LTC-PCF.Data.Nat.Rec.EquationsI

-- 1.3 Programs

-- 1.3.1 The division algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.Division.ProofSpecificationATP
open import LTC-PCF.Program.Division.ProofSpecificationI

-- 1.3.2 The GCD algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.GCD.ProofSpecificationATP
open import LTC-PCF.Program.GCD.ProofSpecificationI