Added some cpo (alea) stuff

Added some cpo (alea) stuff

module alea.cpo where

import Data.Nat.NP as Nat

import Relation.Binary.PropositionalEquality as ≡

record Order (A : Set) : Set₁ where
  constructor mk
  infix 4 _≡_ _≤_
  field
    _≤_ : A → A → Set
    _≡_ : A → A → Set
    reflexive : ∀ {x} → x ≤ x
    antisym : ∀ {x y} → x ≤ y → y ≤ x → x ≡ y
    transitive : ∀ {x y z} → x ≤ y → y ≤ z → x ≤ z

  ≡-reflexive : ∀ {x} → x ≡ x
  ≡-reflexive = antisym reflexive reflexive

ℕ : Order Nat.ℕ
ℕ = mk Nat._≤_ ≡._≡_ Nat.ℕ≤.refl Nat.ℕ≤.antisym Nat.ℕ≤.trans

funOrder : ∀ {A B : Set} → Order B → Order (A → B)
funOrder or = mk (λ f g  → ∀ x → f x ≤ g x) (λ f g → ∀ x → f x ≡ g x)
              (λ x₁ → reflexive)
              (λ f g x → antisym (f x) (g x))
              (λ f g x  → transitive (f x) (g x))
  where open Order or

_o→_ : ∀ A {B} → Order B → Order (A → B)
A o→ ob = funOrder {A} ob

record _→m_ {A B}(oa : Order A)(ob : Order B) : Set where
  constructor mk
  field
    _$_ : A → B
    mon : ∀ {x y} → Order._≤_ oa x y → Order._≤_ ob (_$_ x) (_$_ y)
open _→m_ using (_$_ ; mon)

_o→m_ : ∀ {A B}(oa : Order A)(ob : Order B) → Order (oa →m ob)
_o→m_ {A} oa ob = mk (λ f g → _$_ f ≤ _$_ g)
                     (λ f g → _$_ f ≡ _$_ g)
                     reflexive antisym transitive
  where open Order (A o→ ob)

_∘m_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
f ∘m g = mk (λ x → f $ (g $ x)) (λ x → mon f (mon g x))

_$m_ : ∀ {A B C}{oa : Order A}{oc : Order C} → oa →m (funOrder {B} oc)
     → B → oa →m oc
_$m_ {oa = oa}{oc} f b = mk (λ a → (f $ a) b) (λ x≤y → mon f x≤y b )

UB : ∀ {A} → Order A → A → Set
UB or a = ∀ x → x ≤ a
  where open Order or

record cpo {D} (o : Order D) : Set where
  constructor mk
  open Order o

  field
    d0 : D
    lub : (f : ℕ →m o) → D

  -- proofs
  field
    Dbot : ∀ x → d0 ≤ x
    lubUB : ∀ (f : ℕ →m o) n → (f $ n) ≤ lub f
    lubLUB : ∀ (f : ℕ →m o) x → (∀ n → (f $ n) ≤ x) → lub f ≤ x

funcpo : ∀ {A D}{od : Order D} → cpo od → cpo (A o→ od)
funcpo cpod = mk (λ x → d0) (λ f x → lub (f $m x)) (λ x x₁ → Dbot (x x₁)) (λ f n x → lubUB (f $m x) n)
  (λ f x x₁ x₂ → lubLUB (f $m x₂) (x x₂) (λ n → x₁ n x₂))
  where
    open cpo cpod
    open Nat
    open ≡ using (_≡_)

_c→m_ : ∀ {A D}(oa : Order A){od : Order D} → cpo od → cpo (oa o→m od)
_c→m_ {A} oa {od} cpod = mk (mk (λ x → d0) (λ x₁ → Order.reflexive od))
                        (λ f → mk (cpo.lub (funcpo {A} cpod)
                                     (mk (λ n a → (f $ n) $ a) (mon f)))
                                  (λ x≤y → lubLUB _ _ (λ n → transitive (mon (f $ n) x≤y) (lubUB _ n))))
                        (λ x x₁ → Dbot (x $ x₁))
                        (λ f n x → lubUB (mk (λ m → (f $ m) $ x) (λ x₂ → mon f x₂ x)) n)
                        (λ f x x₁ x₂ → lubLUB (mk (λ n → _$_ (f $ n)) (mon f) $m x₂) (x $ x₂) (λ n → x₁ n x₂))
  where
    open cpo cpod
    open Order od renaming (_≤_ to _≤ᵈ_)
    open Order oa using () renaming (_≤_ to _≤ᵃ_)

record continous {A B}{oa : Order A}{ob : Order B}
                 (c1 : cpo oa)(c2 : cpo ob)(f : oa →m ob) : Set where
  constructor mk
  open cpo c1 renaming (lub to luba ; lubUB to lubUBa ; lubLUB to lubLUBa)
  open cpo c2
  open Order ob
  field
    contIntro : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≤ lub (f ∘m h)

  contIntro' : ∀ (h : ℕ →m oa) → lub (f ∘m h) ≤ f $ luba h
  contIntro' h = lubLUB (f ∘m h) (f $ luba h) (λ n → mon f (lubUBa _ n))

  contEq : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≡ lub (f ∘m h)
  contEq h = antisym (contIntro h) (contIntro' h)

open continous

postulate
  Ur  : Set -- the set [0,1]
  oUr : Order Ur
  U   : cpo oUr

record distr A : Set where
  constructor mk
  field
    μ : (A o→ oUr) →m oUr
    muContinous : continous (funcpo U) U μ

open distr

distrOrder : ∀ A → Order (distr A)
distrOrder A = mk (λ f g → μ f ≤ μ g) (λ f g → μ f ≡ μ g)
  (λ {x} → reflexive {μ x}) (λ {x} {y} → antisym {μ x} {μ y}) (λ {x} {y} {z} → transitive {μ x} {μ y} {μ z})
  where
    open Order ((A o→ oUr) o→m oUr)

distrcpo : ∀ A → cpo (distrOrder A)
distrcpo A = mk (mk d0 (mk (λ h → lubUB (mk (λ z → mk (_) (_)) (_)) {!!} {!!})))
                (λ f → mk (lub (mk (λ x → μ (f $ x)) (mon f))) (mk (λ h → {!!})))
                {!!}
                {!!}
                {!!}
  where
     open cpo ((A o→ oUr) c→m U)

module FIXPOINTS {d} {D : Order d} {c : cpo D} where
  open cpo c
  open Order D

  iter : (f : D →m D) → Nat.ℕ → d
  iter f Nat.zero = d0
  iter f (Nat.suc n) = f $ iter f n

  iter-mon : (f : D →m D) → ℕ →m D
  iter-mon f = mk (iter f) mono
    where
      mono : ∀ {x y} → x Nat.≤ y → iter f x ≤ iter f y
      mono Nat.z≤n = Dbot _
      mono (Nat.s≤s prf) = mon f (mono prf)

  fix : (f : D →m D) → d
  fix f = lub (iter-mon f)

  fix-le : (F : D →m D) → fix F ≤ F $ (fix F)
  fix-le F = lubLUB _ _ prf
    where
      prf : (n : Nat.ℕ) → iter-mon F $ n ≤ F $ fix F
      prf Nat.zero = Dbot (F $ fix F)
      prf (Nat.suc n) = mon F (lubUB (iter-mon F) n)

module _ where

  open Order oUr
  open cpo U

  Munit : ∀ {A} → A → distr A
  Munit x = mk (mk (λ f → f x) (λ x≤y → x≤y x)) (mk (λ h → reflexive))

  Mlet : ∀ {A B} → distr A → (A → distr B) → distr B
  Mlet m k = mk (mk (λ f → μ m $ (λ x → μ (k x) $ f)) (λ x≤y → mon (μ m) (λ x → mon (μ (k x)) x≤y)))
     (mk (λ h → transitive (mon (μ m) (λ x → contIntro (muContinous (k x)) h)) (contIntro (muContinous m) _)))

  Munit-simpl : ∀ {A}(q : A → Ur) x → μ (Munit x) $ q ≡ q x
  Munit-simpl q x = ≡-reflexive

  Mlet-simpl : ∀ {A B}(m : distr A)(M : A → distr B)(f : B → Ur)
             → μ (Mlet m M) $ f ≡ μ m $ (λ x → μ (M x) $ f)
  Mlet-simpl m M f = ≡-reflexive

  Mlet-le-compat : ∀ {A B} (m1 m2 : distr A)(M1 M2 : A → distr B)
    → Order._≤_ (distrOrder A) m1 m2
    → Order._≤_ (A o→ distrOrder B) M1 M2
    → Order._≤_ (distrOrder B) (Mlet m1 M1) (Mlet m2 M2)
  Mlet-le-compat m1 m2 M1 M2 m1≤m2 M1≤M2 f = transitive (mon (μ m1) (λ x → M1≤M2 x f)) (m1≤m2 _)

  -- Monad laws

  Mlet-unit : ∀ {A B} (x : A)(m : A → distr B)
            → Order._≡_ (distrOrder B) (Mlet (Munit x) m) (m x)
  Mlet-unit x m f = ≡-reflexive

  Mlet-ext : ∀ {A}(m : distr A) → Order._≡_ (distrOrder A) (Mlet m Munit) m
  Mlet-ext m f = ≡-reflexive

  Mlet-assoc : ∀ {A B C}(m1 : distr A)(m2 : A → distr B)(m3 : B → distr C)
             → Order._≡_ (distrOrder C)
                (Mlet (Mlet m1 m2) m3)
                (Mlet m1 (λ x → Mlet (m2 x) m3))
  Mlet-assoc m1 m2 m3 f = ≡-reflexive

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


Version of propositional desc examples with inferred arguments.

It is probably not acceptable to include the complexity of implicit
arguments and unification in the core type theory.
However, breaking up the grammar to allow for more bidirectional
synthesis is probably okay and can reduce the size of core terms.

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.InferredPropositionalDesc where

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

elimEq : {A : Set} (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : {E : Enum} (P : Tag E → Set) → Set
Cases {[]} P = ⊤
Cases {l ∷ E} P = P here × Cases λ t → P (there t)

case : {E : Enum} (P : Tag E → Set) (cs : Cases P) (t : Tag E) → P t
case {l ∷ E} P (c , cs) here = c
case {l ∷ E} P (c , cs) (there t) = case (λ t → P (there t)) cs t

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : {I : Set} (D : Desc I) (X : ISet I) → ISet I
El (`End j) X i = j ≡ i
El (`Rec j D) X i = X j × El D X i
El (`Arg A B) X i = Σ A (λ a → El (B a) X i)
El (`RecFun A B D) X i = ((a : A) → X (B a)) × El D X i

data μ {I : Set} (D : Desc I) (i : I) : Set where
  con : El D (μ D) i → μ D i

All : {I : Set} (D : Desc I) {X : ISet I} (P : (i : I) → X i → Set) (i : I) (xs : El D X i) → Set
All (`End j) P i q = ⊤
All (`Rec j D) P i (x , xs) = P j x × All D P i xs
All (`Arg A B) P i (a , b) = All (B a) P i b
All (`RecFun A B D) P i (f , xs) = ((a : A) → P (B a) (f a)) × All D P i xs

caseD : (E : Enum) (I : Set) (cs : Cases (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case (λ _ → Desc I) cs t

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

ind :
  {I : Set}
  (D : Desc I)
  (P : (i : I) → μ D i → Set)
  (pcon : (i : I) (xs : El D (μ D) i) → All D P i xs → P i (con xs))
  {i : I}
  (x : μ D i)
  → P i x

hyps :
  {I : Set}
  (D₁ : Desc I)
  (P : (i : I) → μ D₁ i → Set)
  (pcon : (i : I) (xs : El D₁ (μ D₁) i) → All D₁ P i xs → P i (con xs))
  (D₂ : Desc I)
  {i : I}
  (xs : El D₂ (μ D₁) i)
  → All D₂ P i xs

ind D P pcon (con xs) = pcon _ xs (hyps D P pcon D xs)

hyps D P pcon (`End j) q = tt
hyps D P pcon (`Rec j A) (x , xs) = ind D P pcon x , hyps D P pcon A xs
hyps D P pcon (`Arg A B) (a , b) = hyps D P pcon (B a) b
hyps D P pcon (`RecFun A B E) (f , xs) = (λ a → ind D P pcon (f a)) , hyps D P pcon E xs

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case
        (λ t → (c : El (ℕC t) ℕ u)
               (ih : All ℕD (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case
        (λ t → (c : El (ℕC t) ℕ u)
               (ih : All ℕD (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A m = ind (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case
        (λ t → (c : El (VecC A t) (Vec A) m)
               (ih : All (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m n = ind (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case
        (λ t → (c : El (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (VecD (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ℕD (λ u n → P n)
      (λ u t,c → case
        (λ t → (c : El (ℕC t) ℕ u)
               (ih : All ℕD (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons n = ind (VecD A) (λ n xs → P n xs)
      (λ n t,c → case
        (λ t → (c : El (VecC A t) (Vec A) n)
               (ih : All (VecD A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

error: pathspec 'formalization/agda/Spire/Examples/InferredPropositionalDesc.agda' did not match any file(s) known to git


redid comm, even exists proof

redid comm, even exists proof

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong; cong-app)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Data.Product using (∃; _,_)

+-identity : ∀ (m : ℕ) → m + zero ≡ m
+-identity zero =
  begin
    zero + zero
  ≡⟨⟩
    zero
  ∎
+-identity (suc m) =
  begin
    suc m + zero
  ≡⟨⟩
    suc (m + zero)
  ≡⟨ cong suc (+-identity m) ⟩
    suc m
  ∎

+-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc zero n =
  begin
    zero + suc n
  ≡⟨⟩
    suc n
  ≡⟨⟩
    suc (zero + n)
  ∎
+-suc (suc m) n =
  begin
    suc m + suc n
  ≡⟨⟩
    suc (m + suc n)
  ≡⟨ cong suc (+-suc m n) ⟩
    suc (suc (m + n))
  ≡⟨⟩
    suc (suc m + n)
  ∎

+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm m zero =
  begin
    m + zero
  ≡⟨ +-identity m ⟩
    m
  ≡⟨⟩
    zero + m
  ∎
+-comm m (suc n) =
  begin
    m + suc n
  ≡⟨ +-suc m n ⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨⟩
    suc n + m
  ∎

data even : ℕ → Set where
  ev0 : even zero
  ev+2 : ∀ {n : ℕ} → even n → even (suc (suc n))

lemma : ∀ (m : ℕ) → 2 * suc m ≡ suc (suc (2 * m))
lemma m =
  begin
    2 * suc m
  ≡⟨⟩
    suc m + (suc m + zero)
  ≡⟨⟩
    suc (m + (suc (m + zero)))
  ≡⟨ cong suc (+-suc m (m + zero)) ⟩
    suc (suc (m + (m + zero)))
  ≡⟨⟩
    suc (suc (2 * m))
  ∎

ev-ex : ∀ {n : ℕ} → even n → ∃(λ (m : ℕ) → 2 * m ≡ n)
ev-ex ev0 =  (0 , refl)
ev-ex (ev+2 ev) with ev-ex ev
... | (m , refl) = (suc m , lemma m)

ex-ev : ∀ {n : ℕ} → ∃(λ (m : ℕ) → 2 * m ≡ n) → even n
ex-ev (zero , refl) = ev0
ex-ev (suc m , refl) rewrite lemma m = ev+2 (ex-ev (m , refl))

-- I can't see how to avoid using rewrite in the second proof,
-- or how to use rewrite in the first proof!

error: pathspec 'src/extra/Even.agda' did not match any file(s) known to git


Added missing file.

Added missing file.

------------------------------------------------------------------------------
-- Well-founded induction on the relation _≪_
------------------------------------------------------------------------------

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

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP where

open import FOTC.Base
open import FOTC.Data.Nat

import FOTC.Data.Nat.Induction.Acc.WF-ATP
open FOTC.Data.Nat.Induction.Acc.WF-ATP.WF-<

open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Induction.WF
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.PropertiesATP

-- Parametrized modules
open module InvImg =
  FOTC.Induction.WF.InverseImage {N} {N} {_<_} ≪-fn-N

------------------------------------------------------------------------------
-- The relation _≪_ is well-founded (using the inverse image combinator).
wf-≪ : WellFounded _≪_
wf-≪ Nn = wellFounded wf-< Nn

-- Well-founded induction on the relation _≪_.
wfInd-≪ : (A : D → Set) →
          (∀ {n} → N n → (∀ {m} → N m → m ≪ n → A m) → A n) →
          ∀ {n} → N n → A n
wfInd-≪ A = WellFoundedInduction wf-≪

error: pathspec 'src/fot/FOTC/Program/McCarthy91/WF-Relation/Induction/Acc/WF-ATP.agda' did not match any file(s) known to git


refactor

refactor

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/zeitraffer/agda-cats.git/'


Vec: drop′, take′, ⊛

Vec: drop′, take′, ⊛

module Data.Vec.NP where

open import Data.Vec public hiding (_⊛_; zipWith; zip; map)
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
open import Data.Fin.Props
open import Data.Bool
open import Data.Product hiding (map; zip)
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    map : ∀ {a b n} {A : Set a} {B : Set b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

    zip : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec A n → Vec B n → Vec (A × B) n
    zip = zipWith _,_

open waiting-for-a-fix-in-the-stdlib public

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite inject₁-lemma (countᶠ pred (map f xs))
                  | inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite inject₁-lemma (countᶠ pred (xs ++ ys))
                  | inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

drop′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop′ zero    = id
drop′ (suc m) = drop′ m ∘ tail

drop′-spec : ∀ {a} {A : Set a} m {n} → drop′ {A = A} m {n} ≗ drop m {n}
drop′-spec zero xs = refl
drop′-spec (suc m) (x ∷ xs) rewrite drop′-spec m xs | drop-∷ m x xs = refl

take′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take′ zero    _  = []
take′ (suc m) xs = head xs ∷ take′ m (tail xs)

take′-spec : ∀ {a} {A : Set a} m {n} → take′ {A = A} m {n} ≗ take m {n}
take′-spec zero xs = refl
take′-spec (suc m) (x ∷ xs) rewrite take′-spec m xs | take-∷ m x xs = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

-- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔+1⟩ = 0↔1
⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

-- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
--           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot-up-to zero    = id
rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

-- Inverse of rot-up-to
rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot⁻¹-up-to zero    = id
rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
rot⁻¹-up-to∘rot-up-to zero            _ = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = ≡.refl

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = rot⁻¹-up-to (inject₁ i) ∘ rot-up-to (suc i)

⟨0↔zero⟩ : ∀ {n a} {A : Set a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = ≡.refl

-- ⟨ i ↔ j ⟩: Exchange elements at position i and j.
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

⟨0↔⟩-spec : ∀ {n a} {A : Set a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
⟨0↔⟩-spec _ _ = ≡.refl

⟨_↔_⟩′ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔ j     ⟩′ = ⟨0↔ j ⟩
⟨ i     ↔ zero  ⟩′ = ⟨0↔ i ⟩
⟨ suc i ↔ suc j ⟩′ = map-tail ⟨ i ↔ j ⟩′

⟨↔⟩′-comm : ∀ {n a} {A : Set a} (i j : Fin n) → ⟨ i ↔ j ⟩′ ≗ ⟨ j ↔ i ⟩′ {A = A}
⟨↔⟩′-comm zero    zero    _ = ≡.refl
⟨↔⟩′-comm zero    (suc _) _ = ≡.refl
⟨↔⟩′-comm (suc _) zero    _ = ≡.refl
⟨↔⟩′-comm (suc i) (suc j) (x ∷ xs) rewrite ⟨↔⟩′-comm i j xs = ≡.refl

⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : Set a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩′ {A = A}
⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = ≡.refl
⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = ≡.refl

⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔_⟩′ {zero}  i xs = xs
⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

module Data.Vec.NP where

open import Data.Vec public
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
open import Data.Fin.Props
open import Data.Bool
open import Data.Product hiding (map)
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite inject₁-lemma (countᶠ pred (map f xs))
                  | inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite inject₁-lemma (countᶠ pred (xs ++ ys))
                  | inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

-- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔+1⟩ = 0↔1
⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

-- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
--           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot-up-to zero    = id
rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

-- Inverse of rot-up-to
rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot⁻¹-up-to zero    = id
rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
rot⁻¹-up-to∘rot-up-to zero            _ = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = ≡.refl

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = rot⁻¹-up-to (inject₁ i) ∘ rot-up-to (suc i)

⟨0↔zero⟩ : ∀ {n a} {A : Set a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = ≡.refl

-- ⟨ i ↔ j ⟩: Exchange elements at position i and j.
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

⟨0↔⟩-spec : ∀ {n a} {A : Set a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
⟨0↔⟩-spec _ _ = ≡.refl

⟨_↔_⟩′ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔ j     ⟩′ = ⟨0↔ j ⟩
⟨ i     ↔ zero  ⟩′ = ⟨0↔ i ⟩
⟨ suc i ↔ suc j ⟩′ = map-tail ⟨ i ↔ j ⟩′

⟨↔⟩′-comm : ∀ {n a} {A : Set a} (i j : Fin n) → ⟨ i ↔ j ⟩′ ≗ ⟨ j ↔ i ⟩′ {A = A}
⟨↔⟩′-comm zero    zero    _ = ≡.refl
⟨↔⟩′-comm zero    (suc _) _ = ≡.refl
⟨↔⟩′-comm (suc _) zero    _ = ≡.refl
⟨↔⟩′-comm (suc i) (suc j) (x ∷ xs) rewrite ⟨↔⟩′-comm i j xs = ≡.refl

⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : Set a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩′ {A = A}
⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = ≡.refl
⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = ≡.refl

⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔_⟩′ {zero}  i xs = xs
⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)


Added note on proof terms.

Added note on proof terms.

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

-- Discussion about the inductive approach for representing
-- first-order theories.

-- Peter: If you take away the proof objects (as you do when you go to
-- predicate logic) the K axiom doesn't give you any extra power.

module ProofTerm where

infix 7  _≡_
infixr 7 _,_

postulate D : Set

-- The identity type on the universe of discourse.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

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

foo : (∃ λ x → ∃ λ y → x ≡ y) → (∃ λ x → ∃ λ y → y ≡ x)
foo (x , .x , refl) = x , x , refl

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


Minimal example demonstrating sized types bug in Agda

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/'


First use of CTT ('Function Extensionality')

module CTT where

open import PathPrelude
open import Data.Empty
open import Relation.Nullary

¬fun-eq : ∀{ℓ} → {A : Set ℓ} → (f g : ¬ A) → f ≡ g
¬fun-eq f g = funExt (¬fun-eq' f g) where
  ¬fun-eq' : ∀{ℓ} → {A : Set ℓ} → (f g : ¬ A) → (x : A) → f x ≡ g x
  ¬fun-eq' f g x = ⊥-elim (f x)

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


Start labelled descriptions examples, and use eliminators exclusively.

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.LabelledDesc where

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

data Cases2 (A : Set) : Enum → Set where -- Vec, Enum is ℕ, Tag is Fin
  [] : Cases2 A []
  _∷_ : ∀{l E} → A → Cases2 A E → Cases2 A (l ∷ E)

-- lookup
case2 : (E : Enum) (A : Set) → Cases2 A E → Tag E → A
case2 (l ∷ E) A (c ∷ cs) here = c
case2 (l ∷ E) A (c ∷ cs) (there t) = case2 E A cs t

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

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

data Desc (I : Set) : Set₁ where
  `Rec : (i : I) (D : Desc I) → Desc I
  `End : (i : I) → Desc I
  `Σ `Π : (A : Set) (B : A → Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j)   X i = i ≡ j
El I (`Rec j D) X i = X j × El I D X i
El I (`Σ A B)   X i = Σ A (λ a → El I (B a) X i)
El I (`Π A B)   X i = (a : A) → El I (B a) X i

data μ (I : Set) (D : Desc I) (i : I) : Set where
  con : El I D (μ I D) i → μ I D i

All : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
All I (`Rec j D) X P i (x , xs) = P j x × All I D X P i xs
All I (`End j) X P i q = ⊤
All I (`Σ A B) X P i (a , b) = All I (B a) X P i b
All I (`Π A B) X P i f = (a : A) → All I (B a) X P i (f a)

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : (i : I) (xs : El I D (μ I D) i) → All I D (μ I D) P i xs → P i (con xs))
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : (i : I) (xs : El I D₁ (μ I D₁) i) → All I D₁ (μ I D₁) P i xs → P i (con xs))
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → All I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Σ A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`Π A B) i f = λ a → hyps I D P pcon (B a) i (f a)

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

ℕT : Enum
ℕT = "zero" ∷ "suc" ∷ []

VecT : Enum
VecT = "nil" ∷ "cons" ∷ []

ℕC : Tag ℕT → Desc ⊤
ℕC = caseD ℕT ⊤
  ( `End tt
  , `Rec tt (`End tt)
  , tt
  )

ℕD : Desc ⊤
ℕD = `Σ (Tag ℕT) ℕC

ℕD2 : Desc ⊤
ℕD2 = `Σ (Tag ℕT) (case2 ℕT (Desc ⊤)
  ( `End tt
  ∷ `Rec tt (`End tt)
  ∷ []
  ))

ℕ : ⊤ → Set
ℕ = μ ⊤ ℕD

-- zero : ℕ tt
pattern zero = con (here , refl)

-- suc : ℕ tt → ℕ tt
pattern suc n = con (there here , n , refl)

VecD : (A : Set) → Desc (ℕ tt)
VecD A = `Σ (Tag VecT) (caseD VecT (ℕ tt)
  ( `End zero
  , `Σ (ℕ tt) (λ n → `Σ A λ _ → `Rec n (`End (suc n)))
  , tt
  ))

Vec : (A : Set) (n : ℕ tt) → Set
Vec A n = μ (ℕ tt) (VecD A) n

nil : (A : Set) → Vec A zero
nil A = con (here , refl)

cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons A n x xs = con (there here , n , x , xs , refl)

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

addC : (u : ⊤) (xs : El ⊤ ℕD ℕ u)
  (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u xs)
  → ℕ u → ℕ u
addC u xs = case ℕT
  (λ t → (c : El ⊤ (ℕC t) ℕ u) (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c)) → ℕ u → ℕ u )
  ( (λ q ih n → n)
  , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
  , tt
  )
  (proj₁ xs)
  (proj₂ xs)

-- addC : (u : ⊤) (xs : El ⊤ ℕD ℕ u)
--   (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u xs)
--   → ℕ u → ℕ u
-- addC tt (here , q) ih n = n
-- addC tt (there here , m , q) (ih , tt) n = suc (ih n)
-- addC tt (there (there ()) , q) ih n

add : ℕ tt → ℕ tt → ℕ tt
add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt) addC tt

-- multC : (u : ⊤) (xs : El ⊤ ℕD ℕ u)
--   (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u xs)
--   → ℕ u → ℕ u
-- multC tt (`zero , q) tt n = zero
-- multC tt (`suc , m , q) (ih , tt) n = add n (ih n)

-- mult : ℕ tt → ℕ tt → ℕ tt
-- mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt) multC tt

-- appendC : (u : ⊤) (A : Set) (m : ℕ u) (xs : El (ℕ u) (VecD A) (Vec A) m)
--   (ih : All (ℕ u) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m xs)
--   (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
-- appendC tt A .(con (`zero , refl)) (`nil , refl) ih n ys = ys
-- appendC tt A .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys = cons A (add m n) x (ih n ys)

-- append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
-- append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) (appendC tt A)

-- concatC : (u : ⊤) (A : Set) (m n : ℕ u) (xss : El (ℕ u) (VecD (Vec A m)) (Vec (Vec A m)) n)
--   (ih : All (ℕ u) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n xss)
--   → Vec A (mult n m)
-- concatC tt A m .(con (`zero , refl)) (`nil , refl) tt = nil A
-- concatC tt A m .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) = append A m xs (mult n m) ih

-- concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
-- concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m)) (concatC tt A m)

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

error: pathspec 'formalization/agda/Spire/Examples/LabelledDesc.agda' did not match any file(s) known to git


module Function.Bijection.SyntaxKit where

import Level as L
open import Function.NP
open import Data.Bool
open import Data.Bool.Properties
open import Data.Unit
open import Relation.Binary.PropositionalEquality

record BijKit b {a} (A : Set a) : Set (L.suc b L.⊔ a) where
  constructor mk
  field
    Bij   : Set b
    eval  : Bij → Endo A
    _⁻¹   : Endo Bij
    idBij : Bij
    _⁏Bij_ : Bij → Bij → Bij

  eval⁻¹ : Bij → Endo A
  eval⁻¹ f = eval (f ⁻¹)

  _≗Bij_ : Bij → Bij → Set _
  _≗Bij_ = λ f g → ∀ (x : A) → eval f x ≡ eval g x

  field
    id-spec : eval idBij ≗ id
    _⁏-spec_ : ∀ f g → eval (f ⁏Bij g) ≗ eval g ∘ eval f

    _⁻¹-inverse : ∀ f → eval (f ⁻¹) ∘ eval f ≗ id
    _⁻¹-involutive : ∀ f → (f ⁻¹) ⁻¹ ≗Bij f

  _⁻¹-inverseBij : ∀ f → (f ⁏Bij f ⁻¹) ≗Bij idBij
  (f ⁻¹-inverseBij) x rewrite (f ⁏-spec (f ⁻¹)) x
                            | id-spec x
                            | (f ⁻¹-inverse)
                            x = refl

  _⁻¹-inverse′ : ∀ f → (eval f ∘ eval (f ⁻¹)) ≗ id
  (f ⁻¹-inverse′) x with ((f ⁻¹) ⁻¹-inverse) x
  ... | p rewrite (f ⁻¹-involutive) (eval (f ⁻¹) x) = p

  _⁻¹-inverseBij′ : ∀ f → (f ⁻¹ ⁏Bij f) ≗Bij idBij
  (f ⁻¹-inverseBij′) x rewrite (f ⁻¹ ⁏-spec f) x
                             | id-spec x
                             | (f ⁻¹-inverse′)
                            x = refl

module BoolBijection where
  data BoolBij : Set where
    `id `not : BoolBij

  bool-bijKit : BijKit L.zero Bool
  bool-bijKit = mk BoolBij eval id `id _⁏Bij_ (λ _ → refl) _⁏-spec_ _⁻¹-inverse (λ _ _ → refl) where
    eval  : BoolBij → Endo Bool
    eval `id = id
    eval `not = not

    _⁏Bij_ : BoolBij → BoolBij → BoolBij
    `id  ⁏Bij g    = g
    f    ⁏Bij `id  = f
    `not ⁏Bij `not = `id

    _⁏-spec_ : ∀ f g → eval (f ⁏Bij g) ≗ eval g ∘ eval f
    `id  ⁏-spec g    = λ _ → refl
    `not ⁏-spec `id  = λ _ → refl
    `not ⁏-spec `not = sym ∘ not-involutive

    _⁻¹-inverse : ∀ f → eval f ∘ eval f ≗ id
    (`id  ⁻¹-inverse) = λ _ → refl
    (`not ⁻¹-inverse) = not-involutive

  module BoolBijKit = BijKit bool-bijKit

module 1-Bijection {a} (A : Set a) where
    1-bij : BijKit L.zero A
    1-bij = mk ⊤ (λ _ → id) _ _ _ (λ _ → refl) (λ _ _ _ → refl) (λ _ _ → refl) (λ _ _ → refl)

    module 1-BijKit = BijKit 1-bij

module UnitBijection where
    open 1-Bijection
    ⊤-bijKit : BijKit L.zero ⊤
    ⊤-bijKit = 1-bij ⊤

    module UnitBijKit = 1-BijKit ⊤

error: pathspec 'lib/Function/Bijection/SyntaxKit.agda' did not match any file(s) known to git


cont.agda

cont.agda

{-# OPTIONS --copatterns #-}

open import Type
open import Function
open import Data.Product hiding (map)

module cont (T : ★) where

ContA : ★ → ★
ContA A = (A → T) → T

record Cont (A : ★) : ★ where
  field
    runCont : (A → T) → T

open Cont

return : ∀ {A} → A → Cont A
runCont (return x) k = k x

map : ∀ {A B} → (A → B) → (Cont A → Cont B)
runCont (map f mx) k = runCont mx λ x → k (f x)

_>>=_ : ∀ {A B} → Cont A → (A → Cont B) → Cont B
runCont (mx >>= f) k = runCont mx λ x → runCont (f x) k

join : ∀ {A} → Cont (Cont A) → Cont A
join mmx = mmx >>= id

_⊛_ : ∀ {A B} → Cont (A → B) → Cont A → Cont B
mf ⊛ mx = mf >>= λ f → map f mx

⟪_·_·_⟫ : ∀ {A B C} → (A → B → C) → Cont A → Cont B → Cont C
⟪ f · mx · my ⟫ = map f mx ⊛ my

_⟨,⟩_ : ∀ {A B} → Cont A → Cont B → Cont (A × B)
mx ⟨,⟩ my = ⟪ _,_ · mx · my ⟫

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


new cool way

new cool way


[ test-suite ] Added common definitions.

------------------------------------------------------------------------------
-- Common FOL definitions
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module Common.FOL where

infix  6 ∃
infix  4 _≡_
infixr 4 _,_

postulate D : Set

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

-- The identity type on D.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

error: pathspec 'test/succeed/fol-theorems/Common/FOL.agda' did not match any file(s) known to git


some trials

some trials

open import Base

module GoaTest where

data Bool : Type where
  true : Bool
  false : Bool

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

notnot : Bool → Bool
notnot x = not (not x)

and : Bool → Bool → Bool
and true y = y
and false y = false

data ℕ : Type where
  zero : ℕ
  succ : ℕ → ℕ

even : ℕ → Bool
even zero = true
even (succ x) = not (even x)

add : ℕ → ℕ → ℕ
add zero y = y
add (succ x) y = succ (add x y)

{-# BUILTIN NATURAL ℕ #-}

data True : Type where
  qed : True

data False : Type where

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


Another bug generator for Agda 2.3.2

Another bug generator for Agda 2.3.2

Old-commit-hash: 42373aea0f9da90ca9060e42aa9d40627ffacf75

{-
Bug generator for Agda 2.3.2

Typechecking this file yields the following message:

An internal error has occurred. Please report this as a bug.
Location of the error: src/full/Agda/TypeChecking/Conversion.hs:428
-}

module TaggedDeltaTypes where

open import Data.NatBag renaming
  (map to mapBag ; empty to emptyBag ; update to updateBag)
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

-- Postulates: Extensionality and bag properties (#55)
postulate extensionality : Extensionality Level.zero Level.zero
--
-- 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
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

------------------------
-- Syntax of programs --
------------------------

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

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

  add : ∀ {Γ} → (s : Term Γ nats) → (t : Term Γ nats) → Term Γ nats
  map : ∀ {Γ} → (f : Term Γ (nats ⇒ nats)) → (b : Term Γ bags) → Term Γ bags

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 (add t₁ t₂) = add (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (map f b) = map (weaken subctx f) (weaken subctx b)

---------------------------
-- Semantics of programs --
---------------------------

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
⟦ add m n ⟧Term ρ = ⟦ m ⟧Term ρ + ⟦ n ⟧Term ρ
⟦ map f b ⟧Term ρ = mapBag (⟦ f ⟧Term ρ) (⟦ 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 (add m n) ρ = cong₂ _+_ (weaken-sound m ρ) (weaken-sound n ρ)
weaken-sound (map f b) ρ =
  cong₂ mapBag (weaken-sound f ρ) (weaken-sound b ρ)

----------------------------------------------------------
-- Syntax and semantics of changes (they are entangled) --
----------------------------------------------------------

data Δ-Type : Set where
  Δ : (τ : Type) → Δ-Type

data Δ-Context : Set where
  Δ : (Γ : Context) → Δ-Context

Env : Context → Set
Env Γ = ⟦ Γ ⟧Context

private data Δ-Term : Δ-Context → Δ-Type → Set

-- Syntax of Δ-Types
-- ...   is mutually recursive with semantics of Δ-Terms,
-- (because it embeds validity proofs)
-- which is mutually recursive with validity and Δ-environments,
-- which is mutually recursive with ⊕,
-- which is mutually recursive with ⊝ and R[v,v⊝v],
-- which is mutually recursive with v⊕[u⊝v]=v, et cetera.
⟦_⟧Δτ : Δ-Type → Set
Δ-Env : Context → Set
⟦_⟧Δ : ∀ {τ : Type} {Γ : Context}
    → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
_⊕_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → ⟦ τ ⟧
_⊝_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ
valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → Set
R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊕ (u ⊝ v) ≡ u
ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧
update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧

infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

abstract
 data Δ-Term where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → Δ-Term (Δ Γ) (Δ nats)
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → Δ-Term (Δ Γ) (Δ bags)
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → Δ-Term (Δ Γ) (Δ τ)
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (t : Δ-Term (Δ (τ₁ • Γ)) (Δ τ₂)) →
         Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂))
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {τ₁ τ₂ Γ} →(ds : Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂)))
                    → ( t :   Term    Γ      τ₁)
                    → (dt : Δ-Term (Δ Γ) (Δ  τ₁))
                    → (R[t,dt] : {ρ : Δ-Env Γ} → -- 'Tis but a proof.
                                 valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ)) →
         Δ-Term (Δ Γ) (Δ τ₂)
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ} → (ds : Δ-Term (Δ Γ) (Δ nats))
               → (dt : Δ-Term (Δ Γ) (Δ nats)) →
         Δ-Term (Δ Γ) (Δ nats)
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (df : Δ-Term (Δ Γ) (Δ (nats ⇒ nats)))
                → ( b :   Term    Γ     bags)
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)
  Δmap₁ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)

-- ⟦_⟧Δτ : Δ-Type → Set
⟦ Δ nats ⟧Δτ = ℕ × ℕ
⟦ Δ bags ⟧Δτ = Bag
⟦ Δ (τ₁ ⇒ τ₂) ⟧Δτ =
  (v : ⟦ τ₁ ⟧) → (dv : ⟦ Δ τ₁ ⟧Δτ) → valid v dv → ⟦ Δ τ₂ ⟧Δτ

meaning-Δτ : Meaning Δ-Type
meaning-Δτ = meaning ⟦_⟧Δτ

_⊕_ {nats}   n dn = proj₂ dn
_⊕_ {bags}   b db = b ++ db
_⊕_ {τ₁ ⇒ τ₂} f df = λ v → f v ⊕ df v (v ⊝ v) R[v,u⊝v]

_⊝_ {nats}   m n = (n , m)
_⊝_ {bags}   b d = b \\ d
_⊝_ {τ₁ ⇒ τ₂} f g = λ v dv R[v,dv] → f (v ⊕ dv) ⊝ g v

-- valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {τ₁ ⇒ τ₂} f df =
  ∀ (v : ⟦ τ₁ ⟧) (dv : ⟦ Δ τ₁ ⟧Δτ) (R[v,dv] : valid v dv)
  → valid (f v) (df v dv R[v,dv])
  × (f ⊕ df) (v ⊕ dv) ≡ f v ⊕ df v dv R[v,dv]

eq1 : ∀ {τ₁ τ₂ : Type} {f : ⟦ τ₁ ⇒ τ₂ ⟧} {df} {x : ⟦ τ₁ ⟧} {dx} →
      valid f df → (R[x,dx] : valid x dx) →
      (f ⊕ df) (x ⊕ dx) ≡ f x ⊕ df x dx R[x,dx]

eq1 R[f,df] R[x,dx] = proj₂ (R[f,df] _ _ R[x,dx])

v⊕[u⊝v]=u {nats}   {u} {v} = refl
v⊕[u⊝v]=u {bags}   {u} {v} = b++[d\\b]=d {v} {u}
v⊕[u⊝v]=u {τ₁ ⇒ τ₂} {u} {v} = extensionality (λ w →
  begin
    (v ⊕ (u ⊝ v)) w
  ≡⟨ refl ⟩ -- for clarity
    v w ⊕ (u (w ⊕ (w ⊝ w)) ⊝ v w)
  ≡⟨ cong (λ hole → v w ⊕ (u hole ⊝ v w)) v⊕[u⊝v]=u ⟩
    v w ⊕ (u w ⊝ v w)
  ≡⟨ v⊕[u⊝v]=u ⟩
    u w
  ∎) where open ≡-Reasoning

R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {τ₁ ⇒ τ₂} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v] -- NOT a self recursion: implicit arguments are different.
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {_} {u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {_} {u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

record Quadruple
  (A : Set) (B : A → Set) (C : (a : A) → B a → Set)
  (D : (a : A) → (b : B a) → (c : C a b) → Set): Set where
  constructor cons
  field
    car    : A
    cadr   : B car
    caddr  : C car cadr
    cadddr : D car cadr caddr

open Quadruple public

-- The type of environments ensures their consistency.
-- Δ-Env : Context → Set
Δ-Env ∅ = EmptySet
Δ-Env (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ v → ⟦ Δ τ ⟧Δτ)
  (λ v dv → valid v dv)
  (λ v dv R[v,dv] → Δ-Env Γ)

-- ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
ignore {∅} ρ = ∅
ignore {τ • Γ} (cons v dv R[v,dv] ρ) = v • ignore ρ

-- update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
update {∅} ρ = ∅
update {τ • Γ} (cons v dv R[v,dv] ρ) = (v ⊕ dv) • update ρ

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] ρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] ρ) = ⟦ x ⟧ΔVar ρ

-- ⟦_⟧ΔVar is not put into the Meaning type class
-- because its argument is identical to that of ⟦_⟧Var.

-- ⟦_⟧Δ : ∀ {τ Γ} → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
abstract
 ⟦ Δnat old new ⟧Δ ρ = (old , new)
 ⟦ Δbag db ⟧Δ ρ = db
 ⟦ Δvar x ⟧Δ ρ = ⟦ x ⟧ΔVar ρ
 ⟦ Δabs t ⟧Δ ρ = λ v dv R[v,dv] → ⟦ t ⟧Δ (cons v dv R[v,dv] ρ)
 ⟦ Δapp ds t dt R[dt,t] ⟧Δ ρ =
   ⟦ ds ⟧Δ ρ (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ) R[dt,t]
 ⟦ Δadd ds dt ⟧Δ ρ =
   let
     (old-s , new-s) = ⟦ ds ⟧Δ ρ
     (old-t , new-t) = ⟦ dt ⟧Δ ρ
   in
     (old-s + old-t , new-s + new-t)
 ⟦ Δmap₀ f df b db ⟧Δ ρ =
   let
     v  = ⟦ b ⟧ (ignore ρ)
     h  = ⟦ f ⟧ (ignore ρ)
     dv = ⟦ db ⟧Δ ρ
     dh = ⟦ df ⟧Δ ρ
   in
     mapBag (h ⊕ dh) (v ⊕ dv) \\ mapBag h v
 ⟦ Δmap₁ f db ⟧Δ ρ = mapBag (⟦ f ⟧ (ignore ρ)) (⟦ db ⟧Δ ρ)

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

--------------------------------------------------------
-- Program transformation and correctness (entangled) --
--------------------------------------------------------

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

validity : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  valid (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

-- derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)
derive (nat n) = Δnat n n
derive (bag b) = Δbag b
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t) validity
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

validity-var : ∀ {τ Γ} → (x : Var Γ τ) →
  ∀ {ρ : Δ-Env Γ} → valid (⟦ x ⟧ (ignore ρ)) (⟦ x ⟧ΔVar ρ)

validity-var this {cons v dv R[v,dv] ρ} = R[v,dv]
validity-var (that x) {cons v dv R[v,dv] ρ} = validity-var x

--validity {nats} {Γ} {nat n} {∅} = ?
validity {nats} {∅}    {nat n} {∅} =
  begin
    n
  ≡⟨ ? ⟩
    proj₁ (n , n)
  ≡⟨ {!!} ⟩
    proj₁ (⟦ Δnat n n ⟧ ∅)
  ∎ where open ≡-Reasoning
validity {nats} {τ • Γ} {nat n} {ρ} = {!!}
validity {bags} {Γ} {bag b} = {!!}
validity {τ} {Γ} {var x} = {!!}
validity {τ₁ ⇒ τ₂} {Γ} {abs t} = {!!}
validity {τ} {Γ} {app t t₁} = {!!}
validity {nats} {Γ} {add t t₁} = {!!}
validity {bags} {Γ} {map t t₁} = {!!}

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


Add lemmas to prove function changes valid

module New.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Product
open import Postulate.Extensionality

open import New.Changes

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

  -- To avoid unification problems, use a one-field record (a Haskell "newtype")
  -- instead of a "type synonym".
  record _≙_ (dx dy : Ch A) : Set a where
    -- doe = Delta-Observational Equivalence.
    constructor doe
    field
      proof : x ⊕ dx ≡ x ⊕ dy

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

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

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

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

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

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

  ≙-setoid : Setoid a a
  ≙-setoid = record
    { Carrier       = Ch A
    ; _≈_           = _≙_
    ; isEquivalence = ≙-isEquivalence
    }

≙-syntax : ∀ {a} {A : Set a} {{CA : ChAlg A}} (x : A) (dx₁ dx₂ : Ch A) → Set a
≙-syntax x dx₁ dx₂ = _≙_ {x = x} dx₁ dx₂
syntax ≙-syntax x dx₁ dx₂ = dx₁ ≙[ x ] dx₂

module BinaryValid
  {A : Set} {{CA : ChAlg A}}
  {B : Set} {{CB : ChAlg B}}
  {C : Set} {{CC : ChAlg C}}
  (f : A → B → C) (df : A → Ch A → B → Ch B → Ch C)
  where
  open import Data.Product

  binary-valid-preserve-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
    → valid (f a b) (df a da b db)

  binary-valid-eq-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
    → (f ⊕ df) (a ⊕ da) (b ⊕ db) ≡ f a b ⊕ df a da b db

  binary-valid :
    binary-valid-preserve-hp →
    binary-valid-eq-hp →
    valid f df
  binary-valid ext-valid proof a da ada =
      (λ b db bdb → ext-valid a da ada b db bdb , lem2 b db bdb)
    , ext lem1
    where
      lem1 : ∀ b → f (a ⊕ da) b ⊕ df (a ⊕ da) (nil (a ⊕ da)) b (nil b) ≡
        f a b ⊕ df a da b (nil b)
      lem1 b
        rewrite sym (update-nil b)
        | proof a da ada b (nil b) (nil-valid b)
        | update-nil b = refl
      lem2 : ∀ b (db : Ch B) (bdb : valid b db) →
        f a (b ⊕ db) ⊕ df a da (b ⊕ db) (nil (b ⊕ db)) ≡
        f a b ⊕ df a da b db
      lem2 b db bdb
        rewrite sym (proof a da ada (b ⊕ db) (nil (b ⊕ db)) (nil-valid (b ⊕ db)))
        | update-nil (b ⊕ db) = proof a da ada b db bdb

module TernaryValid
  {A : Set} {{CA : ChAlg A}}
  {B : Set} {{CB : ChAlg B}}
  {C : Set} {{CC : ChAlg C}}
  {D : Set} {{CD : ChAlg D}}
  (f : A → B → C → D) (df : A → Ch A → B → Ch B → C → Ch C → Ch D)
  where

  ternary-valid-preserve-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
      c dc (cdc : valid c dc)
    → valid (f a b c) (df a da b db c dc)

  -- These are explicit definitions only to speed up typechecking.
  CA→B→C→D : ChAlg (A → B → C → D)
  CA→B→C→D = funCA
  f⊕df = (_⊕_ {{CA→B→C→D}} f df)

  -- Already this definition takes a while to typecheck.
  ternary-valid-eq-hp =
    ∀ a (da : Ch A {{CA}}) (ada : valid {{CA}} a da)
      b (db : Ch B {{CB}}) (bdb : valid {{CB}} b db)
      c (dc : Ch C {{CC}}) (cdc : valid {{CC}} c dc)
    → f⊕df (a ⊕ da) (b ⊕ db) (c ⊕ dc) ≡ f a b c ⊕ df a da b db c dc

  ternary-valid :
    ternary-valid-preserve-hp →
    ternary-valid-eq-hp →
    valid f df
  ternary-valid ext-valid proof a da ada =
    binary-valid
      (λ b db bdb c dc cdc → ext-valid a da ada b db bdb c dc cdc)
      lem2
    , ext (λ b → ext (lem1 b))
    where
      open BinaryValid (f a) (df a da)
      lem1 : ∀ b c → f⊕df (a ⊕ da) b c ≡ (f a ⊕ df a da) b c
      lem1 b c
        rewrite sym (update-nil b)
        | sym (update-nil c)
        |
          proof
            a da ada
            b (nil b) (nil-valid b)
            c (nil c) (nil-valid c)
        | update-nil b
        | update-nil c = refl
        -- rewrite
        --   sym
        --   (proof
        --     (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))
        --     b (nil b) (nil-valid b)
        --     c (nil c) (nil-valid c))
        -- | update-nil (a ⊕ da)
        -- | update-nil b
        -- | update-nil c = {! !}
      lem2 : ∀ b db (bdb : valid b db)
               c dc (cdc : valid c dc) →
                 (f a ⊕ df a da) (b ⊕ db) (c ⊕ dc)
               ≡ f a b c ⊕ df a da b db c dc
      lem2 b db bdb c dc cdc
        rewrite sym
          (proof
            a da ada
            (b ⊕ db) (nil (b ⊕ db)) (nil-valid (b ⊕ db))
            (c ⊕ dc) (nil (c ⊕ dc)) (nil-valid (c ⊕ dc))
          )
        | update-nil (b ⊕ db)
        | update-nil (c ⊕ dc) = proof a da ada b db bdb c dc cdc

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


Rand.agda

Rand.agda

{- This file illustrate that if we were given a (non-indexed)
   monad to write randomized programs then we could embed
   randomized programs modeled as deterministic programs taking
   their randomness as an extra argument. -}

open import Type
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (_↔_; module Inverse; sym)
open import Function.Related.TypeIsomorphisms.NP
open import Data.Product
open import Data.Bits
open import Data.Fin using (Fin; zero; suc)
open import Data.Sum
open import Data.Nat using (ℕ; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat.Positive
open import Data.Unit
open import Data.Maybe.NP
open import Relation.Binary.PropositionalEquality as ≡ using (→-to-⟶)

module Rand
  (M       : ★ → ★)
  (]0,1[   : ★)
  (_/num+_ : ℕ⁺ → ℕ⁺ → ]0,1[)
  (unit    : ∀ {A} → A → M A)
  (_>>=_   : ∀ {A B} → M A → (A → M B) → M B)
  (map     : ∀ {A B} → (A → B) → M A → M B)
  (choose  : ∀ {A} → ]0,1[ → M A → M A → M A)
 where

Cardinality = ℕ⁺

Rand : ★ → ★
Rand A = Cardinality × M A

embed : ∀ {R A B : ★} → Rand R → (R → A → B) → A → M B
embed (_ , randᴿ) f x = randᴿ >>= λ r → unit (f r x)

1/2 : ]0,1[
1/2 = [ 1 ] /num+ [ 1 ]

rand⊤ : Rand ⊤
rand⊤ = [ 1 ] , unit _

randBit : Rand Bit
randBit = [ 2 ] , choose 1/2 (unit false) (unit true)

_×Rand_ : ∀ {A B} → Rand A → Rand B → Rand (A × B)
(cᴬ , mᴬ) ×Rand (cᴮ , mᴮ) = cᴬˣᴮ , mᴬˣᴮ
  where
  cᴬˣᴮ = cᴬ * cᴮ
  mᴬˣᴮ = mᴬ >>= λ x → mᴮ >>= λ y → unit (x , y)

_⊎Rand_ : ∀ {A B} → Rand A → Rand B → Rand (A ⊎ B)
(cᴬ , mᴬ) ⊎Rand (cᴮ , mᴮ) = cᴬ⁺ᴮ , mᴬ⁺ᴮ
  where
  cᴬ⁺ᴮ    = cᴬ + cᴮ
  cᴬ/cᴬ⁺ᴮ = cᴬ /num+ cᴮ
  mᴬ⁺ᴮ    = choose cᴬ/cᴬ⁺ᴮ (map inj₁ mᴬ) (map inj₂ mᴮ)

mapRand : ∀ {A B} → A ↔ B → Rand A → Rand B
mapRand f (cᴬ , mᴬ) = cᴬ , map f′ mᴬ
  where f′ = _⟨$⟩_ (Inverse.to f)

rand^ : ∀ {A} → Rand A → (n : ℕ) → Rand (A ^ n)
rand^ randᴬ zero    = rand⊤
rand^ randᴬ (suc n) = randᴬ ×Rand (rand^ randᴬ n)

randVec : ∀ {A} → Rand A → (n : ℕ) → Rand (Vec A n)
randVec randᴬ n = mapRand (^↔Vec n) (rand^ randᴬ n)

randBits : ∀ n → Rand (Bits n)
randBits = randVec randBit

randMaybe : ∀ {A} → Rand A → Rand (Maybe A)
randMaybe randᴬ = mapRand (sym Maybe↔⊤⊎) (rand⊤ ⊎Rand randᴬ)

randMaybe^ : ∀ n → Rand (Maybe^ n ⊤)
randMaybe^ zero    = rand⊤
randMaybe^ (suc n) = randMaybe (randMaybe^ n)

randFin1+ : ∀ n → Rand (Fin (suc n))
randFin1+ n = mapRand (Maybe^⊤↔Fin1+ n) (randMaybe^ n)

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


BinTree.agda

BinTree.agda

module Explore.BinTree where

open import Data.Tree.Binary
open import Explore.Type

fromBinTree : ∀ {m A} → BinTree A → Explore m A
fromBinTree (leaf x)   _   f = f x
fromBinTree (fork ℓ r) _∙_ f = fromBinTree ℓ _∙_ f ∙ fromBinTree r _∙_ f

fromBinTree-ind : ∀ {m p A} (t : BinTree A) → ExploreInd p (fromBinTree {m} t)
fromBinTree-ind (leaf x)   P P∙ Pf = Pf x
fromBinTree-ind (fork ℓ r) P P∙ Pf = P∙ (fromBinTree-ind ℓ P P∙ Pf)
                                        (fromBinTree-ind r P P∙ Pf)

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


Added draft.

Added draft.

Ignore-this: 407d8f291bd3f81e1fd716785e70b062

darcs-hash:20120317171605-3bd4e-9126a34c681bcdca472afce25dc8175b3105ac18.gz

------------------------------------------------------------------------------
-- Reasoning partially about functions
------------------------------------------------------------------------------

-- We cannot reasoning partially about partial functions intended to
-- operate in total values.

-- Tested with FOT and agda2atp on 17 March 2012.

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

module Draft.FOTC.Data.Nat.AddPartialRightIdentity where

open import FOTC.Base
open import FOTC.Data.Nat

-- How proceed?
+-partialRightIdentity : ∀ n → n + zero ≡ n
+-partialRightIdentity n = {!!}

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


Added a consistency test.

Added a consistency test.

Ignore-this: 366798ddd1e890a4e0023f7957bf578c

darcs-hash:20110205132837-3bd4e-1ea1501f1785c59b2b75ff4e6d70907c9c170f06.gz

------------------------------------------------------------------------------
-- Test the consistency of Draft.McCarthy91.McCarthy91
------------------------------------------------------------------------------

-- In the module Draft.McCarthy91.McCarthy91 we declare Agda
-- postulates as FOL axioms. We test if it is possible to prove an
-- unprovable theorem from these axioms.

module Draft.McCarthy91.McCarthy91.ConsistencyTest where

open import LTC.Base

open import Draft.McCarthy91.McCarthy91

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

postulate
  impossible : ∀ d e → d ≡ e
{-# ATP prove impossible #-}

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


models/DescFix.agda: generic recursion principle for Desc (not structurally recursive yet)

{-# OPTIONS --type-in-type #-}

module DescFix where

open import DescTT

aux : (C : Desc)(D : Desc)(P : Mu C -> Set)(x : [| D |] (Mu C)) -> Set
aux C id          P (con y) = P (con y) * aux C C P y
aux C (const K)   P k       = Unit
aux C (prod D D') P (s , t) = aux C D P s * aux C D' P t
aux C (sigma S T) P (s , t) = aux C (T s) P t
aux C (pi S T)    P f       = (s : S) -> aux C (T s) P (f s)

gen : (C : Desc)(D : Desc)(P : Mu C -> Set)
  (rec : (y : [| C |] Mu C) -> aux C C P y -> P (con y))
  (x : [| D |] Mu C) -> aux C D P x
gen C id          P rec (con x) = rec x (gen C C P rec x) , gen C C P rec x
gen C (const K)   P rec k       = Void
gen C (prod D D') P rec (s , t) = gen C D P rec s , gen C D' P rec t
gen C (sigma S T) P rec (s , t) = gen C (T s) P rec t
gen C (pi S T)    P rec f       = \ s -> gen C (T s) P rec (f s)

fix : (D : Desc)(P : Mu D -> Set)
  (rec : (y : [| D |] Mu D) -> aux D D P y -> P (con y))
  (x : Mu D) -> P x
fix D P rec (con x) = rec x (gen D D P rec x)

plus : Nat -> Nat -> Nat
plus (con (Ze , Void)) n = n
plus (con (Suc , m)) n = suc (plus m n)

fib : Nat -> Nat
fib = fix NatD (\ _ -> Nat) help
  where
    help : (m : [| NatD |] Nat) -> aux NatD NatD (\ _ -> Nat) m -> Nat
    help (Ze , x) a = suc ze
    help (Suc , con (Ze , _)) a = suc ze
    help (Suc , con (Suc , con n)) (fib-n , (fib-sn , a)) = plus fib-n fib-sn

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


Added Kovacs strong normalisation proof to extra

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

open import Relation.Binary.PropositionalEquality
open import Data.Product
open import Data.Unit
open import Data.Empty
open import Function

-- some HoTT-inspired combinators

_&_ = cong
_⁻¹ = sym
_◾_ = trans

coe : {A B : Set} → A ≡ B → A → B
coe refl a = a

_⊗_ : ∀ {A B : Set}{f g : A → B}{a a'} → f ≡ g → a ≡ a' → f a ≡ g a'
refl ⊗ refl = refl

infix 6 _⁻¹
infixr 4 _◾_
infixl 9 _&_
infixl 8 _⊗_

-- Syntax
--------------------------------------------------------------------------------

infixr 4 _⇒_
infixr 4 _,_

data Ty : Set where
  ι   : Ty
  _⇒_ : Ty → Ty → Ty

data Con : Set where
  ∙   : Con
  _,_ : Con → Ty → Con

data _∈_ (A : Ty) : Con → Set where
  vz : ∀ {Γ} → A ∈ (Γ , A)
  vs : ∀ {B Γ} → A ∈ Γ → A ∈ (Γ , B)

data Tm Γ : Ty → Set where
  var : ∀ {A} → A ∈ Γ → Tm Γ A
  lam : ∀ {A B} → Tm (Γ , A) B → Tm Γ (A ⇒ B)
  app : ∀ {A B} → Tm Γ (A ⇒ B) → Tm Γ A → Tm Γ B

-- Embedding
--------------------------------------------------------------------------------

-- Order-preserving embedding
data OPE : Con → Con → Set where
  ∙    : OPE ∙ ∙
  drop : ∀ {A Γ Δ} → OPE Γ Δ → OPE (Γ , A) Δ
  keep : ∀ {A Γ Δ} → OPE Γ Δ → OPE (Γ , A) (Δ , A)

-- OPE is a category
idₑ : ∀ {Γ} → OPE Γ Γ
idₑ {∙}     = ∙
idₑ {Γ , A} = keep (idₑ {Γ})

wk : ∀ {A Γ} → OPE (Γ , A) Γ
wk = drop idₑ

_∘ₑ_ : ∀ {Γ Δ Σ} → OPE Δ Σ → OPE Γ Δ → OPE Γ Σ
σ      ∘ₑ ∙      = σ
σ      ∘ₑ drop δ = drop (σ ∘ₑ δ)
drop σ ∘ₑ keep δ = drop (σ ∘ₑ δ)
keep σ ∘ₑ keep δ = keep (σ ∘ₑ δ)

idlₑ : ∀ {Γ Δ}(σ : OPE Γ Δ) → idₑ ∘ₑ σ ≡ σ
idlₑ ∙        = refl
idlₑ (drop σ) = drop & idlₑ σ
idlₑ (keep σ) = keep & idlₑ σ

idrₑ : ∀ {Γ Δ}(σ : OPE Γ Δ) → σ ∘ₑ idₑ ≡ σ
idrₑ ∙        = refl
idrₑ (drop σ) = drop & idrₑ σ
idrₑ (keep σ) = keep & idrₑ σ

assₑ :
  ∀ {Γ Δ Σ Ξ}(σ : OPE Σ Ξ)(δ : OPE Δ Σ)(ν : OPE Γ Δ)
  → (σ ∘ₑ δ) ∘ₑ ν ≡ σ ∘ₑ (δ ∘ₑ ν)
assₑ σ        δ        ∙        = refl
assₑ σ        δ        (drop ν) = drop & assₑ σ δ ν
assₑ σ        (drop δ) (keep ν) = drop & assₑ σ δ ν
assₑ (drop σ) (keep δ) (keep ν) = drop & assₑ σ δ ν
assₑ (keep σ) (keep δ) (keep ν) = keep & assₑ σ δ ν

∈ₑ : ∀ {A Γ Δ} → OPE Γ Δ → A ∈ Δ → A ∈ Γ
∈ₑ ∙        v      = v
∈ₑ (drop σ) v      = vs (∈ₑ σ v)
∈ₑ (keep σ) vz     = vz
∈ₑ (keep σ) (vs v) = vs (∈ₑ σ v)

∈-idₑ : ∀ {A Γ}(v : A ∈ Γ) → ∈ₑ idₑ v ≡ v
∈-idₑ vz     = refl
∈-idₑ (vs v) = vs & ∈-idₑ v

∈-∘ₑ : ∀ {A Γ Δ Σ}(σ : OPE Δ Σ)(δ : OPE Γ Δ)(v : A ∈ Σ) → ∈ₑ (σ ∘ₑ δ) v ≡ ∈ₑ δ (∈ₑ σ v)
∈-∘ₑ ∙        ∙        v      = refl
∈-∘ₑ σ        (drop δ) v      = vs & ∈-∘ₑ σ δ v
∈-∘ₑ (drop σ) (keep δ) v      = vs & ∈-∘ₑ σ δ v
∈-∘ₑ (keep σ) (keep δ) vz     = refl
∈-∘ₑ (keep σ) (keep δ) (vs v) = vs & ∈-∘ₑ σ δ v

Tmₑ : ∀ {A Γ Δ} → OPE Γ Δ → Tm Δ A → Tm Γ A
Tmₑ σ (var v)   = var (∈ₑ σ v)
Tmₑ σ (lam t)   = lam (Tmₑ (keep σ) t)
Tmₑ σ (app f a) = app (Tmₑ σ f) (Tmₑ σ a)

Tm-idₑ : ∀ {A Γ}(t : Tm Γ A) → Tmₑ idₑ t ≡ t
Tm-idₑ (var v)   = var & ∈-idₑ v
Tm-idₑ (lam t)   = lam & Tm-idₑ t
Tm-idₑ (app f a) = app & Tm-idₑ f ⊗ Tm-idₑ a

Tm-∘ₑ : ∀ {A Γ Δ Σ}(σ : OPE Δ Σ)(δ : OPE Γ Δ)(t : Tm Σ A) → Tmₑ (σ ∘ₑ δ) t ≡ Tmₑ δ (Tmₑ σ t)
Tm-∘ₑ σ δ (var v)   = var & ∈-∘ₑ σ δ v
Tm-∘ₑ σ δ (lam t)   = lam & Tm-∘ₑ (keep σ) (keep δ) t
Tm-∘ₑ σ δ (app f a) = app & Tm-∘ₑ σ δ f ⊗ Tm-∘ₑ σ δ a

-- Theory of substitution & embedding
--------------------------------------------------------------------------------

infixr 6 _ₑ∘ₛ_ _ₛ∘ₑ_ _∘ₛ_

data Sub (Γ : Con) : Con → Set where
  ∙   : Sub Γ ∙
  _,_ : ∀ {A : Ty}{Δ : Con} → Sub Γ Δ → Tm Γ A → Sub Γ (Δ , A)

_ₛ∘ₑ_ : ∀ {Γ Δ Σ} → Sub Δ Σ → OPE Γ Δ → Sub Γ Σ
∙       ₛ∘ₑ δ = ∙
(σ , t) ₛ∘ₑ δ = σ ₛ∘ₑ δ , Tmₑ δ t

_ₑ∘ₛ_ : ∀ {Γ Δ Σ} → OPE Δ Σ → Sub Γ Δ → Sub Γ Σ
∙      ₑ∘ₛ δ       = δ
drop σ ₑ∘ₛ (δ , t) = σ ₑ∘ₛ δ
keep σ ₑ∘ₛ (δ , t) = σ ₑ∘ₛ δ , t

dropₛ : ∀ {A Γ Δ} → Sub Γ Δ → Sub (Γ , A) Δ
dropₛ σ = σ ₛ∘ₑ wk

keepₛ : ∀ {A Γ Δ} → Sub Γ Δ → Sub (Γ , A) (Δ , A)
keepₛ σ = dropₛ σ , var vz

⌜_⌝ᵒᵖᵉ : ∀ {Γ Δ} → OPE Γ Δ → Sub Γ Δ
⌜ ∙      ⌝ᵒᵖᵉ = ∙
⌜ drop σ ⌝ᵒᵖᵉ = dropₛ ⌜ σ ⌝ᵒᵖᵉ
⌜ keep σ ⌝ᵒᵖᵉ = keepₛ ⌜ σ ⌝ᵒᵖᵉ

∈ₛ : ∀ {A Γ Δ} → Sub Γ Δ → A ∈ Δ → Tm Γ A
∈ₛ (σ , t) vz     = t
∈ₛ (σ  , t)(vs v) = ∈ₛ σ v

Tmₛ : ∀ {A Γ Δ} → Sub Γ Δ → Tm Δ A → Tm Γ A
Tmₛ σ (var v)   = ∈ₛ σ v
Tmₛ σ (lam t)   = lam (Tmₛ (keepₛ σ) t)
Tmₛ σ (app f a) = app (Tmₛ σ f) (Tmₛ σ a)

idₛ : ∀ {Γ} → Sub Γ Γ
idₛ {∙}     = ∙
idₛ {Γ , A} = (idₛ {Γ} ₛ∘ₑ drop idₑ) , var vz

_∘ₛ_ : ∀ {Γ Δ Σ} → Sub Δ Σ → Sub Γ Δ → Sub Γ Σ
∙       ∘ₛ δ = ∙
(σ , t) ∘ₛ δ = σ ∘ₛ δ , Tmₛ δ t

assₛₑₑ :
  ∀ {Γ Δ Σ Ξ}(σ : Sub Σ Ξ)(δ : OPE Δ Σ)(ν : OPE Γ Δ)
  → (σ ₛ∘ₑ δ) ₛ∘ₑ ν ≡ σ ₛ∘ₑ (δ ∘ₑ ν)
assₛₑₑ ∙       δ ν = refl
assₛₑₑ (σ , t) δ ν = _,_ & assₛₑₑ σ δ ν ⊗ (Tm-∘ₑ δ ν t ⁻¹)

assₑₛₑ :
  ∀ {Γ Δ Σ Ξ}(σ : OPE Σ Ξ)(δ : Sub Δ Σ)(ν : OPE Γ Δ)
  → (σ ₑ∘ₛ δ) ₛ∘ₑ ν ≡ σ ₑ∘ₛ (δ ₛ∘ₑ ν)
assₑₛₑ ∙        δ       ν = refl
assₑₛₑ (drop σ) (δ , t) ν = assₑₛₑ σ δ ν
assₑₛₑ (keep σ) (δ , t) ν = (_, Tmₑ ν t) & assₑₛₑ σ δ ν

idlₑₛ : ∀ {Γ Δ}(σ : Sub Γ Δ) → idₑ ₑ∘ₛ σ ≡ σ
idlₑₛ ∙       = refl
idlₑₛ (σ , t) = (_, t) & idlₑₛ σ

idlₛₑ : ∀ {Γ Δ}(σ : OPE Γ Δ) → idₛ ₛ∘ₑ σ ≡ ⌜ σ ⌝ᵒᵖᵉ
idlₛₑ ∙        = refl
idlₛₑ (drop σ) =
      ((idₛ ₛ∘ₑ_) ∘ drop) & idrₑ σ ⁻¹
    ◾ assₛₑₑ idₛ σ wk ⁻¹
    ◾ dropₛ & idlₛₑ σ
idlₛₑ (keep σ) =
  (_, var vz) &
      (assₛₑₑ idₛ wk (keep σ)
    ◾ ((idₛ ₛ∘ₑ_) ∘ drop) & (idlₑ σ ◾ idrₑ σ ⁻¹)
    ◾ assₛₑₑ idₛ σ wk ⁻¹
    ◾ (_ₛ∘ₑ wk) & idlₛₑ σ )

idrₑₛ : ∀ {Γ Δ}(σ : OPE Γ Δ) → σ ₑ∘ₛ idₛ ≡ ⌜ σ ⌝ᵒᵖᵉ
idrₑₛ ∙        = refl
idrₑₛ (drop σ) = assₑₛₑ σ idₛ wk ⁻¹ ◾ dropₛ & idrₑₛ σ
idrₑₛ (keep σ) = (_, var vz) & (assₑₛₑ σ idₛ wk ⁻¹ ◾ (_ₛ∘ₑ wk) & idrₑₛ σ)

∈-ₑ∘ₛ : ∀ {A Γ Δ Σ}(σ : OPE Δ Σ)(δ : Sub Γ Δ)(v : A ∈ Σ) → ∈ₛ (σ ₑ∘ₛ δ) v ≡ ∈ₛ δ (∈ₑ σ v)
∈-ₑ∘ₛ ∙        δ       v      = refl
∈-ₑ∘ₛ (drop σ) (δ , t) v      = ∈-ₑ∘ₛ σ δ v
∈-ₑ∘ₛ (keep σ) (δ , t) vz     = refl
∈-ₑ∘ₛ (keep σ) (δ , t) (vs v) = ∈-ₑ∘ₛ σ δ v

Tm-ₑ∘ₛ : ∀ {A Γ Δ Σ}(σ : OPE Δ Σ)(δ : Sub Γ Δ)(t : Tm Σ A) → Tmₛ (σ ₑ∘ₛ δ) t ≡ Tmₛ δ (Tmₑ σ t)
Tm-ₑ∘ₛ σ δ (var v) = ∈-ₑ∘ₛ σ δ v
Tm-ₑ∘ₛ σ δ (lam t) =
  lam & ((λ x → Tmₛ (x , var vz) t) & assₑₛₑ σ δ wk ◾ Tm-ₑ∘ₛ (keep σ) (keepₛ δ) t)
Tm-ₑ∘ₛ σ δ (app f a) = app & Tm-ₑ∘ₛ σ δ f ⊗ Tm-ₑ∘ₛ σ δ a

∈-ₛ∘ₑ : ∀ {A Γ Δ Σ}(σ : Sub Δ Σ)(δ : OPE Γ Δ)(v : A ∈ Σ) → ∈ₛ (σ ₛ∘ₑ δ) v ≡ Tmₑ δ (∈ₛ σ v)
∈-ₛ∘ₑ (σ , _) δ vz     = refl
∈-ₛ∘ₑ (σ , _) δ (vs v) = ∈-ₛ∘ₑ σ δ v

Tm-ₛ∘ₑ : ∀ {A Γ Δ Σ}(σ : Sub Δ Σ)(δ : OPE Γ Δ)(t : Tm Σ A) → Tmₛ (σ ₛ∘ₑ δ) t ≡ Tmₑ δ (Tmₛ σ t)
Tm-ₛ∘ₑ σ δ (var v)   = ∈-ₛ∘ₑ σ δ v
Tm-ₛ∘ₑ σ δ (lam t)   =
  lam &
      ((λ x → Tmₛ (x , var vz) t) &
          (assₛₑₑ σ δ wk
        ◾ (σ ₛ∘ₑ_) & (drop & (idrₑ δ ◾ idlₑ δ ⁻¹))
        ◾ assₛₑₑ σ wk (keep δ) ⁻¹)
    ◾ Tm-ₛ∘ₑ (keepₛ σ) (keep δ) t)
Tm-ₛ∘ₑ σ δ (app f a) = app & Tm-ₛ∘ₑ σ δ f ⊗ Tm-ₛ∘ₑ σ δ a

assₛₑₛ :
  ∀ {Γ Δ Σ Ξ}(σ : Sub Σ Ξ)(δ : OPE Δ Σ)(ν : Sub Γ Δ)
  → (σ ₛ∘ₑ δ) ∘ₛ ν ≡ σ ∘ₛ (δ ₑ∘ₛ ν)
assₛₑₛ ∙       δ ν = refl
assₛₑₛ (σ , t) δ ν = _,_ & assₛₑₛ σ δ ν ⊗ (Tm-ₑ∘ₛ δ ν t ⁻¹)

assₛₛₑ :
  ∀ {Γ Δ Σ Ξ}(σ : Sub Σ Ξ)(δ : Sub Δ Σ)(ν : OPE Γ Δ)
  → (σ ∘ₛ δ) ₛ∘ₑ ν ≡ σ ∘ₛ (δ ₛ∘ₑ ν)
assₛₛₑ ∙       δ ν = refl
assₛₛₑ (σ , t) δ ν = _,_ & assₛₛₑ σ δ ν ⊗ (Tm-ₛ∘ₑ δ ν t ⁻¹)

∈-idₛ : ∀ {A Γ}(v : A ∈ Γ) → ∈ₛ idₛ v ≡ var v
∈-idₛ vz     = refl
∈-idₛ (vs v) = ∈-ₛ∘ₑ idₛ wk v ◾ Tmₑ wk & ∈-idₛ v ◾ (var ∘ vs) & ∈-idₑ v

∈-∘ₛ : ∀ {A Γ Δ Σ}(σ : Sub Δ Σ)(δ : Sub Γ Δ)(v : A ∈ Σ) → ∈ₛ (σ ∘ₛ δ) v ≡ Tmₛ δ (∈ₛ σ v)
∈-∘ₛ (σ , _) δ vz     = refl
∈-∘ₛ (σ , _) δ (vs v) = ∈-∘ₛ σ δ v

Tm-idₛ : ∀ {A Γ}(t : Tm Γ A) → Tmₛ idₛ t ≡ t
Tm-idₛ (var v)   = ∈-idₛ v
Tm-idₛ (lam t)   = lam & Tm-idₛ t
Tm-idₛ (app f a) = app & Tm-idₛ f ⊗ Tm-idₛ a

Tm-∘ₛ : ∀ {A Γ Δ Σ}(σ : Sub Δ Σ)(δ : Sub Γ Δ)(t : Tm Σ A) → Tmₛ (σ ∘ₛ δ) t ≡ Tmₛ δ (Tmₛ σ t)
Tm-∘ₛ σ δ (var v)   = ∈-∘ₛ σ δ v
Tm-∘ₛ σ δ (lam t)   =
  lam &
      ((λ x → Tmₛ (x , var vz) t) &
          (assₛₛₑ σ δ wk
        ◾ (σ ∘ₛ_) & (idlₑₛ  (dropₛ δ) ⁻¹) ◾ assₛₑₛ σ wk (keepₛ δ) ⁻¹)
    ◾ Tm-∘ₛ (keepₛ σ) (keepₛ δ) t)
Tm-∘ₛ σ δ (app f a) = app & Tm-∘ₛ σ δ f ⊗ Tm-∘ₛ σ δ a

idrₛ : ∀ {Γ Δ}(σ : Sub Γ Δ) → σ ∘ₛ idₛ ≡ σ
idrₛ ∙       = refl
idrₛ (σ , t) = _,_ & idrₛ σ ⊗ Tm-idₛ t

idlₛ : ∀ {Γ Δ}(σ : Sub Γ Δ) → idₛ ∘ₛ σ ≡ σ
idlₛ ∙       = refl
idlₛ (σ , t) = (_, t) & (assₛₑₛ idₛ wk (σ , t) ◾ (idₛ ∘ₛ_) & idlₑₛ σ ◾ idlₛ σ)

-- Reduction
--------------------------------------------------------------------------------

data _~>_ {Γ} : ∀ {A} → Tm Γ A → Tm Γ A → Set where
  β    : ∀ {A B}(t : Tm (Γ , A) B) t'  → app (lam t) t' ~> Tmₛ (idₛ , t') t
  lam  : ∀ {A B}{t t' : Tm (Γ , A) B}     → t ~> t' →  lam t   ~> lam t'
  app₁ : ∀ {A B}{f}{f' : Tm Γ (A ⇒ B)}{a} → f ~> f' →  app f a ~> app f' a
  app₂ : ∀ {A B}{f : Tm Γ (A ⇒ B)} {a a'} → a ~> a' →  app f a ~> app f  a'
infix 3 _~>_

~>ₛ : ∀ {Γ Δ A}{t t' : Tm Γ A}(σ : Sub Δ Γ) → t ~> t' → Tmₛ σ t ~> Tmₛ σ t'
~>ₛ σ (β t t') =
  coe ((app (lam (Tmₛ (keepₛ σ) t)) (Tmₛ σ t') ~>_) &
      (Tm-∘ₛ (keepₛ σ) (idₛ , Tmₛ σ t') t ⁻¹
    ◾ (λ x → Tmₛ (x , Tmₛ σ t') t) &
        (assₛₑₛ σ wk (idₛ , Tmₛ σ t')
      ◾ ((σ ∘ₛ_) & idlₑₛ idₛ ◾ idrₛ σ) ◾ idlₛ σ ⁻¹)
    ◾ Tm-∘ₛ (idₛ , t') σ t))
  (β (Tmₛ (keepₛ σ) t) (Tmₛ σ t'))
~>ₛ σ (lam  step) = lam  (~>ₛ (keepₛ σ) step)
~>ₛ σ (app₁ step) = app₁ (~>ₛ σ step)
~>ₛ σ (app₂ step) = app₂ (~>ₛ σ step)

~>ₑ : ∀ {Γ Δ A}{t t' : Tm Γ A}(σ : OPE Δ Γ) → t ~> t' → Tmₑ σ t ~> Tmₑ σ t'
~>ₑ σ (β t t')    =
  coe ((app (lam (Tmₑ (keep σ) t)) (Tmₑ σ t') ~>_)
      & (Tm-ₑ∘ₛ (keep σ) (idₛ , Tmₑ σ t') t ⁻¹
      ◾ (λ x → Tmₛ (x , Tmₑ σ t') t) & (idrₑₛ σ ◾ idlₛₑ σ ⁻¹)
      ◾ Tm-ₛ∘ₑ (idₛ , t') σ t))
  (β (Tmₑ (keep σ) t) (Tmₑ σ t'))
~>ₑ σ (lam step)  = lam (~>ₑ (keep σ) step)
~>ₑ σ (app₁ step) = app₁ (~>ₑ σ step)
~>ₑ σ (app₂ step) = app₂ (~>ₑ σ step)

Tmₑ~> :
  ∀ {Γ Δ A}{t : Tm Γ A}{σ : OPE Δ Γ}{t'}
  → Tmₑ σ t ~> t' → ∃ λ t'' → (t ~> t'') × (Tmₑ σ t'' ≡ t')
Tmₑ~> {t = var x} ()
Tmₑ~> {t = lam t} (lam step) with Tmₑ~> step
... | t'' , (p , refl) = lam t'' , lam p , refl
Tmₑ~> {t = app (var v) a} (app₁ ())
Tmₑ~> {t = app (var v) a} (app₂ step) with Tmₑ~> step
... | t'' , (p , refl) = app (var v) t'' , app₂ p , refl
Tmₑ~> {t = app (lam f) a} {σ} (β _ _) =
  Tmₛ (idₛ , a) f , β _ _ ,
      Tm-ₛ∘ₑ (idₛ , a) σ f ⁻¹
    ◾ (λ x →  Tmₛ (x , Tmₑ σ a) f) & (idlₛₑ σ ◾ idrₑₛ σ ⁻¹)
    ◾ Tm-ₑ∘ₛ (keep σ) (idₛ , Tmₑ σ a) f
Tmₑ~> {t = app (lam f) a}     (app₁ (lam step)) with Tmₑ~> step
... | t'' , (p , refl) = app (lam t'') a , app₁ (lam p) , refl
Tmₑ~> {t = app (lam f) a}     (app₂ step) with Tmₑ~> step
... | t'' , (p , refl) = app (lam f) t'' , app₂ p , refl
Tmₑ~> {t = app (app f a) a'}  (app₁ step) with Tmₑ~> step
... | t'' , (p , refl) = app t'' a' , app₁ p , refl
Tmₑ~> {t = app (app f a) a''} (app₂ step) with Tmₑ~> step
... | t'' , (p , refl) = app (app f a) t'' , app₂ p , refl

-- Strong normalization/neutrality definition
--------------------------------------------------------------------------------

data SN {Γ A} (t : Tm Γ A) : Set where
  sn : (∀ {t'} → t ~> t' → SN t') → SN t

SNₑ→ : ∀ {Γ Δ A}{t : Tm Γ A}(σ : OPE Δ Γ) → SN t → SN (Tmₑ σ t)
SNₑ→ σ (sn s) = sn λ {t'} step →
  let (t'' , (p , q)) = Tmₑ~> step in coe (SN & q) (SNₑ→ σ (s p))

SNₑ← : ∀ {Γ Δ A}{t : Tm Γ A}(σ : OPE Δ Γ) → SN (Tmₑ σ t) → SN t
SNₑ← σ (sn s) = sn λ step → SNₑ← σ (s (~>ₑ σ step))

SN-app₁ : ∀ {Γ A B}{f : Tm Γ (A ⇒ B)}{a} → SN (app f a) → SN f
SN-app₁ (sn s) = sn λ f~>f' → SN-app₁ (s (app₁ f~>f'))

neu : ∀ {Γ A} → Tm Γ A → Set
neu (lam _)   = ⊥
neu _         = ⊤

neuₑ : ∀ {Γ Δ A}(σ : OPE Δ Γ)(t : Tm Γ A) → neu t → neu (Tmₑ σ t)
neuₑ σ (lam t)   nt = nt
neuₑ σ (var v)   nt = tt
neuₑ σ (app f a) nt = tt

-- The actual proof, by Kripke logical predicate
--------------------------------------------------------------------------------

Tmᴾ : ∀ {Γ A} → Tm Γ A → Set
Tmᴾ {Γ}{ι}     t = SN t
Tmᴾ {Γ}{A ⇒ B} t = ∀ {Δ}(σ : OPE Δ Γ){a} → Tmᴾ a → Tmᴾ (app (Tmₑ σ t) a)

data Subᴾ {Γ} : ∀ {Δ} → Sub Γ Δ → Set where
  ∙   : Subᴾ ∙
  _,_ : ∀ {A Δ}{σ : Sub Γ Δ}{t : Tm Γ A}(σᴾ : Subᴾ σ)(tᴾ : Tmᴾ t) → Subᴾ (σ , t)

Tmᴾₑ : ∀ {Γ Δ A}{t : Tm Γ A}(σ : OPE Δ Γ) → Tmᴾ t → Tmᴾ (Tmₑ σ t)
Tmᴾₑ {A = ι}        σ tᴾ = SNₑ→ σ tᴾ
Tmᴾₑ {A = A ⇒ B}{t} σ tᴾ δ aᴾ rewrite Tm-∘ₑ σ δ t ⁻¹ = tᴾ (σ ∘ₑ δ) aᴾ

Subᴾₑ : ∀ {Γ Δ Σ}{σ : Sub Δ Σ}(δ : OPE Γ Δ) → Subᴾ σ → Subᴾ (σ ₛ∘ₑ δ)
Subᴾₑ σ ∙        = ∙
Subᴾₑ σ (δ , tᴾ) = Subᴾₑ σ δ , Tmᴾₑ σ tᴾ

~>ᴾ : ∀ {Γ A}{t t' : Tm Γ A} → t ~> t' → Tmᴾ t → Tmᴾ t'
~>ᴾ {A = ι}     t~>t' (sn tˢⁿ) = tˢⁿ t~>t'
~>ᴾ {A = A ⇒ B} t~>t' tᴾ       = λ σ aᴾ → ~>ᴾ (app₁ (~>ₑ σ t~>t')) (tᴾ σ aᴾ)

mutual
  -- quote
  qᴾ : ∀ {Γ A}{t : Tm Γ A} → Tmᴾ t → SN t
  qᴾ {A = ι}     tᴾ = tᴾ
  qᴾ {A = A ⇒ B} tᴾ = SNₑ← wk $ SN-app₁ (qᴾ $ tᴾ wk (uᴾ (var vz) (λ ())))

  -- unquote
  uᴾ : ∀ {Γ A}(t : Tm Γ A){nt : neu t} → (∀ {t'} → t ~> t' → Tmᴾ t') → Tmᴾ t
  uᴾ {Γ} {A = ι} t      f     = sn f
  uᴾ {Γ} {A ⇒ B} t {nt} f {Δ} σ {a} aᴾ =
    uᴾ (app (Tmₑ σ t) a) (go (Tmₑ σ t) (neuₑ σ t nt) f' a aᴾ (qᴾ aᴾ))
    where
      f' : ∀ {t'} → Tmₑ σ t ~> t' → Tmᴾ t'
      f' step δ aᴾ with Tmₑ~> step
      ... | t'' , step' , refl rewrite Tm-∘ₑ σ δ t'' ⁻¹ = f step' (σ ∘ₑ δ) aᴾ

      go :
        ∀ {Γ A B}(t : Tm Γ (A ⇒ B)) → neu t → (∀ {t'} → t ~> t' → Tmᴾ t')
        → ∀ a → Tmᴾ a → SN a → ∀ {t'} → app t a ~> t' → Tmᴾ t'
      go _ () _ _ _ _ (β _ _)
      go t nt f a aᴾ sna (app₁ {f' = f'} step) =
        coe ((λ x → Tmᴾ (app x a)) & Tm-idₑ f') (f step idₑ aᴾ)
      go t nt f a aᴾ (sn aˢⁿ) (app₂ {a' = a'} step) =
        uᴾ (app t a') (go t nt f a' (~>ᴾ step aᴾ) (aˢⁿ step))

fundThm-∈ : ∀ {Γ A}(v : A ∈ Γ) → ∀ {Δ}{σ : Sub Δ Γ} → Subᴾ σ → Tmᴾ (∈ₛ σ v)
fundThm-∈ vz     (σᴾ , tᴾ) = tᴾ
fundThm-∈ (vs v) (σᴾ , tᴾ) = fundThm-∈ v σᴾ

fundThm-lam :
  ∀ {Γ A B}
    (t : Tm (Γ , A) B)
  → SN t
  → (∀ {a} → Tmᴾ a → Tmᴾ (Tmₛ (idₛ , a) t))
  → ∀ a → SN a → Tmᴾ a → Tmᴾ (app (lam t) a)
fundThm-lam {Γ} t (sn tˢⁿ) hyp a (sn aˢⁿ) aᴾ = uᴾ (app (lam t) a)
  λ {(β _ _) → hyp aᴾ;
     (app₁ (lam {t' = t'} t~>t')) →
       fundThm-lam t' (tˢⁿ t~>t') (λ aᴾ → ~>ᴾ (~>ₛ _ t~>t') (hyp aᴾ)) a (sn aˢⁿ) aᴾ;
     (app₂ a~>a') →
       fundThm-lam t (sn tˢⁿ) hyp _ (aˢⁿ a~>a') (~>ᴾ a~>a' aᴾ)}

fundThm : ∀ {Γ A}(t : Tm Γ A) → ∀ {Δ}{σ : Sub Δ Γ} → Subᴾ σ → Tmᴾ (Tmₛ σ t)
fundThm (var v) σᴾ = fundThm-∈ v σᴾ
fundThm (lam {A} t) {σ = σ} σᴾ δ {a} aᴾ
  rewrite Tm-ₛ∘ₑ (keepₛ σ) (keep δ) t ⁻¹ | assₛₑₑ σ (wk {A}) (keep δ) | idlₑ δ
  = fundThm-lam
      (Tmₛ (σ ₛ∘ₑ drop δ , var vz) t)
      (qᴾ (fundThm t (Subᴾₑ (drop δ) σᴾ , uᴾ (var vz) (λ ()))))
      (λ aᴾ → coe (Tmᴾ & sub-sub-lem) (fundThm t (Subᴾₑ δ σᴾ , aᴾ)))
      a (qᴾ aᴾ) aᴾ
  where
    sub-sub-lem : ∀ {a} → Tmₛ (σ ₛ∘ₑ δ , a) t ≡ Tmₛ (idₛ , a) (Tmₛ (σ ₛ∘ₑ drop δ , var vz) t)
    sub-sub-lem {a} =
        (λ x → Tmₛ (x , a) t) &
          (idrₛ (σ ₛ∘ₑ δ) ⁻¹ ◾ assₛₑₛ σ δ idₛ ◾ assₛₑₛ σ (drop δ) (idₛ , a) ⁻¹)
      ◾ Tm-∘ₛ (σ ₛ∘ₑ drop δ , var vz) (idₛ , a) t
fundThm (app f a) {σ = σ} σᴾ
  rewrite Tm-idₑ (Tmₛ σ f) ⁻¹
  = fundThm f σᴾ idₑ (fundThm a σᴾ)

idₛᴾ : ∀ {Γ} → Subᴾ (idₛ {Γ})
idₛᴾ {∙}     = ∙
idₛᴾ {Γ , A} = Subᴾₑ wk idₛᴾ , uᴾ (var vz) (λ ())

strongNorm : ∀ {Γ A}(t : Tm Γ A) → SN t
strongNorm t = qᴾ (coe (Tmᴾ & Tm-idₛ t) (fundThm t idₛᴾ))

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