fix spaces

fix spaces

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Sum

open import Function

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

record ]0,1[-ops (]0,1[ : Set) (_<E_ : ]0,1[ → ]0,1[ → Set) : Set where
  constructor mk

  field
    -- 1E : ]0,1]
    1+_/1+x_ : ℕ → ℕ → ]0,1[
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[

   -- proofs <E
  field
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  field
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[){y : ]0,1[} → (x ·E y) <E y
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  -- proofs ≡ maybe should be some Equivalence ≈
  field
    +E-sym : (x y : ]0,1[) → x +E y ≡ y +E x
    +E-assoc : (x y z : ]0,1[) → (x +E y) +E z ≡ x +E (y +E z)
    ·/E-identity : (x : ]0,1[){y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

module ]0,1[-ℚ where
  data ]0,1[ : Set where
    1+_/2+x+_ : ℕ → ℕ → ]0,1[
  -- toℚ : ]0,1] → ℚ
  -- toℚ (1+ x /1+x+ y) = (1 + x) /ℚ (1 + x + y)

  postulate
    _<E_ : ]0,1[ → ]0,1[ → Set
  -- (1+ x /1+x+ y) ≤E (1+ x' /1+x+ y') = ?
  -- (1 + x' + y') * (1 + x) ≤E (1 + x + y) * (1 + x') = ?
  postulate
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[

  postulate
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  postulate
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[) {x₁ : ]0,1[} → (x ·E x₁) <E x₁
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  postulate
    +E-sym : (x x₁ : ]0,1[) → x +E x₁ ≡ x₁ +E x
    +E-assoc : (x x₁ x₂ : ]0,1[) → (x +E x₁) +E x₂ ≡ x +E (x₁ +E x₂)
    ·/E-identity : (x : ]0,1[) {y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

  ops : ]0,1[-ops ]0,1[ _<E_
  ops = mk 1+_/2+x+_ _+E_ _·E_ _/E_<_> <E-trans +E-mono₁ +E-mono₂ ·E-anti₁ ·E-anti₂ ·/E-assoc +E-sym +E-assoc ·/E-identity

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

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

  infixl 6 _+I_
  infix 4 _≤I_

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

  data _≤I_ : [0,1] → [0,1] → Set where
    z≤n : ∀ {n} → 0I ≤I n
    n≤1 : ∀ {n} → n ≤I 1I
    E≤E : ∀ {x y} → x <E y → (x I) ≤I (y I)
    E≡E : ∀ {x} → x I ≤I x I

  ≤I-refl : ∀ {x} → x ≤I x
  ≤I-refl {0I} = z≤n
  ≤I-refl {1I} = n≤1
  ≤I-refl {x I} = E≡E

  Pos : [0,1] → Set
  Pos 0I    = ⊥
  Pos 1I    = ⊤
  Pos (_ I) = ⊤

  Inc : [0,1] → Set
  Inc 0I = ⊥
  Inc 1I = ⊥
  Inc (x I) = ⊤

  _<_> : (x : [0,1]) → Inc x → ]0,1[
  0I < () >
  1I < () >
  (x I) < pos > = x

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

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

  -- 1/I1+_ : ℕ → [0,1]

  _/I_<_,_> : (x y : [0,1]) → x ≤I y → Pos y → [0,1]
  x /I 0I    < _        , () >
  x /I 1I    < _        , _  > = x
  0I /I _    < _        , _  > = 0I
  1I /I _ I  < ()       , _  >
  (x I) /I y I < E≤E pf , _  > = (x /E y < pf >) I
  (x I) /I .x I < E≡E   , _  > = 1I

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

  *-anti : (x : [0,1]){y z : [0,1]} → y ≤I z → x ·I y ≤I z
  *-anti 0I le = z≤n
  *-anti 1I le = le
  *-anti (x I) z≤n = z≤n
  *-anti (x I) n≤1 = n≤1
  *-anti (x I) (E≤E pf) = E≤E (·E-anti₂ x pf)
  *-anti (x I) E≡E = E≤E (·E-anti₁ x)

  */-assoc : (x y z : [0,1])(pr : y ≤I z)(pos : Pos z) → (x ·I (y /I z < pr , pos >)) ≡ (x ·I y) /I z < *-anti x pr , pos >
  */-assoc x y 0I pr ()
  */-assoc x y 1I pr pos = refl
  */-assoc 0I y (z I) pr pos = refl
  */-assoc 1I y (z I) pr pos = refl
  */-assoc (x I) 0I (z I) pr pos = refl
  */-assoc (x I) 1I (z I) () pos
  */-assoc (x I) (y I) (z I) (E≤E pf) pos = cong _I (·/E-assoc x y z pf)
  */-assoc (x I) (y I) (.y I) E≡E pos = cong _I (·/E-identity x)

  +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
  +I-sym 0I 0I = refl
  +I-sym 0I 1I = refl
  +I-sym 0I (x I) = refl
  +I-sym 1I 0I = refl
  +I-sym 1I 1I = refl
  +I-sym 1I (x I) = refl
  +I-sym (x I) 0I = refl
  +I-sym (x I) 1I = refl
  +I-sym (x I) (y I) = cong _I (+E-sym x y)

  +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)
  +I-assoc 0I y z = refl
  +I-assoc 1I y z = refl
  +I-assoc (x I) 0I z = refl
  +I-assoc (x I) 1I z = refl
  +I-assoc (x I) (y I) 0I = refl
  +I-assoc (x I) (y I) 1I = refl
  +I-assoc (x I) (y I) (z I) = cong _I (+E-assoc x y z)

  ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
  ≤I-trans z≤n le2 = z≤n
  ≤I-trans n≤1 n≤1 = n≤1
  ≤I-trans (E≤E x₁) n≤1 = n≤1
  ≤I-trans (E≤E x₁) (E≤E x₂) = E≤E (<E-trans x₁ x₂)
  ≤I-trans (E≤E x₁) E≡E = E≤E x₁
  ≤I-trans E≡E le2 = le2

  ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
  ≤I-mono 0I {z = z} le rewrite +I-sym z 0I = le
  ≤I-mono 1I {z = z} le rewrite +I-sym z 1I = n≤1
  ≤I-mono (x I) z≤n = z≤n
  ≤I-mono (x I) n≤1 = n≤1
  ≤I-mono (x I) (E≤E x₂) = E≤E (<E-trans x₂ (+E-mono₁ x))
  ≤I-mono (x I) E≡E = E≤E (+E-mono₁ x)

  ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z
  ≤I-pres 0I le = le
  ≤I-pres 1I le = n≤1
  ≤I-pres (x I) {.0I} {0I} z≤n = E≡E
  ≤I-pres (x I) {.0I} {1I} z≤n = n≤1
  ≤I-pres (x I) {.0I} {x₁ I} z≤n = E≤E (+E-mono₁ x₁)
  ≤I-pres (x I) n≤1 = n≤1
  ≤I-pres (x I) (E≤E x₂) = E≤E (+E-mono₂ x x₂)
  ≤I-pres (x I) E≡E = E≡E

module Univ {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_)
            (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)

  record Distr : Set where
    constructor _,_
    field
      P : U → [0,1]
      sumP≡1 : sumP P allU ≡ 1I

  module Prob (d : Distr) where
    open Distr d

    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 → Set
    A ⊆ B = ∀ x → T(A x) → T(B x)

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

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

    postulate
      Pr-mono : ∀ {A B} → A ⊆ B → Pr[ A ] ≤I Pr[ B ]

    ∪-lem : ∀ {A} B → A ⊆ (A ∪ B)
    ∪-lem {A} _ x with A x
    ... | true = id
    ... | false = λ()

    ∩-lem : ∀ A {B} → (A ∩ B) ⊆ B
    ∩-lem A x with A x
    ... | true  = id
    ... | false = λ()

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < Pr-mono (∩-lem A) , 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)


agda: Remove code duplication

agda: Remove code duplication

The current code defines two overloads of the same function independently, with
duplicated documentation. However, one can be defined in terms of the other.

Note: I could not fully test this code, since it is not yet clear which file is
the main one. I typechecked Syntax.Language.Atlas, I hope this was enough.

I couldn't test this change because of #41: without fixing it, either I risk
breaking code, or I can't fix issues I spot.

Old-commit-hash: b481a293cbc77ca4b2981761c15e7771d95216af

module Syntax.Type.Plotkin where

-- Types for language description à la Plotkin (LCF as PL)
--
-- Given base types, we build function types.

infixr 5 _⇒_

data Type (B : Set {- of base types -}) : Set where
  base : (ι : B) → Type B
  _⇒_ : (σ : Type B) → (τ : Type B) → Type B

-- Lift (Δ : B → Type B) to (Δtype : Type B → Type B)
-- according to Δ (σ ⇒ τ) = σ ⇒ Δ σ ⇒ Δ τ
lift₁ : ∀ {B} → (B → Type B) → (Type B → Type B)
lift₁ f (base ι) = f ι
lift₁ f (σ ⇒ τ) = let Δ = lift₁ f in σ ⇒ Δ σ ⇒ Δ τ

-- Note: the above is monadic bind with a different argument order.

open import Function

-- Variant of lift₁ for (Δ : B → B).
lift₀ : ∀ {B} → (B → B) → (Type B → Type B)
lift₀ f = lift₁ $ base ∘ f
-- If lift₁ is a monadic bind, this is fmap,
-- and base is return.
--
-- Similarly, for collections map can be defined from flatMap, like lift₀ can be
-- defined in terms of lift₁.

module Syntax.Type.Plotkin where

-- Types for language description à la Plotkin (LCF as PL)
--
-- Given base types, we build function types.

infixr 5 _⇒_

data Type (B : Set {- of base types -}) : Set where
  base : (ι : B) → Type B
  _⇒_ : (σ : Type B) → (τ : Type B) → Type B

-- Lift (Δ : B → B) to (Δtype : Type B → Type B)
-- according to Δ (σ ⇒ τ) = σ ⇒ Δ σ ⇒ Δ τ
lift₀ : ∀ {B} → (B → B) → (Type B → Type B)
lift₀ f (base ι) = base (f ι)
lift₀ f (σ ⇒ τ) = let Δ = lift₀ f in σ ⇒ Δ σ ⇒ Δ τ

-- Lift (Δ : B → Type B) to (Δtype : Type B → Type B)
-- according to Δ (σ ⇒ τ) = σ ⇒ Δ σ ⇒ Δ τ
lift₁ : ∀ {B} → (B → Type B) → (Type B → Type B)
lift₁ f (base ι) = f ι
lift₁ f (σ ⇒ τ) = let Δ = lift₁ f in σ ⇒ Δ σ ⇒ Δ τ


If distance between x y are zero, then x = y

open import Data.Nat.NP
open import Data.Nat.Properties as Props
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP

module Data.Nat.Distance where

dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y

dist-refl : ∀ x → dist x x ≡ 0
dist-refl zero = idp
dist-refl (suc x) rewrite dist-refl x = idp

dist-0≡id : ∀ x → dist 0 x ≡ x
dist-0≡id _ = idp

dist-x-x+y≡y : ∀ x y → dist x (x + y) ≡ y
dist-x-x+y≡y zero    y = idp
dist-x-x+y≡y (suc x) y = dist-x-x+y≡y x y

dist-sym : ∀ x y → dist x y ≡ dist y x
dist-sym zero zero = idp
dist-sym zero (suc y) = idp
dist-sym (suc x) zero = idp
dist-sym (suc x) (suc y) = dist-sym x y

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

dist-2* : ∀ x y → dist (2* x) (2* y) ≡ 2* dist x y
dist-2* zero y = idp
dist-2* (suc x) zero = idp
dist-2* (suc x) (suc y) rewrite +-assoc-comm {x} {1} {x} | +-assoc-comm {y} {1} {y} = dist-2* x y

dist-asym-def : ∀ {x y} → x ≤ y → x + dist x y ≡ y
dist-asym-def z≤n = idp
dist-asym-def (s≤s pf) = ap suc (dist-asym-def pf)

dist-sym-wlog : ∀ (f : ℕ → ℕ) → (∀ x k → dist (f x) (f (x + k)) ≡ f k) → ∀ x y → dist (f x) (f y) ≡ f (dist x y)
dist-sym-wlog f pf x y with compare x y
dist-sym-wlog f pf x .(suc (x + k)) | less .x k with pf x (suc k)
... | q rewrite +-assoc-comm {x} {1} {k} | q | ! +-assoc-comm {x} {1} {k} | dist-x-x+y≡y x (suc k) = idp
dist-sym-wlog f pf .y y | equal .y with pf y 0
... | q rewrite ℕ°.+-comm y 0 | dist-refl y = q
dist-sym-wlog f pf .(suc (y + k)) y | greater .y k with pf y (suc k)
... | q rewrite +-assoc-comm {1} {y} {k} | dist-sym (y + suc k) y | dist-x-x+y≡y y (suc k) | dist-sym (f (y + suc k)) (f y) = q

dist-x* : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
dist-x* x = dist-sym-wlog (_*_ x) pf
  where pf : ∀ a k → dist (x * a) (x * (a + k)) ≡ x * k
        pf a k rewrite proj₁ ℕ°.distrib x a k = dist-x-x+y≡y (x * a) _

dist-2^* : ∀ x y z → dist ⟨2^ x * y ⟩ ⟨2^ x * z ⟩ ≡ ⟨2^ x * dist y z ⟩
dist-2^* x = dist-sym-wlog (2^⟨ x ⟩*) pf
  where pf : ∀ a k → dist ⟨2^ x * a ⟩ ⟨2^ x * (a + k) ⟩ ≡ ⟨2^ x * k ⟩
        pf a k rewrite 2^*-distrib x a k = dist-x-x+y≡y ⟨2^ x * a ⟩ ⟨2^ x * k ⟩

dist-bounded : ∀ {x y f} → x ≤ f → y ≤ f → dist x y ≤ f
dist-bounded z≤n       y≤f = y≤f
dist-bounded (s≤s x≤f) z≤n = s≤s x≤f
dist-bounded (s≤s x≤f) (s≤s y≤f) = ≤-step (dist-bounded x≤f y≤f)

-- Triangular inequality
dist-sum : ∀ x y z → dist x z ≤ dist x y + dist y z
dist-sum zero    zero    z       = ℕ≤.refl
dist-sum zero    (suc y) zero    = z≤n
dist-sum zero    (suc y) (suc z) = s≤s (dist-sum zero y z)
dist-sum (suc x) zero    zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 x))
dist-sum (suc x) (suc y) zero
  rewrite ℕ°.+-comm (dist x y) (suc y)
        | dist-sym x y = s≤s (dist-sum zero y x)
dist-sum (suc x) zero    (suc z) = dist-sum x zero z
                                ∙≤ ℕ≤.reflexive (ap₂ _+_ (dist-sym x 0) idp)
                                ∙≤ ≤-step (ℕ≤.refl {x} +-mono ≤-step ℕ≤.refl)
dist-sum (suc x) (suc y) (suc z) = dist-sum x y z

dist≡0 : ∀ x y → dist x y ≡ 0 → x ≡ y
dist≡0 zero zero d≡0 = refl
dist≡0 zero (suc y) ()
dist≡0 (suc x) zero ()
dist≡0 (suc x) (suc y) d≡0 = ap suc (dist≡0 x y d≡0)
{-
post--ulate
  dist-≤     : ∀ x y → dist x y ≤ x
  dist-mono₁ : ∀ x y z t → x ≤ y → dist z t ≤ dist (x + z) (y + t)
-}

-- Haskell
-- let dist x y = abs (x - y)
-- quickCheck (forAll (replicateM 3 (choose (0,100))) (\ [x,y,z] -> dist (x * y) (x * z) == x * dist y z))

open import Data.Nat.NP
open import Data.Nat.Properties as Props
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP

module Data.Nat.Distance where

dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y

dist-refl : ∀ x → dist x x ≡ 0
dist-refl zero = idp
dist-refl (suc x) rewrite dist-refl x = idp

dist-0≡id : ∀ x → dist 0 x ≡ x
dist-0≡id _ = idp

dist-x-x+y≡y : ∀ x y → dist x (x + y) ≡ y
dist-x-x+y≡y zero    y = idp
dist-x-x+y≡y (suc x) y = dist-x-x+y≡y x y

dist-sym : ∀ x y → dist x y ≡ dist y x
dist-sym zero zero = idp
dist-sym zero (suc y) = idp
dist-sym (suc x) zero = idp
dist-sym (suc x) (suc y) = dist-sym x y

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

dist-2* : ∀ x y → dist (2* x) (2* y) ≡ 2* dist x y
dist-2* zero y = idp
dist-2* (suc x) zero = idp
dist-2* (suc x) (suc y) rewrite +-assoc-comm {x} {1} {x} | +-assoc-comm {y} {1} {y} = dist-2* x y

dist-asym-def : ∀ {x y} → x ≤ y → x + dist x y ≡ y
dist-asym-def z≤n = idp
dist-asym-def (s≤s pf) = ap suc (dist-asym-def pf)

dist-sym-wlog : ∀ (f : ℕ → ℕ) → (∀ x k → dist (f x) (f (x + k)) ≡ f k) → ∀ x y → dist (f x) (f y) ≡ f (dist x y)
dist-sym-wlog f pf x y with compare x y
dist-sym-wlog f pf x .(suc (x + k)) | less .x k with pf x (suc k)
... | q rewrite +-assoc-comm {x} {1} {k} | q | ! +-assoc-comm {x} {1} {k} | dist-x-x+y≡y x (suc k) = idp
dist-sym-wlog f pf .y y | equal .y with pf y 0
... | q rewrite ℕ°.+-comm y 0 | dist-refl y = q
dist-sym-wlog f pf .(suc (y + k)) y | greater .y k with pf y (suc k)
... | q rewrite +-assoc-comm {1} {y} {k} | dist-sym (y + suc k) y | dist-x-x+y≡y y (suc k) | dist-sym (f (y + suc k)) (f y) = q

dist-x* : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
dist-x* x = dist-sym-wlog (_*_ x) pf
  where pf : ∀ a k → dist (x * a) (x * (a + k)) ≡ x * k
        pf a k rewrite proj₁ ℕ°.distrib x a k = dist-x-x+y≡y (x * a) _

dist-2^* : ∀ x y z → dist ⟨2^ x * y ⟩ ⟨2^ x * z ⟩ ≡ ⟨2^ x * dist y z ⟩
dist-2^* x = dist-sym-wlog (2^⟨ x ⟩*) pf
  where pf : ∀ a k → dist ⟨2^ x * a ⟩ ⟨2^ x * (a + k) ⟩ ≡ ⟨2^ x * k ⟩
        pf a k rewrite 2^*-distrib x a k = dist-x-x+y≡y ⟨2^ x * a ⟩ ⟨2^ x * k ⟩

dist-bounded : ∀ {x y f} → x ≤ f → y ≤ f → dist x y ≤ f
dist-bounded z≤n       y≤f = y≤f
dist-bounded (s≤s x≤f) z≤n = s≤s x≤f
dist-bounded (s≤s x≤f) (s≤s y≤f) = ≤-step (dist-bounded x≤f y≤f)

-- Triangular inequality
dist-sum : ∀ x y z → dist x z ≤ dist x y + dist y z
dist-sum zero    zero    z       = ℕ≤.refl
dist-sum zero    (suc y) zero    = z≤n
dist-sum zero    (suc y) (suc z) = s≤s (dist-sum zero y z)
dist-sum (suc x) zero    zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 x))
dist-sum (suc x) (suc y) zero
  rewrite ℕ°.+-comm (dist x y) (suc y)
        | dist-sym x y = s≤s (dist-sum zero y x)
dist-sum (suc x) zero    (suc z) = dist-sum x zero z
                                ∙≤ ℕ≤.reflexive (ap₂ _+_ (dist-sym x 0) idp)
                                ∙≤ ≤-step (ℕ≤.refl {x} +-mono ≤-step ℕ≤.refl)
dist-sum (suc x) (suc y) (suc z) = dist-sum x y z

{-
post--ulate
  dist-≤     : ∀ x y → dist x y ≤ x
  dist-mono₁ : ∀ x y z t → x ≤ y → dist z t ≤ dist (x + z) (y + t)
-}

-- Haskell
-- let dist x y = abs (x - y)
-- quickCheck (forAll (replicateM 3 (choose (0,100))) (\ [x,y,z] -> dist (x * y) (x * z) == x * dist y z))


Mention third claim of the Agda code (for #275).

Old-commit-hash: 3506fbc56e5ce8c777e14da362a2aa440bcd62bb

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Machine-checked formalization of the theoretical results presented
-- in the paper:
--
--   Yufei Cai, Paolo G. Giarrusso, Tillmann Rendel, Klaus Ostermann.
--   A Theory of Changes for Higher-Order Languages:
--   Incrementalizing λ-Calculi by Static Differentiation.
--   To appear at PLDI, ACM 2014.
--
-- We claim that this formalization
--
--   (1) proves every lemma and theorem in Sec. 2 and 3 of the paper,
--   (2) formally specifies the interface between our incrementalization
--       framework and potential plugins, and
--   (3) shows that the plugin interface can be instantiated.
--
-- The first claim is the main reason for a machine-checked
-- proof: We want to be sure that we got the proofs right.
--
-- The second claim is about reusability and applicability: Only
-- a clearly defined interface allows other researchers to
-- provide plugins for our framework.
--
-- The third claim is to show that the plugin interface is
-- consistent: An inconsistent plugin interface would allow to
-- prove arbitrary results in the framework.
------------------------------------------------------------------------

module README where

-- We know two good ways to read this code base. You can either
-- use Emacs with agda2-mode to interact with the source files,
-- or you can use a web browser to view the pretty-printed and
-- hyperlinked source files. For Agda power users, we also
-- include basic setup information for your own machine.

-- IF YOU WANT TO USE A BROWSER
-- ============================
--
-- Start with *HTML* version of this readme. On the AEC
-- submission website (online or inside the VM), follow the link
-- "view the Agda code in their browser" to the file
-- agda/README.html.
--
-- The source code is syntax highlighted and hyperlinked. You can
-- click on module names to open the corresponding files, or you
-- can click on identifiers to jump to their definition. In
-- general, a Agda file with name `Foo/Bar/Baz.agda` contains a
-- module `Foo.Bar.Baz` and is shown in an HTML file
-- `Foo.Bar.Baz.html`.
--
-- Note that we also include the HTML files generated for our
-- transitive dependencies from the Agda standard library. This
-- allows you to follow hyperlinks to the Agda standard
-- library. It is the default behavior of `agda --html` which we
-- used to generate the HTML.
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE EMACS
-- ========================
--
-- Open this file in Emacs with agda2-mode installed. See below
-- for which Agda version you need to install. On the VM image,
-- everything is setup for you and you can just open this file in
-- Emacs.
--
--   C-c C-l   Load code. Type checks and syntax highlights. Use
--             this if the code is not syntax highlighted, or
--             after you changed something that you want to type
--             check.
--
--   M-.       Jump to definition of identifier at the point.
--   M-*       Jump back.
--
-- Note that README.agda imports Everything.agda which imports
-- every Agda file in our formalization. So if README.agda type
-- checks successfully, everything does. If you want to type
-- check everything from scratch, delete the *.agdai files to
-- disable separate compilation. You can use "find . -name
-- '*.agdai' | xargs rm" to do that.
--
-- More information on the Agda mode is available on the Agda wiki:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.EmacsModeKeyCombinations
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE YOUR OWN SETUP
-- =================================
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda, the Agda standard library (version 0.7), generate Everything.agda
-- with the attached Haskell helper, and finally run Agda on this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- We use Agda HEAD from September 2013; Agda 2.3.2.1 might happen to work, but
-- has some bugs with serialization of code using some recent syntactic sugar
-- which we use (https://code.google.com/p/agda/issues/detail?id=756), so it
-- might work or not. When it does not, removing Agda caches (.agdai files)
-- appears to often help. You can use "find . -name '*.agdai' | xargs rm" to do
-- that.
--
-- If you're not an Agda power user, it is probably easier to use
-- the VM image or look at the pretty-printed and hyperlinked
-- HTML files, see above.

-- WHERE TO START READING?
-- =======================
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--   Good if you want to get a broad overview.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda
--   formalization.  Good if you want to begin at the beginning
--   and understand the structure of our code.
--
-- PLDI14-List-of-Theorems.agda
--   Pointers to the Agda formalizations of all theorems, lemmas
--   or definitions in the PLDI paper. Good if you want to read
--   the paper and the Agda code side by side.
--
--   Here is an import of this file, so you can jump to it
--   directly (use M-. in Emacs or click the module name in the
--   Browser):

import PLDI14-List-of-Theorems

-- Everything.agda
--   Imports every Agda module in our formalization. Good if you
--   want to make sure you don't miss anything.
--
--   Again, here's is an import of this file so you can navigate
--   there:

import Everything

-- (This import is also important to ensure that if we typecheck
-- README.agda, we also typecheck every other file of our
-- formalization).

-- THE AGDA CODE
-- =============

import Postulate.Extensionality

import Base.Data.DependentList

-- Variables and contexts
import Base.Syntax.Context

-- Sets of variables
import Base.Syntax.Vars

import Base.Denotation.Notation

-- Environments
import Base.Denotation.Environment

-- Change contexts
import Base.Change.Context

-- # Base, parametric proof.
--
-- This is for a parametric calculus where:
-- types are parametric in base types
-- terms are parametric in constants
--
--
-- Modules are ordered and grouped according to what they represent.

-- ## Definitions

import Parametric.Syntax.Type
import Parametric.Syntax.Term

import Parametric.Denotation.Value
import Parametric.Denotation.Evaluation

import Parametric.Change.Type
import Parametric.Change.Term

import Parametric.Change.Derive

import Parametric.Change.Value
import Parametric.Change.Evaluation

-- ## Proofs

import Parametric.Change.Validity
import Parametric.Change.Specification
import Parametric.Change.Implementation
import Parametric.Change.Correctness

-- # Nehemiah plugin
--
-- The structure is the same as the parametric proof (down to the
-- order and the grouping of modules), except for the postulate module.

-- Postulate an abstract data type for integer Bags.
import Postulate.Bag-Nehemiah

-- ## Definitions
import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation

import Nehemiah.Change.Term
import Nehemiah.Change.Type

import Nehemiah.Change.Derive

import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- ## Proofs

import Nehemiah.Change.Validity
import Nehemiah.Change.Specification
import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Machine-checked formalization of the theoretical results presented
-- in the paper:
--
--   Yufei Cai, Paolo G. Giarrusso, Tillmann Rendel, Klaus Ostermann.
--   A Theory of Changes for Higher-Order Languages:
--   Incrementalizing λ-Calculi by Static Differentiation.
--   To appear at PLDI, ACM 2014.
--
-- We claim that this formalization
--
--   (1) proves every lemma and theorem in Sec. 2 and 3 of the paper,
--   (2) and formally specifies the interface between our incrementalization
--       framework and potential plugins.
--
-- The first claim is the main reason for a machine-checked
-- proof: We want to be sure that we got the proofs right.
--
-- The second claim is about reusability and applicability: Only
-- a clearly defined interface allows other researchers to
-- provide plugins for our framework.
------------------------------------------------------------------------

module README where

-- We know two good ways to read this code base. You can either
-- use Emacs with agda2-mode to interact with the source files,
-- or you can use a web browser to view the pretty-printed and
-- hyperlinked source files. For Agda power users, we also
-- include basic setup information for your own machine.

-- IF YOU WANT TO USE A BROWSER
-- ============================
--
-- Start with *HTML* version of this readme. On the AEC
-- submission website (online or inside the VM), follow the link
-- "view the Agda code in their browser" to the file
-- agda/README.html.
--
-- The source code is syntax highlighted and hyperlinked. You can
-- click on module names to open the corresponding files, or you
-- can click on identifiers to jump to their definition. In
-- general, a Agda file with name `Foo/Bar/Baz.agda` contains a
-- module `Foo.Bar.Baz` and is shown in an HTML file
-- `Foo.Bar.Baz.html`.
--
-- Note that we also include the HTML files generated for our
-- transitive dependencies from the Agda standard library. This
-- allows you to follow hyperlinks to the Agda standard
-- library. It is the default behavior of `agda --html` which we
-- used to generate the HTML.
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE EMACS
-- ========================
--
-- Open this file in Emacs with agda2-mode installed. See below
-- for which Agda version you need to install. On the VM image,
-- everything is setup for you and you can just open this file in
-- Emacs.
--
--   C-c C-l   Load code. Type checks and syntax highlights. Use
--             this if the code is not syntax highlighted, or
--             after you changed something that you want to type
--             check.
--
--   M-.       Jump to definition of identifier at the point.
--   M-*       Jump back.
--
-- Note that README.agda imports Everything.agda which imports
-- every Agda file in our formalization. So if README.agda type
-- checks successfully, everything does. If you want to type
-- check everything from scratch, delete the *.agdai files to
-- disable separate compilation. You can use "find . -name
-- '*.agdai' | xargs rm" to do that.
--
-- More information on the Agda mode is available on the Agda wiki:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.EmacsModeKeyCombinations
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE YOUR OWN SETUP
-- =================================
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda, the Agda standard library (version 0.7), generate Everything.agda
-- with the attached Haskell helper, and finally run Agda on this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- We use Agda HEAD from September 2013; Agda 2.3.2.1 might happen to work, but
-- has some bugs with serialization of code using some recent syntactic sugar
-- which we use (https://code.google.com/p/agda/issues/detail?id=756), so it
-- might work or not. When it does not, removing Agda caches (.agdai files)
-- appears to often help. You can use "find . -name '*.agdai' | xargs rm" to do
-- that.
--
-- If you're not an Agda power user, it is probably easier to use
-- the VM image or look at the pretty-printed and hyperlinked
-- HTML files, see above.

-- WHERE TO START READING?
-- =======================
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--   Good if you want to get a broad overview.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda
--   formalization.  Good if you want to begin at the beginning
--   and understand the structure of our code.
--
-- PLDI14-List-of-Theorems.agda
--   Pointers to the Agda formalizations of all theorems, lemmas
--   or definitions in the PLDI paper. Good if you want to read
--   the paper and the Agda code side by side.
--
--   Here is an import of this file, so you can jump to it
--   directly (use M-. in Emacs or click the module name in the
--   Browser):

import PLDI14-List-of-Theorems

-- Everything.agda
--   Imports every Agda module in our formalization. Good if you
--   want to make sure you don't miss anything.
--
--   Again, here's is an import of this file so you can navigate
--   there:

import Everything

-- (This import is also important to ensure that if we typecheck
-- README.agda, we also typecheck every other file of our
-- formalization).

-- THE AGDA CODE
-- =============

import Postulate.Extensionality

import Base.Data.DependentList

-- Variables and contexts
import Base.Syntax.Context

-- Sets of variables
import Base.Syntax.Vars

import Base.Denotation.Notation

-- Environments
import Base.Denotation.Environment

-- Change contexts
import Base.Change.Context

-- # Base, parametric proof.
--
-- This is for a parametric calculus where:
-- types are parametric in base types
-- terms are parametric in constants
--
--
-- Modules are ordered and grouped according to what they represent.

-- ## Definitions

import Parametric.Syntax.Type
import Parametric.Syntax.Term

import Parametric.Denotation.Value
import Parametric.Denotation.Evaluation

import Parametric.Change.Type
import Parametric.Change.Term

import Parametric.Change.Derive

import Parametric.Change.Value
import Parametric.Change.Evaluation

-- ## Proofs

import Parametric.Change.Validity
import Parametric.Change.Specification
import Parametric.Change.Implementation
import Parametric.Change.Correctness

-- # Nehemiah plugin
--
-- The structure is the same as the parametric proof (down to the
-- order and the grouping of modules), except for the postulate module.

-- Postulate an abstract data type for integer Bags.
import Postulate.Bag-Nehemiah

-- ## Definitions
import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation

import Nehemiah.Change.Term
import Nehemiah.Change.Type

import Nehemiah.Change.Derive

import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- ## Proofs

import Nehemiah.Change.Validity
import Nehemiah.Change.Specification
import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness


Update references to paper

Update references to paper

During revision, I added Lemma 2.5 to the paper, changing the numbering.
This commits updates the numbering in the formalization.

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u

  -- In the paper, this is Def. 2.2.
  nil : ∀ v → Change v
  nil v = diff v v

  -- In the paper, this is Lemma 2.3.
  update-nil : ∀ v → update v (nil v) ≡ v
  update-nil v = update-diff v v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    isChangeAlgebra : IsChangeAlgebra Change update diff

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} ℓ {A : Set a} (P : A → Set p): Set (suc ℓ ⊔ p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra ℓ (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

Derivative : ∀ {a b c d} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra c A}} →
  {{CB : ChangeAlgebra d B}} →
  (f : A → B) →
  (df : (a : A) (da : Δ a) → Δ (f a)) →
  Set (a ⊔ b ⊔ c)
Derivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of Derivative for change algebra families.
Derivative₍_,_₎ : ∀ {a b p q c d} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily c P}} →
  {{CQ : ChangeAlgebraFamily d Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : (px : P x) (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)) →
  Set (p ⊔ q ⊔ c)
Derivative₍ x , y ₎ f df = Derivative f df where
  CPx = change-algebra₍ x ₎
  CQy = change-algebra₍ y ₎

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebra : ChangeAlgebra a A
    changeAlgebra = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} {c} {d} (A : Set a) (B : Set b) {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b ⊔ c ⊔ d) where
      constructor
        cons
      field
        -- Definition 2.6a
        apply : (a : A) (da : Δ a) →
          Δ (f a)

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    changeAlgebra : ChangeAlgebra (a ⊔ b ⊔ c ⊔ d) (A → B)
    changeAlgebra = record
      { Change = FunctionChange
        -- in the paper, update and diff below are in Def. 2.7
      ; update = λ f df a → f a ⊞ apply df a (nil a)
      ; diff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g ((a ⊞ da) ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }
      ; isChangeAlgebra = record
          -- the proof of update-diff is the second half of what
          -- we have to prove for Theorem 2.8.
        { update-diff = λ g f → ext (λ a →
          begin
            f a ⊞ (g (a ⊞ nil a) ⊟ f a)
          ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
            f a ⊞ (g a ⊟ f a)
          ≡⟨ update-diff (g a) (f a) ⟩
            g a
          ∎)
        }
      }

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper.
    nil-is-derivative : ∀ (f : A → B) →
      Derivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {c} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily c P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ (Δ₍ _ ₎) pxs → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞₍ x ₎ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ (Δ₍ _ ₎) pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟₍ _ ₎ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff₍ _ ₎ px′ px) (update-diff-all pxs′ pxs)

    changeAlgebra : ChangeAlgebraFamily (c ⊔ a) (All P)
    changeAlgebra = record
      { change-algebra = λ xs → record
        { Change = All′ Δ₍ _ ₎
        ; update = update-all
        ; diff = diff-all
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          }
        }
      }

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u

  -- In the paper, this is Def. 2.2.
  nil : ∀ v → Change v
  nil v = diff v v

  -- In the paper, this is Lemma 2.3.
  update-nil : ∀ v → update v (nil v) ≡ v
  update-nil v = update-diff v v

  -- abbrevitations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    isChangeAlgebra : IsChangeAlgebra Change update diff

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} ℓ {A : Set a} (P : A → Set p): Set (suc ℓ ⊔ p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra ℓ (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

Derivative : ∀ {a b c d} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra c A}} →
  {{CB : ChangeAlgebra d B}} →
  (f : A → B) →
  (df : (a : A) (da : Δ a) → Δ (f a)) →
  Set (a ⊔ b ⊔ c)
Derivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of Derivative for change algebra families.
Derivative₍_,_₎ : ∀ {a b p q c d} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily c P}} →
  {{CQ : ChangeAlgebraFamily d Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : (px : P x) (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)) →
  Set (p ⊔ q ⊔ c)
Derivative₍ x , y ₎ f df = Derivative f df where
  CPx = change-algebra₍ x ₎
  CQy = change-algebra₍ y ₎

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebra : ChangeAlgebra a A
    changeAlgebra = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} {c} {d} (A : Set a) (B : Set b) {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}}
  where
    -- This corresponds to Definition 2.5 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b ⊔ c ⊔ d) where
      constructor
        cons
      field
        -- Definition 2.5a
        apply : (a : A) (da : Δ a) →
          Δ (f a)

        -- Definition 2.5b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    changeAlgebra : ChangeAlgebra (a ⊔ b ⊔ c ⊔ d) (A → B)
    changeAlgebra = record
      { Change = FunctionChange
        -- in the paper, update and diff below are in Def. 2.6
      ; update = λ f df a → f a ⊞ apply df a (nil a)
      ; diff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g ((a ⊞ da) ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }
      ; isChangeAlgebra = record
          -- the proof of update-diff is the second half of what
          -- we have to prove for Theorem 2.7.
        { update-diff = λ g f → ext (λ a →
          begin
            f a ⊞ (g (a ⊞ nil a) ⊟ f a)
          ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
            f a ⊞ (g a ⊟ f a)
          ≡⟨ update-diff (g a) (f a) ⟩
            g a
          ∎)
        }
      }

    -- This is Lemma 2.8 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.9 in the paper.
    nil-is-derivative : ∀ (f : A → B) →
      Derivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {c} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily c P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ (Δ₍ _ ₎) pxs → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞₍ x ₎ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ (Δ₍ _ ₎) pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟₍ _ ₎ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff₍ _ ₎ px′ px) (update-diff-all pxs′ pxs)

    changeAlgebra : ChangeAlgebraFamily (c ⊔ a) (All P)
    changeAlgebra = record
      { change-algebra = λ xs → record
        { Change = All′ Δ₍ _ ₎
        ; update = update-all
        ; diff = diff-all
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          }
        }
      }


boolean and function composition

boolean and function composition

data Bool : Set where
  true  : Bool
  false : Bool

not : Bool → Bool
not true = false
not false = true

data ℕ : Set where
  O : ℕ
  S : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
O   + a = a
S a + b = S (a + b)

_*_ : ℕ → ℕ → ℕ
O   * a = O
S a * b = a + (a * b)

_or_ : Bool → Bool → Bool
true  or _ = true
false or b = b

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then x else y = x
if false then x else y = y

infixl 60 _*_
infixl 40 _+_
infixr 20 _or_
infix  5 if_then_else_

infixr 40 _::_
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

_∘_ : {A : Set} -> {B : A -> Set} -> {C : (x : A) -> B x -> Set} ->
      (f : {x : A} -> (y : B x) -> C x y) -> (g : (x : A) -> B x) ->
      (x : A) -> C x (g x)
_∘_ f g a = f (g a)

plus-two = S ∘ S


[ doc ] Added reference for non-redundant group theory axioms.

------------------------------------------------------------------------------
-- Group theory base
------------------------------------------------------------------------------

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

module GroupTheory.Base where

-- We add 3 to the fixities of the standard library.
infix  11 _⁻¹
infixl 10 _·_  -- The symbol is '\cdot'.

------------------------------------------------------------------------------
-- First-order logic with equality.
open import Common.FOL.FOL-Eq public renaming ( D to G )

-- Group theory axioms
postulate
  ε   : G          -- The identity element.
  _·_ : G → G → G  -- The binary operation.
  _⁻¹ : G → G      -- The inverse function.

  -- We choose a non-redundant set of axioms. See for example (Mac
  -- Lane and Garret 1999, exercises 5-7, p. 50-51, or Hodges 1993,
  -- p. 37).
  assoc         : ∀ a b c → a · b · c ≡ a · (b · c)
  leftIdentity  : ∀ a → ε · a         ≡ a
  leftInverse   : ∀ a → a ⁻¹ · a      ≡ ε
{-# ATP axiom assoc leftIdentity leftInverse #-}

------------------------------------------------------------------------------
-- References
--
-- Hodges, W. (1993). Model Theory. Vol. 42. Encyclopedia of
-- Mathematics and its Applications. Cambridge University Press.
--
-- Mac Lane, S. and Birkhof, G. (1999). Algebra. 3rd ed. AMS Chelsea
-- Publishing.

------------------------------------------------------------------------------
-- Group theory base
------------------------------------------------------------------------------

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

module GroupTheory.Base where

-- We add 3 to the fixities of the standard library.
infix  11 _⁻¹
infixl 10 _·_  -- The symbol is '\cdot'.

------------------------------------------------------------------------------
-- First-order logic with equality.
open import Common.FOL.FOL-Eq public renaming ( D to G )

-- Group theory axioms
postulate
  ε   : G          -- The identity element.
  _·_ : G → G → G  -- The binary operation.
  _⁻¹ : G → G      -- The inverse function.

  -- We choose a mininal set of axioms. See for example Saunders Mac
  -- Lane and Garret Birkhoff. Algebra. AMS Chelsea Publishing, 3rd
  -- edition, 1999. exercises 5-7, p. 50-51.
  assoc         : ∀ a b c → a · b · c ≡ a · (b · c)
  leftIdentity  : ∀ a → ε · a         ≡ a
  leftInverse   : ∀ a → a ⁻¹ · a      ≡ ε
{-# ATP axiom assoc leftIdentity leftInverse #-}


Type: cleanup

Type: cleanup

{-# OPTIONS --without-K #-}
-- The core types behind exploration functions
module Explore.Type where

open import Level.NP
open import Type hiding (★)
open import Function.NP
open import Function.Inverse using (_↔_)
open import Data.Nat.NP hiding (_⊔_)
open import Data.Bit
open import Data.Bits
open import Data.Indexed
open import Algebra
open import Relation.Binary.NP
open import Data.Product
open import Data.Sum
open import Data.Two using (𝟚; ✓)
open import Data.Maybe.NP using (_→?_)
open import Data.Fin using (Fin)
import Algebra.FunctionProperties.NP as FP
open FP using (Op₂)
open import Relation.Unary.Logical
open import Relation.Binary.Logical
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_; _≗_)

module SgrpExtra {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★ _
  C = Carrier
  _≈°_ : ∀ {a} {A : ★ a} (f g : A → C) → ★ _
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {a} {A : ★ a} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong

module Sgrp {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg public
  open SgrpExtra sg public

module RawMon {c} {C : ★ c} (rawMon : C × Op₂ C) where
  ε    = proj₁ rawMon
  _∙_  = proj₂ rawMon

module Mon {c ℓ} (m : Monoid c ℓ) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public
  RawMon = C × Op₂ C
  rawMon : RawMon
  rawMon = ε , _∙_

module CMon {c ℓ} (cm : CommutativeMonoid c ℓ) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public
  open FP _≈_

  ∙-interchange : Interchange _∙_ _∙_
  ∙-interchange = InterchangeFromAssocCommCong.∙-interchange
                    isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

Explore : ∀ ℓ → ★₀ → ★ ₛ ℓ
Explore ℓ A = ∀ {M : ★ ℓ} → (_∙_ : M → M → M) → (A → M) → M

Explore₀ : ★₀ → ★₁
Explore₀ = Explore _

Explore₁ : ★₀ → ★₂
Explore₁ = Explore _

[Explore] : ([★₀] [→] [★₁]) (Explore _)
[Explore] Aₚ = ∀⟨ Mₚ ∶ [★₀] ⟩[→] [Op₂] Mₚ [→] (Aₚ [→] Mₚ) [→] Mₚ

⟦Explore⟧ : (⟦★₀⟧ ⟦→⟧ ⟦★₁⟧) (Explore _) (Explore _)
⟦Explore⟧ Aᵣ = ∀⟨ Mᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ⟦Op₂⟧ Mᵣ ⟦→⟧ (Aᵣ ⟦→⟧ Mᵣ) ⟦→⟧ Mᵣ

⟦Explore⟧ᵤ : ∀ {ℓ} → (⟦★₀⟧ ⟦→⟧ ⟦★⟧ (ₛ ℓ)) (Explore ℓ) (Explore ℓ)
⟦Explore⟧ᵤ {ℓ} Aᵣ = ∀⟨ Mᵣ ∶ ⟦★⟧ ℓ ⟩⟦→⟧ ⟦Op₂⟧ Mᵣ ⟦→⟧ (Aᵣ ⟦→⟧ Mᵣ) ⟦→⟧ Mᵣ

-- Trimmed down version of ⟦Explore⟧
⟦Explore⟧₁ : ∀ {A : ★_ _} (Aᵣ : A → A → ★_ _) → Explore _ A → ★₁
⟦Explore⟧₁ Aᵣ s = ⟦Explore⟧ Aᵣ s s

_∙-explore_ : ∀ {ℓ A} → Explore ℓ A → Explore ℓ A → Explore ℓ A
(s₀ ∙-explore s₁) _∙_ f = s₀ _∙_ f ∙ s₁ _∙_ f

const-explore : ∀ {ℓ A} → A → Explore ℓ A
const-explore x _ f = f x

ExploreInd : ∀ p {ℓ A} → Explore ℓ A → ★ _
ExploreInd p {ℓ} {A} srch =
  ∀ (P  : Explore ℓ A → ★ p)
    (P∙ : ∀ {s₀ s₁ : Explore ℓ A} → P s₀ → P s₁ → P (λ _∙_ f → s₀ _∙_ f ∙ s₁ _∙_ f))
    (Pf : ∀ x → P (λ _ f → f x))
  → P srch

const-explore-ind : ∀ {ℓ p A} (x : A) → ExploreInd p (const-explore {ℓ} x)
const-explore-ind x _ _ Pf = Pf x

{-
_∙ExploreInd_ : ∀ {ℓ p A} {s₀ s₁ : Explore ℓ A}
               → ExploreInd p s₀ → ExploreInd p s₁
               → ExploreInd p (s₀ ∙Explore s₁)
_∙ExploreInd_ {s₀ = s₀} {s₁} Ps₀ Ps₁ P P∙ Pf = Ps₀ (λ s → P s₁ → P (s ∙Explore s₁)) (λ {s₂} {s₃} Ps₂ Ps₃ Ps₁' → {!!}) (P∙ ∘ Pf) (Ps₁ P P∙ Pf)
-}

record ExploreIndKit p {ℓ A} (P : Explore ℓ A → ★ p) : ★ (ₛ ℓ ⊔ p) where
  constructor _,_
  field
    P∙ : ∀ {s₀ s₁ : Explore ℓ A} → P s₀ → P s₁ → P (s₀ ∙-explore s₁)
    Pf : ∀ x → P (const-explore x)

_$kit_ : ∀ {p ℓ A} {P : Explore ℓ A → ★ p} {s : Explore ℓ A}
         → ExploreInd p s → ExploreIndKit p P → P s
_$kit_ {P = P} ind (P∙ , Pf) = ind P P∙ Pf

ExploreInd₀ : ∀ {ℓ A} → Explore ℓ A → ★ _
ExploreInd₀ = ExploreInd ₀

ExploreInd₁ : ∀ {ℓ A} → Explore ℓ A → ★ _
ExploreInd₁ = ExploreInd ₁

ExploreMon : ∀ {c ℓ} → Monoid c ℓ → ★₀ → ★ _
ExploreMon M A = (A → C) → C
  where open Mon M

ExploreMonInd : ∀ p {c ℓ} {A} (M : Monoid c ℓ) → ExploreMon M A → ★ _
ExploreMonInd p {c} {ℓ} {A} M srch =
  ∀ (P  : ExploreMon M A → ★ p)
    (P∙ : ∀ {s₀ s₁ : ExploreMon M A} → P s₀ → P s₁ → P (λ f → s₀ f ∙ s₁ f))
    (Pf : ∀ x → P (λ f → f x))
    (P≈ : ∀ {s s'} → s ≈° s' → P s → P s')
  → P srch
  where open Mon M

explore∘FromExplore : ∀ {m A} → Explore m A
                    → ∀ {M : ★ m} → (M → M → M) → (A → M) → (M → M)
explore∘FromExplore explore op f = explore _∘′_ (op ∘ f)

ExplorePlug : ∀ {m ℓ A} (M : Monoid m ℓ) (s : Explore _ A) → ★ _
ExplorePlug M s = ∀ f x → s∘ _∙_ f ε ∙ x ≈ s∘ _∙_ f x
   where open Mon M
         s∘ = explore∘FromExplore s

  {-
ExploreMon : ∀ m → ★₀ → ★ _
ExploreMon m A = ∀ {M : ★ m} → M × Op₂ M → (A → M) → M

ExploreMonInd : ∀ p {ℓ} {A} → ExploreMon ℓ A → ★ _
ExploreMonInd p {ℓ} {A} srch =
  ∀ (P  : ExploreMon _ A → ★ p)
    (P∙ : ∀ {s₀ s₁ : ExploreMon _ A} → P s₀ → P s₁ → P (λ M f → let _∙_ = proj₂ M in
                                                               s₀ M f ∙ s₁ M f))
    (Pf : ∀ x → P (λ _ f → f x))
  → P srch

exploreMonFromExplore : ∀ {ℓ A}
                      → Explore ℓ A → ExploreMon ℓ A
exploreMonFromExplore s = s ∘ proj₂
  -}

exploreMonFromExplore : ∀ {c ℓ A}
                      → Explore c A → (M : Monoid c ℓ) → ExploreMon M A
exploreMonFromExplore s M = s _∙_ where open Mon M

Sum : ★₀ → ★₀
Sum A = (A → ℕ) → ℕ

Product : ★₀ → ★₀
Product A = (A → ℕ) → ℕ

AdequateSum : ∀ {A} → Sum A → ★₀
AdequateSum {A} sumᴬ = ∀ f → Fin (sumᴬ f) ↔ Σ A (Fin ∘ f)

AdequateProduct : ∀ {A} → Product A → ★₀
AdequateProduct {A} productᴬ = ∀ f → Fin (productᴬ f) ↔ Π A (Fin ∘ f)

Count : ★₀ → ★₀
Count A = (A → Bit) → ℕ

Find? : ★₀ → ★₁
Find? A = ∀ {B : ★₀} → (A →? B) →? B

FindKey : ★₀ → ★₀
FindKey A = (A → 𝟚) →? A

_,-kit_ : ∀ {m p A} {P : Explore m A → ★ p}{Q : Explore m A → ★ p}
          → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
Pk ,-kit Qk = (λ x y → P∙ Pk (proj₁ x) (proj₁ y) , P∙ Qk (proj₂ x) (proj₂ y))
            , (λ x → Pf Pk x , Pf Qk x)
             where open ExploreIndKit

ExploreInd-Extra : ∀ p {m A} → Explore m A → ★ _
ExploreInd-Extra p {m} {A} srch =
  ∀ (Q     : Explore m A → ★ p)
    (Q-kit : ExploreIndKit p Q)
    (P     : Explore m A → ★ p)
    (P∙    : ∀ {s₀ s₁ : Explore m A} → Q s₀ → Q s₁ → P s₀ → P s₁
             → P (s₀ ∙-explore s₁))
    (Pf    : ∀ x → P (const-explore x))
  → P srch

to-extra : ∀ {p m A} {s : Explore m A} → ExploreInd p s → ExploreInd-Extra p s
to-extra s-ind Q Q-kit P P∙ Pf =
 proj₂ (s-ind (Q ×° P)
         (λ { (a , b) (c , d) → Q∙ a c , P∙ a c b d })
         (λ x → Qf x , Pf x))
 where open ExploreIndKit Q-kit renaming (P∙ to Q∙; Pf to Qf)

StableUnder : ∀ {ℓ A} → Explore ℓ A → (A → A) → ★ _
StableUnder explore p = ∀ {M} op (f : _ → M) → explore op f ≡ explore op (f ∘ p)

SumStableUnder : ∀ {A} → Sum A → (A → A) → ★ _
SumStableUnder sum p = ∀ f → sum f ≡ sum (f ∘ p)

CountStableUnder : ∀ {A} → Count A → (A → A) → ★ _
CountStableUnder count p = ∀ f → count f ≡ count (f ∘ p)

-- TODO: remove the hard-wired ≡
Injective : ∀ {a b}{A : ★ a}{B : ★ b}(f : A → B) → ★ _
Injective f = ∀ {x y} → f x ≡ f y → x ≡ y

SumStableUnderInjection : ∀ {A} → Sum A → ★ _
SumStableUnderInjection sum = ∀ p → Injective p → SumStableUnder sum p

SumInd : ∀ {A} → Sum A → ★₁
SumInd {A} sum = ∀ (P  : Sum A → ★₀)
                   (P+ : ∀ {s₀ s₁ : Sum A} → P s₀ → P s₁ → P (λ f → s₀ f + s₁ f))
                   (Pf : ∀ x → P (λ f → f x))
                →  P sum

ExploreMono : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreMono r sᴬ = ∀ {C} (_⊆_ : C → C → ★ r)
                    {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                    {f g} →
                    (∀ x → f x ⊆ g x) → sᴬ _∙_ f ⊆ sᴬ _∙_ g

ExploreExtFun : ∀ {A B} → Explore _ (A → B) → ★₁
ExploreExtFun {A}{B} sᴬᴮ = ∀ {M} op {f g : (A → B) → M} → (∀ {φ ψ} → φ ≗ ψ → f φ ≡ g ψ) → sᴬᴮ op f ≡ sᴬᴮ op g

ExploreSgExt : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreSgExt r {ℓ} sᴬ = ∀ (sg : Semigroup ℓ r) {f g}
                       → let open Sgrp sg in
                         f ≈° g → sᴬ _∙_ f ≈ sᴬ _∙_ g

ExploreExt : ∀ {ℓ A} → Explore ℓ A → ★ _
ExploreExt {ℓ} {A} sᴬ = ∀ {M} op {f g : A → M} → f ≗ g → sᴬ op f ≡ sᴬ op g

SumExt : ∀ {A} → Sum A → ★ _
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★ _
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

Exploreε : ∀ ℓ r {A} → Explore _ A → ★ _
Exploreε ℓ r sᴬ = ∀ (m : Monoid ℓ r) →
                       let open Mon m in
                       sᴬ _∙_ (const ε) ≈ ε

SumZero : ∀ {A} → Sum A → ★ _
SumZero sumᴬ = sumᴬ (λ _ → 0) ≡ 0

ExploreLinˡ : ∀ ℓ r {A} → Explore _ A → ★ _
ExploreLinˡ ℓ r sᴬ = ∀ m _◎_ f k →
                     let open Mon {ℓ} {r} m
                         open FP _≈_ in
                     _◎_ DistributesOverˡ _∙_ →
                     sᴬ _∙_ (λ x → k ◎ f x) ≈ k ◎ sᴬ _∙_ f

ExploreLinʳ : ∀ ℓ r {A} → Explore _ A → ★ _
ExploreLinʳ ℓ r sᴬ =
  ∀ m _◎_ f k →
    let open Mon {ℓ} {r} m
        open FP _≈_ in
    _◎_ DistributesOverʳ _∙_ →
    sᴬ _∙_ (λ x → f x ◎ k) ≈ sᴬ _∙_ f ◎ k

SumLin : ∀ {A} → Sum A → ★ _
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

ExploreHom : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreHom r sᴬ = ∀ sg f g → let open Sgrp {_} {r} sg in
                            sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

ExploreMonHom : ∀ ℓ r {A} → Explore _ A → ★ _
ExploreMonHom ℓ r sᴬ =
  ∀ cm f g →
    let open CMon {ℓ} {r} cm in
    sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

SumHom : ∀ {A} → Sum A → ★ _
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMono : ∀ {A} → Sum A → ★ _
SumMono sumᴬ = ∀ {f g} → (∀ x → f x ≤ g x) → sumᴬ f ≤ sumᴬ g

ExploreSwap : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreSwap r {ℓ} {A} sᴬ = ∀ {B : ★₀} sg f →
                            let open Sgrp {_} {r} sg in
                          ∀ {sᴮ : (B → C) → C}
                          → (hom : ∀ f g → sᴮ (f ∙° g) ≈ sᴮ f ∙ sᴮ g)
                          → sᴬ _∙_ (sᴮ ∘ f) ≈ sᴮ (sᴬ _∙_ ∘ flip f)

Unique : ∀ {A} → Cmp A → Count A → ★ _
Unique cmp count = ∀ x → count (cmp x) ≡ 1

module _ {ℓ A} (Aᵉ : Explore (ₛ ℓ) A) where
    DataΠ : (A → ★ ℓ) → ★ ℓ
    DataΠ = Aᵉ _×_

    ΣPoint : (A → ★ ℓ) → ★ ℓ
    ΣPoint = Aᵉ _⊎_

module _ {ℓ A} (Aᵉ : Explore (ₛ ℓ) A) where
    Lookup : ★ (ₛ ℓ)
    Lookup = ∀ {P : A → ★ ℓ} → DataΠ Aᵉ P → Π A P

    Reify : ★ (ₛ ℓ)
    Reify = ∀ {P : A → ★ ℓ} → Π A P → DataΠ Aᵉ P

    Reified : ★ (ₛ ℓ)
    Reified = ∀ {P : A → ★ ℓ} → Π A P ↔ DataΠ Aᵉ P

    Unfocus : ★ (ₛ ℓ)
    Unfocus = ∀ {P : A → ★ ℓ} → ΣPoint Aᵉ P → Σ A P

    Focus : ★ (ₛ ℓ)
    Focus = ∀ {P : A → ★ ℓ} → Σ A P → ΣPoint Aᵉ P

    Focused : ★ (ₛ ℓ)
    Focused = ∀ {P : A → ★ ℓ} → Σ A P ↔ ΣPoint Aᵉ P
-- -}

{-# OPTIONS --without-K #-}
-- The core types behind exploration functions
module Explore.Type where

open import Level using (_⊔_) renaming (zero to ₀; suc to ₛ)
open import Type hiding (★)
open import Function.NP
open import Function.Inverse using (_↔_)
open import Data.Nat.NP hiding (_⊔_)
open import Data.Bit
open import Data.Bits
open import Data.Indexed
open import Algebra
open import Relation.Binary.NP
open import Data.Product
open import Data.Sum
open import Data.Two using (𝟚; ✓)
open import Data.Maybe.NP using (_→?_)
open import Data.Fin using (Fin)
import Algebra.FunctionProperties.NP as FP
open FP using (Op₂)
open import Relation.Unary.Logical
open import Relation.Binary.Logical
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_; _≗_)

module SgrpExtra {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★ _
  C = Carrier
  _≈°_ : ∀ {a} {A : ★ a} (f g : A → C) → ★ _
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {a} {A : ★ a} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong

module Sgrp {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg public
  open SgrpExtra sg public

module RawMon {c} {C : ★ c} (rawMon : C × Op₂ C) where
  ε    = proj₁ rawMon
  _∙_  = proj₂ rawMon

module Mon {c ℓ} (m : Monoid c ℓ) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public
  RawMon = C × Op₂ C
  rawMon : RawMon
  rawMon = ε , _∙_

module CMon {c ℓ} (cm : CommutativeMonoid c ℓ) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public
  open FP _≈_

  ∙-interchange : Interchange _∙_ _∙_
  ∙-interchange = InterchangeFromAssocCommCong.∙-interchange
                    isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

Explore : ∀ ℓ → ★₀ → ★ ₛ ℓ
Explore ℓ A = ∀ {M : ★ ℓ} → (_∙_ : M → M → M) → (A → M) → M

Explore₀ : ★₀ → ★₁
Explore₀ = Explore _

Explore₁ : ★₀ → ★₂
Explore₁ = Explore _

[Explore] : ([★₀] [→] [★₁]) (Explore _)
[Explore] Aₚ = ∀⟨ Mₚ ∶ [★₀] ⟩[→] [Op₂] Mₚ [→] (Aₚ [→] Mₚ) [→] Mₚ

⟦Explore⟧ : (⟦★₀⟧ ⟦→⟧ ⟦★₁⟧) (Explore _) (Explore _)
⟦Explore⟧ Aᵣ = ∀⟨ Mᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ⟦Op₂⟧ Mᵣ ⟦→⟧ (Aᵣ ⟦→⟧ Mᵣ) ⟦→⟧ Mᵣ

⟦Explore⟧ᵤ : ∀ {ℓ} → (⟦★₀⟧ ⟦→⟧ ⟦★⟧ (ₛ ℓ)) (Explore ℓ) (Explore ℓ)
⟦Explore⟧ᵤ {ℓ} Aᵣ = ∀⟨ Mᵣ ∶ ⟦★⟧ ℓ ⟩⟦→⟧ ⟦Op₂⟧ Mᵣ ⟦→⟧ (Aᵣ ⟦→⟧ Mᵣ) ⟦→⟧ Mᵣ

-- Trimmed down version of ⟦Explore⟧
⟦Explore⟧₁ : ∀ {A : ★_ _} (Aᵣ : A → A → ★_ _) → Explore _ A → ★₁
⟦Explore⟧₁ Aᵣ s = ⟦Explore⟧ Aᵣ s s

_∙-explore_ : ∀ {ℓ A} → Explore ℓ A → Explore ℓ A → Explore ℓ A
(s₀ ∙-explore s₁) _∙_ f = s₀ _∙_ f ∙ s₁ _∙_ f

const-explore : ∀ {ℓ A} → A → Explore ℓ A
const-explore x _ f = f x

ExploreInd : ∀ p {ℓ A} → Explore ℓ A → ★ _
ExploreInd p {ℓ} {A} srch =
  ∀ (P  : Explore ℓ A → ★ p)
    (P∙ : ∀ {s₀ s₁ : Explore ℓ A} → P s₀ → P s₁ → P (λ _∙_ f → s₀ _∙_ f ∙ s₁ _∙_ f))
    (Pf : ∀ x → P (λ _ f → f x))
  → P srch

const-explore-ind : ∀ {ℓ p A} (x : A) → ExploreInd p (const-explore {ℓ} x)
const-explore-ind x _ _ Pf = Pf x

{-
_∙ExploreInd_ : ∀ {ℓ p A} {s₀ s₁ : Explore ℓ A}
               → ExploreInd p s₀ → ExploreInd p s₁
               → ExploreInd p (s₀ ∙Explore s₁)
_∙ExploreInd_ {s₀ = s₀} {s₁} Ps₀ Ps₁ P P∙ Pf = Ps₀ (λ s → P s₁ → P (s ∙Explore s₁)) (λ {s₂} {s₃} Ps₂ Ps₃ Ps₁' → {!!}) (P∙ ∘ Pf) (Ps₁ P P∙ Pf)
-}

record ExploreIndKit p {ℓ A} (P : Explore ℓ A → ★ p) : ★ (ₛ ℓ ⊔ p) where
  constructor _,_
  field
    P∙ : ∀ {s₀ s₁ : Explore ℓ A} → P s₀ → P s₁ → P (s₀ ∙-explore s₁)
    Pf : ∀ x → P (const-explore x)

_$kit_ : ∀ {p ℓ A} {P : Explore ℓ A → ★ p} {s : Explore ℓ A}
         → ExploreInd p s → ExploreIndKit p P → P s
_$kit_ {P = P} ind (P∙ , Pf) = ind P P∙ Pf

ExploreInd₀ : ∀ {ℓ A} → Explore ℓ A → ★ _
ExploreInd₀ = ExploreInd ₀

ExploreMon : ∀ {c ℓ} → Monoid c ℓ → ★₀ → ★ _
ExploreMon M A = (A → C) → C
  where open Mon M

ExploreMonInd : ∀ p {c ℓ} {A} (M : Monoid c ℓ) → ExploreMon M A → ★ _
ExploreMonInd p {c} {ℓ} {A} M srch =
  ∀ (P  : ExploreMon M A → ★ p)
    (P∙ : ∀ {s₀ s₁ : ExploreMon M A} → P s₀ → P s₁ → P (λ f → s₀ f ∙ s₁ f))
    (Pf : ∀ x → P (λ f → f x))
    (P≈ : ∀ {s s'} → s ≈° s' → P s → P s')
  → P srch
  where open Mon M

explore∘FromExplore : ∀ {m A} → Explore m A
                    → ∀ {M : ★ m} → (M → M → M) → (A → M) → (M → M)
explore∘FromExplore explore op f = explore _∘′_ (op ∘ f)

ExplorePlug : ∀ {m ℓ A} (M : Monoid m ℓ) (s : Explore _ A) → ★ _
ExplorePlug M s = ∀ f x → s∘ _∙_ f ε ∙ x ≈ s∘ _∙_ f x
   where open Mon M
         s∘ = explore∘FromExplore s

  {-
ExploreMon : ∀ m → ★₀ → ★ _
ExploreMon m A = ∀ {M : ★ m} → M × Op₂ M → (A → M) → M

ExploreMonInd : ∀ p {ℓ} {A} → ExploreMon ℓ A → ★ _
ExploreMonInd p {ℓ} {A} srch =
  ∀ (P  : ExploreMon _ A → ★ p)
    (P∙ : ∀ {s₀ s₁ : ExploreMon _ A} → P s₀ → P s₁ → P (λ M f → let _∙_ = proj₂ M in
                                                               s₀ M f ∙ s₁ M f))
    (Pf : ∀ x → P (λ _ f → f x))
  → P srch

exploreMonFromExplore : ∀ {ℓ A}
                      → Explore ℓ A → ExploreMon ℓ A
exploreMonFromExplore s = s ∘ proj₂
  -}

exploreMonFromExplore : ∀ {c ℓ A}
                      → Explore c A → (M : Monoid c ℓ) → ExploreMon M A
exploreMonFromExplore s M = s _∙_ where open Mon M

Sum : ★₀ → ★₀
Sum A = (A → ℕ) → ℕ

Product : ★₀ → ★₀
Product A = (A → ℕ) → ℕ

AdequateSum : ∀ {A} → Sum A → ★₀
AdequateSum {A} sumᴬ = ∀ f → Fin (sumᴬ f) ↔ Σ A (Fin ∘ f)

AdequateProduct : ∀ {A} → Product A → ★₀
AdequateProduct {A} productᴬ = ∀ f → Fin (productᴬ f) ↔ Π A (Fin ∘ f)

Count : ★₀ → ★₀
Count A = (A → Bit) → ℕ

Find? : ★₀ → ★₁
Find? A = ∀ {B : ★₀} → (A →? B) →? B

FindKey : ★₀ → ★₀
FindKey A = (A → 𝟚) →? A

_,-kit_ : ∀ {m p A} {P : Explore m A → ★ p}{Q : Explore m A → ★ p}
          → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
Pk ,-kit Qk = (λ x y → P∙ Pk (proj₁ x) (proj₁ y) , P∙ Qk (proj₂ x) (proj₂ y))
            , (λ x → Pf Pk x , Pf Qk x)
             where open ExploreIndKit

ExploreInd-Extra : ∀ p {m A} → Explore m A → ★ _
ExploreInd-Extra p {m} {A} srch =
  ∀ (Q     : Explore m A → ★ p)
    (Q-kit : ExploreIndKit p Q)
    (P     : Explore m A → ★ p)
    (P∙    : ∀ {s₀ s₁ : Explore m A} → Q s₀ → Q s₁ → P s₀ → P s₁
             → P (s₀ ∙-explore s₁))
    (Pf    : ∀ x → P (const-explore x))
  → P srch

to-extra : ∀ {p m A} {s : Explore m A} → ExploreInd p s → ExploreInd-Extra p s
to-extra s-ind Q Q-kit P P∙ Pf =
 proj₂ (s-ind (Q ×° P)
         (λ { (a , b) (c , d) → Q∙ a c , P∙ a c b d })
         (λ x → Qf x , Pf x))
 where open ExploreIndKit Q-kit renaming (P∙ to Q∙; Pf to Qf)

StableUnder : ∀ {ℓ A} → Explore ℓ A → (A → A) → ★ _
StableUnder explore p = ∀ {M} op (f : _ → M) → explore op f ≡ explore op (f ∘ p)

SumStableUnder : ∀ {A} → Sum A → (A → A) → ★ _
SumStableUnder sum p = ∀ f → sum f ≡ sum (f ∘ p)

CountStableUnder : ∀ {A} → Count A → (A → A) → ★ _
CountStableUnder count p = ∀ f → count f ≡ count (f ∘ p)

-- TODO: remove the hard-wired ≡
Injective : ∀ {a b}{A : ★ a}{B : ★ b}(f : A → B) → ★ _
Injective f = ∀ {x y} → f x ≡ f y → x ≡ y

SumStableUnderInjection : ∀ {A} → Sum A → ★ _
SumStableUnderInjection sum = ∀ p → Injective p → SumStableUnder sum p

SumInd : ∀ {A} → Sum A → ★₁
SumInd {A} sum = ∀ (P  : Sum A → ★₀)
                   (P+ : ∀ {s₀ s₁ : Sum A} → P s₀ → P s₁ → P (λ f → s₀ f + s₁ f))
                   (Pf : ∀ x → P (λ f → f x))
                →  P sum

ExploreMono : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreMono r sᴬ = ∀ {C} (_⊆_ : C → C → ★ r)
                    {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                    {f g} →
                    (∀ x → f x ⊆ g x) → sᴬ _∙_ f ⊆ sᴬ _∙_ g

ExploreExtFun : ∀ {A B} → Explore _ (A → B) → ★₁
ExploreExtFun {A}{B} sᴬᴮ = ∀ {M} op {f g : (A → B) → M} → (∀ {φ ψ} → φ ≗ ψ → f φ ≡ g ψ) → sᴬᴮ op f ≡ sᴬᴮ op g

ExploreSgExt : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreSgExt r {ℓ} sᴬ = ∀ (sg : Semigroup ℓ r) {f g}
                       → let open Sgrp sg in
                         f ≈° g → sᴬ _∙_ f ≈ sᴬ _∙_ g

ExploreExt : ∀ {ℓ A} → Explore ℓ A → ★ _
ExploreExt {ℓ} {A} sᴬ = ∀ {M} op {f g : A → M} → f ≗ g → sᴬ op f ≡ sᴬ op g

SumExt : ∀ {A} → Sum A → ★ _
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★ _
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

Exploreε : ∀ ℓ r {A} → Explore _ A → ★ _
Exploreε ℓ r sᴬ = ∀ (m : Monoid ℓ r) →
                       let open Mon m in
                       sᴬ _∙_ (const ε) ≈ ε

SumZero : ∀ {A} → Sum A → ★ _
SumZero sumᴬ = sumᴬ (λ _ → 0) ≡ 0

ExploreLinˡ : ∀ ℓ r {A} → Explore _ A → ★ _
ExploreLinˡ ℓ r sᴬ = ∀ m _◎_ f k →
                     let open Mon {ℓ} {r} m
                         open FP _≈_ in
                     _◎_ DistributesOverˡ _∙_ →
                     sᴬ _∙_ (λ x → k ◎ f x) ≈ k ◎ sᴬ _∙_ f

ExploreLinʳ : ∀ ℓ r {A} → Explore _ A → ★ _
ExploreLinʳ ℓ r sᴬ =
  ∀ m _◎_ f k →
    let open Mon {ℓ} {r} m
        open FP _≈_ in
    _◎_ DistributesOverʳ _∙_ →
    sᴬ _∙_ (λ x → f x ◎ k) ≈ sᴬ _∙_ f ◎ k

SumLin : ∀ {A} → Sum A → ★ _
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

ExploreHom : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreHom r sᴬ = ∀ sg f g → let open Sgrp {_} {r} sg in
                            sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

ExploreMonHom : ∀ ℓ r {A} → Explore _ A → ★ _
ExploreMonHom ℓ r sᴬ =
  ∀ cm f g →
    let open CMon {ℓ} {r} cm in
    sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

SumHom : ∀ {A} → Sum A → ★ _
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMono : ∀ {A} → Sum A → ★ _
SumMono sumᴬ = ∀ {f g} → (∀ x → f x ≤ g x) → sumᴬ f ≤ sumᴬ g

ExploreSwap : ∀ r {ℓ A} → Explore ℓ A → ★ _
ExploreSwap r {ℓ} {A} sᴬ = ∀ {B : ★₀} sg f →
                            let open Sgrp {_} {r} sg in
                          ∀ {sᴮ : (B → C) → C}
                          → (hom : ∀ f g → sᴮ (f ∙° g) ≈ sᴮ f ∙ sᴮ g)
                          → sᴬ _∙_ (sᴮ ∘ f) ≈ sᴮ (sᴬ _∙_ ∘ flip f)

Unique : ∀ {A} → Cmp A → Count A → ★ _
Unique cmp count = ∀ x → count (cmp x) ≡ 1

DataΠ : ∀ {b A} → Explore _ A → (A → ★ b) → ★ b
DataΠ sA = sA _×_

Lookup : ∀ {b A} → Explore _ A → ★ _
Lookup {b} {A} sA = ∀ {B : A → ★ b} → DataΠ sA B → Π A B

Reify : ∀ {b A} → Explore _ A → ★ _
Reify {b} {A} sA = ∀ {B : A → ★ b} → Π A B → DataΠ sA B

Reified : ∀ {b A} → Explore _ A → ★ _
Reified {b} {A} sA = ∀ {B : A → ★ b} → Π A B ↔ DataΠ sA B

ΣPoint : ∀ {b A} → Explore _ A → (A → ★ b) → ★ b
ΣPoint sA = sA _⊎_

Unfocus : ∀ {b A} → Explore _ A → ★ _
Unfocus {b} {A} sA = ∀ {B : A → ★ b} → ΣPoint sA B → Σ A B

Focus : ∀ {b A} → Explore _ A → ★ _
Focus {b} {A} sA = ∀ {B : A → ★ b} → Σ A B → ΣPoint sA B

Focused : ∀ {b A} → Explore _ A → ★ _
Focused {b} {A} sA = ∀ {B : A → ★ b} → Σ A B ↔ ΣPoint sA B
-- -}


CCA2† more intermediate names

CCA2† more intermediate names

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product

open import Data.Nat.NP
--open import Rat

open import Explore.Core
open import Explore.Explorable
open import Explore.Product
open Operators
open import Control.Strategy renaming (run to runStrategy)
import Game.IND-CPA-utils

open import Relation.Binary.PropositionalEquality

module Game.IND-CCA2-dagger
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

open Game.IND-CPA-utils Message CipherText
open CPAAdversary

Adversary : ★
Adversary = Rₐ → PubKey →
                   DecRound              -- first round of decryption queries
                     (CPAAdversary       -- choosen plaintext attack
                       (CipherText →     -- in which a second ciphertext is provided
                          DecRound Bit)) -- second round of decryption queries

{-
Valid-Adv : Adv → Set
Valid-Adv (m , d) = ∀ {rₐ rₓ pk c c'} → Valid (λ x → x ≢ c × x ≢ c') (d rₐ rₓ pk c c')
-}

R : ★
R = Rₐ × Rₖ × Rₑ × Rₑ

Experiment : ★
Experiment = Adversary → R → Bit

module EXP (b : Bit) (A : Adversary) (rₐ : Rₐ) (pk : PubKey) (sk : SecKey) (rₑ₀ rₑ₁ : Rₑ) where
  decRound = runStrategy (Dec sk)
  A1       = A rₐ pk
  cpaA     = decRound A1
  mb       = proj′ (get-m cpaA)
  c₀       = Enc pk (mb b)       rₑ₀
  c₁       = Enc pk (mb (not b)) rₑ₁
  A2       = put-c cpaA c₀ c₁
  b′       = decRound A2

  ct       = proj′ (c₀ , c₁)

EXP : Bit → Experiment
EXP b A (rₐ , rₖ , rₑ₀ , rₑ₁) with KeyGen rₖ
... | pk , sk = EXP.b′ b A rₐ pk sk rₑ₀ rₑ₁

module Advantage
  (μₑ : Explore₀ Rₑ)
  (μₖ : Explore₀ Rₖ)
  (μₐ : Explore₀ Rₐ)
  where
  μR : Explore₀ R
  μR = μₐ ×ᵉ μₖ ×ᵉ μₑ ×ᵉ μₑ

  module μR = FromExplore₀ μR

  run : Bit → Adversary → ℕ
  run b adv = μR.count (EXP b adv)

  {-
  Advantage : Adv → ℚ
  Advantage adv = dist (run 0b adv) (run 1b adv) / μR.Card
  -}

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product

open import Data.Nat.NP
--open import Rat

open import Explore.Core
open import Explore.Explorable
open import Explore.Product
open Operators
open import Control.Strategy renaming (run to runStrategy)
import Game.IND-CPA-utils

open import Relation.Binary.PropositionalEquality

module Game.IND-CCA2-dagger
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

open Game.IND-CPA-utils Message CipherText
open CPAAdversary

Adversary : ★
Adversary = Rₐ → PubKey →
                   DecRound              -- first round of decryption queries
                     (CPAAdversary       -- choosen plaintext attack
                       (CipherText →     -- in which a second ciphertext is provided
                          DecRound Bit)) -- second round of decryption queries

{-
Valid-Adv : Adv → Set
Valid-Adv (m , d) = ∀ {rₐ rₓ pk c c'} → Valid (λ x → x ≢ c × x ≢ c') (d rₐ rₓ pk c c')
-}

R : ★
R = Rₐ × Rₖ × Rₑ × Rₑ

Experiment : ★
Experiment = Adversary → R → Bit

module EXP (b : Bit) (A : Adversary) (rₐ : Rₐ) (pk : PubKey) (sk : SecKey) (rₑ₀ rₑ₁ : Rₑ) where
  decRound = runStrategy (Dec sk)
  cpaA     = decRound (A rₐ pk)
  mb       = proj′ (get-m cpaA)
  c₀       = Enc pk (mb b)       rₑ₀
  c₁       = Enc pk (mb (not b)) rₑ₁
  b′       = decRound (put-c cpaA c₀ c₁)

EXP : Bit → Experiment
EXP b A (rₐ , rₖ , rₑ₀ , rₑ₁) with KeyGen rₖ
... | pk , sk = EXP.b′ b A rₐ pk sk rₑ₀ rₑ₁

module Advantage
  (μₑ : Explore₀ Rₑ)
  (μₖ : Explore₀ Rₖ)
  (μₐ : Explore₀ Rₐ)
  where
  μR : Explore₀ R
  μR = μₐ ×ᵉ μₖ ×ᵉ μₑ ×ᵉ μₑ

  module μR = FromExplore₀ μR

  run : Bit → Adversary → ℕ
  run b adv = μR.count (EXP b adv)

  {-
  Advantage : Adv → ℚ
  Advantage adv = dist (run 0b adv) (run 1b adv) / μR.Card
  -}


Use helpers for nested applications.

Use helpers for nested applications.

Old-commit-hash: e4c7562ec14ff04d00f64f84b95725baa11a85ca

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  lift-diff-apply :
    ∀ {τ Γ} →
      Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-diff-apply {base ι} = diff-base , apply-base
  lift-diff-apply {σ ⇒ τ} =
    let
      -- for diff
      g  = var (that (that (that this)))
      f  = var (that (that this))
      x  = var (that this)
      Δx = var this
      -- for apply
      Δh = var (that (that this))
      h  = var (that this)
      y  = var this
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply {τ} {Γ})
      _⊝σ_ = λ s t  → app₂ diffσ s t
      _⊝τ_ = λ s t  → app₂ diffτ s t
      _⊕σ_ = λ t Δt → app₂ applyσ Δt t
      _⊕τ_ = λ t Δt → app₂ applyτ Δt t
    in
      abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
      ,
      abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

  lift-diff :
    ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  lift-diff = λ {τ Γ} →
    proj₁ (lift-diff-apply {τ} {Γ})

  lift-apply :
    ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-apply = λ {τ Γ} →
    proj₂ (lift-diff-apply {τ} {Γ})

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  lift-diff-apply :
    ∀ {τ Γ} →
      Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-diff-apply {base ι} = diff-base , apply-base
  lift-diff-apply {σ ⇒ τ} =
    let
      -- for diff
      g  = var (that (that (that this)))
      f  = var (that (that this))
      x  = var (that this)
      Δx = var this
      -- for apply
      Δh = var (that (that this))
      h  = var (that this)
      y  = var this
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply {τ} {Γ})
      _⊝σ_ = λ s t  → app (app diffσ s) t
      _⊝τ_ = λ s t  → app (app diffτ s) t
      _⊕σ_ = λ t Δt → app (app applyσ Δt) t
      _⊕τ_ = λ t Δt → app (app applyτ Δt) t
    in
      abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
      ,
      abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

  lift-diff :
    ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  lift-diff = λ {τ Γ} →
    proj₁ (lift-diff-apply {τ} {Γ})

  lift-apply :
    ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-apply = λ {τ Γ} →
    proj₂ (lift-diff-apply {τ} {Γ})


Removed unnecessary arguments.

Removed unnecessary arguments.

Ignore-this: a39d6ebeef4c07ea14c5405619bc8d59

darcs-hash:20111218163729-3bd4e-c8488225fefcfde5c7622ca2471e2ae95fba08c7.gz

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

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

module FOTC.Program.ABP.Fair.PropertiesATP where

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

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

head-tail-Fair-helper : ∀ {os ol os'} → O*L ol → os ≡ ol ++ os' →
                        os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
head-tail-Fair-helper {os} nilO*L h = prf
  where
  postulate prf : os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
  {-# ATP prove prf #-}

head-tail-Fair-helper {os} (consO*L OLol) h = prf
  where
  postulate prf : os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
  {-# ATP prove prf #-}

head-tail-Fair : ∀ {os} → Fair os → os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
head-tail-Fair {os} Fos = prf
  where
  postulate prf : os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
  {-# ATP prove prf head-tail-Fair-helper #-}

tail-Fair-helper : ∀ {os ol os'} → O*L ol → os ≡ ol ++ os' → Fair os' →
                   Fair (tail₁ os)
tail-Fair-helper {os} nilO*L h Fos' = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf #-}

tail-Fair-helper {os} (consO*L OLol) h Fos' = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf Fair-gfp₃ #-}

tail-Fair : ∀ {os} → Fair os → Fair (tail₁ os)
tail-Fair {os} Fos = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf tail-Fair-helper #-}

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

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

module FOTC.Program.ABP.Fair.PropertiesATP where

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

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

head-tail-Fair-helper : ∀ {os ol os'} → O*L ol → os ≡ ol ++ os' →
                        os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
head-tail-Fair-helper {os} {os' = os'} nilO*L h = prf
  where
  postulate prf : os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
  {-# ATP prove prf #-}

head-tail-Fair-helper {os} {os' = os'} (consO*L OLol) h = prf
  where
  postulate prf : os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
  {-# ATP prove prf #-}

head-tail-Fair : ∀ {os} → Fair os → os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
head-tail-Fair {os} Fos = prf
  where
  postulate prf : os ≡ L ∷ tail₁ os ∨ os ≡ O ∷ tail₁ os
  {-# ATP prove prf head-tail-Fair-helper #-}

tail-Fair-helper : ∀ {os ol os'} → O*L ol → os ≡ ol ++ os' → Fair os' →
                   Fair (tail₁ os)
tail-Fair-helper {os} {os' = os'} nilO*L h Fos' = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf #-}

tail-Fair-helper {os} {os' = os'} (consO*L OLol) h Fos' = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf Fair-gfp₃ #-}

tail-Fair : ∀ {os} → Fair os → Fair (tail₁ os)
tail-Fair {os} Fos = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf tail-Fair-helper #-}