Bug reproducer for Agda 2.3.2

Bug reproducer for Agda 2.3.2

Old-commit-hash: c47ccb8a19ecffd481c881027a572370b1c961c3

-- Agda 2.3.2 bug reproducer.
-- On type check, expect to see:
--
-- An internal error has occured. Please report this
-- as a bug. Location of error:
-- src/full/agda/TypeChecking/Records.hs:216

module Bug where

open import Data.Product
open import Data.Nat using (ℕ)
open import Data.Unit using (⊤)

open import Relation.Binary.PropositionalEquality

open import Level using
  (zero ; Level ; suc)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)

postulate extensionality : Extensionality zero zero

data Type : Set where
  nats : Type
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

⟨∅⟩ : ∅ ≡ ∅
⟨∅⟩ = refl

_⟨•⟩_ : ∀ {τ₁ τ₂ Γ₁ Γ₂} → τ₁ ≡ τ₂ → Γ₁ ≡ Γ₂ → τ₁ • Γ₁ ≡ τ₂ • Γ₂
_⟨•⟩_ = cong₂ _•_

data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ τ τ′} → (x : Var Γ τ) → Var (τ′ • Γ) τ

data Term : Context -> Type -> Set where
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ
  nat : ∀ {Γ} → (n : ℕ) → Term Γ nats
  abs : ∀ {τ₁ τ₂ Γ} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁)
                   → Term Γ τ₂

  -- Change to nats = replacement Church pairs
  -- 3 -> 5 ::= λf. f 3 5

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

≼-reflexivity : Reflexive _≼_
≼-reflexivity {∅} = ∅≼∅
≼-reflexivity {τ • x} = keep τ • ≼-reflexivity

≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
≼-reflexive refl = ≼-reflexivity

≼-transitive : Transitive _≼_
≼-transitive ∅≼∅ rel1 = rel1
≼-transitive (keep τ • rel0) (keep .τ • rel1) =
  keep τ • ≼-transitive rel0 rel1
≼-transitive (keep τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (keep τ • rel0) rel1
≼-transitive (drop τ • rel0) (keep .τ • rel1) =
  drop τ • ≼-transitive rel0 rel1
≼-transitive (drop τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (drop τ • rel0) rel1

≼-isPreorder : IsPreorder _≡_ _≼_
≼-isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive = ≼-reflexive
  ; trans = ≼-transitive
  }

≼-preorder : Preorder _ _ _
≼-preorder = record
  { Carrier = Context
  ; _≈_ = _≡_
  ; isPreorder = ≼-isPreorder
  }

module ≼-reasoning where
  open import Relation.Binary.PreorderReasoning ≼-preorder public
    renaming
      ( _≈⟨_⟩_ to _≡⟨_⟩_
      ; _∼⟨_⟩_ to _≼⟨_⟩_
      ; _≈⟨⟩_ to _≡⟨⟩_
      )

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x

record Meaning (Syntax : Set) {ℓ : Level} : Set (suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

⟦_⟧Type : Type -> Set
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type
⟦ nats ⟧Type = ℕ

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ nat n ⟧Term ρ = n

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

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = cong₂ (λ x y → x y)

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = ≡-app (weaken-sound t₁ ρ) (weaken-sound t₂ ρ)
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

-- Changes to ℕ are replacement Church pairs. The only arguments
-- of conern are `fst` and `snd`, so the Church pairs don't have
-- to be polymorphic.

Δ-Type : Type → Type
Δ-Type nats = (nats ⇒ nats ⇒ nats) ⇒ nats
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂

-- It is clear that ⟦⊝⟧ exists on the semantic level:
-- there exists an Agda value to describe the change between any
-- two Agda values denoted by terms. If we have (not dependently-
-- typed) arrays, no term denotes the change between two arrays
-- of different lengths. Thus no full abstraction.

⟦derive⟧ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

infixl 6 _⟦⊕⟧_
infixl 6 _⟦⊝⟧_

⟦fst⟧ : ℕ → ℕ → ℕ
⟦snd⟧ : ℕ → ℕ → ℕ

⟦derive⟧ {τ₁ ⇒ τ₂} f = λ v dv → f (v ⟦⊕⟧ dv) ⟦⊝⟧ f v
⟦derive⟧ {nats} n = λ f → f n n

_⟦⊝⟧_ {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → f₁ (v ⟦⊕⟧ dv) ⟦⊝⟧ f₂ v
_⟦⊝⟧_ {nats} m n = λ f → f n m
-- m ⟦⊝⟧ n ::= replace n by m

_⟦⊕⟧_ {τ₁ ⇒ τ₂} f df = λ v → f v ⟦⊕⟧ df v (⟦derive⟧ v)
_⟦⊕⟧_ {nats} n dn = dn ⟦snd⟧

⟦fst⟧ m n = m
⟦snd⟧ m n = n

-- Strong validity!
data ⟦ValidΔ⟧ : {τ : Type} → (v : ⟦ τ ⟧) → (dv : ⟦ Δ-Type τ ⟧) → Set where
  -- Following Pierce's case names `T-Var`, `T-Abs`, `T-App`
  -- with Agda's capitalization convention
  -- generalized to the semantic (value) domain
  v-nat : (n : ℕ) → (dn : (ℕ → ℕ → ℕ) → ℕ) →
          n ≡ dn ⟦fst⟧ →
          ⟦ValidΔ⟧ n dn

  v-fun : {τ₁ τ₂ : Type} →
          (f : ⟦ τ₁ ⇒ τ₂ ⟧) → (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) →
          -- A strong antecedent: f and df map invalid changes to
          -- valid changes! So long as invalid changes exist,
          -- this is NOT satisfied by
          --
          --      f = ⟦ λ x. x ⟧     = identity
          --     df = ⟦ λ x dx. dx ⟧ = ⟦snd⟧,
          --
          -- negating any hope of ⟦ValidΔ⟧ ⟦ t ⟧ ⟦ derive t ⟧.
          (∀ {s ds} → {-ValidΔ s ds →-} ⟦ValidΔ⟧ (f s) (df s ds)) →
          (∀ {s ds} → (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ (f s ⟦⊕⟧ df s ds)) →
          ⟦ValidΔ⟧ f df

absurdity-of-0=1 : 0 ≡ 1 → (∀ {A : Set} → A)
absurdity-of-0=1 ()

it-is-absurd-that : ⟦ValidΔ⟧ {nats} 0 (λ f → f 1 1) → (∀ {A : Set} → A)
it-is-absurd-that (v-nat .0 .(λ f → f 1 1) 0=1) = absurdity-of-0=1 0=1

-- If (λ x dx → dx) is a ⟦ValidΔ⟧ to (λ x → x),
-- then impossible is nothing.
no-way : ⟦ValidΔ⟧ {nats ⇒ nats} (λ x → x) (λ x dx → dx) →
         (∀ {A : Set} → A)
no-way (v-fun .(λ x → x) .(λ x dx → dx) validity correctness) =
  it-is-absurd-that (validity {0} {λ f → f 1 1})

-- Cool lemmas

f⟦⊝⟧f=⟦deriv⟧f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊝⟧ f ≡ ⟦derive⟧ f
f⟦⊝⟧f=⟦deriv⟧f {nats} f = refl
f⟦⊝⟧f=⟦deriv⟧f {τ₁ ⇒ τ₂} f = refl

f⊕[g⊝f]=g : ∀ {τ : Type} (f g : ⟦ τ ⟧) → f ⟦⊕⟧ (g ⟦⊝⟧ f) ≡ g

f⊕Δf=f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊕⟧ (⟦derive⟧ f) ≡ f

f⊕[g⊝f]=g {nats} m n = refl
f⊕[g⊝f]=g {τ₁ ⇒ τ₂} f g = extensionality (λ x →
    begin
      (f ⟦⊕⟧ (g ⟦⊝⟧ f)) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (g (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong₂ _⟦⊕⟧_
            {x = f x} {y = f x} refl
            (cong₂ _⟦⊝⟧_ (cong g (f⊕Δf=f x)) refl) ⟩
      f x ⟦⊕⟧ (g x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (g x) ⟩
      g x
    ∎
  ) where open ≡-Reasoning

f⊕Δf=f {nats} n = refl
f⊕Δf=f {τ₁ ⇒ τ₂} f = extensionality (λ x →
    begin
      (f ⟦⊕⟧ ⟦derive⟧ f) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (f (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong (λ hole → f x ⟦⊕⟧ (f hole ⟦⊝⟧ f x)) (f⊕Δf=f x) ⟩
      f x ⟦⊕⟧ (f x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (f x) ⟩
      f x
    ∎
  ) where open ≡-Reasoning

valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid-Δ {nats} n dn = n ≡ dn ⟦fst⟧
valid-Δ {τ₁ ⇒ τ₂} f df =
  ∀ (s : ⟦ τ₁ ⟧) (ds : ⟦ Δ-Type τ₁ ⟧) (R[s,ds] : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×              -- (valid-Δ:1)
    (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ f s ⟦⊕⟧ df s ds -- (valid-Δ:2)

R[f,g⊝f] : ∀ {τ} (f g : ⟦ τ ⟧) → valid-Δ {τ} f (g ⟦⊝⟧ f)
R[f,g⊝f] {nats} m n = refl
R[f,g⊝f] {τ₁ ⇒ τ₂} f g = λ x dx R[x,dx] →
  R[f,g⊝f] {τ₂} (f x) (g (x ⟦⊕⟧ dx)) -- (valid-Δ:1)
  , -- tuple constructor
  (begin
    (f ⟦⊕⟧ (g ⟦⊝⟧ f)) (x ⟦⊕⟧ dx)
  ≡⟨ refl ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧
      (g ((x ⟦⊕⟧ dx) ⟦⊕⟧ ⟦derive⟧ (x ⟦⊕⟧ dx)) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ cong (λ hole → f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g hole ⟦⊝⟧ f (x ⟦⊕⟧ dx)))
          (f⊕Δf=f (x ⟦⊕⟧ dx)) ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g (x ⟦⊕⟧ dx) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ f⊕[g⊝f]=g (f (x ⟦⊕⟧ dx)) (g (x ⟦⊕⟧ dx)) ⟩
    g (x ⟦⊕⟧ dx)
  ≡⟨ sym (f⊕[g⊝f]=g (f x) (g (x ⟦⊕⟧ dx))) ⟩
      f x ⟦⊕⟧ (g ⟦⊝⟧ f) x dx
  ∎)
  where open ≡-Reasoning

R[f,Δf] : ∀ {τ} (f : ⟦ τ ⟧) → valid-Δ {τ} f (⟦derive⟧ f)
R[f,Δf] f rewrite sym (f⟦⊝⟧f=⟦deriv⟧f f) = R[f,g⊝f] f f

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ -- push τ, then push Δτ.

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • (keep τ • Γ≼ΔΓ)

-- Data type to hold proofs that environments are valid
data Valid-Δenv : {Γ : Context} (ρ : ⟦ Γ ⟧) (Δρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is its own valid Δ-environment.
  ρ=∅ : Valid-Δenv {∅} ∅ ∅
  -- Induction case: the change introduced therein should be valid,
  -- and the smaller Δ-environment should be valid as well.
  ρ=v•ρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
            {Γ₀ : Context} {ρ₀ : ⟦ Γ₀ ⟧} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
            valid-Δ v dv → Valid-Δenv ρ₀ dρ₀ →
            Valid-Δenv {τ • Γ₀} (v • ρ₀) (dv • v • dρ₀)

-- Data type to hold proofs that a Δ-env is consistent with self
data Consistent-Δenv : {Γ : Context} (dρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is consistent with itself
  dρ=∅ : Consistent-Δenv {∅} ∅
  -- Induction case: the change introduced at top level
  -- should be valid.
  dρ=dv•v•dρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
                 {Γ₀ : Context} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
                 valid-Δ v dv → Consistent-Δenv dρ₀ →
                 Consistent-Δenv {τ • Γ₀} (dv • v • dρ₀)

-- If a Δ-environment is valid for some other environment,
-- then it is also consistent with itself.

valid-Δenv-is-consistent :
   ∀ {Γ : Context} {ρ : ⟦ Γ ⟧} {dρ : ⟦ Δ-Context Γ ⟧} →
    Valid-Δenv ρ dρ → Consistent-Δenv dρ

valid-Δenv-is-consistent ρ=∅ = dρ=∅
valid-Δenv-is-consistent (ρ=v•ρ₀ valid[v,dv] valid[ρ₀,dρ₀]) =
  dρ=dv•v•dρ₀ valid[v,dv] (valid-Δenv-is-consistent valid[ρ₀,dρ₀])

-- finally, update and ignore

update : ∀ {Γ} → (dρ : ⟦ Δ-Context Γ ⟧) → {_ : Consistent-Δenv dρ} → ⟦ Γ ⟧
update {∅} ∅ {dρ=∅} = ∅
update {τ • Γ} (dv • v • dρ) {dρ=dv•v•dρ₀ valid[v,dv] consistent[dρ₀]} =
  (v ⟦⊕⟧ dv) • update dρ {consistent[dρ₀]}

-- Ignorance is bliss (don't have to pass consistency proofs around :D)

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore = ⟦ Γ≼ΔΓ ⟧ -- Using a proof to describe computation

-- Naming scheme follows weakenVar/weaken

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

derive : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)

-- derive(n) = λf. f n n
derive (nat n) = abs (app (app (var this) (nat n)) (nat n))

-- derive(x) = dx
derive (var x) = var (deriveVar x)

-- derive(λx. t) = λx. λdx. derive(t)
derive (abs t) = abs (abs (derive t))

-- derive(f s) = derive(f) s derive(s)
derive (app f s) = app (app (derive f) (weaken Γ≼ΔΓ s)) (derive s)

-- Extensional equivalence for changes
data as-Δ_is_ext-equiv-to_ :
  ∀ (τ : Type) → (df : ⟦ Δ-Type τ ⟧) → (dg : ⟦ Δ-Type τ ⟧) → Set where
  ext-Δ : ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
          (∀ (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg →
             (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)) →
          as-Δ τ is df ext-equiv-to dg

infix 3 as-Δ_is_ext-equiv-to_

-- Extractor for extensional-equivalence-as-changes:
-- Given a value of the data type holding the proof,
-- returns the proof in applicable form.
--
-- Question: Would it not have been better if such
-- proof-holding types were defined as a function in
-- the first place, say in the manner of `valid-Δ`?
--
extract-Δequiv :
  ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
    as-Δ τ is df ext-equiv-to dg →
    (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg → (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)

extract-Δequiv (ext-Δ proof-method) = proof-method

-- Distribution lemmas of validity over ⟦⊝⟧ and ⟦⊕⟧

application-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v) ≡ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
application-over-⊕-and-⊝ f g df v =
  begin
    f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v
  ≡⟨ cong₂ _⟦⊝⟧_
       (cong₂ _⟦⊕⟧_
         (cong f ((sym (f⊕Δf=f v))))
         (cong₂ df
           (sym (f⊕Δf=f v))
           (cong ⟦derive⟧ (sym (f⊕Δf=f v)))))
       refl ⟩
    f (v ⟦⊕⟧ ⟦derive⟧ v)
    ⟦⊕⟧ df (v ⟦⊕⟧ ⟦derive⟧ v) (⟦derive⟧ (v ⟦⊕⟧ ⟦derive⟧ v))
    ⟦⊝⟧ f v
  ≡⟨ refl ⟩
   (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
  ∎ where open ≡-Reasoning

validity-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    valid-Δ g (f ⟦⊕⟧ df ⟦⊝⟧ f) →
    valid-Δ (g v) (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
validity-over-⊕-and-⊝ f g df v R[g,f⊕df]
  rewrite application-over-⊕-and-⊝ f g df v =
    proj₁ (R[g,f⊕df] v (⟦derive⟧ v) (R[f,Δf] v))

-- diff-apply
df=f⊕df⊝f :
  ∀ {τ} (f : ⟦ τ ⟧) (df : ⟦ Δ-Type τ ⟧) →
    valid-Δ f df → as-Δ τ is df ext-equiv-to f ⟦⊕⟧ df ⟦⊝⟧ f

-- Case nat: this REFL is more obvious to Agda than to a human.
df=f⊕df⊝f {nats} n dn valid-f-df =
  ext-Δ (λ m valid-m-dn valid-rhs → refl)

df=f⊕df⊝f {τ₁ ⇒ τ₂} f df R[f,df] = ext-Δ (
  λ g R[g,df] R[g,f⊕df⊝f] →
    extensionality (λ v →
      begin
        g v ⟦⊕⟧ df v (⟦derive⟧ v)
      ≡⟨ extract-Δequiv
           (df=f⊕df⊝f
             (f v) (df v (⟦derive⟧ v))
             (proj₁ (R[f,df] v (⟦derive⟧ v) (R[f,Δf] v))))
           (g v)
           (proj₁ (R[g,df] v (⟦derive⟧ v) (R[f,Δf] v)))
           (validity-over-⊕-and-⊝ f g df v R[g,f⊕df⊝f]) ⟩
        g v ⟦⊕⟧ (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
      ≡⟨ cong₂ _⟦⊕⟧_
           {x = g v} {y = g v} refl
           (application-over-⊕-and-⊝ f g df v) ⟩
        g v ⟦⊕⟧ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
      ∎
    )
  )
  where open ≡-Reasoning

correctness-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  as-Δ τ is
  ⟦ deriveVar x ⟧ ρ
  ext-equiv-to
  ⟦ x ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ x ⟧ (ignore ρ)

correctness-of-deriveVar {τ • Γ₀} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  this = df=f⊕df⊝f v dv ?
  --Putting `df=f⊕df⊝f v dv ?` on RHS triggers Agda bug.
  --TODO: Report it as Agda tells us to.

correctness-of-deriveVar {τ₀ • Γ₀} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ₀} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  (that x) = correctness-of-deriveVar ρ x

error: pathspec 'nats/Bug.agda' did not match any file(s) known to git


[ note ] Testing timeout for arithmetical properties.

------------------------------------------------------------------------------
-- Testing normalisation on arithmetic properties
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.Inequalities.ArithmeticPropertiesSL where

open import Data.Nat
open import Relation.Binary.PropositionalEquality

101≡100+11∸10 : 101 ≡ 100 + 11 ∸ 10
101≡100+11∸10 = refl

91≡100+11∸10∸10 : 91 ≡ 100 + 11 ∸ 10 ∸ 10
91≡100+11∸10∸10 = refl

-- Agsy failed using a timeout of 5 minutes and it succeed with a
-- timeout of 10 minutes.
100+11>100 : 100 + 11 > 100
100+11>100 = s≤s
               (s≤s
                (s≤s
                 (s≤s
                  (s≤s
                   (s≤s
                    (s≤s
                     (s≤s
                      (s≤s
                       (s≤s
                        (s≤s
                         (s≤s
                          (s≤s
                           (s≤s
                            (s≤s
                             (s≤s
                              (s≤s
                               (s≤s
                                (s≤s
                                 (s≤s
                                  (s≤s
                                   (s≤s
                                    (s≤s
                                     (s≤s
                                      (s≤s
                                       (s≤s
                                        (s≤s
                                         (s≤s
                                          (s≤s
                                           (s≤s
                                            (s≤s
                                             (s≤s
                                              (s≤s
                                               (s≤s
                                                (s≤s
                                                 (s≤s
                                                  (s≤s
                                                   (s≤s
                                                    (s≤s
                                                     (s≤s
                                                      (s≤s
                                                       (s≤s
                                                        (s≤s
                                                         (s≤s
                                                          (s≤s
                                                           (s≤s
                                                            (s≤s
                                                             (s≤s
                                                              (s≤s
                                                               (s≤s
                                                                (s≤s
                                                                 (s≤s
                                                                  (s≤s
                                                                   (s≤s
                                                                    (s≤s
                                                                     (s≤s
                                                                      (s≤s
                                                                       (s≤s
                                                                        (s≤s
                                                                         (s≤s
                                                                          (s≤s
                                                                           (s≤s
                                                                            (s≤s
                                                                             (s≤s
                                                                              (s≤s
                                                                               (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                (s≤s
                                                                                z≤n))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

error: pathspec 'notes/FOT/FOTC/Data/Nat/Inequalities/ArithmeticPropertiesSL.agda' did not match any file(s) known to git


Add substitution (and subst. lemma)

Add substitution (and subst. lemma)

fatal: unable to access 'https://github.com/inc-lc/ilc-agda.git/': The requested URL returned error: 403


Added draft on inductive predicates for representating FOTC functions.

Ignore-this: a8a69744dc25bf0d0428a6f96bb7bbb

darcs-hash:20120313144819-3bd4e-1c025eb4919a5c7f1ec28208bd7854b1e6934ed9.gz

------------------------------------------------------------------------------
-- An inductive predicate for representing functions
------------------------------------------------------------------------------

-- Tested with FOT on 13 March 2012.

module Draft.FOTC.Data.Fun where

open import FOTC.Base

------------------------------------------------------------------------------
-- 2012-03-13. I don't see how we can distinguish between data
-- elements and functions in FOTC. The following inductive predicate
-- is true for any element d : D.
data Fun : D → Set where
  fun : (f : D) → Fun f

-- But using a lambda-abstraction we could make a distinguish:
postulate lam : (D → D) → D  -- LTC-PCF abstraction.

data Fun₁ : D → Set where
  fun₁ : (f : D → D) → Fun₁ (lam f)

error: pathspec 'Draft/FOTC/Data/Fun.agda' did not match any file(s) known to git


Added a bug.

Added a bug.

Ignore-this: c70dea8476b482629247a87e2ec3066e

darcs-hash:20120314150816-3bd4e-6472f54bd5cb96331c848d448b2b0ff54b2ab9b6.gz

error: pathspec 'Bugs/BadErase.agda' did not match any file(s) known to git


open import Function
open import Data.Product.NP
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
open import Algebra.FunctionProperties.Eq
open ≡-Reasoning

module Algebra.Group where

record Group-Ops {ℓ} (G : Set ℓ) : Set ℓ where
  infixl 7 _∙_ _/_

  field
    _∙_ : G → G → G
    ε   : G
    _⁻¹ : G → G

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

record Group-Struct {ℓ} {G : Set ℓ} (grp-ops : Group-Ops G) : Set ℓ where
  open Group-Ops grp-ops

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

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

  /= : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → x / y ≡ x' / y'
  /= {x} {y' = y'} p q = ap (_/_ x) q ♦ ap (λ z → z / y') p

  ∙-/ : ∀ {x y} → x ≡ (x ∙ y) / y
  ∙-/ {x} {y}
    = x            ≡⟨ ! snd identity ⟩
      x ∙ ε        ≡⟨ ap (_∙_ x) (! snd inverse) ⟩
      x ∙ (y / y)  ≡⟨ ! assoc ⟩
      (x ∙ y) / y  ∎

  /-∙ : ∀ {x y} → x ≡ (x / y) ∙ y
  /-∙ {x} {y}
    = x               ≡⟨ ! snd identity ⟩
      x ∙ ε           ≡⟨ ap (_∙_ x) (! fst inverse) ⟩
      x ∙ (y ⁻¹ ∙ y)  ≡⟨ ! assoc ⟩
      (x / y) ∙ y     ∎

  unique-ε : ∀ {x y} → x ∙ y ≡ y → x ≡ ε
  unique-ε {x} {y} eq
    = x            ≡⟨ ∙-/ ⟩
      (x ∙ y) / y  ≡⟨ /= eq idp ⟩
      y / y        ≡⟨ snd inverse ⟩
      ε            ∎

  unique-⁻¹ : ∀ {x y} → x ∙ y ≡ ε → x ≡ y ⁻¹
  unique-⁻¹ {x} {y} eq
    = x            ≡⟨ ∙-/ ⟩
      (x ∙ y) / y  ≡⟨ /= eq idp ⟩
      ε / y        ≡⟨ fst identity ⟩
      y ⁻¹         ∎

  cancels-∙ : ∀ {x y z} → x ∙ y ≡ x ∙ z → y ≡ z
  cancels-∙ {x} {y} {z} e
    = y              ≡⟨ ! fst identity ⟩
      ε ∙ y          ≡⟨ ∙= (! fst inverse) idp ⟩
      x ⁻¹ ∙ x ∙ y   ≡⟨ assoc ⟩
      x ⁻¹ ∙ (x ∙ y) ≡⟨ ∙= idp e ⟩
      x ⁻¹ ∙ (x ∙ z) ≡⟨ ! assoc ⟩
      x ⁻¹ ∙ x ∙ z   ≡⟨ ∙= (fst inverse) idp ⟩
      ε ∙ z          ≡⟨ fst identity ⟩
      z ∎

  ⁻¹-hom′ : ∀ {x y} → (x ∙ y)⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
  ⁻¹-hom′ {x} {y} = cancels-∙ {x ∙ y}
     ((x ∙ y) ∙ (x ∙ y)⁻¹     ≡⟨ snd inverse ⟩
      ε                       ≡⟨ ! snd inverse ⟩
      x ∙ x ⁻¹                ≡⟨ ap (_∙_ x) (! fst identity) ⟩
      x ∙ (ε ∙ x ⁻¹)          ≡⟨ ∙= idp (∙= (! snd inverse) idp) ⟩
      x ∙ ((y ∙ y ⁻¹) ∙ x ⁻¹) ≡⟨ ap (_∙_ x) assoc ⟩
      x ∙ (y ∙ (y ⁻¹ ∙ x ⁻¹)) ≡⟨ ! assoc ⟩
      (x ∙ y) ∙ (y ⁻¹ ∙ x ⁻¹) ∎)

record Group (G : Set) : Set where
  field
    grp-ops    : Group-Ops G
    grp-struct : Group-Struct grp-ops
  open Group-Ops    grp-ops    public
  open Group-Struct grp-struct public

record Abelian-Group-Struct {ℓ} {G : Set ℓ} (grp-ops : Group-Ops G) : Set ℓ where
  open Group-Ops grp-ops
  field
    grp-struct : Group-Struct grp-ops
    comm : Commutative _∙_
  open Group-Struct grp-struct

  assoc-comm : ∀ {x y z} → x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
  assoc-comm = ! assoc ♦ ∙= comm idp ♦ assoc

  interchange : Interchange _∙_ _∙_
  interchange = InterchangeFromAssocComm.·-interchange _∙_ assoc comm

  ⁻¹-hom : ∀ {x y} → (x ∙ y)⁻¹ ≡ x ⁻¹ ∙ y ⁻¹
  ⁻¹-hom = ⁻¹-hom′ ♦ comm

  split-/-∙ : ∀ {x y z t} → (x ∙ y) / (z ∙ t) ≡ (x / z) ∙ (y / t)
  split-/-∙ {x} {y} {z} {t}
    = (x ∙ y)    / (z ∙ t)       ≡⟨by-definition⟩
      (x ∙ y)    ∙ (z ∙ t)⁻¹     ≡⟨ ∙= idp ⁻¹-hom ⟩
      (x ∙ y)    ∙ (z ⁻¹ ∙ t ⁻¹) ≡⟨ assoc ⟩
      x ∙ (y    ∙ (z ⁻¹ ∙ t ⁻¹)) ≡⟨ ∙= idp assoc-comm ⟩
      x ∙ (z ⁻¹ ∙ (y ∙ t ⁻¹))    ≡⟨ ! assoc ⟩
      (x ∙ z ⁻¹) ∙ (y ∙ t ⁻¹)    ≡⟨by-definition⟩
      (x / z) ∙ (y / t) ∎

  cancels-/ : ∀ {x y z} → (x ∙ y) / (x ∙ z) ≡ y / z
  cancels-/ {x} {y} {z}
    = (x ∙ y) / (x ∙ z) ≡⟨ split-/-∙ ⟩
      (x / x) ∙ (y / z) ≡⟨ ap (λ u →  u ∙ (y / z)) (snd inverse) ⟩
      ε ∙ (y / z)       ≡⟨ fst identity ⟩
      y / z ∎

record Abelian-Group (G : Set) : Set where
  field
    grp-ops    : Group-Ops G
    grp-comm   : Abelian-Group-Struct grp-ops
  open Group-Ops    grp-ops    public
  open Abelian-Group-Struct grp-comm public
  open Group-Struct grp-struct public
  grp : Group G
  grp = record { grp-struct = grp-struct }

-- A renaming of Group with additive notation
module Additive-Group {G} (grp : Group G) = Group grp
    renaming ( _∙_ to _+_; ε to 0ᵍ; _⁻¹ to 0-_; _/_ to _−_
             ; assoc to +-assoc; identity to +-identity
             ; inverse to 0--inverse
             ; ∙-/ to +-−; /-∙ to −-+; unique-ε to unique-0ᵍ; unique-⁻¹ to unique-0-
             ; cancels-∙ to cancels-+
             ; ⁻¹-hom′ to 0--hom′
             ; ∙= to +=; /= to −=)

-- A renaming of Group with multiplicative notation
module Multiplicative-Group {G} (grp : Group G) = Group grp
    using    ( _⁻¹; unique-⁻¹; _/_; /=; ⁻¹-hom′ )
    renaming ( _∙_ to _*_; ε to 1ᵍ
             ; assoc to *-assoc; identity to *-identity
             ; inverse to ⁻¹-inverse
             ; ∙-/ to *-/; /-∙ to /-*; unique-ε to unique-1ᵍ
             ; cancels-∙ to cancels-*
             ; ∙= to *= )

module Additive-Abelian-Group {G} (grp-comm : Abelian-Group G)
  = Abelian-Group grp-comm
    renaming ( _∙_ to _+_; ε to 0ᵍ; _⁻¹ to 0-_; _/_ to _−_
             ; assoc to +-assoc; identity to +-identity
             ; inverse to 0--inverse
             ; ∙-/ to +-−; /-∙ to −-+; unique-ε to unique-0ᵍ; unique-⁻¹ to unique-0-
             ; ∙= to +=; /= to −=
             ; assoc-comm to +-assoc-comm
             ; interchange to +-interchange
             ; ⁻¹-hom to 0--hom
             ; split-/-∙ to split-−-+
             ; cancels-/ to cancels-−)

module Multiplicative-Abelian-Group {G} (grp : Abelian-Group G) = Abelian-Group grp
    using    ( _⁻¹; unique-⁻¹; _/_; /=; ⁻¹-hom′
             ; ⁻¹-hom
             ; cancels-/ )
    renaming ( _∙_ to _*_; ε to 1ᵍ
             ; assoc to *-assoc; identity to *-identity
             ; inverse to ⁻¹-inverse
             ; ∙-/ to *-/; /-∙ to /-*; unique-ε to unique-1ᵍ
             ; cancels-∙ to cancels-*
             ; ∙= to *=
             ; assoc-comm to *-assoc-comm
             ; interchange to *-interchange
             ; split-/-∙ to split-/-* )

module _ {A B : Set}(grpA0+ : Group A)(grpB1* : Group B) where
  open Additive-Group grpA0+
  open Multiplicative-Group grpB1*

  GroupHomomorphism : (A → B) → Set
  GroupHomomorphism f = ∀ {x y} → f (x + y) ≡ f x * f y

  -- TODO
  -- If you are looking for a proof of:
  --   f (Σ(xᵢ∈A) g(x₁)) ≡ Π(xᵢ∈A) (f(g(xᵢ)))
  -- Have a look to:
  --   https://github.com/crypto-agda/explore/blob/master/lib/Explore/GroupHomomorphism.agda

  module GroupHomomorphismProp {f}(f-homo : GroupHomomorphism f) where
    f-pres-unit : f 0ᵍ ≡ 1ᵍ
    f-pres-unit = unique-1ᵍ part
      where part = f 0ᵍ * f 0ᵍ  ≡⟨ ! f-homo ⟩
                   f (0ᵍ + 0ᵍ)  ≡⟨ ap f (fst +-identity) ⟩
                   f 0ᵍ         ∎

    f-pres-0ᵍ-1ᵍ = f-pres-unit

    f-pres-inv : ∀ {x} → f (0- x) ≡ (f x)⁻¹
    f-pres-inv {x} = unique-⁻¹ part
      where part = f (0- x) * f x  ≡⟨ ! f-homo ⟩
                   f (0- x + x)    ≡⟨ ap f (fst 0--inverse) ⟩
                   f 0ᵍ            ≡⟨ f-pres-unit ⟩
                   1ᵍ              ∎

    f-0--⁻¹ = f-pres-inv

    f-−-/ : ∀ {x y} → f (x − y) ≡ f x / f y
    f-−-/ {x} {y} = f (x − y)       ≡⟨ f-homo ⟩
                    f x * f (0- y)  ≡⟨ ap (_*_ (f x)) f-pres-inv ⟩
                    f x / f y       ∎

-- -}
-- -}
-- -}
-- -}

error: pathspec 'lib/Algebra/Group.agda' did not match any file(s) known to git


Experiment: Example 3 with `inc` as a primitive
Speed-up is conceivable: The derivative of `inc` operates on the
change alone and not on the original bag (see line 374):

    derive (inc b) = inc (derive b)

where `b` is a term of type `bags`.

Old-commit-hash: d8eb6ddab9bc78bbd97ab1d3596eeb59630b4fa8

{-
The goal of this file is to make the 3rd example
described in /examples.md, "Map.mapValues", fast,
by having `inc` as a primitive, before tackling
the somewhat harder task of having some form of
`isNil` available during the derivation process.

    inc :: Bag Integer -> Bag Integer
    inc = map (+1)

    old = fromList [1, 2 .. n - 1, n]
    res = inc old = [2, 3 .. n, n + 1]
-}

module IncBag where

open import Data.NatBag renaming
  (map to mapBag ; empty to emptyBag ; update to updateBag)
open import Relation.Binary.PropositionalEquality

-- This module has holes and can't be imported.
-- We postulate necessary properties now to be able
-- to work on derivation and remove them later.
--
-- Perhaps proving that bags form a group with
-- emptyBag, ++, \\ is a necessity?
--
-- open import Data.NatBag.Properties
postulate b\\b=∅ : ∀ {{b : Bag}} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {{b : Bag}} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {{b : Bag}} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  map-over-\\ : ∀ {b d f} →
    mapBag f (b \\ d) ≡ mapBag f b \\ mapBag f d

open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level
import Data.Product as Product

postulate extensionality : Extensionality Level.zero Level.zero

data Type : Set where
  nats : Type
  bags : Type
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

data Var : Context → Type → Set where
  this : ∀ {τ Γ} → Var (τ • Γ) τ
  that : ∀ {τ τ′ Γ} → (x : Var Γ τ) → Var (τ′ • Γ) τ

data Term : Context -> Type -> Set where

  nat : ∀ {Γ} → (n : ℕ) → Term Γ nats
  bag : ∀ {Γ} → (b : Bag) → Term Γ bags
  inc : ∀ {Γ} → (b : Term Γ bags) → Term Γ bags

  var : ∀ {τ Γ} → (x : Var Γ τ) → Term Γ τ
  abs : ∀ {τ₁ τ₂ Γ} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁)
                   → Term Γ τ₂

  -- Change to nats = replacement Church pairs
  -- 3 -> 5 ::= λf. f 3 5

  -- Change to bags = a summand
  -- b₁ -> b₂ ::= b₂ \\ b₁

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

Γ≼Γ : ∀ {Γ} → Γ ≼ Γ
Γ≼Γ {∅} = ∅≼∅
Γ≼Γ {τ • Γ} = keep τ • Γ≼Γ {Γ}

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x
weaken subctx (bag b) = bag b
weaken subctx (inc b) = inc (weaken subctx b)

record Meaning (Syntax : Set) {ℓ : Level.Level} : Set (Level.suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

⟦_⟧Type : Type -> Set
⟦ nats ⟧Type = ℕ
⟦ bags ⟧Type = Bag
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

identity-weakening : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
identity-weakening {∅} {∅} = refl
identity-weakening {τ • Γ} {v • ρ} =
  cong₂ _•_ {x = v} refl (identity-weakening {Γ} {ρ})

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ nat n ⟧Term ρ = n
⟦ bag b ⟧Term ρ = b
⟦ inc b ⟧Term ρ = mapBag suc (⟦ b ⟧Term ρ)

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

_⟨$⟩_ : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
_⟨$⟩_ = cong₂ (λ x y → x y)

-- infix 0 $ in Haskell
infixl 0 _⟨$⟩_

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = weaken-sound t₁ ρ ⟨$⟩ weaken-sound t₂ ρ
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (bag b) ρ = refl
weaken-sound (inc b) ρ = cong (mapBag suc) (weaken-sound b ρ)

-- Changes to ℕ are replacement Church pairs. The only arguments
-- of conern are `fst` and `snd`, so the Church pairs don't have
-- to be polymorphic.
--
-- Changes on bags are bags. They allow negative multiplicities
-- to begin with.

Δ-Type : Type → Type
Δ-Type nats = (nats ⇒ nats ⇒ nats) ⇒ nats
Δ-Type bags = bags
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ -- push τ, then push Δτ.

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • (keep τ • Γ≼ΔΓ)

-- It is clear that ⟦⊝⟧ exists on the semantic level:
-- there exists an Agda value to describe the change between any
-- two Agda values denoted by terms. If we have (not dependently-
-- typed) arrays, no term denotes the change between two arrays
-- of different lengths. Thus no full abstraction.

_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

infixl 6 _⟦⊕⟧_
infixl 6 _⟦⊝⟧_

⟦fst⟧ ⟦snd⟧ : ℕ → ℕ → ℕ
⟦fst⟧ m n = m
⟦snd⟧ m n = n

fst snd : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
fst = abs (abs (var (that this)))
snd = abs (abs (var this))

⟦derive⟧ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
⟦derive⟧ {nats} n = λ f → f n n
⟦derive⟧ {bags} b = emptyBag
⟦derive⟧ {τ₁ ⇒ τ₂} f = λ v dv → f (v ⟦⊕⟧ dv) ⟦⊝⟧ f v

_⟦⊝⟧_ {nats} m n = λ f → f n m
_⟦⊝⟧_ {bags} b₁ b₂ = b₁ \\ b₂
_⟦⊝⟧_ {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → f₁ (v ⟦⊕⟧ dv) ⟦⊝⟧ f₂ v
-- m ⟦⊝⟧ n ::= replace n by m

_⟦⊕⟧_ {nats} n dn = dn ⟦snd⟧
_⟦⊕⟧_ {bags} b db = b ++ db
_⟦⊕⟧_ {τ₁ ⇒ τ₂} f df = λ v → f v ⟦⊕⟧ df v (⟦derive⟧ v)

-- Cool lemmas

f⟦⊝⟧f=⟦deriv⟧f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊝⟧ f ≡ ⟦derive⟧ f
f⟦⊝⟧f=⟦deriv⟧f {nats} f = refl
f⟦⊝⟧f=⟦deriv⟧f {bags} b = b\\b=∅
f⟦⊝⟧f=⟦deriv⟧f {τ₁ ⇒ τ₂} f = refl

f⊕[g⊝f]=g : ∀ {τ : Type} (f g : ⟦ τ ⟧) → f ⟦⊕⟧ (g ⟦⊝⟧ f) ≡ g

f⊕Δf=f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊕⟧ (⟦derive⟧ f) ≡ f

f⊕[g⊝f]=g {nats} m n = refl
f⊕[g⊝f]=g {bags} b₁ b₂ = b++[d\\b]=d {b₁} {b₂}
f⊕[g⊝f]=g {τ₁ ⇒ τ₂} f g = extensionality (λ x →
    begin
      (f ⟦⊕⟧ (g ⟦⊝⟧ f)) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (g (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong₂ _⟦⊕⟧_
            {x = f x} {y = f x} refl
            (cong₂ _⟦⊝⟧_ (cong g (f⊕Δf=f x)) refl) ⟩
      f x ⟦⊕⟧ (g x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (g x) ⟩
      g x
    ∎
  ) where open ≡-Reasoning

f⊕Δf=f {nats} n = refl
f⊕Δf=f {bags} b = b++∅=b
f⊕Δf=f {τ₁ ⇒ τ₂} f = extensionality (λ x →
    begin
      (f ⟦⊕⟧ ⟦derive⟧ f) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (f (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong (λ hole → f x ⟦⊕⟧ (f hole ⟦⊝⟧ f x)) (f⊕Δf=f x) ⟩
      f x ⟦⊕⟧ (f x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (f x) ⟩
      f x
    ∎
  ) where open ≡-Reasoning

valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid-Δ {nats} n dn = n ≡ dn ⟦fst⟧
valid-Δ {bags} b db = ⊤ -- all bags are vald for all other bags
valid-Δ {τ₁ ⇒ τ₂} f df =
  ∀ (s : ⟦ τ₁ ⟧) (ds : ⟦ Δ-Type τ₁ ⟧) (R[s,ds] : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×              -- (valid-Δ:1)
    (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ f s ⟦⊕⟧ df s ds -- (valid-Δ:2)

R[f,g⊝f] : ∀ {τ} (f g : ⟦ τ ⟧) → valid-Δ {τ} f (g ⟦⊝⟧ f)
R[f,g⊝f] {nats} m n = refl
R[f,g⊝f] {bags} b₁ b₂ = tt
R[f,g⊝f] {τ₁ ⇒ τ₂} f g = λ x dx R[x,dx] →
  R[f,g⊝f] {τ₂} (f x) (g (x ⟦⊕⟧ dx)) -- (valid-Δ:1)
  , -- tuple constructor
  (begin
    (f ⟦⊕⟧ (g ⟦⊝⟧ f)) (x ⟦⊕⟧ dx)
  ≡⟨ refl ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧
      (g ((x ⟦⊕⟧ dx) ⟦⊕⟧ ⟦derive⟧ (x ⟦⊕⟧ dx)) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ cong (λ hole → f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g hole ⟦⊝⟧ f (x ⟦⊕⟧ dx)))
          (f⊕Δf=f (x ⟦⊕⟧ dx)) ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g (x ⟦⊕⟧ dx) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ f⊕[g⊝f]=g (f (x ⟦⊕⟧ dx)) (g (x ⟦⊕⟧ dx)) ⟩
    g (x ⟦⊕⟧ dx)
  ≡⟨ sym (f⊕[g⊝f]=g (f x) (g (x ⟦⊕⟧ dx))) ⟩
      f x ⟦⊕⟧ (g ⟦⊝⟧ f) x dx
  ∎)
  where open ≡-Reasoning

R[f,Δf] : ∀ {τ} (f : ⟦ τ ⟧) → valid-Δ {τ} f (⟦derive⟧ f)
R[f,Δf] f rewrite sym (f⟦⊝⟧f=⟦deriv⟧f f) = R[f,g⊝f] f f

-- Data type to hold proofs that a Δ-env is consistent with self
data Consistent-Δenv : {Γ : Context} (dρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is consistent with itself
  dρ=∅ : Consistent-Δenv {∅} ∅
  -- Induction case: the change introduced at top level
  -- should be valid.
  dρ=dv•v•dρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
                 {Γ₀ : Context} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
                 valid-Δ v dv → Consistent-Δenv dρ₀ →
                 Consistent-Δenv {τ • Γ₀} (dv • v • dρ₀)

-- finally, update and ignore

update : ∀ {Γ} → (dρ : ⟦ Δ-Context Γ ⟧) → {_ : Consistent-Δenv dρ} → ⟦ Γ ⟧
update {∅} ∅ {dρ=∅} = ∅
update {τ • Γ} (dv • v • dρ) {dρ=dv•v•dρ₀ valid[v,dv] consistent[dρ₀]} =
  (v ⟦⊕⟧ dv) • update dρ {consistent[dρ₀]}

-- Ignorance is bliss (don't have to pass consistency proofs around :D)

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore = ⟦ Γ≼ΔΓ ⟧ -- Using a proof to describe computation

-- Naming scheme follows weakenVar/weaken

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

derive : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)

-- derive(n) = λf. f n n
derive (nat n) = abs (app (app (var this) (nat n)) (nat n))

-- derive(x) = dx
derive (var x) = var (deriveVar x)

-- derive(λx. t) = λx. λdx. derive(t)
derive (abs t) = abs (abs (derive t))

-- derive(f s) = derive(f) s derive(s)
derive (app f s) = app (app (derive f) (weaken Γ≼ΔΓ s)) (derive s)

-- derive(bag) = ∅
derive (bag b) = bag emptyBag

-- derive(inc b) = inc (derive b)
derive (inc b) = inc (derive b)

-- Extensional equivalence for changes
data Extensionally-equivalent-as-changes :
  ∀ (τ : Type) → (df : ⟦ Δ-Type τ ⟧) → (dg : ⟦ Δ-Type τ ⟧) → Set where
  ext-Δ : ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
          (∀ (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg →
             (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)) →
          Extensionally-equivalent-as-changes τ df dg

syntax Extensionally-equivalent-as-changes τ df dg = df ≈ dg :Δ τ

-- Question: How to declare fixity for infix syntax?
-- infix 4 _≈_:Δ_ -- same as ≡

-- Extractor for extensional-equivalence-as-changes:
-- Given a value of the data type holding the proof,
-- returns the proof in applicable form.
--
-- It would not be necessary if such
-- proof-holding types were defined as a function in
-- the first place, say in the manner of `valid-Δ`.
--
extract-Δequiv :
  ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
    df ≈ dg :Δ τ →
    (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg → (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)

extract-Δequiv (ext-Δ proof-method) = proof-method

-- Distribution lemmas of validity over ⟦⊝⟧ and ⟦⊕⟧

application-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v) ≡ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
application-over-⊕-and-⊝ f g df v =
  begin
    f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v
  ≡⟨ cong₂ _⟦⊝⟧_
       (cong₂ _⟦⊕⟧_
         (cong f ((sym (f⊕Δf=f v))))
         (cong₂ df
           (sym (f⊕Δf=f v))
           (cong ⟦derive⟧ (sym (f⊕Δf=f v)))))
       refl ⟩
    f (v ⟦⊕⟧ ⟦derive⟧ v)
    ⟦⊕⟧ df (v ⟦⊕⟧ ⟦derive⟧ v) (⟦derive⟧ (v ⟦⊕⟧ ⟦derive⟧ v))
    ⟦⊝⟧ f v
  ≡⟨ refl ⟩
   (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
  ∎ where open ≡-Reasoning

validity-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    valid-Δ g (f ⟦⊕⟧ df ⟦⊝⟧ f) →
    valid-Δ (g v) (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
validity-over-⊕-and-⊝ f g df v R[g,f⊕df]
  rewrite application-over-⊕-and-⊝ f g df v =
    proj₁ (R[g,f⊕df] v (⟦derive⟧ v) (R[f,Δf] v))

-- diff-apply
df=f⊕df⊝f :
  ∀ {τ} (f : ⟦ τ ⟧) (df : ⟦ Δ-Type τ ⟧) →
    valid-Δ f df → df ≈ (f ⟦⊕⟧ df ⟦⊝⟧ f) :Δ τ

-- Case nat: this REFL is more obvious to Agda than to a human.
df=f⊕df⊝f {nats} n dn valid-n-dn =
  ext-Δ (λ m valid-m-dn valid-rhs → refl)

-- Case bags: rely on set-theoretic interpretation of bags.
df=f⊕df⊝f {bags} b db valid-b-db = ext-Δ (λ d _ _ →
  begin -- Reasoning done in 1 step. Here for clarity only.
    d ⟦⊕⟧ db
  ≡⟨ cong₂ _⟦⊕⟧_ {x = d} refl (sym ([b++d]\\b=d {b} {db})) ⟩
    d ⟦⊕⟧ (b ⟦⊕⟧ db ⟦⊝⟧ b)
  ∎) where open ≡-Reasoning

df=f⊕df⊝f {τ₁ ⇒ τ₂} f df R[f,df] = ext-Δ (
  λ g R[g,df] R[g,f⊕df⊝f] →
    extensionality (λ v →
      begin
        g v ⟦⊕⟧ df v (⟦derive⟧ v)
      ≡⟨ extract-Δequiv
           (df=f⊕df⊝f
             (f v) (df v (⟦derive⟧ v))
             (proj₁ (R[f,df] v (⟦derive⟧ v) (R[f,Δf] v))))
           (g v)
           (proj₁ (R[g,df] v (⟦derive⟧ v) (R[f,Δf] v)))
           (validity-over-⊕-and-⊝ f g df v R[g,f⊕df⊝f]) ⟩
        g v ⟦⊕⟧ (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
      ≡⟨ cong₂ _⟦⊕⟧_
           {x = g v} {y = g v} refl
           (application-over-⊕-and-⊝ f g df v) ⟩
        g v ⟦⊕⟧ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
      ∎
    )
  )
  where open ≡-Reasoning

correctness-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  (⟦ deriveVar x ⟧ ρ)
  ≈
  (⟦ x ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ x ⟧ (ignore ρ)) :Δ τ

correctness-of-deriveVar {τ • Γ₀} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  this = df=f⊕df⊝f {τ} v dv R[v,dv]

correctness-of-deriveVar {τ₀ • Γ₀} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ₀} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  (that x) = correctness-of-deriveVar ρ x

module Foo where

correctness-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →

    (⟦ derive t ⟧ ρ)
  ≈ (⟦ t ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ t ⟧ (ignore ρ)) :Δ τ

correctness-of-derive′ : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →

    (⟦ derive t ⟧ ρ)
  ≈ (⟦ t ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ weaken Γ≼ΔΓ t ⟧ ρ) :Δ τ

correctness-of-derive′ ρ {consistency} t
  rewrite weaken-sound {subctx = Γ≼ΔΓ} t ρ
  = correctness-of-derive ρ {consistency} t

-- Mutually recursive lemmas

-- diff-apply holds with propositional equality on bags

db=b⊕db⊝b : ∀ {Γ : Context} →
  (b : Term Γ bags) →
  {ρ : ⟦ Δ-Context Γ ⟧} {consistency : Consistent-Δenv ρ} →
  ⟦ derive b ⟧ ρ ≡ ⟦ b ⟧ (update ρ {consistency}) \\ ⟦ b ⟧ (ignore ρ)
db=b⊕db⊝b b {ρ = ρ} {consistency = consistency} =
  begin
    ⟦ derive b ⟧ ρ
  ≡⟨ sym (∅++b=b {{⟦ derive b ⟧ ρ}}) ⟩
    emptyBag ++ ⟦ derive b ⟧ ρ
  ≡⟨ extract-Δequiv
       (correctness-of-derive ρ {consistency} b)
       emptyBag tt tt ⟩
    emptyBag ++ (⟦ b ⟧ (update ρ {consistency}) \\ ⟦ b ⟧ (ignore ρ))
  ≡⟨ ∅++b=b {{⟦ b ⟧ (update ρ {consistency}) \\ ⟦ b ⟧ (ignore ρ)}} ⟩
    ⟦ b ⟧ (update ρ {consistency}) \\ ⟦ b ⟧ (ignore ρ)
  ∎ where open ≡-Reasoning

-- Derivatives are valid

validity-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  valid-Δ (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

validity-of-derive′ : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  valid-Δ (⟦ weaken Γ≼ΔΓ t ⟧ ρ) (⟦ derive t ⟧ ρ)

validity-of-derive′ ρ {consistency} t
  rewrite weaken-sound {subctx = Γ≼ΔΓ} t ρ
  = validity-of-derive ρ {consistency} t

validity-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  valid-Δ (⟦ x ⟧ (ignore ρ)) (⟦ deriveVar x ⟧ ρ)

validity-of-deriveVar {τ • Γ} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  this = R[v,dv]

validity-of-deriveVar {τ₀ • Γ} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  (that x) = validity-of-deriveVar ρ {consistency} x

validity-of-derive ρ {consistency} (var x) =
  validity-of-deriveVar ρ {consistency} x

validity-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs t) = λ v dv R[v,dv] →
    validity-of-derive (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency} t
    , -- tuple constructor
      (begin
        ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          ⟦ derive t ⟧ (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
      ≡⟨ extract-Δequiv
           (correctness-of-derive
             (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
             {dρ=dv•v•dρ₀ (R[f,Δf] (v ⟦⊕⟧ dv)) consistency}
             t)
           (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
           (validity-of-derive
             (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
             {dρ=dv•v•dρ₀ (R[f,Δf] (v ⟦⊕⟧ dv)) consistency}
             t)
           ((R[f,g⊝f] (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
                     (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                       update ρ {consistency})))) ⟩
         ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                  update ρ {consistency})
           ⟦⊝⟧
           ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
      ≡⟨ f⊕[g⊝f]=g (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
                   (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                          update ρ {consistency})) ⟩
        ⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                  update ρ {consistency})
      ≡⟨ cong ⟦ t ⟧ (cong₂ _•_ (f⊕Δf=f (v ⟦⊕⟧ dv)) refl) ⟩
        ⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})
      ≡⟨ sym (f⊕[g⊝f]=g (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
                        (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency}))) ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})
           ⟦⊝⟧
           ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
      ≡⟨ sym (extract-Δequiv
           (correctness-of-derive
             ((dv • v • ρ))
             {dρ=dv•v•dρ₀ R[v,dv] consistency}
             t)
           (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
           (validity-of-derive
             (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
             t)
           (R[f,g⊝f] (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
                     (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})))) ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧ ⟦ derive t ⟧ (dv • v • ρ)
      ∎)
  where open ≡-Reasoning

validity-of-derive ρ {consistency} (app {τ₁} {τ₂} t₁ t₂)
  = R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧]
  where
    open ≡-Reasoning
    v₁ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁ = ⟦ t₁ ⟧ (ignore ρ)
    v₂ : ⟦ τ₁ ⟧
    v₂ = ⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ

    dv₁ : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    dv₁ = ⟦ derive t₁ ⟧ ρ
    dv₂ : ⟦ Δ-Type τ₁ ⟧
    dv₂ = ⟦ derive t₂ ⟧ ρ

    v₁′ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁′ = ⟦ t₁ ⟧ (update ρ {consistency})
    v₂′ : ⟦ τ₁ ⟧
    v₂′ = ⟦ t₂ ⟧ (update ρ {consistency})

    v₂=old-v₂ : v₂ ≡ ⟦ t₂ ⟧ (ignore ρ)
    v₂=old-v₂ = weaken-sound {subctx = Γ≼ΔΓ} t₂ ρ

    valid-dv₁ : valid-Δ v₁ dv₁
    valid-dv₁ = validity-of-derive ρ {consistency} t₁

    valid-dv₂ : valid-Δ v₂ dv₂
    valid-dv₂ rewrite v₂=old-v₂ =
      validity-of-derive ρ {consistency} t₂

    R[v₁v₂,dv₁v₂dv₂] : valid-Δ (v₁ v₂) (dv₁ v₂ dv₂)
    R[v₁v₂,dv₁v₂dv₂] = proj₁ (valid-dv₁ v₂ dv₂ valid-dv₂)

    ⟦t₁t₂⟧=v₁v₂ : ⟦ app t₁ t₂ ⟧ (ignore ρ) ≡ v₁ v₂
    ⟦t₁t₂⟧=v₁v₂ rewrite (sym v₂=old-v₂) = refl

    ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ : ⟦ derive (app t₁ t₂) ⟧ ρ ≡ dv₁ v₂ dv₂
    ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ = refl

    R[⟦t₁t₂⟧,dv₁v₂dv₂] : valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (dv₁ v₂ dv₂)
    R[⟦t₁t₂⟧,dv₁v₂dv₂] rewrite ⟦t₁t₂⟧=v₁v₂ = R[v₁v₂,dv₁v₂dv₂]

    -- What I want to write:
    {-
        R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] :
          valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (⟦ derive (app t₁ t₂) ⟧ ρ)
        R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] rewrite ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ = R[⟦t₁t₂⟧,dv₁v₂dv₂]
    -}

    -- What I have to write:

    R : {τ : Type} → {v : ⟦ τ ⟧} → {dv₁ dv₂ : ⟦ Δ-Type τ ⟧} →
        dv₁ ≡ dv₂ → valid-Δ v dv₁ → valid-Δ v dv₂

    R {nats} dv₁=dv₂ refl = cong₂ (λ f x → f x) dv₁=dv₂ refl

    R {bags} dv₁=dv₂ _ = tt

    --R {τ₁ ⇒ τ₂} dv₁=dv₂ valid-dv₁ rewrite dv₁=dv₂ = {!valid-dv₁!}
    R {τ₁ ⇒ τ₂} {v} {dv₁} {dv₂} dv₁=dv₂ valid-dv₁ =
      λ s ds R[s,ds] →
        R {τ₂} {v s} {dv₁ s ds} {dv₂ s ds}
           (cong₂ (λ f x → f x)
                  (cong₂ (λ f x → f x) dv₁=dv₂ refl) refl)
           (proj₁ (valid-dv₁ s ds R[s,ds]))
        ,
        (begin
          v (s ⟦⊕⟧ ds) ⟦⊕⟧ dv₂ (s ⟦⊕⟧ ds) (⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ cong₂ _⟦⊕⟧_
                 {x = v (s ⟦⊕⟧ ds)} refl
                 (cong₂ (λ f x → f x)
                        (cong₂ (λ f x → f x) (sym dv₁=dv₂) refl) refl) ⟩
          v (s ⟦⊕⟧ ds) ⟦⊕⟧ dv₁ (s ⟦⊕⟧ ds) (⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ sym (proj₂ (valid-dv₁
               (s ⟦⊕⟧ ds)
               (⟦derive⟧ (s ⟦⊕⟧ ds))
               (R[f,Δf] (s ⟦⊕⟧ ds)))) ⟩
          (v ⟦⊕⟧ dv₁) (s ⟦⊕⟧ ds ⟦⊕⟧ ⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ cong (v ⟦⊕⟧ dv₁) (f⊕Δf=f (s ⟦⊕⟧ ds)) ⟩
          (v ⟦⊕⟧ dv₁) (s ⟦⊕⟧ ds)
        ≡⟨ proj₂ (valid-dv₁ s ds R[s,ds]) ⟩
          v s ⟦⊕⟧ dv₁ s ds
        ≡⟨ cong₂ _⟦⊕⟧_
                 {x = v s} refl
                 (cong₂ (λ f x → f x)
                        (cong₂ (λ f x → f x) dv₁=dv₂ refl) refl) ⟩
          v s ⟦⊕⟧ dv₂ s ds
        ∎) where open ≡-Reasoning

    R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] :
      valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (⟦ derive (app t₁ t₂) ⟧ ρ)
    R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] = R ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ R[⟦t₁t₂⟧,dv₁v₂dv₂]

-- Validity of deriving bag-typed terms is trivial.

validity-of-derive ρ (bag b) = tt

validity-of-derive ρ (inc b) = tt

validity-of-derive ρ (nat n) = refl

correctness-of-derive ρ (var x) = correctness-of-deriveVar ρ x

correctness-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs {.τ₁} {.τ₂} t) =
  ext-Δ {τ₁ ⇒ τ₂}
    (λ f R[f,Δt] R[f,t′⊝t] →
      extensionality {⟦ τ₁ ⟧} {λ _ → ⟦ τ₂ ⟧} (λ x →
        begin
          f x ⟦⊕⟧ ⟦ derive t ⟧ (⟦derive⟧ x • x • ρ)
        ≡⟨ extract-Δequiv
            (correctness-of-derive {τ₁ • Γ} {τ₂}
               (⟦derive⟧ x • x • ρ)
               {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency}
               t)
            (f x)
            (proj₁ (R[f,Δt] x (⟦derive⟧ x) (R[f,Δf] x)))
            (proj₁ (R[f,t′⊝t] x (⟦derive⟧ x) (R[f,Δf] x))) ⟩
          f x
          ⟦⊕⟧
          (⟦ t ⟧ (update (⟦derive⟧ x • x • ρ)
                {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency})
          ⟦⊝⟧ ⟦ t ⟧ (x • ⟦ Γ≼ΔΓ ⟧ ρ))
        ∎
  )) where open ≡-Reasoning

correctness-of-derive ρ {consistency} (app {τ₁} {τ₂} {Γ} t₁ t₂) =
  ext-Δ {τ₂}
  (λ f R[f,Δt] R[f,t′⊝t] →
    begin
      f ⟦⊕⟧ ⟦ derive t₁ ⟧ ρ (⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ) (⟦ derive t₂ ⟧ ρ)
    ≡⟨ extract-Δequiv ext-Δ[t₁t₂] f R[f,Δt] R[f,t′⊝t] ⟩
      f ⟦⊕⟧
        (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ))
         ⟦⊝⟧
         ⟦ t₁ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ) (⟦ t₂ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ)))
    ∎)
  where
    open ≡-Reasoning

    v₁ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁ = ⟦ t₁ ⟧ (ignore ρ)
    v₂ : ⟦ τ₁ ⟧
    v₂ = ⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ

    dv₁ : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    dv₁ = ⟦ derive t₁ ⟧ ρ
    dv₂ : ⟦ Δ-Type τ₁ ⟧
    dv₂ = ⟦ derive t₂ ⟧ ρ

    v₁′ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁′ = ⟦ t₁ ⟧ (update ρ {consistency})
    v₂′ : ⟦ τ₁ ⟧
    v₂′ = ⟦ t₂ ⟧ (update ρ {consistency})

    v₂=old-v₂ : v₂ ≡ ⟦ t₂ ⟧ (ignore ρ)
    v₂=old-v₂ = weaken-sound {subctx = Γ≼ΔΓ} t₂ ρ

    valid-dv₁ : valid-Δ v₁ dv₁
    valid-dv₁ = validity-of-derive ρ {consistency} t₁

    valid-dv₂ : valid-Δ v₂ dv₂
    valid-dv₂ rewrite v₂=old-v₂ =
      validity-of-derive ρ {consistency} t₂

    v₁⊕dv₁=v₁′ : v₁ ⟦⊕⟧ dv₁ ≡ v₁′
    v₁⊕dv₁=v₁′ =
      begin
        v₁ ⟦⊕⟧ dv₁
      ≡⟨ extract-Δequiv
           (correctness-of-derive ρ {consistency} t₁)
           v₁ valid-dv₁ (R[f,g⊝f] v₁ v₁′) ⟩
        v₁ ⟦⊕⟧ (v₁′ ⟦⊝⟧ v₁)
      ≡⟨ f⊕[g⊝f]=g v₁ v₁′ ⟩
        v₁′
      ∎

    -- TODO: remove code duplication.
    v₂⊕dv₂=v₂′ : v₂ ⟦⊕⟧ dv₂ ≡ v₂′
    v₂⊕dv₂=v₂′ rewrite v₂=old-v₂ =
      begin
        old-v₂ ⟦⊕⟧ dv₂
      ≡⟨ extract-Δequiv
           (correctness-of-derive ρ {consistency} t₂)
           old-v₂
           (validity-of-derive ρ {consistency} t₂)
           (R[f,g⊝f] old-v₂ v₂′) ⟩
        old-v₂ ⟦⊕⟧ (v₂′ ⟦⊝⟧ old-v₂)
      ≡⟨ f⊕[g⊝f]=g old-v₂ v₂′ ⟩
        v₂′
      ∎
      where old-v₂ = ⟦ t₂ ⟧ (ignore ρ)

    v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] : v₁′ v₂′ ≡ (v₁ ⟦⊕⟧ dv₁) (v₂ ⟦⊕⟧ dv₂)
    v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] = sym (cong₂ (λ f x → f x) v₁⊕dv₁=v₁′ v₂⊕dv₂=v₂′)

    [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂ :
      (v₁ ⟦⊕⟧ dv₁) (v₂ ⟦⊕⟧ dv₂) ≡ v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂
    [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂ = proj₂ (valid-dv₁ v₂ dv₂ valid-dv₂)

    v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ :
      v₁′ v₂′ ⟦⊝⟧ v₁ v₂ ≡ v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂ ⟦⊝⟧ v₁ v₂
    v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      cong₂ _⟦⊝⟧_
        (trans v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂)
        refl

    R[v₁v₂,dv₁v₂dv₂] : valid-Δ (v₁ v₂) (dv₁ v₂ dv₂)
    R[v₁v₂,dv₁v₂dv₂] = proj₁ (valid-dv₁ v₂ dv₂ valid-dv₂)

    dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ :
      (dv₁ v₂ dv₂) ≈ (v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂ ⟦⊝⟧ v₁ v₂) :Δ τ₂
    dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      df=f⊕df⊝f (v₁ v₂) (dv₁ v₂ dv₂) R[v₁v₂,dv₁v₂dv₂]

    dv₁v₂dv₂=v₁′v₂′⊝v₁v₂ : (dv₁ v₂ dv₂) ≈ (v₁′ v₂′ ⟦⊝⟧ v₁ v₂) :Δ τ₂
    dv₁v₂dv₂=v₁′v₂′⊝v₁v₂ rewrite v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂

    ext-Δ[t₁t₂] :
      (⟦ derive t₁ ⟧ ρ (⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ) (⟦ derive t₂ ⟧ ρ))
      ≈
      (⟦ t₁ ⟧ (update ρ {consistency}) (⟦ t₂ ⟧ (update ρ {consistency}))
      ⟦⊝⟧ ⟦ t₁ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ) (⟦ t₂ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ)))
      :Δ τ₂
    ext-Δ[t₁t₂] rewrite sym v₂=old-v₂ = dv₁v₂dv₂=v₁′v₂′⊝v₁v₂

correctness-of-derive ρ (nat n) = ext-Δ (λ _ _ _ → refl)

correctness-of-derive ρ (bag b) = ext-Δ (λ d _ _ →
 begin
   d ++ emptyBag
  ≡⟨ cong₂ _++_ {x = d} refl (sym (b\\b=∅)) ⟩
   d ++ (b \\ b)
 ∎) where open ≡-Reasoning

correctness-of-derive ρ {consistency} (inc b) = ext-Δ (λ d _ _ →
  begin
    d ++ increment (⟦ derive b ⟧ ρ)
  ≡⟨ cong (λ hole → d ++ increment hole)
          (db=b⊕db⊝b b {ρ} {consistency}) ⟩
    d ++ increment (⟦ b ⟧ (update ρ {consistency}) \\ ⟦ b ⟧ (ignore ρ))
  ≡⟨ cong (λ hole → d ++ hole)
          (map-over-\\ {⟦ b ⟧ (update ρ)} {⟦ b ⟧ (ignore ρ)}) ⟩
    d ++ increment (⟦ b ⟧ (update ρ)) \\ increment (⟦ b ⟧ (ignore ρ))
  ∎) where
    open ≡-Reasoning
    increment : Bag → Bag
    increment = mapBag suc

correctness-on-closed-terms : ∀ {τ₁ τ₂} →
  ∀ (f : Term ∅ (τ₁ ⇒ τ₂)) →
  ∀ (s : Term ∅ τ₁) (ds : Term ∅ (Δ-Type τ₁))
    {R[v,dv] : valid-Δ (⟦ s ⟧ ∅) (⟦ ds ⟧ ∅)} →
    ⟦ f ⟧ ∅ (⟦ s ⟧ ∅ ⟦⊕⟧ ⟦ ds ⟧ ∅)
    ≡
    ⟦ f ⟧ ∅ (⟦ s ⟧ ∅) ⟦⊕⟧ ⟦ derive f ⟧ ∅ (⟦ s ⟧ ∅) (⟦ ds ⟧ ∅)

correctness-on-closed-terms {τ₁} {τ₂} f s ds {R[v,dv]} =
  begin
    h (v ⟦⊕⟧ dv)
  ≡⟨ cong₂ (λ f x → f x)
           (sym (f⊕[g⊝f]=g h h))
           refl ⟩
    (h ⟦⊕⟧ (h ⟦⊝⟧ h)) (v ⟦⊕⟧ dv)
  ≡⟨ cong₂ (λ f x → f x)
      (sym (extract-Δequiv
        (correctness-of-derive ∅ f)
        h
        (validity-of-derive ∅ {dρ=∅} f)
        (R[f,g⊝f] h h)))
      refl ⟩
    (h ⟦⊕⟧ Δh) (v ⟦⊕⟧ dv)
  ≡⟨ proj₂ (validity-of-derive ∅ {dρ=∅} f v dv R[v,dv]) ⟩
    h v ⟦⊕⟧ Δh v dv
  ∎
  where
    open ≡-Reasoning
    h : ⟦ τ₁ ⇒ τ₂ ⟧
    h = ⟦ f ⟧ ∅
    Δh : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    Δh = ⟦ derive f ⟧ ∅
    v : ⟦ τ₁ ⟧
    v = ⟦ s ⟧ ∅
    dv : ⟦ Δ-Type τ₁ ⟧
    dv = ⟦ ds ⟧ ∅

error: pathspec 'experimental/IncBag.agda' did not match any file(s) known to git


clean up

clean up

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/nfjinjing/chu2.git/'


Implement delta-observational equivalence (#244, #299)

This proof shows that delta-observational equivalence is an equivalence
relation.

Known limitations of this commit:
* it does not show that any function respects this relation;
* it does not rephrase existing results;
* this might better belong in Base.Change.Equivalence.

Old-commit-hash: 46789e08b7a8bbd95738f9bf14b3ff8644151772

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

module Parametric.Change.Equivalence
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

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

open import Base.Denotation.Notation public

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

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

module Structure (unused : Structure) where

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

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

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

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

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely. That should be true for functions
    -- using changes parametrically, for derivatives and function changes, and
    -- for functions using only the interface to changes (including the fact
    -- that function changes are functions). Stating the general result, though,
    -- seems hard, we should rather have lemmas proving that certain classes of
    -- functions respect this equivalence.

error: pathspec 'Parametric/Change/Equivalence.agda' did not match any file(s) known to git


Added Fair-Stream.

Added Fair-Stream.

------------------------------------------------------------------------------
-- Fair properties
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.ABP.Fair.Properties where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Fair.PropertiesI
open import FOTC.Program.ABP.Terms

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

Fair-Stream : ∀ {os} → Fair os → Stream os
Fair-Stream {os} Fos = Stream-coind A h refl
  where
  A : D → Set
  A xs = xs ≡ xs

  h : A os → ∃[ o' ] ∃[ os' ] os ≡ o' ∷ os' ∧ A os'
  h _ with head-tail-Fair Fos
  h x₁ | inj₁ prf = T , tail₁ os , prf , refl
  h x₁ | inj₂ prf = F , tail₁ os , prf , refl

error: pathspec 'notes/FOT/FOTC/Program/ABP/Fair/Properties.agda' did not match any file(s) known to git


Model capnproto types

Model capnproto types

open import Data.List
open import Data.List.Any
open import Data.Nat as ℕ
data capn-kind : Set where
 cKStruct : capn-kind
 ckInter  : capn-kind
open import Relation.Binary.PropositionalEquality
open Membership (setoid capn-kind)
capn-ctx = List capn-kind
data capn-τ : {Γ : capn-ctx} → Set
data capn-field : {Γ : capn-ctx} → Set
data capn-method : {Γ : capn-ctx} → Set

--While the actual capnp schema supports declaration of structs in any order / arbitrary recursion,
--I am limiting this to reference to structs-declared-so-far. This makes the model simpler, without
--removing any of the power (I think), though it would be less convenient to write code for.

data capn-τ where
  cVoid      : ∀ {Γ} → capn-τ {Γ}
  cBool      : ∀ {Γ} → capn-τ {Γ}
  cInt8      : ∀ {Γ} → capn-τ {Γ}
  cInt16     : ∀ {Γ} → capn-τ {Γ}
  cInt32     : ∀ {Γ} → capn-τ {Γ}
  cInt64     : ∀ {Γ} → capn-τ {Γ}
  cUInt8     : ∀ {Γ} → capn-τ {Γ}
  cUInt16    : ∀ {Γ} → capn-τ {Γ}
  cUInt32    : ∀ {Γ} → capn-τ {Γ}
  cUInt64    : ∀ {Γ} → capn-τ {Γ}
  cFloat32   : ∀ {Γ} → capn-τ {Γ}
  cFloat64   : ∀ {Γ} → capn-τ {Γ}
  cData      : ∀ {Γ} → capn-τ {Γ}
  cText      : ∀ {Γ} → capn-τ {Γ}
  cList      : ∀ {Γ} → capn-τ {Γ} → capn-τ {Γ}
  cStruct    : ∀ {Γ} → List (capn-field {cKStruct ∷ Γ}) → capn-τ {cKStruct ∷ Γ}
  cEnum      : ∀ {Γ} → ℕ → capn-τ {Γ}
  cVar       : ∀ {Γ k} → (k ∈ Γ) → capn-τ {Γ}
  cInterface : ∀ {Γ} → List (capn-method {ckInter ∷ Γ}) → capn-τ {ckInter ∷ Γ}

--I'm ignoring field names, because fields can be indexed by list position, which is enough for proofs
--I'm also ignoring groups, since they are just an addressing convenience
data capn-field where
  cField   : ∀ {Γ} → capn-τ {Γ} → capn-field {Γ}
  cUnion   : ∀ {Γ} → List (capn-field {Γ})→ capn-field {Γ}
  cAny     : ∀ {Γ} → capn-field {Γ}

data capn-method where
  cMeth : ∀ {Γ} → List (capn-τ {Γ}) → List (capn-τ {Γ}) → capn-method {Γ}


Nils' example about databases for Agsy.

Nils' example about databases for Agsy.

Ignore-this: de83605d4ea73cfa5979791e4351319a

darcs-hash:20110527160613-3bd4e-38150bcac1d06f53a4112e22fd3626561d5f3d56.gz

-- Nils' idea about databases in the Agda mailing list.
-- http://thread.gmane.org/gmane.comp.lang.agda/2911/focus=2917

-- Tested with the development version of the standard library on
-- 27 May 2011.

module DataBase where

open import Data.Nat
open import Data.Product

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

postulate
  right-identity : ∀ n → n + 0 ≡ n
  move-suc       : ∀ m n → suc (m + n) ≡ m + suc n

db = right-identity ,′ move-suc

comm : ∀ m n → m + n ≡ n + m  -- Via auto {!-c db!}
comm zero n     = sym (proj₁ db n)
comm (suc n) n' =
  begin
    suc (n + n') ≡⟨ cong suc (comm n n') ⟩
    suc (n' + n) ≡⟨ proj₂ db n' n ⟩ (n' + suc n)
  ∎

error: pathspec 'Draft/Agsy/DataBase.agda' did not match any file(s) known to git


exn-arrow.agda

exn-arrow.agda

error: pathspec 'exn-arrow.agda' did not match any file(s) known to git


[ test-suite ] Added missing file.

[ test-suite ] Added missing file.

error: pathspec 'test/fail/errors/NoATPs/Test.agda' did not match any file(s) known to git


Agda: Brutal Meta-introduction

Agda: Brutal Meta-introduction

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/jstolarek/sandbox.git/'


Adeed NestSL.

Adeed NestSL.

------------------------------------------------------------------------------
-- Example of a nested recursive function using the standard library
------------------------------------------------------------------------------

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

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. vol 2152 LNCS. 2001.

module FOT.FOTC.Program.Nest.NestSL where

open import Data.Nat renaming (suc to succ)
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------------
-- The non-terminating function.
{-# NO_TERMINATION_CHECK #-}
nest : ℕ → ℕ
nest 0        = 0
nest (succ n) = nest (nest n)

-- The non-terminating property.
{-# NO_TERMINATION_CHECK #-}
nest-x≡0 : ∀ n → nest n ≡ zero
nest-x≡0 zero     = refl
nest-x≡0 (succ n) = nest-x≡0 (nest n)

error: pathspec 'notes/FOT/FOTC/Program/Nest/NestSL.agda' did not match any file(s) known to git


A(nother) model of Containers

A(nother) model of Containers

{-# OPTIONS --type-in-type --no-termination-check
  #-}

module Containers where

  record Sigma (A : Set) (B : A -> Set) : Set where
    field fst : A
          snd : B fst

  open Sigma

  _*_ : (A B : Set) -> Set
  A * B = Sigma A \_ -> B

  data Zero : Set where

  record One : Set where

  data PROP : Set where
    Absu : PROP
    Triv : PROP
    _/\_ : PROP -> PROP -> PROP
    All : (S : Set) -> (S -> PROP) -> PROP

  Prf : PROP -> Set
  Prf Absu = Zero
  Prf Triv = One
  Prf (P /\ Q) = Prf P * Prf Q
  Prf (All S P) = (x : S) -> Prf (P x)

  _,_ : forall {A B} -> (a : A) -> B a -> Sigma A B
  a , b = record { fst = a ; snd = b }

  split : ∀ {A B} {C : Sigma A B -> Set} ->
    (f : (a : A) -> (b : B a) -> C (a , b)) -> (ab : Sigma A B) -> C ab
  split f ab = f (fst ab) (snd ab)

  data _+_ (A B : Set) : Set where
    l : A -> A + B
    r : B -> A + B

  cases : ∀ {A B} {C : A + B -> Set} ->
            ((a : A) -> C (l a)) -> ((b : B) -> C (r b)) ->
            (ab : A + B) -> C ab
  cases f g (l a) = f a
  cases f g (r b) = g b

  rearrange : ∀ {A B X} (C : A → Set) (D : B → Set) (f : Sigma A C → X) →
              Sigma (A + B) (cases C D) → X + Sigma B D
  rearrange {A} {B} {X} C D f = split {A + B} (cases (\a c → l (f (a , c))) (\b d → r (b , d)))

  data CON (I : Set) : Set where
    ?? : I -> CON I
    PrfC : PROP -> CON I
    _*C_ : CON I -> CON I -> CON I
    PiC : (S : Set) -> (S -> CON I) -> CON I
    SiC : (S : Set) -> (S -> CON I) -> CON I
    MuC : (O : Set) -> (O -> CON (I + O)) -> O -> CON I

  mutual

    data Mu {I : Set} (O : Set) (D : O -> CON (I + O))
            (X : I -> Set) : O -> Set where
      inm : {o : O} -> [| D o |] (cases X (Mu O D X)) ->  Mu O D X o

    [|_|]_ : {I : Set} -> (CON I) -> (I -> Set) -> Set
    [| ?? i |] X = X i
    [| PrfC p |] X = Prf p
    [| C *C D |] X = [| C |] X * [| D |] X
    [| PiC S C |] X = (s : S) -> [| C s |] X
    [| SiC S C |] X = Sigma S \s -> [| C s |] X
    [| MuC O C o |] X = Mu O C X o

  outm : {I O : Set} {D : O -> CON (I + O)} {X : I -> Set} {o : O} ->
    Mu O D X o -> [| D o |]  (cases X (Mu O D X))
  outm (inm x) = x

  Everywhere : {I : Set} -> (D : CON I) -> (J : I -> Set) -> (X : Set) ->
               (Sigma I J -> X) ->  [| D |] J -> CON X
  Everywhere (?? i) J X c t = ?? (c (i , t))
  Everywhere (PrfC p) J X c t = PrfC Triv
  Everywhere (C *C D) J X c t =
    Everywhere C J X c (fst t) *C Everywhere D J X c (snd t)
  Everywhere (PiC S C) J X c t = PiC S (\s -> Everywhere (C s) J X c (t s))
  Everywhere (SiC S C) J X c t = Everywhere (C (fst t)) J X c (snd t)
  Everywhere (MuC O C o) J X c t = MuC (Sigma O (Mu O C J)) (\ot' ->
        Everywhere (C (fst ot'))
                   (cases J (Mu O C J))
                   (X + (Sigma O (Mu O C J)))
                   (split (cases(\i j -> l (c (i , j)))
                                (\o'' t'' -> r (o'' , t''))))
                   (outm (snd ot')))
     (o , t)

  everywhere : {I : Set} -> (D : CON I) -> (J : I -> Set) -> (X : Set) ->
               (c : Sigma I J -> X) -> (Y : X -> Set) ->
               (f : (ij : Sigma I J) -> Y (c ij)) -> (t : [| D |] J) ->
               [| Everywhere D J X c t |] Y
  everywhere (?? i) J X c Y f t = f (i , t)
  everywhere (PrfC p) J X c Y f t = _
  everywhere (C *C D) J X c Y f t =
    everywhere C J X c Y f (fst t) , everywhere D J X c Y f (snd t)
  everywhere (PiC S C) J X c Y f t = \s -> everywhere (C s) J X c Y f (t s)
  everywhere (SiC S C) J X c Y f t = everywhere (C (fst t)) J X c Y f (snd t)
  everywhere (MuC O C o) J X c Y f (inm t) =
    inm (everywhere (C o) (cases J (Mu O C J)) (X + Sigma O (Mu O C J)) (
        (split (cases (\i j -> l (c (i , j))) (\o t -> r (o , t)))))
        (cases Y (split \o'' t'' -> [| Everywhere (MuC O C o'') J X c t'' |] Y))
        (split (cases (\i j -> f (i , j))
                      (\o'' t'' -> everywhere (MuC O C o'') J X c Y f t'')))
        t)

  induction : {I O : Set} (D : O -> CON (I + O)) (J : I -> Set) (X : Set)
              (c : Sigma I J -> X) (Y : X -> Set) (f : (ij : Sigma I J) -> Y (c ij))
              (P : Sigma O (Mu O D J) -> Set) ->
              ({o : O} (v : [| D o |] cases J (Mu O D J)) ->
               [| Everywhere (D o) _ (X + Sigma O (Mu O D J))
                             (split (cases (\i j -> l (c (i , j)))
                             (\o v -> r (o , v)))) v |] cases Y P ->
               P (o , inm v)) ->
              (o : O) (v : Mu O D J o) -> P (o , v)
  induction {I} {O} D J X c Y f P p o (inm v) =
    p v (everywhere {I + O} (D o)
                    (λ x -> cases {I} {O} {\_ -> Set} J
                    (Mu O D J) x) ((X + Sigma O (Mu O D J)))
                    (rearrange J (Mu O D J) c) (cases Y P)
                    (split {I + O} (cases (\i j -> f (i , j))
                    (\o v -> induction D J X c Y f P p o v))) v)

error: pathspec 'models/Containers.agda' did not match any file(s) known to git


Added thesis' example.

Added thesis' example.

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --schematic-propositional-functions #-}
{-# OPTIONS --without-K #-}

module CombiningProofs.ForallExistSchema where

open import Common.FOL.FOL-Eq

A : D → Set
A x = x ≡ x ∨ x ≡ x
{-# ATP definition A #-}

postulate ∀→∃₁ : (∀ {x} → A x) → ∃ A
{-# ATP prove ∀→∃₁ #-}

postulate ∀→∃₂ : {A : D → Set} → (∀ {x} → A x) → ∃ A
{-# ATP prove ∀→∃₂ #-}

error: pathspec 'notes/thesis/CombiningProofs/ForallExistSchema.agda' did not match any file(s) known to git


DivMod.NP: simpler, more properties

DivMod.NP: simpler, more properties

module Data.Nat.DivMod.NP where

open import Data.Fin as Fin using (Fin; toℕ; #_)
import Data.Fin.Properties as FinP
open import Data.Product
open import Data.Nat.NP as Nat
open import Data.Nat.Properties as NatP
open import Data.Nat.Properties.Simple
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Binary.PropositionalEquality.TrustMe.NP
  using (erase)
open import Relation.Binary

{-
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Explicits.FromAssocComm _+_ +-assoc +-comm
  renaming ( assoc-comm to +-assoc-comm )
-}

open NatP.SemiringSolver
open P.≡-Reasoning

infixl 7 _div_ -- _modℕ_ -- _mod_ -- _divMod_

-- A specification of integer division.

record DivMod (dividend divisor : ℕ) : Set where
  constructor result
  field
    quotient  : ℕ
    remainder : Fin divisor
    property  : dividend ≡ toℕ remainder + quotient * divisor

-- Integer division.

private

  div-helper : ℕ → ℕ → ℕ → ℕ → ℕ
  div-helper ack s zero    n       = ack
  div-helper ack s (suc d) zero    = div-helper (suc ack) s d s
  div-helper ack s (suc d) (suc n) = div-helper ack       s d n

  {-# BUILTIN NATDIVSUCAUX div-helper #-}

div-helper' : ℕ → ℕ → ℕ → ℕ
div-helper' s zero    n       = 0
div-helper' s (suc d) zero    = suc (div-helper' s d s)
div-helper' s (suc d) (suc n) =      div-helper' s d n

{-
div-helper-prop' : ∀ ack s d n → div-helper ack s d n ≡ div-helper' s d n + ack
div-helper-prop' ack s zero n = P.refl
div-helper-prop' ack s (suc d) zero = {!div-helper-prop' (suc ack) s d s!}
div-helper-prop' ack s (suc d) (suc n) = div-helper-prop' ack s d n
-}

div-helper-prop : ∀ ack s d n → div-helper ack s d n ≡ div-helper' s d n +ᵃ ack
div-helper-prop ack s zero n = P.refl
div-helper-prop ack s (suc d) zero = div-helper-prop (suc ack) s d s
div-helper-prop ack s (suc d) (suc n) = div-helper-prop ack s d n

_div_ : (dividend divisor : ℕ) → ℕ
(d div 0)     = 0
(d div suc s) = div-helper 0 s d s

-- The remainder after integer division.

private

  mod-helper : ℕ → ℕ → ℕ → ℕ → ℕ
  mod-helper ack s zero    n       = ack
  mod-helper ack s (suc d) zero    = mod-helper zero      s d s
  mod-helper ack s (suc d) (suc n) = mod-helper (suc ack) s d n

  {-# BUILTIN NATMODSUCAUX mod-helper #-}

  -- The remainder is not too large.

  mod-lemma : (ack d n : ℕ) →
              let s = ack + n in
              mod-helper ack s d n ≤ s

  mod-lemma ack zero n = m≤m+n ack n

  mod-lemma ack (suc d) zero = mod-lemma zero d (ack + 0)

  mod-lemma ack (suc d) (suc n) =
    P.subst (λ x → mod-helper (suc ack) x d n ≤ x)
            (P.sym (+-suc ack n))
            (mod-lemma (suc ack) d n)

  mod-helper-+ᵃ : ∀ ack {d n} → d ≤ n → mod-helper ack (ack +ᵃ n) d n ≡ d +ᵃ ack
  mod-helper-+ᵃ ack z≤n = P.refl
  mod-helper-+ᵃ ack (s≤s d≤n) = mod-helper-+ᵃ (suc ack) d≤n

  mod-helper0-+ᵃ : ∀ {d n} → d ≤ n → mod-helper 0 n d n ≡ d
  mod-helper0-+ᵃ d≤n = P.trans (mod-helper-+ᵃ 0 d≤n) (+ᵃ0-identity _)

  mod-helper-+ᵃ-∸-+ᵃ : ∀ ack {s d} → s ≤ d → mod-helper 0 (ack +ᵃ s) (d ∸ s) (ack +ᵃ s) ≡ mod-helper ack (ack +ᵃ s) (suc d) s
  mod-helper-+ᵃ-∸-+ᵃ ack z≤n = P.refl
  mod-helper-+ᵃ-∸-+ᵃ ack (s≤s p) = mod-helper-+ᵃ-∸-+ᵃ (suc ack) p

  _+ᵃ-mono_ : _+ᵃ_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
  _+ᵃ-mono_ {x} {y} {u} {v} p q rewrite +ᵃ-+ x u | +ᵃ-+ y v = p +-mono q

{-
  mod-helper0-+ᵃ-id-+ᵃ : ∀ ack d s → d ≤ ack → mod-helper 0 (ack +ᵃ s) d (ack +ᵃ s) ≡ d
  mod-helper0-+ᵃ-id-+ᵃ ack d zero    p rewrite +ᵃ0-identity ack = mod-helper0-+ᵃ {d} {ack} p
  mod-helper0-+ᵃ-id-+ᵃ ack d (suc s) p = mod-helper0-+ᵃ-id-+ᵃ (suc ack) d s (≤-step p)

  mod-helper0-+ᵃ-id-+ᵃ' : ∀ k ack s → mod-helper 0 (k + ack +ᵃ s) (k +ᵃ s) (k + ack +ᵃ s) ≡ k +ᵃ s
  mod-helper0-+ᵃ-id-+ᵃ' k ack s = mod-helper0-+ᵃ-id-+ᵃ (k + ack) (k +ᵃ s) s {!!}
-}

  mod-helper0-+ᵃ-+ᵃ-+ᵃ : ∀ a k s → mod-helper 0 (a + k +ᵃ s) (a +ᵃ s) (a + k +ᵃ s) ≡ a +ᵃ s
  mod-helper0-+ᵃ-+ᵃ-+ᵃ a k zero    rewrite +ᵃ0-identity a | +ᵃ0-identity (a + k)
                                        = mod-helper0-+ᵃ {a} {a + k} (≤-steps′ {a} _)
  mod-helper0-+ᵃ-+ᵃ-+ᵃ a k (suc s) = mod-helper0-+ᵃ-+ᵃ-+ᵃ (suc a) k s

  -- seems like "mod-helper0-+ᵃ : ∀ {d n} → d ≤ n → mod-helper 0 n d n ≡ d"
  -- but with n ≡ k + d
  mod-helper0-+ᵃ-id-+ᵃ : ∀ k s → mod-helper 0 (k +ᵃ s) s (k +ᵃ s) ≡ s
  mod-helper0-+ᵃ-id-+ᵃ k s = mod-helper0-+ᵃ-+ᵃ-+ᵃ 0 k s

{-
  mod-helper0-+ᵃ-id-+ᵃ : ∀ k ack s → mod-helper 0 (k +ᵃ ack) (k +ᵃ s) (k +ᵃ ack) ≡ k +ᵃ s
  mod-helper0-+ᵃ-id-+ᵃ k ack zero rewrite +ᵃ0-identity k = {!mod-helper0-+ᵃ {k} {k + ack} (≤-steps′ {k} _)!}
  mod-helper0-+ᵃ-id-+ᵃ k ack (suc s) = {!mod-helper0-+ᵃ-id-+ᵃ (suc k) ack s!}

  mod-helper-s∸ : ∀ a a' {d s} → d ≤ s → mod-helper 0 (a +ᵃ s) (a' +ᵃ s ∸ d) (a +ᵃ s) ≡ a' +ᵃ s ∸ (mod-helper a (a' +ᵃ s) d s)
  mod-helper-s∸ a a' (z≤n {s}) = {!P.trans (mod-helper0-+ᵃ-id-+ᵃ a' a s)
                               {!(P.trans (P.sym (m+n∸n≡m s a))
                               (P.cong (λ z → z ∸ a) (P.trans (+-comm s a) (P.sym (+ᵃ-+ a s)))))!}!}
  mod-helper-s∸ a a' (s≤s p) = {!mod-helper-s∸ (suc a) (suc a') p!}
  -}

  mod-helper-s∸ : ∀ ack {d s} → d ≤ s → mod-helper 0 (ack +ᵃ s) (s ∸ d) (ack +ᵃ s) ≡ ack +ᵃ s ∸ (mod-helper ack (ack +ᵃ s) d s)
  mod-helper-s∸ ack (z≤n {s}) = P.trans (mod-helper0-+ᵃ-id-+ᵃ ack s)
                               (P.trans (P.sym (m+n∸n≡m s ack))
                               (P.cong (λ z → z ∸ ack) (P.trans (+-comm s ack) (P.sym (+ᵃ-+ ack s)))))
  mod-helper-s∸ ack (s≤s p) = mod-helper-s∸ (suc ack) p

  mod-helper0-s∸ : ∀ {d s} → d ≤ s → mod-helper 0 s (s ∸ d) s ≡ s ∸ (mod-helper 0 s d s)
  mod-helper0-s∸ = mod-helper-s∸ 0

-- Notice: d modℕ 0 ≡ d
-- One can argue that if one cannot divide by 0 then what remains is the whole thing.
-- Of course the remainder is not smaller than the divisor in this case.
_modℕ_ : (dividend divisor : ℕ) → ℕ
(d modℕ 0)     = d
(d modℕ suc s) = mod-helper 0 s d s

modℕ<divisor : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} → dividend modℕ divisor < divisor
modℕ<divisor d 0 {}
modℕ<divisor d (suc s) = s≤s (mod-lemma 0 d s)

_mod_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} → Fin divisor
(d mod s) {≢0} = Fin.fromℕ≤ {d modℕ s} (modℕ<divisor d s {≢0})

ap-fromℕ≤ : ∀ {x y n}{p : x < n}{q : y < n} → x ≡ y → Fin.fromℕ≤ {x} {n} p ≡ Fin.fromℕ≤ {y} {n} q
ap-fromℕ≤ {x} {y} {n} {p} {q} e = FinP.toℕ-injective (begin
     toℕ (Fin.fromℕ≤ p)  ≡⟨ FinP.toℕ-fromℕ≤ p ⟩
     x                   ≡⟨ e ⟩
     y                   ≡⟨ P.sym (FinP.toℕ-fromℕ≤ q) ⟩
     toℕ (Fin.fromℕ≤ q)  ∎)

∸s-mod : ∀ {d s}{≢0 : False (s ≟ 0)} → s ≤ d → ((d ∸ s)mod s){≢0} ≡ (d mod s){≢0}
∸s-mod z≤n = P.refl
∸s-mod (s≤s s≤d) = ap-fromℕ≤ (mod-helper-+ᵃ-∸-+ᵃ 0 s≤d)

modℕ-<s : ∀ {d s}(p : d < s) → d modℕ s ≡ d
modℕ-<s (s≤s p) = mod-helper0-+ᵃ p

modℕ-∸s : ∀ {d s} → s ≤ d → (d ∸ s)modℕ s ≡ d modℕ s
modℕ-∸s z≤n = P.refl
modℕ-∸s (s≤s s≤d) = mod-helper-+ᵃ-∸-+ᵃ 0 s≤d

bar : ∀ x s → s ∸ x ≤ s
bar zero s = ℕ≤.refl
bar (suc x) zero = ℕ≤.refl
bar (suc x) (suc s) = ≤-step (bar x s)

gar : ∀ {x s} → 0 < x → 0 < s → s ∸ x < s
gar (s≤s (z≤n {x})) (s≤s (z≤n {s})) = s≤s (bar x s)

modℕ-s∸ : ∀ {x s} → 0 < x → x < s → (s ∸ x)modℕ s ≡ s ∸ (x modℕ s)
modℕ-s∸ {x} {s} 0<x x<s = begin
  (s ∸ x)modℕ s  ≡⟨ modℕ-<s (gar 0<x (ℕ≤.trans (s≤s z≤n) x<s)) ⟩
  s ∸ x          ≡⟨ P.cong (_∸_ s) (P.sym (modℕ-<s x<s)) ⟩
  s ∸ (x modℕ s) ∎

{-
mod-helper0-+ᵃ-suc-+ᵃ : ∀ k a s → mod-helper 0 (a +ᵃ k +ᵃ s) (a + suc s) (a +ᵃ k +ᵃ s) ≡ suc s
mod-helper0-+ᵃ-suc-+ᵃ k zero s = {!!}
mod-helper0-+ᵃ-suc-+ᵃ k (suc a) s = {!mod-helper0-+ᵃ-suc-+ᵃ (suc k) a s!}

Goal : ∀ a x s → x ≤ s → mod-helper 0 (a +ᵃ s) (suc s ∸ x) (a +ᵃ s) ≡ a +ᵃ suc s ∸ mod-helper a (a +ᵃ s) x s
Goal a .0 s z≤n = {!mod-helper0-+ᵃ-+ᵃ-+ᵃ 0!}
Goal a ._ ._ (s≤s p) = Goal (suc a) _ _ p

-- modℕ-s∸ : ∀ {x s} → x ≤ s → (s ∸ x)modℕ s ≡ s ∸ (x modℕ s)
modℕ-s∸ : ∀ {x s} → x < s → (s ∸ x)modℕ s ≡ s ∸ (x modℕ s)
modℕ-s∸ {s = zero} ()
modℕ-s∸ {x} {s = suc s} (s≤s p) = Goal 0 x s p
-}

{-
-- with ≤⇒∃ p
--... | k , e {-rewrite P.sym e-} =
  begin
  mod-helper 0 s (suc s ∸ x) s ≡⟨ {!mod-helper0-+ᵃ-id-+ᵃ (suc x) (suc s ∸ x)!} ⟩ -- mod-helper0-+ᵃ {suc s ∸ x} {s} {!≡+-≥ (suc s ∸ x) ? s!} ⟩
  suc s ∸ x ≡⟨ P.cong (λ z → suc s ∸ z) (P.sym (mod-helper0-+ᵃ {x} {s} p)) ⟩
  suc s ∸ mod-helper 0 s x s ∎
  {-
begin
  mod-helper 0 s (s ∸ x) s ≡⟨ {!!} ⟩
  mod-helper 0 s k s ≡⟨ mod-helper0-+ᵃ {k} {s} (≡+-≥ s x k (P.sym (P.cong pred e))) ⟩
  k ≡⟨ {!!} ⟩
  suc x + k ∸ x ≡⟨ P.cong (λ z → suc x + k ∸ z) (P.sym (mod-helper0-+ᵃ {x} {s} {!!})) ⟩
  suc s ∸ mod-helper 0 s x s ∎

{-
suc s ≡ k + x
mod-helper 0 s (k + x ∸ x) s ≡ suc s ∸ mod-helper 0 s x s

--{!P.trans ? ()!}
-}
-}
-}

-- Integer division with remainder.

private

  -- The quotient and remainder are related to the dividend and
  -- divisor in the right way.

  division-lemma :
    (mod-ack div-ack d n : ℕ) →
    let s = mod-ack + n in
    mod-ack + div-ack * suc s + d
      ≡
    mod-helper mod-ack s d n + div-helper div-ack s d n * suc s

  division-lemma mod-ack div-ack zero n = begin

    mod-ack + div-ack * suc s + zero  ≡⟨ +-right-identity _ ⟩

    mod-ack + div-ack * suc s         ∎

    where s = mod-ack + n

  division-lemma mod-ack div-ack (suc d) zero = begin

    mod-ack + div-ack * suc s + suc d                ≡⟨ solve 3
                                                              (λ mod-ack div-ack d →
                                                                   let s = mod-ack :+ con 0 in
                                                                   mod-ack :+ div-ack :* (con 1 :+ s) :+ (con 1 :+ d)
                                                                     :=
                                                                   (con 1 :+ div-ack) :* (con 1 :+ s) :+ d)
                                                              P.refl mod-ack div-ack d ⟩
    suc div-ack * suc s + d                          ≡⟨ division-lemma zero (suc div-ack) d s ⟩

    mod-helper zero          s      d  s    +
    div-helper (suc div-ack) s      d  s    * suc s  ≡⟨⟩

    mod-helper      mod-ack  s (suc d) zero +
    div-helper      div-ack  s (suc d) zero * suc s  ∎

    where s = mod-ack + 0

  division-lemma mod-ack div-ack (suc d) (suc n) = begin

    mod-ack + div-ack * suc s + suc d                   ≡⟨ solve 4
                                                                 (λ mod-ack div-ack n d →
                                                                      mod-ack :+ div-ack :* (con 1 :+ (mod-ack :+ (con 1 :+ n))) :+ (con 1 :+ d)
                                                                        :=
                                                                      con 1 :+ mod-ack :+ div-ack :* (con 2 :+ mod-ack :+ n) :+ d)
                                                                 P.refl mod-ack div-ack n d ⟩
    suc mod-ack + div-ack * suc s′ + d                  ≡⟨ division-lemma (suc mod-ack) div-ack d n ⟩

    mod-helper (suc mod-ack) s′ d n +
    div-helper      div-ack  s′ d n * suc s′            ≡⟨ P.cong (λ s → mod-helper (suc mod-ack) s d n +
                                                                         div-helper div-ack s d n * suc s)
                                                                  (P.sym (+-suc mod-ack n)) ⟩

    mod-helper (suc mod-ack) s d n +
    div-helper      div-ack  s d n * suc s              ≡⟨⟩

    mod-helper      mod-ack  s (suc d) (suc n) +
    div-helper      div-ack  s (suc d) (suc n) * suc s  ∎

    where
    s  = mod-ack + suc n
    s′ = suc mod-ack + n

divModPropℕ : ∀ d s → d ≡ d modℕ s + (d div s) * s
divModPropℕ _ zero    = P.sym (+-comm _ 0)
divModPropℕ d (suc s) = erase (division-lemma 0 0 d s)

divModProp : ∀ d s {≢0 : False (s ≟ 0)} → d ≡ toℕ ((d mod s){≢0}) + (d div s) * s
divModProp d (s) {≢0} = erase (begin
    d                                       ≡⟨ divModPropℕ d (s) ⟩
    d modℕ s + (d div s) * s                ≡⟨ P.cong₂ _+_ (P.sym (FinP.toℕ-fromℕ≤ lemma)) P.refl ⟩
    toℕ (Fin.fromℕ≤ lemma) + (d div s) * s  ∎)
  where lemma = modℕ<divisor d s {≢0}

_divMod_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} →
           DivMod dividend divisor
(d divMod s) {≢0} = result (d div s) (d mod s) (divModProp d s {≢0})

div<≡0 : ∀ {d s} → d < s → d div s ≡ 0
div<≡0 {d} {zero}  d<s = P.refl
div<≡0 {d} {suc s} d<s = helper (≤-pred d<s)
  where
    helper : ∀ {d s n} → d ≤ n → div-helper 0 s d n ≡ 0
    helper z≤n       = P.refl
    helper (s≤s d≤n) = helper d≤n

d/d≡1 : ∀ d {≢0 : False (d ≟ 0)} → d div d ≡ 1
d/d≡1 zero {}
d/d≡1 (suc d) = helper d
  where
    helper : ∀ {s} d → div-helper 0 s (suc d) d ≡ 1
    helper zero    = P.refl
    helper (suc x) = helper x

1-modℕ : ∀ {s} → 1 < s → 1 modℕ s ≡ 1
1-modℕ = modℕ-<s

modℕ-prop : ∀ x {s} → x modℕ s ≡ x ∸ (x div s) * s
modℕ-prop x {s} = +-∸ x (x modℕ s) (x div s * s) (divModPropℕ x s)

{-
modℕ-ns∸ : ∀ {n x s} → 0 < x → x < n * s → (n * s ∸ x)modℕ s ≡ s ∸ (x modℕ s)
{-
modℕ-ns∸ {n} {x} {s} 0<x x<s =
    begin
    (n * s ∸ x)modℕ s      ≡⟨ {!!} ⟩
    s ∸ (x ∸ q1 * s)  ≡⟨ P.cong (_∸_ s) (P.sym (mod-prop x {s})) ⟩
    s ∸ (x modℕ s)         ∎
    where q1 = x div s
-}
modℕ-ns∸ {n} {x} {zero}  0<x x<s rewrite ℕ°.*-comm n 0 = P.refl
modℕ-ns∸ {n} {x} {suc s} 0<x x<s = helper n x s 0<x x<s
  where helper : ∀ n x s →
          0 < x →
          x < n * suc s →
          mod-helper 0 s (n * suc s ∸ x) s ≡ suc s ∸ mod-helper 0 s x s
        helper n zero    s p q = {!!}
        helper n (suc x) s p q = {!helper n x s!}

{-
suc s * n = n + s * n

(n + sn) ∸ x

-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

error: pathspec 'lib/Data/Nat/DivMod/NP.agda' did not match any file(s) known to git


Added initial support for talking about probability.

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec

open import Function

open import Relation.Binary.PropositionalEquality.NP
open import Relation.Nullary

record ]0,1]-ops (]0,1] : Set) : Set where
  field
    1E : ]0,1]
    _+E_ : ]0,1] → ]0,1] → ]0,1]
    _·E_ : ]0,1] → ]0,1] → ]0,1]
    1/E_ : ]0,1] → ]0,1]

module [0,1] {]0,1]}(]0,1]R : ]0,1]-ops ]0,1]) where

  open ]0,1]-ops ]0,1]R public

  infixl 6 _+I_
  infix 4 _≤I_

  data [0,1] : Set where
   0I : [0,1]
   _I : ]0,1] → [0,1]

  1I : [0,1]
  1I = 1E I

  Pos : [0,1] → Set
  Pos x = ¬ (x ≡ 0I)

  _<_> : (x : [0,1]) → Pos x → ]0,1]
  0I < pos > with pos refl
  ... | ()
  (x I) < pos > = x

  _+I_ : [0,1] → [0,1] → [0,1]
  0I +I x = x
  x I +I 0I = x I
  x I +I x₁ I = (x +E x₁) I

  _·I_ : [0,1] → [0,1] → [0,1]
  0I ·I y = 0I
  (x I) ·I 0I = 0I
  (x I) ·I (x₁ I) = (x ·E x₁) I

  1/I_ : ]0,1] → [0,1]
  1/I x = (1/E x) I

  _/I_ : [0,1] → ]0,1] → [0,1]
  x /I y = x ·I (1/I y)

  +I-identity : (x : [0,1]) → x ≡ 0I +I x
  +I-identity x = refl

  postulate
    +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
    +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)

    _≤I_ : [0,1] → [0,1] → Set
    ≤I-refl : {x : [0,1]} → x ≤I x

    ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
    ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
    ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z

module Univ ( ]0,1] : Set)(]0,1]R : ]0,1]-ops ]0,1])
            (U : Set)
            (size-1 : ℕ)
            (allU : Vec U (suc size-1))
            (x∈allU : (x : U) → x ∈ allU)  where

  open [0,1] ]0,1]R

  sumP : {n : ℕ} → (U → [0,1]) → Vec U n → [0,1]
  sumP P []       = 0I
  sumP P (x ∷ xs) = (P x) +I (sumP P xs)

  module Prob (P : U → [0,1])
              (sumP≡1 : sumP P allU ≡ 1I) where

    Event : Set
    Event = U → Bool

    pr_∋_ : Event → U → [0,1]
    pr A ∋ x = if A x then P x else 0I

    _∪_ : Event → Event → Event
    A₁ ∪ A₂ = λ x → A₁ x ∨ A₂ x

    _∩_ : Event → Event → Event
    A₁ ∩ A₂ = λ x → A₁ x ∧ A₂ x

    ℂ[_] : Event → Event
    ℂ[ A ] = not ∘ A

    Pr[_] : Event → [0,1]
    Pr[ A ] = sumP (pr_∋_ A) allU

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < pr >

    _ind_ : (A B : Event) → Set
    A ind B = Pr[ A ] ·I Pr[ B ] ≡ Pr[ A ∩ B ]

    union-bound : (A₁ A₂ : Event) → Pr[ (A₁ ∪ A₂) ] ≤I Pr[ A₁ ] +I Pr[ A₂ ]
    union-bound A₁ A₂ = go allU where
      sA₁ : {n : ℕ} → Vec U n → [0,1]
      sA₁ = λ xs → sumP (pr_∋_ A₁) xs
      sA₂ : {n : ℕ} → Vec U n → [0,1]
      sA₂ = sumP (pr_∋_ A₂)
      go : {n : ℕ}(xs : Vec U n) → sumP (pr_∋_ (A₁ ∪ A₂)) xs ≤I sumP (pr_∋_ A₁) xs +I sumP (pr_∋_ A₂) xs
      go [] = ≤I-refl
      go (x ∷ xs) with A₁ x | A₂ x
      ... | true  | true  rewrite +I-assoc (P x) (sA₁ xs) (P x +I sA₂ xs)
                                | +I-sym (P x) (sA₂ xs)
                                | sym (+I-assoc (sA₁ xs) (sA₂ xs) (P x))
                                = ≤I-pres (P x) (≤I-mono (P x) (go xs))
      ... | true  | false rewrite +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | true  rewrite sym (+I-assoc (sA₁ xs) (P x) (sA₂ xs))
                                | +I-sym (sA₁ xs) (P x)
                                | +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | false = go xs

    module RandomVar (V : Set) (_==V_ : V → V → Bool) where
       RV : Set
       RV = U → V

       _^-1_ : RV → V → Event
       RV ^-1 v = λ x → RV x ==V v

       _≡r_ : RV → V → Event
       RV ≡r v = RV ^-1 v

       -- sugar, socker et sucre
       Pr[_≡_] : RV → V → [0,1]
       Pr[ X ≡ v ] = Pr[ X ≡r v ]

       -- ∀ (a b) . Pr[X = a and Y = b] = Pr[X = a] · Pr[Y = b]
       _indRV_ : RV → RV → Set
       X indRV Y = (a b : V) → (X ^-1 a) ind (Y ^-1 b)

error: pathspec 'Prob.agda' did not match any file(s) known to git


Add missing file.

Add missing file.

Forgot to add this file in commit ba1d8a8be0778b4d917c4d98c7db8f78f8f3cbbc.

Old-commit-hash: 02fcec1035aa2e0190d1ba3fc335cecbade97c9b

module meaning where

open import Level

record Meaning (Syntax : Set) {ℓ : Level} : Set (suc ℓ) where
  constructor
    meaning
  field
    Semantics : Set ℓ
    ⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public

error: pathspec 'meaning.agda' did not match any file(s) known to git


BigDistr.agda

BigDistr.agda

-- Unifinished

open import Type
open import Function.NP
open import Data.Nat
open import Data.Product
open import Data.Fin using (Fin)
open import Explore.Type
import Function.Related as FR
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)
open import Function.Related.TypeIsomorphisms.NP

module Explore.BigDistr
                {A B : ★₀}
                {exploreᴬ : Explore₀ A}
                {exploreᴮ : Explore₀ B}
                {exploreᴬᴮ : Explore₀ (A → B)}
                (F : A → B → ℕ)
                where
  productᴬ = exploreᴬ _*_
  sumᴮ = exploreᴮ _+_
  sumᴬᴮ = exploreᴬᴮ _+_

  module _
    (adequate-productᴬ : AdequateProduct productᴬ)
    (adequate-sumᴮ : AdequateSum sumᴮ)
    (adequate-sumᴬᴮ : AdequateSum sumᴬᴮ)
    where

    open FR.EquationalReasoning
    big-distr :
      productᴬ (sumᴮ ∘ F) ≡
      sumᴬᴮ (λ f → productᴬ (F ˢ f))
    big-distr = Fin-injective (
        Fin (productᴬ (sumᴮ ∘ F))
      ↔⟨ adequate-productᴬ (sumᴮ ∘ F) ⟩
        Π A (Fin ∘ sumᴮ ∘ F)
      ↔⟨ {!!} ⟩
        Π A (λ x → Σ B (Fin ∘ F x))
      ↔⟨ dep-choice-iso _ ⟩
        Σ (Π A (const B)) (λ f → Π A (λ x → Fin (F x (f x))))
      ↔⟨ second-iso (λ f → sym (adequate-productᴬ (F ˢ f))) ⟩
        Σ (Π A (const B)) (λ f → Fin (productᴬ (F ˢ f)))
      ↔⟨ sym (adequate-sumᴬᴮ (λ f → productᴬ (F ˢ f))) ⟩
        Fin (sumᴬᴮ (λ f → productᴬ (F ˢ f)))
      ∎)

error: pathspec 'lib/Explore/BigDistr.agda' did not match any file(s) known to git


module Explore.Examples where

open import Type
open import Level.NP
open import Data.Maybe.NP
open import Data.List
open import Data.Two

open import Explore.Core
open import Explore.Explorable
open import Explore.Monad ₀ renaming (map to map-explore)

module E where
  open FromExplore₀ public
  open FromExplore public

module M {Msg Digest : ★}
         (_==_ : Digest → Digest → 𝟚)
         (H : Msg → Digest)
         (exploreMsg : Explore ₀ Msg)
         (d : Digest) where

  module V1 where
    list-H⁻¹ : List Msg
    list-H⁻¹ = exploreMsg [] _++_ (λ m → [0: [] 1: [ m ] ] (H m == d))

  module ExploreMsg = FromExplore₀ exploreMsg

  module V2 where
    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = ExploreMsg.findKey (λ m → H m == d)

  module V3 where
    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ ε _⊕_ f = exploreMsg ε _⊕_ (λ m → [0: ε 1: f m ] (H m == d))

  module V4 where
    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ = exploreMsg >>= λ m → [0: empty-explore 1: point-explore m ] (H m == d)

  module V5 where

    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ = filter-explore (λ m → H m == d) exploreMsg

    list-H⁻¹ : List Msg
    list-H⁻¹ = E.list explore-H⁻¹

    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = E.first explore-H⁻¹

  module V6 where
    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ = explore-endo (filter-explore (λ m → H m == d) exploreMsg)

    list-H⁻¹ : List Msg
    list-H⁻¹ = E.list explore-H⁻¹

    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = E.first explore-H⁻¹

    last-H⁻¹ : Maybe Msg
    last-H⁻¹ = E.last explore-H⁻¹

open import Data.Two
open import Data.Product
open import Explore.Two
open import Explore.Product
open Explore.Product.Operators
open import Relation.Binary.PropositionalEquality
Msg = 𝟚 × 𝟚
Digest = 𝟚
-- _==_ : Digest → Digest → 𝟚
H : Msg → Digest
H (x , y) = x xor y
Msgᵉ : Explore ₀ Msg
Msgᵉ = 𝟚ᵉ ×ᵉ 𝟚ᵉ
module N5 = M.V5 _==_ H Msgᵉ
module N6 = M.V6 _==_ H Msgᵉ
test5 = N5.list-H⁻¹
test6-list : N6.list-H⁻¹ 0₂ ≡ 0₂ , 0₂ ∷ 1₂ , 1₂ ∷ []
test6-list = refl
test6-rev-list : E.list (E.backward (N6.explore-H⁻¹ 0₂)) ≡ 1₂ , 1₂ ∷ 0₂ , 0₂ ∷ []
test6-rev-list = refl
test6-first : N6.first-H⁻¹ 0₂ ≡ just (0₂ , 0₂)
test6-first = refl
test6-last : N6.last-H⁻¹ 0₂ ≡ just (1₂ , 1₂)
test6-last = refl

error: pathspec 'lib/Explore/Examples.agda' did not match any file(s) known to git


IDesc model: type-in-type, so it goes... :-(

error: pathspec 'models/IDesc_type_type.agda' did not match any file(s) known to git


Added draft for the existential quantifier syntax.

Ignore-this: 524214e2db728613cf79637177679098

darcs-hash:20111129214314-3bd4e-189edf1e0b969900d1c8b5ee6123a5c1a663d485.gz

module ExistentialSyntax where

infixr 4 _,_

postulate
  D : Set
  _≡_ : D → D → Set
  refl : ∀ {d} → d ≡ d
  d : D

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

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

t1 : ∃ λ x → x ≡ x
t1 = d , refl

t2 : ∃[ x ] (x ≡ x)
t2 = d , refl

t3 : ∃ λ x → ∃ λ y → x ≡ y
t3 = d , d , refl

t4 : ∃[ x ] ∃[ y ] x ≡ y
t4 = d , d ,  refl

error: pathspec 'notes/ExistentialSyntax.agda' did not match any file(s) known to git


bintree-proba.agda

bintree-proba.agda

module bintree-proba
  ([0,1] : Set)
where

open import Data.Nat
open import Data.Bits

data Tree : ℕ → Set where
  leaf : ∀ {n} → Bits n → Tree n
  fork : ∀ {n} (proba : [0,1]) (left right : Tree n) → Tree (1 + n)

error: pathspec 'bintree-proba.agda' did not match any file(s) known to git