Add partensor experiment

Add partensor experiment

open import Function using (_∘_ ; id ; const ; flip)
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Nat.NP
open import Data.List
open import Data.Product using (_,_ ; Σ ; ∃ ; _×_ ; proj₁ ; proj₂)
open import Data.Sum using (_⊎_ ; inj₁ ; inj₂)
  renaming (map to smap ; [_,_] to either ; [_,_]′ to either′)

open import Level
open import Size

open import Relation.Binary.PropositionalEquality.NP using (_≡_ ; refl ; !_ ; ap ; tr ; _∙_ ; _≢_)

module partensor.Terms where

data Com : Set where IN OUT : Com

data Session : Set₁ where
  end : Session
  com : Com → {M : Set} (P : M → Session) → Session

data Ended : Session → Set₁ where
  end : Ended end

pattern send P = com OUT P
pattern recv P = com IN P

mapSession : (Com → Com) → Session → Session
mapSession f end = end
mapSession f (com c P) = com (f c) (λ m → mapSession f (P m))

dualC : Com → Com
dualC IN = OUT
dualC OUT = IN

dual : Session → Session
dual = mapSession dualC

infix 5 _⅋_ _⊗_
data Proto : Set₁ where
  act : Session → Proto
  _⅋_ _⊗_ : Proto → Proto → Proto

dual' : Proto → Proto
dual' (act x) = act (dual x)
dual' (P ⅋ P₁) = dual' P ⊗ dual' P₁
dual' (P ⊗ P₁) = dual' P ⅋ dual' P₁

data Dual : (P Q : Proto) → Set₁ where
  act  : ∀ {P} → Dual (act P) (act (dual P))
  act' : ∀ {P} → Dual (act (dual P)) (act P)
  ⊗⅋ : ∀ {A A' B B'}
     → Dual A A' → Dual A' A
     → Dual B B' → Dual B' B
     → Dual (A ⊗ B) (A' ⅋ B')
  ⅋⊗ : ∀ {A A' B B'}
     → Dual A A' → Dual A' A
     → Dual B B' → Dual B' B
     → Dual (A ⅋ B) (A' ⊗ B')

symDual : ∀ {P Q} → Dual P Q → Dual Q P
symDual act = act'
symDual act' = act
symDual (⊗⅋ x x₁ x₂ x₃) = ⅋⊗ x₁ x x₃ x₂
symDual (⅋⊗ x x₁ x₂ x₃) = ⊗⅋ x₁ x x₃ x₂

mkDual : ∀ P → Dual P (dual' P)
mkDual (act x) = act
mkDual (P ⅋ P₁) = ⅋⊗ (mkDual P) (symDual (mkDual P)) (mkDual P₁) (symDual (mkDual P₁))
mkDual (P ⊗ P₁) = ⊗⅋ (mkDual P) (symDual (mkDual P)) (mkDual P₁) (symDual (mkDual P₁))

infix 4 _∈'_ -- _∈_
data _∈'_ : Proto → Proto → Set₁ where
  here   : ∀ {S} → S ∈' S
  left  : ∀ {P Q S} → S ∈' P → S ∈' (P ⅋ Q)
  right : ∀ {P Q S} → S ∈' Q → S ∈' (P ⅋ Q)

infix 4 _⊆_
data _⊆_ : (Ψ : Proto) → Proto → Set₁ where
  ⊆-in : ∀ {A B Γ} → (A ⊗ B) ∈' Γ → (A ⊗ B) ⊆ Γ

⊆-left : ∀ {P Q Ψ} → Ψ ⊆ P → Ψ ⊆ P ⅋ Q
⊆-left (⊆-in x) = ⊆-in (left x)

infix 6 _/_

_[_≔_]' : {x : Proto}(Δ : Proto) → x ∈' Δ → Proto → Proto
x [ here ≔ S' ]' = S'
(Δ ⅋ Δ₁) [ left l ≔ S' ]' = Δ [ l ≔ S' ]' ⅋ Δ₁
(Δ ⅋ Δ₁) [ right l ≔ S' ]' = Δ ⅋ Δ₁ [ l ≔ S' ]'

_/_ : {x : Proto} (Δ : Proto) → x ⊆ Δ → Proto
Δ / (⊆-in l) = Δ [ l ≔ act end ]'

data PEnded : Proto → Set₁ where
  ε : PEnded (act end)
  P⅋ : ∀ {P Q} → PEnded P → PEnded Q → PEnded (P ⅋ Q)

data PEnded' : Proto → Set₁ where
  ε : PEnded' (act end)
  P⅋ : ∀ {P Q} → PEnded' P → PEnded' Q → PEnded' (P ⅋ Q)
  P⊗ : ∀ {P Q} → PEnded' P → PEnded' Q → PEnded' (P ⊗ Q)

_∈_ : Session → Proto → Set₁
S ∈ Γ = act S ∈' Γ

_[_≔_] : {x : Session}(Δ : Proto) → x ∈ Δ → Session → Proto
Δ [ l ≔ S ] = Δ [ l ≔ act S ]'

infix 4 _≈_ _≈'_
infixr 4 _·_

module _ {x M P}(let S = com x {M} P) where
  ∉-PEnd : ∀ {P} → PEnded P → act S ∈' P → 𝟘
  ∉-PEnd () here
  ∉-PEnd (P⅋ p p₁) (left l) = ∉-PEnd p l
  ∉-PEnd (P⅋ p p₁) (right l) = ∉-PEnd p₁ l

data _≈'_ : Proto → Proto → Set₁ where
  _·_ : ∀ {P Q R} → P ≈' Q → Q ≈' R → P ≈' R
  ⅋-congₗ : ∀ {P P' Q} → P ≈' P' → P ⅋ Q ≈' P' ⅋ Q
  ⅋ε : ∀ {P} → P ⅋ act end ≈' P
  ⅋ε' : ∀ {P} → P ≈' P ⅋ act end
  ⅋-comm : ∀ {P Q} → P ⅋ Q ≈' Q ⅋ P
  ⅋-assoc : ∀ {P Q R} → (P ⅋ Q) ⅋ R ≈' P ⅋ (Q ⅋ R)

data _≈_ : Proto → Proto → Set₁ where
  _·_ : ∀ {P Q R} → P ≈ Q → Q ≈ R → P ≈ R

  ⅋-congₗ : ∀ {P P' Q} → P ≈ P' → P ⅋ Q ≈ P' ⅋ Q
  ⅋ε : ∀ {P} → P ⅋ act end ≈ P
  ⅋ε' : ∀ {P} → P ≈ P ⅋ act end
  ⅋-comm : ∀ {P Q} → P ⅋ Q ≈ Q ⅋ P
  ⅋-assoc : ∀ {P Q R} → (P ⅋ Q) ⅋ R ≈ P ⅋ (Q ⅋ R)

  ⊗-congₗ : ∀ {P P' Q} → P ≈ P' → P ⊗ Q ≈ P' ⊗ Q
  ⊗ε : ∀ {P} → P ⊗ act end ≈ P
  ⊗-comm : ∀ {P Q} → P ⊗ Q ≈ Q ⊗ P
  ⊗-assoc : ∀ {P Q R} → (P ⊗ Q) ⊗ R ≈ P ⊗ (Q ⊗ R)

→≈' : ∀ {P Q} → P ≈' Q → P ≈ Q
→≈' (x · x₁) = →≈' x · →≈' x₁
→≈' (⅋-congₗ x) = ⅋-congₗ (→≈' x)
→≈' ⅋ε = ⅋ε
→≈' ⅋ε' = ⅋ε'
→≈' ⅋-comm = ⅋-comm
→≈' ⅋-assoc = ⅋-assoc

id'≈ : ∀ {P} → P ≈' P
id'≈ = ⅋ε' · ⅋ε

!'_ : ∀ {P Q} → P ≈' Q → Q ≈' P
!' (e · e₁) = !' e₁ · !' e
!' ⅋-congₗ e = ⅋-congₗ (!' e)
!' ⅋ε = ⅋ε'
!' ⅋ε' = ⅋ε
!' ⅋-comm = ⅋-comm
!' ⅋-assoc = ⅋-comm · ⅋-congₗ ⅋-comm · ⅋-assoc · ⅋-comm · ⅋-congₗ ⅋-comm

⅋'-congᵣ : ∀ {P P' Q} → P ≈' P' → Q ⅋ P ≈' Q ⅋ P'
⅋'-congᵣ e = ⅋-comm · ⅋-congₗ e · ⅋-comm

⅋'-cong : ∀ {P P' Q Q'} → Q ≈' Q' → P ≈' P' → Q ⅋ P ≈' Q' ⅋ P'
⅋'-cong e e' = ⅋-congₗ e · ⅋'-congᵣ e'

≈'-PEnd : ∀ {P Q} → P ≈' Q → PEnded P → PEnded Q
≈'-PEnd (e · e₁) p = ≈'-PEnd e₁ (≈'-PEnd e p)
≈'-PEnd (⅋-congₗ e) (P⅋ x x₁) = P⅋ (≈'-PEnd e x) x₁
≈'-PEnd ⅋ε (P⅋ x x₁) = x
≈'-PEnd ⅋ε' p = P⅋ p ε
≈'-PEnd ⅋-comm (P⅋ x x₁) = P⅋ x₁ x
≈'-PEnd ⅋-assoc (P⅋ (P⅋ p p₁) p₂) = P⅋ p (P⅋ p₁ p₂)

PEnd-≈' : ∀ {P Q} → PEnded P → PEnded Q → P ≈' Q
PEnd-≈' ε ε = id'≈
PEnd-≈' ε (P⅋ q q₁) = ⅋ε' · ⅋'-cong (PEnd-≈' ε q) (PEnd-≈' ε q₁)
PEnd-≈' (P⅋ p p₁) ε = ⅋'-cong (PEnd-≈' p ε) (PEnd-≈' p₁ ε) · ⅋ε
PEnd-≈' (P⅋ p p₁) (P⅋ q q₁) = ⅋'-cong (PEnd-≈' p q) (PEnd-≈' p₁ q₁)

⊈-PEnd : ∀ {P Q} → PEnded Q → P ⊆ Q → 𝟘
⊈-PEnd ε (⊆-in ())
⊈-PEnd (P⅋ p p₁) (⊆-in (left x)) = ⊈-PEnd p (⊆-in x)
⊈-PEnd (P⅋ p p₁) (⊆-in (right x)) = ⊈-PEnd p₁ (⊆-in x)

data ⟪_⟫ (Δ : Proto) : Set₁ where
  end : PEnded Δ → ⟪ Δ ⟫

  input : ∀ {M P} (l : recv P ∈ Δ)
    → ((m : M) → ⟪ Δ [ l ≔ P m ] ⟫)
    → ⟪ Δ ⟫

  output : ∀ {M P} (l : send P ∈ Δ)
    → (m : M) → ⟪ Δ [ l ≔ P m ] ⟫
    → ⟪ Δ ⟫

  pair : ∀ {Γ Γ' A B}
    → (l : A ⊗ B ⊆ Δ) → (Δ / l) ≈' (Γ ⅋ Γ')
    → ⟪ Γ ⅋ A ⟫ → ⟪ Γ' ⅋ B ⟫
    → ⟪ Δ ⟫

data NotPar : Proto → Set₁ where
  act1 : ∀ {x M P} → NotPar (act (com x {M} P))
  ten : ∀ {A B} → NotPar (A ⊗ B)

data NotPar' : Proto → Set₁ where
  act0 : ∀ {S} → NotPar' (act S)
  ten : ∀ {A B} → NotPar' (A ⊗ B)

≔-same : ∀ {P Q}(l : P ∈' Q) → Q ≈' Q [ l ≔ P ]'
≔-same here = id'≈
≔-same (left x) = ⅋-congₗ (≔-same x)
≔-same (right x) = ⅋'-congᵣ (≔-same x)

∈'-conv : ∀ {P Q Γ} → NotPar Γ → P ≈' Q → Γ ∈' P → Γ ∈' Q
∈'-conv np (e · e₁) l = ∈'-conv np e₁ (∈'-conv np e l)
∈'-conv () (⅋-congₗ e) here
∈'-conv np (⅋-congₗ e) (left l) = left (∈'-conv np e l)
∈'-conv np (⅋-congₗ e) (right l) = right l
∈'-conv () ⅋ε here
∈'-conv np ⅋ε (left l) = l
∈'-conv () ⅋ε (right here)
∈'-conv np ⅋ε' l = left l
∈'-conv () ⅋-comm here
∈'-conv np ⅋-comm (left l) = right l
∈'-conv np ⅋-comm (right l) = left l
∈'-conv () ⅋-assoc here
∈'-conv () ⅋-assoc (left here)
∈'-conv np ⅋-assoc (left (left l)) = left l
∈'-conv np ⅋-assoc (left (right l)) = right (left l)
∈'-conv np ⅋-assoc (right l) = right (right l)

≔'-conv : ∀ {P Q Γ S'}(np : NotPar Γ)(e : P ≈' Q)(l : Γ ∈' P)
  → P [ l ≔ S' ]' ≈' Q [ ∈'-conv np e l ≔ S' ]'
≔'-conv np (e · e₁) l = ≔'-conv np e l · ≔'-conv np e₁ _
≔'-conv () (⅋-congₗ e) here
≔'-conv np (⅋-congₗ e) (left l) = ⅋-congₗ (≔'-conv np e l)
≔'-conv np (⅋-congₗ e) (right l) = ⅋-congₗ e
≔'-conv () ⅋ε here
≔'-conv np ⅋ε (left l) = ⅋ε
≔'-conv () ⅋ε (right here)
≔'-conv np ⅋ε' l = ⅋ε'
≔'-conv () ⅋-comm here
≔'-conv np ⅋-comm (left l) = ⅋-comm
≔'-conv np ⅋-comm (right l) = ⅋-comm
≔'-conv () ⅋-assoc here
≔'-conv () ⅋-assoc (left here)
≔'-conv np ⅋-assoc (left (left l)) = ⅋-assoc
≔'-conv np ⅋-assoc (left (right l)) = ⅋-assoc
≔'-conv np ⅋-assoc (right l) = ⅋-assoc

⊆-conv : ∀ {P Q Γ} → P ≈' Q → Γ ⊆ P → Γ ⊆ Q
⊆-conv e (⊆-in x) = ⊆-in (∈'-conv ten e x)

/-conv : ∀ {P Q Γ}(e : P ≈' Q)(l : Γ ⊆ P) → P / l ≈' Q / ⊆-conv e l
/-conv e (⊆-in x) = ≔'-conv ten e x

module _ {x M P}(let S = com x {M} P) where

  ∈-conv : ∀ {P Q} → P ≈' Q → S ∈ P → S ∈ Q
  ∈-conv e l = ∈'-conv act1 e l

  ≔-conv : ∀ {P Q S'}(e : P ≈' Q)(l : S ∈ P) → P [ l ≔ S' ] ≈' Q [ ∈-conv e l ≔ S' ]
  ≔-conv e l = ≔'-conv act1 e l

conv : ∀ {P Q} → P ≈' Q → ⟪ P ⟫ → ⟪ Q ⟫
conv e (end x) = end (≈'-PEnd e x)
conv e (input l x) = input (∈-conv e l) (λ m → conv (≔-conv e l) (x m))
conv e (output l m p) = output (∈-conv e l) m (conv (≔-conv e l) p)
conv e (pair l x p p₁) = pair (⊆-conv e l ) (!' /-conv e l · x) p p₁

fwd-S : ∀ S → ⟪ act S ⅋ act (dual S) ⟫
fwd-S end = end (P⅋ ε ε)
fwd-S (send P) = input (right here) λ m →
                 output (left here) m (fwd-S (P m))
fwd-S (recv P) = input (left here) λ m →
                 output (right here) m (fwd-S (P m))

fwd : ∀ Γ → ⟪ Γ ⅋ dual' Γ ⟫
fwd (act x) = fwd-S x
fwd (Γ ⅋ Γ₁) = pair (⊆-in (right here)) ⅋ε (fwd Γ) (fwd Γ₁)
fwd (Γ ⊗ Γ₁) = pair (⊆-in (left here)) (⅋-comm · ⅋ε) (conv ⅋-comm (fwd Γ)) (conv ⅋-comm (fwd Γ₁))

same-var : ∀ {Δ Γ Γ'}(np : NotPar' Γ)(np' : NotPar' Γ')(l : Γ ∈' Δ)(l' : Γ' ∈' Δ) →
  (∃ λ (nl : ∀ {S'} → Γ ∈' Δ [ l' ≔ S' ]')
  → ∃ λ (nl' : ∀ {S} → Γ' ∈' Δ [ l ≔ S ]')
  → ∀ {S S'} → ((Δ [ l' ≔ S' ]') [ nl ≔ S ]') ≈' (Δ [ l ≔ S ]') [ nl' ≔ S' ]')
  ⊎ ∃ λ (p : Γ ≡ Γ') → tr _ p l ≡ l'
same-var np np' here here = inj₂ (refl , refl)
same-var () np' here (left l')
same-var () np' here (right l')
same-var np () (left l) here
same-var np np' (left l) (left l') with same-var np np' l l'
same-var np np' (left l) (left l') | inj₁ (nl , nl' , s)
  = inj₁ (left nl , left nl' , ⅋-congₗ s)
same-var np np' (left l) (left .l) | inj₂ (refl , refl) = inj₂ (refl , refl)
same-var np np' (left l) (right l') = inj₁ (left l , right l' , id'≈)
same-var np () (right l) here
same-var np np' (right l) (left l') = inj₁ (right l , left l' , id'≈)
same-var np np' (right l) (right l') with same-var np np' l l'
same-var np np' (right l) (right l') | inj₁ (nl , nl' , s)
  = inj₁ (right nl , right nl' , ⅋'-congᵣ s)
same-var np np' (right l) (right .l) | inj₂ (refl , refl) = inj₂ (refl , refl)

same-⊗var : ∀ {Δ Γ Γ'}(l : Γ ⊆ Δ)(l' : Γ' ⊆ Δ) →
  (∃ λ (nl : Γ ⊆ Δ / l') → ∃ λ (nl' : Γ' ⊆ Δ / l) → (Δ / l') / nl ≈' (Δ / l) / nl') ⊎ ∃ λ (p : Γ ≡ Γ') → tr _ p l ≡ l'
same-⊗var (⊆-in l) (⊆-in l') with same-var ten ten l l'
same-⊗var (⊆-in l) (⊆-in l') | inj₁ (nl , nl' , s) = inj₁ (⊆-in nl , ⊆-in nl' , s)
same-⊗var (⊆-in l) (⊆-in .l) | inj₂ (refl , refl) = inj₂ (refl , refl)

∈'-≔' : ∀ {Δ Γ Γ' S}(l : Γ ∈' Δ) → Γ' ∈' Δ → NotPar' Γ → NotPar' Γ'
  → Γ ≢ Γ' → Γ' ∈' Δ [ l ≔ S ]'
∈'-≔' here here np np' e = 𝟘-elim (e refl)
∈'-≔' (left l) here np () e
∈'-≔' (right l) here np () e
∈'-≔' here (left l') () np' e
∈'-≔' (left l) (left l') np np' e = left (∈'-≔' l l' np np' e)
∈'-≔' (right l) (left l') np np' e = left l'
∈'-≔' here (right l') () np' e
∈'-≔' (left l) (right l') np np' e = right l'
∈'-≔' (right l) (right l') np np' e = right (∈'-≔' l l' np np' e)

≔'-swap : ∀ {Δ Γ Γ' M M'}(l : Γ ∈' Δ)(l' : Γ' ∈' Δ)
    (np : NotPar' Γ)(np' : NotPar' Γ')(e : Γ ≢ Γ')(e' : Γ' ≢ Γ)
  → (Δ [ l' ≔ M' ]') [ ∈'-≔' l' l np' np e' ≔ M ]'
  ≈' (Δ [ l ≔ M ]') [ ∈'-≔' l l' np np' e ≔ M' ]'
≔'-swap here here np np' e e' = 𝟘-elim (e refl)
≔'-swap here (left l') () np' e e'
≔'-swap here (right l') () np' e e'
≔'-swap (left l) here np () e e'
≔'-swap (left l) (left l') np np' e e' = ⅋-congₗ (≔'-swap l l' np np' e e')
≔'-swap (left l) (right l') np np' e e' = id'≈
≔'-swap (right l) here np () e e'
≔'-swap (right l) (left l') np np' e e' = id'≈
≔'-swap (right l) (right l') np np' e e' = ⅋'-congᵣ (≔'-swap l l' np np' e e')

module _ {S} where
  ∈-/ : ∀ {Δ Γ}(l : Γ ⊆ Δ) → S ∈ Δ → S ∈ (Δ / l)
  ∈-/ (⊆-in l) l' = ∈'-≔' l l' ten act0 (λ ())

  ⊆-≔ : ∀ {Γ Δ M} → Γ ⊆ Δ → (l : S ∈ Δ) → Γ ⊆ Δ [ l ≔ M ]
  ⊆-≔ (⊆-in l) l' = ⊆-in (∈'-≔' l' l act0 ten (λ ()))

  ≔/ : ∀ {Γ Δ M}(l : Γ ⊆ Δ)(v : S ∈ Δ) → Δ [ v ≔ M ] / ⊆-≔ l v ≈' (Δ / l) [ ∈-/ l v ≔ M ]
  ≔/ (⊆-in l) l' = ≔'-swap l l' ten act0 (λ ()) (λ ())

in-sub : ∀ {Γ Γ' Δ}(l : Γ ∈' Δ) → Γ' ∈' Δ [ l ≔ Γ' ]'
in-sub here = here
in-sub (left x) = left (in-sub x)
in-sub (right x) = right (in-sub x)

sub-twice : ∀ {Γ Γ' Γ'' Δ}(l : Γ ∈' Δ) →
  (Δ [ l ≔ Γ' ]') [ in-sub l ≔ Γ'' ]'
  ≈' Δ [ l ≔ Γ'' ]'
sub-twice here = id'≈
sub-twice (left x) = ⅋-congₗ (sub-twice x)
sub-twice (right x) = ⅋'-congᵣ (sub-twice x)

act≠⊗ : ∀ {S A B} → act S ≢ A ⊗ B
act≠⊗ ()

⊗≠act : ∀ {S A B} → A ⊗ B ≢ act S
⊗≠act ()

mix : ∀ {P Q} → ⟪ P ⟫ → ⟪ Q ⟫ → ⟪ P ⅋ Q ⟫
mix (end x) q = conv (⅋ε' · ⅋-comm · ⅋-congₗ (PEnd-≈' ε x)) q
mix (input l x) q = input (left l) λ m → mix (x m) q
mix (output l m p) q = output (left l) m (mix p q)
mix (pair (⊆-in l) x p p₁) q = pair (⊆-in (left l)) (⅋-congₗ x · ⅋-assoc)
  p (conv (⅋-assoc · ⅋'-congᵣ ⅋-comm · !' ⅋-assoc) (mix p₁ q))

end' : ∀ {Δ} → PEnded' Δ → ⟪ Δ ⟫
end' ε = end ε
end' (P⅋ p p₁) = mix (end' p) (end' p₁)
end' (P⊗ p p₁) = pair (⊆-in here) ⅋ε' (conv (⅋ε' · ⅋-comm) (end' p)) (conv (⅋ε' · ⅋-comm) (end' p₁))

cut₁ : ∀ {Δ Δ' S}(l : S ∈ Δ)(l' : dual S ∈ Δ') → ⟪ Δ ⟫ → ⟪ Δ' ⟫ → ⟪ Δ [ l ≔ end ] ⅋ Δ' [ l' ≔ end ] ⟫
cut₁ {S = end} cl cl' p q = conv (⅋'-cong (≔-same cl) (≔-same cl')) (mix p q)
cut₁ {S = com x P} cl cl' (pair (⊆-in tl) s p p₁) q
 with ∈'-≔' {S = act end} cl tl act0 ten act≠⊗
    | ∈'-≔' {S = act end} tl cl ten act0 ⊗≠act
    | ≔'-swap {M = act end} {M' = act end} cl tl act0 ten act≠⊗ ⊗≠act
... | ntl | ncl | sub with ∈-conv s ncl | ≔-conv {S' = end} s ncl
... | left gncl | sub' = pair (⊆-in (left ntl))
                            (⅋-congₗ (!' sub · sub')
                            · ⅋-assoc · ⅋'-congᵣ ⅋-comm · !' ⅋-assoc)
                            (conv (⅋-assoc · ⅋'-congᵣ ⅋-comm · !' ⅋-assoc)
                              (cut₁ (left gncl) cl' p q))
                            p₁
... | right gncl | sub' = pair (⊆-in (left ntl))
       (⅋-congₗ (!' sub · sub') · ⅋-assoc)
       p
       (conv (⅋-assoc · ⅋'-congᵣ ⅋-comm · !' ⅋-assoc)
         (cut₁ (left gncl) cl' p₁ q))
cut₁ {S = com x P} cl cl' p (pair (⊆-in tl) s q q₁)
 with ∈'-≔' {S = act end} cl' tl act0 ten act≠⊗
    | ∈'-≔' {S = act end} tl cl' ten act0 ⊗≠act
    | ≔'-swap {M = act end} {M' = act end} cl' tl act0 ten act≠⊗ ⊗≠act
... | ntl | ncl' | sub with ∈-conv s ncl' | ≔-conv {S' = end} s ncl'
... | left gncl' | sub' = pair (⊆-in (right ntl))
  (⅋'-congᵣ (!' sub · sub') · !' ⅋-assoc)
  (conv (!' ⅋-assoc) (cut₁ cl (left gncl') p q))
  q₁
... | right gncl' | sub' = pair (⊆-in (right ntl))
  (⅋'-congᵣ (!' sub · sub') · !' ⅋-assoc · ⅋-congₗ ⅋-comm · ⅋-assoc)
  q
  (conv (!' ⅋-assoc) (cut₁ cl (left gncl') p q₁))
cut₁ {S = com x P} cl cl' (end p) q = 𝟘-elim (∉-PEnd p cl)
cut₁ {S = com x P} cl cl' p (end q) = 𝟘-elim (∉-PEnd q cl')

cut₁ cl cl' (input l x) (input l' x₁) with same-var act0 act0 cl l | same-var act0 act0 cl' l'
cut₁ cl cl' (input l x₁) (input l' x₂) | inj₁ (ncl , nl , s) | Q = input (left nl) λ m
  → conv (⅋-congₗ s) (cut₁ ncl cl' (x₁ m) (input l' x₂))
cut₁ cl cl' (input l x₁) (input l' x₂) | inj₂ y | inj₁ (ncl' , nl' , s) = input (right nl') λ m
  → conv (⅋'-congᵣ s) (cut₁ cl ncl' (input l x₁) (x₂ m))
cut₁ cl cl' (input l x) (input l' x₁) | inj₂ (refl , proj₂) | inj₂ (() , proj₄)

cut₁ cl cl' (input l p) (output l' m q) with same-var act0 act0 cl l | same-var act0 act0 cl' l'
cut₁ cl cl' (input l p) (output l' m q) | inj₁ (ncl , nl , s) | Q = input (left nl) λ m'
 → conv (⅋-congₗ s) (cut₁ ncl cl' (p m') (output l' m q))
cut₁ cl cl' (input l p) (output l' m q) | inj₂ y | inj₁ (ncl' , nl' , s) = output (right nl') m
  (conv (⅋'-congᵣ s) (cut₁ cl ncl' (input l p) q))
cut₁ cl cl' (input .cl p) (output .cl' m q) | inj₂ (refl , refl) | inj₂ (refl , refl)
  = conv (⅋'-cong (sub-twice cl) (sub-twice cl')) (cut₁ (in-sub cl) (in-sub cl') (p m) q)

cut₁ cl cl' (output l m p) (input l' q) with same-var act0 act0 cl l | same-var act0 act0 cl' l'
cut₁ cl cl' (output l m p) (input l' q) | inj₁ (ncl , nl , s) | Q = output (left nl) m
  (conv (⅋-congₗ s) (cut₁ ncl cl' p (input l' q)))
cut₁ cl cl' (output l m p) (input l' q) | inj₂ y | inj₁ (ncl' , nl' , s) = input (right nl') λ m' →
  conv (⅋'-congᵣ s) (cut₁ cl ncl' (output l m p) (q m'))
cut₁ cl cl' (output .cl m p) (input .cl' q) | inj₂ (refl , refl) | inj₂ (refl , refl)
  = conv (⅋'-cong (sub-twice cl) (sub-twice cl')) (cut₁ (in-sub cl) (in-sub cl') p (q m))

cut₁ cl cl' (output l m p) (output l' m₁ q) with same-var act0 act0 cl l | same-var act0 act0 cl' l'
cut₁ cl cl' (output l m p) (output l' m₁ q) | inj₁ (ncl , nl , s) | Q = output (left nl) m (conv (⅋-congₗ s)
  (cut₁ ncl cl' p (output l' m₁ q)))
cut₁ cl cl' (output l m p) (output l' m₁ q) | inj₂ y | inj₁ (ncl' , nl' , s) = output (right nl') m₁
  (conv (⅋'-congᵣ s) (cut₁ cl ncl' (output l m p) q))
cut₁ cl cl' (output l m p) (output l' m₁ q) | inj₂ (refl , proj₂) | inj₂ (() , proj₄)

the-cut₁ : ∀ {Δ Δ' S} → ⟪ Δ ⅋ act S ⟫ → ⟪ act (dual S) ⅋ Δ' ⟫ → ⟪ Δ ⅋ Δ' ⟫
the-cut₁ p q = conv (⅋-congₗ ⅋ε · ⅋'-congᵣ (⅋-comm · ⅋ε)) (cut₁ (right here) (left here) p q)

mutual
  cut⊗ : ∀ {Δ Δ' A A' B B'} → Dual A A' → Dual B B' → (l : (A ⊗ B) ⊆ Δ) →
    ⟪ Δ ⟫ → ⟪ (A' ⅋ B') ⅋ Δ' ⟫ → ⟪ Δ / l ⅋ Δ' ⟫
  cut⊗ da db cl (end x) q = 𝟘-elim (⊈-PEnd x cl)
  cut⊗ da db cl (input l x) q = input (left (∈-/ cl l)) (λ m → conv (⅋-congₗ (≔/ cl l)) (cut⊗ da db (⊆-≔ cl l) (x m) q))
  cut⊗ da db cl (output l m p) q = output (left (∈-/ cl l)) m (conv (⅋-congₗ (≔/ cl l)) (cut⊗ da db (⊆-≔ cl l) p q))
  cut⊗ da db cl (pair l x p p₁) q with same-⊗var cl l
  cut⊗ da db cl (pair l x₁ p p₁) q | inj₁ (cl' , l' , s) with ⊆-conv x₁ cl' | /-conv x₁ cl'
  cut⊗ da db cl (pair (⊆-in l) x₁ p p₁) q | inj₁ (cl' , ⊆-in l' , s) | ⊆-in (left P₁) | sub
     = pair (⊆-in (left l'))
     (⅋-congₗ  (!' s · sub) · ⅋-assoc · ⅋'-congᵣ ⅋-comm · !' ⅋-assoc)
     (conv (⅋-assoc · ⅋'-congᵣ ⅋-comm · !' ⅋-assoc) (cut⊗ da db (⊆-in (left P₁)) p q)) p₁
  cut⊗ da db cl (pair (⊆-in l) x₁ p p₁) q | inj₁ (cl' , ⊆-in l' , s) | ⊆-in (right P₁) | sub
     = pair (⊆-in (left l')) (⅋-congₗ (!' s · sub) · ⅋-assoc) p
     (conv (⅋-assoc · ⅋'-congᵣ ⅋-comm · !' ⅋-assoc) (cut⊗ da db (⊆-in (left P₁)) p₁ q ))
  cut⊗ da db cl (pair .cl x p p₁) q | inj₂ (refl , refl) = conv
    (!' ⅋-assoc · ⅋-congₗ (⅋-comm · !' x))
    (let X = cut da p (conv ⅋-assoc q)
      in cut db p₁ (conv (!' ⅋-assoc · ⅋-congₗ ⅋-comm · ⅋-assoc) X))

  cut : ∀ {Δ Δ' Ψ Ψ'} → Dual Ψ Ψ' → ⟪ Δ ⅋ Ψ ⟫ → ⟪ Ψ' ⅋ Δ' ⟫ → ⟪ Δ ⅋ Δ' ⟫
  cut act p q = the-cut₁ p q
  cut act' p q = conv ⅋-comm (the-cut₁ (conv ⅋-comm q) (conv ⅋-comm p))
  cut (⊗⅋ d d₁ d₂ d₃) p q = conv (⅋-congₗ ⅋ε) (cut⊗ d d₂ (⊆-in (right here)) p q)
  cut (⅋⊗ d d₁ d₂ d₃) p q = conv (⅋-congₗ (⅋-comm · ⅋ε) · ⅋-comm)
                            (cut⊗ d₁ d₃ (⊆-in (left here)) q (conv ⅋-comm p))

the-cut : ∀ {Δ Δ'} Ψ → ⟪ Δ ⅋ Ψ ⟫ → ⟪ dual' Ψ ⅋ Δ' ⟫ → ⟪ Δ ⅋ Δ' ⟫
the-cut Ψ = cut (mkDual Ψ)

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

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


TrustMe.NP

TrustMe.NP

{-# OPTIONS --without-K #-}
module Relation.Binary.PropositionalEquality.TrustMe.NP where

open import Relation.Binary.PropositionalEquality
open import Relation.Binary.PropositionalEquality.TrustMe public

erase : ∀ {a} {A : Set a} {x y : A} → x ≡ y → x ≡ y
erase _ = trustMe

error: pathspec 'lib/Relation/Binary/PropositionalEquality/TrustMe/NP.agda' did not match any file(s) known to git


Added note on bisimulations.

Added note on bisimulations.

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

module FOT.FOTC.Relation.Binary.Bisimilarity.NonBisimulation where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream
open import FOTC.Relation.Binary.Bisimilarity

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

h : ∀ {xs} → Stream xs → xs ≡ xs →
      ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ xs ≡ x' ∷ ys' ∧ xs' ≡ xs'
h Sxs _ with Stream-unf Sxs
... | x' , xs' , xs≡x'∷xs' , _ = x' , xs' , xs' , xs≡x'∷xs' , xs≡x'∷xs' , refl

≈-refl : ∀ {xs} → Stream xs → xs ≈ xs
≈-refl {xs} Sxs = ≈-coind (λ ys _ → ys ≡ ys) (h Sxs) refl

error: pathspec 'notes/FOT/FOTC/Relation/Binary/Bisimilarity/NonBisimulation.agda' did not match any file(s) known to git


second attempt at induction via map

second attempt at induction via map

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

module Data1 where

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

id : {X : Set} -> X -> X
id x = x

konst : {S : Set}{T : S -> Set} -> ({x : S} -> T x) -> (x : S) -> T x
konst c x = c

data Zero : Set where
record One : Set where

record Sig (S : Set)(T : S -> Set) : Set where
  field
    fst : S
    snd : T fst

open module Sig' {S : Set}{T : S -> Set} = Sig {S}{T}

_,_ : forall {S T}(s : S) -> T s -> Sig S T
s , t = record {fst = s; snd = t}

infixr 40 _,_

_*_ : Set -> Set -> Set
S * T = Sig S \ _ -> T

sig : forall {S T}{P : Sig S T -> Set} ->
      ((s : S)(t : T s) -> P (s , t)) -> (st : Sig S T) -> P st
sig f st = f (fst st) (snd st)

data Cx : Set where
  E : Cx
  _/_ : Cx -> Set -> Cx

data _:>_ : Cx -> Set -> Set where
  ze : {G : Cx}{S : Set} -> (G / S) :> S
  su : {G : Cx}{S T : Set} -> G :> T -> (G / S) :> T

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

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

data CON (G : Cx) : Set where
  ?? : {S : Set} -> G :> S -> S -> CON G
  PrfC : PROP -> CON G
  _*C_ : CON G -> CON G -> CON G
  PiC : (S : Set) -> (S -> CON G) -> CON G
  SiC : (S : Set) -> (S -> CON G) -> CON G
  MuC : (O : Set) -> (O -> CON (G / O)) -> O -> CON G
  NuC : (O : Set) -> (O -> CON (G / O)) -> O -> CON G

Box : (G : Cx) -> ((S : Set) -> (G :> S) -> Set) -> Set
Box E F = One
Box (G / S) F = Box G (\ S n -> F S (su n)) * F S ze

pr : {G : Cx}{S : Set}{F : (S : Set) -> (G :> S) -> Set} -> Box G F -> (n : G :> S) -> F S n
pr fsf ze = snd fsf
pr fsf (su n) = pr (fst fsf) n

Pay : Cx -> Set
Pay G = Box G (\ I _ -> I -> Set)

Arr : (G : Cx) -> Pay G -> Pay G -> Set
Arr G X Y = Box G (\ S n -> (s : S) -> pr X n s -> pr Y n s)

mutual
  [|_|] : {G : Cx} -> CON G -> Pay G -> Set
  [| ?? n i |]     X = pr X n i
  [| PrfC P |]     X = Prf P
  [| C *C D |]     X = [| C |] X * [| D |] X
  [| PiC S C |]    X = (s : S) -> [| C s |] X
  [| SiC S C |]    X = Sig S \ s -> [| C s |] X
  [| MuC O C o |]  X = Mu C X o
  [| NuC O C o |]  X = Nu C X o

  data Mu {G : Cx}{O : Set}(C : O -> CON (G / O))(X : Pay G)(o : O) : Set where
    con : [| C o |] ( X , Mu C X ) -> Mu C X o
  codata Nu {G : Cx}{O : Set}(C : O -> CON (G / O))(X : Pay G)(o : O) : Set where
    con : [| C o |] ( X , Nu C X ) -> Nu C X o

noc :  {G : Cx}{O : Set}{C : O -> CON (G / O)}{X : Pay G}{o : O} ->
       Nu C X o -> [| C o |] ( X , Nu C X )
noc (con xs) = xs

mutual
  map : {G : Cx}{X Y : Pay G} -> (C : CON G) ->
        Arr G X Y ->
        [| C |] X -> [| C |] Y
  map (?? n i)     f = pr f n i
  map (PrfC P)     f = id
  map (C *C D)     f = sig \ c d -> map C f c , map D f d
  map (PiC S C)    f = \ c s -> map (C s) f (c s)
  map (SiC S C)    f = sig \ s c -> s , map (C s) f c
  map (MuC O C o)  f = foldMap C (Mu C _) f (\ o -> con) o
  map (NuC O C o)  f = unfoldMap C (Nu C _) f (\ o -> noc) o

  foldMap :  {G : Cx}{O : Set}(C : O -> CON (G / O)){X Y : Pay G}(Z : O -> Set) ->
          Arr G X Y ->
          ((o : O) -> [| C o |] ( Y , Z ) -> Z o) ->
          (o : O) -> Mu C X o -> Z o
  foldMap C Z f alg o (con xs) = alg o (map (C o) (f , foldMap C Z f alg) xs)

  unfoldMap :  {G : Cx}{O : Set}(C : O -> CON (G / O)){X Y : Pay G}(Z : O -> Set) ->
            Arr G X Y ->
            ((o : O) -> Z o -> [| C o |] ( X , Z )) ->
            (o : O) -> Z o -> Nu C Y o
  unfoldMap C Z f coalg o y = con (map (C o) (f , unfoldMap C Z f coalg) (coalg o y))

ida : (G : Cx) -> (X : Pay G) -> Arr G X X
ida E = id
ida (G / S) = sig \ Xs X -> ida G Xs , \ s x -> x

compa : (G : Cx) -> (X Y Z : Pay G) -> Arr G Y Z -> Arr G X Y -> Arr G X Z
compa E = \ _ _ _ _ _ -> _
compa (G / S) = sig \ Xs X -> sig \ Ys Y -> sig \ Zs Z -> sig \ fs f -> sig \ gs g ->
  compa G Xs Ys Zs fs gs , \ s x -> f s (g s x)

induction : {G : Cx}{O : Set}(C : O -> CON (G / O)){X : Pay G}
            (P : (o : O) -> Mu C X o -> Set) ->
            ((o : O)(xyps : [| C o |] (X , (\ o -> Sig (Mu C X o) (P o)))) ->
             P o (con (map (C o) (ida G X , konst fst) xyps))) ->
            (o : O)(y : Mu C X o) -> P o y
induction {G} C {X} P p o (con xys) =
  p o (map (C o) (ida G X , (\ o y -> (y , induction C P p o y))) xys)

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


open import Type
open import Function
open import Control.Protocol.Choreography
open import Data.One
open import Data.Nat
open import Data.Product
open import Data.Maybe
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

module Control.Protocol.IP (Query : ★) (Resp : Query → ★) where

-- One round from the point of view of the verifier
VerifierRound : Proto
VerifierRound = Σᴾ Query    λ q →
                Πᴾ (Resp q) λ r →
                end

ProverRound : Proto
ProverRound = dual VerifierRound

module Rounds (#rounds : ℕ) where
  Verifierᴾ : Proto
  Verifierᴾ = replicateᴾ #rounds VerifierRound >> (Σᴾ Accept? λ _ → end)

  Proverᴾ   : Proto
  Proverᴾ   = dual Verifierᴾ

  Transcriptᴾ : Proto
  Transcriptᴾ = source-of Verifierᴾ

  Prover   : ★
  Prover   = ⟦ Proverᴾ ⟧

  Verifier : ★
  Verifier = ⟦ Verifierᴾ ⟧

  Transcript : ★
  Transcript = ⟦ Transcriptᴾ ⟧

  _⇆_ : Prover → Verifier → Accept?
  _⇆_ = λ p v → case >>-com (replicateᴾ #rounds VerifierRound) v p of λ { (_ , (a , _) , _) → a }

record IP (#rounds : ℕ) {A : ★} (ℒ : A → ★) : ★ where
  open Rounds #rounds public

  field
    verifier : Verifier

  Convincing : Prover → ★
  Convincing = λ p → Is-accept (p ⇆ verifier)

  Complete : ★
  Complete = ∀ x → ℒ x → Σ Prover Convincing

  Sound : ★
  Sound = ∀ x → ¬(ℒ x) → (p : Prover) → ¬(Convincing p)

NP-Verifier = Σ Query λ q → Resp q → Accept? × 𝟙

NP-Verifier≡Verifier1 : NP-Verifier ≡ Rounds.Verifier 1
NP-Verifier≡Verifier1 = refl

NP : {A : ★} (ℒ : A → ★) → ★
NP = IP 1

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

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


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/sharkspeed/dororis.git/'


Added draft: The relation LTL is well-founded (using the image inverse combinator from the standard library).

Ignore-this: 9e870170aec2a84a8400f4bc3d41951d

darcs-hash:20110305070736-3bd4e-5e3478597e514100f8302001b24ae92a76da00cc.gz

------------------------------------------------------------------------------
-- The relation LTL is well-founded using the image inverse combinator
-- from the standard library
------------------------------------------------------------------------------

module LT-LengthSL {A : Set} where

open import Data.List
open import Data.Nat

open import Induction.Nat
open import Induction.WellFounded

open module II =
  Induction.WellFounded.Inverse-image length

LTL : List A → List A → Set
LTL xs ys = (length xs) <′ (length ys)

wfLTL : Well-founded LTL
wfLTL = well-founded <-well-founded

error: pathspec 'Draft/List/LT-LengthSL.agda' did not match any file(s) known to git


Added a test.

Added a test.

Ignore-this: 5c764a0c6b26f4cca506d737df64e61d

darcs-hash:20110406204621-3bd4e-2d12be8ec0f0528007464d7e2f9d424628e42e79.gz

module Test.Succeed.Conjectures.RepeatedConjecture where

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

-- The ATPs only try to prove the last ATP pragma.
postulate
  sym : ∀ d e → d ≡ e → e ≡ d
{-# ATP prove sym #-}
{-# ATP prove sym refl #-}

error: pathspec 'Test/Succeed/Conjectures/RepeatedConjecture.agda' did not match any file(s) known to git


Added mutual recursive functions example.

------------------------------------------------------------------------------
-- Mutual recursive functions
------------------------------------------------------------------------------

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

-- Tested with agda2atp on 29 August 2012.

module FOT.FOTC.Data.Nat.MutualRecursiveFunctions where

open import FOTC.Base

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

postulate
  even : D → D
  odd  : D → D

  even-0 :       even zero      ≡ true
  even-S : ∀ d → even (succ₁ d) ≡ odd d

  odd-0 :       odd zero      ≡ false
  odd-S : ∀ d → odd (succ₁ d) ≡ even d
{-# ATP axiom even-0 even-S odd-0 odd-S #-}

postulate even-2 : even (succ₁ (succ₁ zero)) ≡ true
{-# ATP prove even-2 #-}

postulate even-3 : even (succ₁ (succ₁ (succ₁ zero))) ≡ false
{-# ATP prove even-3 #-}

postulate odd-2 : odd (succ₁ (succ₁ zero)) ≡ false
{-# ATP prove odd-2 #-}

postulate odd-3 : odd (succ₁ (succ₁ (succ₁ zero))) ≡ true
{-# ATP prove odd-3 #-}

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


First go at a clean model of IDesc. With too much universe polymorphism for now.

fatal: unable to access 'https://github.com/brixen/Epigram.git/': The requested URL returned error: 403


module Function.Related.TypeIsomorphisms.NP where

import Level as L
open import Algebra
open L using (Lift; lower; lift)
open import Type
import Function as F
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Maybe.NP
open import Data.Product
--open import Data.Product.N-ary
open import Data.Sum renaming (map to map⊎)
open import Data.Unit
open import Data.Empty
open import Function.Equality using (_⟨$⟩_)
open import Function.Related
open import Function.Related.TypeIsomorphisms public
open import Function.Inverse using (_↔_; _∘_; sym; id; module Inverse)
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (→-to-⟶)

Maybe↔⊤⊎ : ∀ {a} {A : Set a} → Maybe A ↔ (⊤ ⊎ A)
Maybe↔⊤⊎
  = record { to   = →-to-⟶ (maybe inj₂ (inj₁ _))
           ; from = →-to-⟶ [ F.const nothing , just ]
           ; inverse-of
           = record { left-inverse-of = maybe (λ _ → ≡.refl) ≡.refl
                    ; right-inverse-of = [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ] } }

Maybe-cong : ∀ {a b} {A : Set a} {B : Set b} → A ↔ B → Maybe A ↔ Maybe B
Maybe-cong A↔B = sym Maybe↔⊤⊎ ∘ id ⊎-cong A↔B ∘ Maybe↔⊤⊎

Maybe∘Maybe^↔Maybe^∘Maybe : ∀ {A} n → Maybe (Maybe^ n A) ↔ Maybe^ n (Maybe A)
Maybe∘Maybe^↔Maybe^∘Maybe zero    = id
Maybe∘Maybe^↔Maybe^∘Maybe (suc n) = Maybe-cong (Maybe∘Maybe^↔Maybe^∘Maybe n)

Maybe^-cong : ∀ {A B} n → A ↔ B → Maybe^ n A ↔ Maybe^ n B
Maybe^-cong zero    = F.id
Maybe^-cong (suc n) = Maybe-cong F.∘ Maybe^-cong n

Vec0↔⊤ : ∀ {a} {A : Set a} → Vec A 0 ↔ ⊤
Vec0↔⊤ = record { to         = →-to-⟶ _
                ; from       = →-to-⟶ (F.const [])
                ; inverse-of = record { left-inverse-of  = λ { [] → ≡.refl }
                                      ; right-inverse-of = λ _ → ≡.refl } }

Vec∘suc↔A×Vec : ∀ {a} {A : Set a} {n} → Vec A (suc n) ↔ (A × Vec A n)
Vec∘suc↔A×Vec
  = record { to         = →-to-⟶ (λ { (x ∷ xs) → x , xs })
           ; from       = →-to-⟶ (uncurry _∷_)
           ; inverse-of = record { left-inverse-of  = λ { (x ∷ xs) → ≡.refl }
                                 ; right-inverse-of = λ _ → ≡.refl } }

infix 8 _^_

_^_ : ★ → ℕ → ★
A ^ 0     = ⊤
A ^ suc n = A × A ^ n

^↔Vec : ∀ {A} n → (A ^ n) ↔ Vec A n
^↔Vec zero    = sym Vec0↔⊤
^↔Vec (suc n) = sym Vec∘suc↔A×Vec ∘ (id ×-cong (^↔Vec n))

Fin0↔⊥ : Fin 0 ↔ ⊥
Fin0↔⊥ = record { to   = →-to-⟶ λ()
                ; from = →-to-⟶ λ()
                ; inverse-of = record { left-inverse-of  = λ()
                                      ; right-inverse-of = λ() } }

Fin∘suc↔Maybe∘Fin : ∀ {n} → Fin (suc n) ↔ Maybe (Fin n)
Fin∘suc↔Maybe∘Fin {n}
  = record { to   = →-to-⟶ to
           ; from = →-to-⟶ (maybe suc zero)
           ; inverse-of
           = record { left-inverse-of = λ { zero → ≡.refl ; (suc n) → ≡.refl }
                    ; right-inverse-of = maybe (λ _ → ≡.refl) ≡.refl } }
  where to : Fin (suc n) → Maybe (Fin n)
        to zero = nothing
        to (suc n) = just n

Lift↔id : ∀ {a} {A : Set a} → Lift {a} {a} A ↔ A
Lift↔id = λ {a} {A} → record { to = →-to-⟶ lower
                             ; from = →-to-⟶ lift
                             ; inverse-of = record { left-inverse-of = λ { (lift x) → ≡.refl }
                                                   ; right-inverse-of = λ _ → ≡.refl } }

Maybe⊥↔⊤ : Maybe ⊥ ↔ ⊤
Maybe⊥↔⊤ = (proj₂ CMon.identity ⊤ ∘ id ⊎-cong (sym (Lift↔id {A = ⊥}))) ∘ Maybe↔⊤⊎
  where module CMon = CommutativeMonoid (⊎-CommutativeMonoid bijection L.zero)

Maybe^⊥↔Fin : ∀ n → Maybe^ n ⊥ ↔ Fin n
Maybe^⊥↔Fin zero    = sym Fin0↔⊥
Maybe^⊥↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^⊥↔Fin n)

Maybe^⊤↔Fin1+ : ∀ n → Maybe^ n ⊤ ↔ Fin (suc n)
Maybe^⊤↔Fin1+ n = Maybe^⊥↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe⊥↔⊤)

Fin∘suc↔⊤⊎Fin : ∀ {n} → Fin (suc n) ↔ (⊤ ⊎ Fin n)
Fin∘suc↔⊤⊎Fin = Maybe↔⊤⊎ ∘ Fin∘suc↔Maybe∘Fin

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


Added draft on conat.

Added draft on conat.

Ignore-this: dbc067167cfc6e616f4179393950c00d

darcs-hash:20120320161638-3bd4e-c7da32d17a45b600fe008dbb9ae8b223d936e716.gz

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

-- Tested with FOT 20 March 2012.

module Draft.FOTC.Data.Conat.PropertiesI where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.Nat

≈N-refl : ∀ {n} → Conat n → n ≈N n
≈N-refl {n} h = ≈N-gfp₂ P helper₁ helper₂
  where
  P : D → D → Set
  P a b = Conat a ∧ Conat b ∧ a ≡ b

  helper₁ : ∀ {a b} → P a b → a ≡ zero ∧ b ≡ zero
            ∨ (∃ (λ a' → ∃ (λ b' → P a' b' ∧ a ≡ succ₁ a' ∧ b ≡ succ₁ b')))
  helper₁ {a} {.a} (Ca , Cb , refl) with Conat-gfp₁ Ca
  ... | inj₁ prf = inj₁ (prf , prf)
  ... | inj₂ (a' , Ca' , prf) = inj₂ (a' , a' , (Ca' , Ca' , refl) , (prf , prf))

  helper₂ : Conat n ∧ Conat n ∧ n ≡ n
  helper₂ = h , h , refl

≡→≈N : ∀ {m n} → Conat m → Conat n → m ≡ n → m ≈N n
≡→≈N h₁ h₂ refl = ≈N-refl h₁

{-# NO_TERMINATION_CHECK #-}
Conat→N : ∀ {n} → Conat n → N n
Conat→N Cn with Conat-gfp₁ Cn
... | inj₁ prf = subst N (sym prf) zN
... | inj₂ (n' , Cn' , prf) = subst N (sym prf) (sN {!Conat→N Cn'!})
-- Agda error: Failed to give (Conat→N Cn')

N→Conat : ∀ {n} → N n → Conat n
N→Conat zN          = Conat-gfp₃ (inj₁ refl)
N→Conat (sN {n} Nn) = Conat-gfp₃ (inj₂ (n , ({!N→Conat Nn!} , refl)))
-- Agda error: Failed to give N→Conat Nn

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


Added a note on the normalization of conditional expression.

Ignore-this: 628fc598478e377a98efa1cafb381885

darcs-hash:20120504220208-3bd4e-15e074241f642af80f0aa4a3cc9e9172ac5a3a5a.gz

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

-- From: Peter Dybjer. Comparing integrated and external logics of
-- functional programs. Science of Computer Programming, 14:59–79,
-- 1990

module Norm where

postulate Char : Set

data Atom : Set where
  True False : Atom
  Var        : Char → Atom

data Exp : Set where
  at : Atom → Exp
  if : Exp → Exp → Exp → Exp

-- Agda doesn't recognize the termination of the function.
norm : Exp → Exp
norm (at a)              = at a
norm (if (at a) y z)     = if (at a) (norm y) (norm z)
norm (if (if u v w) y z) = norm (if u (if v y z) (if w y z))

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


Create ttfp1.agda

Create ttfp1.agda

notes while learning ttfp

-- some excises for learning ttfp (type theory for functional programming).
-- most of the code is *borrowed* from learn you an agda shamelessly

-- Function composition
_∘_ : {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) x = f (g x)

-- Conjuntion, ∏-type in haskell

data _∧_ (α : Set) (β : Set) : Set where
  ∧-intro : α → β → (α ∧ β)

∧-elim₁ : {α β : Set} → (α ∧ β) → α
∧-elim₁ (∧-intro p q) = p

∧-elim₂ : {α β : Set} → (α ∧ β) → β
∧-elim₂ (∧-intro p q) = q

_⇔_ : (α : Set) → (β : Set) → Set
a ⇔ b = (a → b) ∧ (b → a)

∧-comm′ : {α β : Set} → (α ∧ β) → (β ∧ α)
∧-comm′ (∧-intro a b) = ∧-intro b a

∧-comm : {α β : Set} → (α ∧ β) ⇔ (β ∧ α)
∧-comm = ∧-intro ∧-comm′ ∧-comm′

-- type signature cannot be eliminated, was expecting type could be infered but it wasn't the case.
e₁e₁ : { P Q R : Set} → ( (P ∧ Q) ∧ R ) → P
e₁e₁ = ∧-elim₁ ∘ ∧-elim₁
e₂e₁ : { P Q R : Set} → ( (P ∧ Q) ∧ R) → Q
e₂e₁ = ∧-elim₂ ∘ ∧-elim₁

∧-assoc₁ : { P Q R : Set } → ((P ∧ Q) ∧ R) → (P ∧ (Q ∧ R))
∧-assoc₁ = λ x → ∧-intro (∧-elim₁ (∧-elim₁ x)) (∧-intro (∧-elim₂ (∧-elim₁ x)) (∧-elim₂ x))

∧-assoc₂ : {P Q R : Set} → (P ∧ (Q ∧ R)) → ((P ∧ Q) ∧ R)
∧-assoc₂ = λ x → ∧-intro (∧-intro (∧-elim₁ x) (∧-elim₁ (∧-elim₂ x))) (∧-elim₂ (∧-elim₂ x))

∧-assoc : {P Q R : Set} → ((P ∧ Q) ∧ R) ⇔ (P ∧ (Q ∧ R))
∧-assoc = ∧-intro ∧-assoc₁ ∧-assoc₂

-- Disjunctions, ∑-type in haskell

data _∨_ (P Q : Set) : Set where
  ∨-intro₁ : P → P ∨ Q
  ∨-intro₂ : Q → P ∨ Q

∨-elim : {A B C : Set} → (A ∨ B) → (A → C) → (B → C) → C
∨-elim (∨-intro₁ a) ac bc = ac a
∨-elim (∨-intro₂ b) ac bc = bc b

∨-comm′ : {P Q : Set} → (P ∨ Q) → (Q ∨ P)
∨-comm′ (∨-intro₁ p) = ∨-intro₂ p
∨-comm′ (∨-intro₂ q) = ∨-intro₁ q

∨-comm : {P Q : Set} → (P ∨ Q) ⇔ (Q ∨ P)
∨-comm = ∧-intro ∨-comm′ ∨-comm′

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


Progress on Agda formalization (see #21).

Old-commit-hash: 01bccf0894187bf2dce188a42cd81a5a40ffc777

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import meaning

-- SIMPLE TYPES

-- Syntax

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

infixr 5 _⇒_

-- Denotational Semantics

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

meaningOfType : Meaning Type
meaningOfType = meaning Set ⟦_⟧Type

-- Value Equivalence

data _≡_ : ∀ {τ} → (v₁ v₂ : ⟦ τ ⟧) → Set where
  ext : ∀ {τ₁ τ₂} {f₁ f₂ : ⟦ τ₁ ⇒ τ₂ ⟧} →
    (∀ v → f₁ v ≡ f₂ v) →
    f₁ ≡ f₂

≡-refl : ∀ {τ} {v : ⟦ τ ⟧} →
  v ≡ v
≡-refl {τ₁ ⇒ τ₂} = ext (λ v → ≡-refl)

≡-sym : ∀ {τ} {v₁ v₂ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₁
≡-sym {τ₁ ⇒ τ₂} (ext ≡) = ext (λ v → ≡-sym (≡ v))

≡-trans : ∀ {τ} {v₁ v₂ v₃ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₃ → v₁ ≡ v₃
≡-trans {τ₁ ⇒ τ₂} {f} (ext ≡₁) (ext ≡₂) =
  ext (λ v → ≡-trans (≡₁ v) (≡₂ v))

≡-cong : ∀ {τ₂ τ₁ v₁ v₂} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧) →
  v₁ ≡ v₂ → f v₁ ≡ f v₂
≡-cong {τ₁ ⇒ τ₂} f ≡ = ext (λ v → ≡-cong (λ x → f x v) ≡)

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

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

≡-isEquivalence : ∀ {τ} → IsEquivalence (_≡_ {τ})
≡-isEquivalence = record
  { refl  = ≡-refl
  ; sym   = ≡-sym
  ; trans = ≡-trans
  }

≡-setoid : Type → Setoid _ _
≡-setoid τ = record
  { Carrier       = ⟦ τ ⟧
  ; _≈_           = _≡_
  ; isEquivalence = ≡-isEquivalence
  }

module ≡-Reasoning where
  module _ {τ : Type} where
    open EqR (≡-setoid τ) public
      hiding (_≡⟨_⟩_) renaming (_≈⟨_⟩_ to _≡⟨_⟩_)

-- CHANGE TYPES

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

derive : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
apply : ∀ {τ} → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧ → ⟦ τ ⟧
diff : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

diff {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → diff (f₁ (apply dv v)) (f₂ v)

derive {τ₁ ⇒ τ₂} f = λ v dv → diff (f (apply dv v)) (f v)

apply {τ₁ ⇒ τ₂} df f = λ v → apply (df v (derive v)) (f v)

compose : ∀ {τ} → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧
compose {τ₁ ⇒ τ₂} df₁ df₂ = λ v dv → compose (df₁ v dv) (df₂ v dv)

-- PROPERTIES of changes

diff-derive : ∀ {τ} (v : ⟦ τ ⟧) →
  diff v v ≡ derive v
diff-derive {τ₁ ⇒ τ₂} v = ≡-refl

diff-apply : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
  diff (apply dv v) v ≡ dv
diff-apply {τ₁ ⇒ τ₂} df f = ext (λ v → ext (λ dv →
  {!!}))

apply-diff : ∀ {τ} (v₁ v₂ : ⟦ τ ⟧) →
  apply (diff v₂ v₁) v₁ ≡ v₂
apply-diff {τ₁ ⇒ τ₂} f₁ f₂ = ext (λ v → apply-diff (f₁ v) (f₂ v))

apply-derive : ∀ {τ} (v : ⟦ τ ⟧) →
  apply (derive v) v ≡ v
apply-derive {τ₁ ⇒ τ₂} f = ext (λ v →
  begin
    apply (derive f) f v
  ≡⟨ ≡-refl ⟩
    apply (diff (f (apply (derive v) v)) (f v)) (f v)
  ≡⟨ ≡-cong (λ x → apply (diff (f x) (f v)) (f v)) (apply-derive v) ⟩
    apply (diff (f v) (f v)) (f v)
  ≡⟨ apply-diff (f v) (f v)⟩
    f v
  ∎) where open ≡-Reasoning

apply-compose : ∀ {τ} (v : ⟦ τ ⟧) (dv₁ dv₂ : ⟦ Δ-Type τ ⟧) →
  apply (compose dv₁ dv₂) v ≡ apply dv₁ (apply dv₂ v)
apply-compose {τ₁ ⇒ τ₂} f df₁ df₂ = ext (λ v →
  apply-compose (f v) (df₂ v (derive v)) (df₂ v (derive v)))

compose-assoc : ∀ {τ} (dv₁ dv₂ dv₃ : ⟦ Δ-Type τ ⟧) →
  compose dv₁ (compose dv₂ dv₃) ≡ compose (compose dv₁ dv₂) dv₃
compose-assoc {τ₁ ⇒ τ₂} df₁ df₂ df₃ = ext (λ v → ext (λ dv →
  compose-assoc (df₁ v dv) (df₂ v dv) (df₃ v dv)))

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ

update : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
update {∅} ∅ = ∅
update {τ • Γ} (dv • v • ρ) = apply dv v • update ρ

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore {∅} ∅ = ∅
ignore {τ • Γ} (dv • v • ρ) = v • ignore ρ

-- TERMS

-- Syntax

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

  -- `Δ t` describes how t changes if its free variables or arguments change
  Δ : ∀ {Γ τ} → (t : Term Γ τ) → Term (Δ-Context Γ) (Δ-Type τ)

-- Denotational Semantics

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

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

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext ≈) = ext (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext ≈₁) (ext ≈₂) = ext (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext ≈₁) (ext ≈₂) = ext (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext ≈) = ext (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ {τ₁ ⇒ τ₂} (ext ≈) = ext (λ ρ → ext (λ v → ext (λ dv →
  ≡-cong₂ (λ x y → diff (x v) (y v)) (≈ (update ρ)) (≈ (ignore ρ)))))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open EqR (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

-- LIFTING terms into Δ-Contexts

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

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term (abs t) = abs {!!}
lift-term (app t₁ t₂) = app (lift-term t₁) (lift-term t₂)
lift-term (var x) = var (lift-var x)
lift-term (Δ t) = Δ (lift-term t)

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore (abs t) = {!!}
lift-term-ignore (app t₁ t₂) = ≡-app (lift-term-ignore t₁) (lift-term-ignore t₂)
lift-term-ignore (var x) = lift-var-ignore _ x
lift-term-ignore (Δ t) = {!!}

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨ ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

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

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term (Δ t) = Δ (derive-term t)

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext (λ ρ → derive-var-correct ρ x)
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)

-- NATURAL SEMANTICS

-- (without support for Δ for now)

-- Syntax

data Env : Context → Set
data Val : Type → Set

data Val where
  ⟨abs_,_⟩ : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) (ρ : Env Γ) → Val (τ₁ ⇒ τ₂)

data Env where
  ∅ : Env ∅
  _•_ : ∀ {Γ τ} → Val τ → Env Γ → Env (τ • Γ)

-- Lookup

infixr 8 _⊢_↓_ _⊢_↦_

data _⊢_↦_ : ∀ {Γ τ} → Env Γ → Var Γ τ → Val τ → Set where
  this : ∀ {Γ τ} {ρ : Env Γ} {v : Val τ} →
    v • ρ ⊢ this ↦ v
  that : ∀ {Γ τ₁ τ₂ x} {ρ : Env Γ} {v₁ : Val τ₁} {v₂ : Val τ₂} →
    ρ ⊢ x ↦ v₂ →
    v₁ • ρ ⊢ that x ↦ v₂

-- Reduction

data _⊢_↓_ : ∀ {Γ τ} → Env Γ → Term Γ τ → Val τ → Set where
  abs : ∀ {Γ τ₁ τ₂ ρ} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓ ⟨abs t , ρ ⟩
  app : ∀ {Γ Γ′ τ₁ τ₂ ρ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓ ⟨abs t′ , ρ′ ⟩ →
    ρ ⊢ t₂ ↓ v₂ →
    v₂ • ρ′ ⊢ t′ ↓ v′ →
    ρ ⊢ app t₁ t₂ ↓ v′
  var : ∀ {Γ τ x} {ρ : Env Γ} {v : Val τ}→
    ρ ⊢ x ↦ v →
    ρ ⊢ var x ↓ v

-- SOUNDNESS of natural semantics

⟦_⟧Env : ∀ {Γ} → Env Γ → ⟦ Γ ⟧
⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ ⟨abs t , ρ ⟩ ⟧Val = λ v → ⟦ t ⟧ (v • ⟦ ρ ⟧Env)

meaningOfEnv : ∀ {Γ} → Meaning (Env Γ)
meaningOfEnv {Γ} = meaning ⟦ Γ ⟧ ⟦_⟧Env

meaningOfVal : ∀ {τ} → Meaning (Val τ)
meaningOfVal {τ} = meaning ⟦ τ ⟧ ⟦_⟧Val

↦-sound : ∀ {Γ τ ρ v} {x : Var Γ τ} →
  ρ ⊢ x ↦ v →
  ⟦ x ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↦-sound this = ≡-refl
↦-sound (that ↦) = ↦-sound ↦

↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
  ρ ⊢ t ↓ v →
  ⟦ t ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↓-sound abs = ≡-refl
↓-sound (app ↓₁ ↓₂ ↓′) =
  ≡-trans
    (≡-cong₂ (λ x y → x y) (↓-sound ↓₁) (↓-sound ↓₂))
    (↓-sound ↓′)
↓-sound (var ↦) = ↦-sound ↦

-- WEAKENING

-- Weaken a term to a super context

{-
weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)
weaken {Γ₁} {Γ₂} (Δ t) = ?
-}

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


combination.agda

combination.agda

module combination where

open import Type
open import Data.Nat.NP
open import Data.Nat.DivMod
open import Data.Fin using (Fin; Fin′; zero; suc) renaming (toℕ to Fin▹ℕ)
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum
open import Data.Product
open import Data.Vec
open import Function.NP
open import Function.Related.TypeIsomorphisms.NP
import Function.Inverse.NP as Inv
open Inv using (_↔_; sym; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from; id to idI; _∘_ to _∘I_)
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡

open import factorial

_/_ : ℕ → ℕ → ℕ
x / y = _div_ x y {{!!}}

module v0 where

  C : ℕ → ℕ → ℕ
  C n       zero    = 1
  C zero    (suc k) = 0
  C (suc n) (suc k) = C n k + C n (suc k)

  D : ℕ → ℕ → ★
  D n       zero    = 𝟙
  D zero    (suc k) = 𝟘
  D (suc n) (suc k) = D n k ⊎ D n (suc k)

  FinC≅D : ∀ n k → Fin (C n k) ↔ D n k
  FinC≅D n       zero    = Fin1↔⊤
  FinC≅D zero    (suc k) = Fin0↔⊥
  FinC≅D (suc n) (suc k) =  FinC≅D n k ⊎-cong FinC≅D n (suc k)
                         ∘I sym (Fin-⊎-+ (C n k) (C n (suc k)))

module v! where

  C : ℕ → ℕ → ℕ
  C n k = n ! / (k ! * (n ∸ k)!)

module v1 where

  C : ℕ → ℕ → ℕ
  C n 0 = 1
  C n (suc k) = (C n k * (n ∸ k)) / suc k

module v2 where

  C : ℕ → ℕ → ℕ
  C n       zero    = 1
  C zero    (suc k) = 0
  C (suc n) (suc k) = (C n k * suc n) / suc k

{- Σ_{0≤k<n} (C n k) ≡ 2ⁿ -}

Σ𝟙F↔F : ∀ (F : 𝟙 → ★) → Σ 𝟙 F ↔ F _
Σ𝟙F↔F F = inverses proj₂ ,_ (λ _ → ≡.refl) (λ _ → ≡.refl)

Bits = Vec 𝟚
Bits1↔𝟚 : Bits 1 ↔ 𝟚
Bits1↔𝟚 = {!!}

open v0
foo : ∀ n → Σ (Fin (suc n)) (D (suc n) ∘ Fin▹ℕ) ↔ Bits (suc n)
foo zero = ((sym Bits1↔𝟚 ∘I {!!}) ∘I Σ𝟙F↔F _) ∘I first-iso Fin1↔⊤
foo (suc n) = {!!}

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


Implement STLC in AGDA (fix #13).

Implement STLC in AGDA (fix #13).

Old-commit-hash: 8c8d0d1e3a7f67f1a6640d7526542321b3a5a424

module incremental where

-- SIMPLE TYPES

-- Syntax

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

infixr 5 _⇒_

-- Semantics

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

-- TYPING CONTEXTS

-- Syntax

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

infixr 9 _•_

-- Semantics

data Empty : Set where
  ∅ : Empty

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

Env⟦_⟧ : Context → Set
Env⟦ ∅ ⟧ = Empty
Env⟦ τ • Γ ⟧ = Bind Dom⟦ τ ⟧ Env⟦ Γ ⟧

-- VARIABLES

-- Syntax

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

-- Semantics

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

-- TERMS

-- Syntax

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

-- Semantics

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

-- WEAKENING

-- Extend a context to a super context

infixr 10 _⋎_

_⋎_ : (Γ₁ Γ₁ : Context) → Context
∅ ⋎ Γ₂ = Γ₂
(τ • Γ₁) ⋎ Γ₂ = τ • Γ₁ ⋎ Γ₂

-- Lift a variable to a super context

lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
lift {∅} {∅} x = x
lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
lift {τ • Γ₁} {Γ₂} this = this
lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- Weaken a term to a super context

weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)

-- CHANGE TYPES

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

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app compose (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = τ • Δ-Type τ • Γ

-- CHANGING TERMS WHEN THE ENVIRONMENT CHANGES

Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)
Δ-term {Γ} (app t₁ t₂) = {!!}
Δ-term {Γ} (var x) = {!!}


+Universe.NP

+Universe.NP

module Universe.NP where

open import Type
open import Type.Identities
open import Function.NP
open import Level.NP
open import Data.Product.NP
open import Data.Nat using (ℕ)
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Fin
open import Data.Sum.NP
open import Relation.Binary.PropositionalEquality.NP
open import HoTT
open Equivalences

open import Universe public

module _ {u e} {U : ★_ u} (El : U → ★_ e) where
    universe : Universe u e
    universe = record { El = El }

U★_ : (ℓ : Level) → Universe (ₛ ℓ) ℓ
U★ ℓ = universe id

U★₀ = U★_ ₀
U★₁ = U★_ ₁
U★₂ = U★_ ₂

UFin U✓ : Universe ₀ ₀

UFin = record { El = Fin }
U✓ = record { El = ✓ }

U𝟘 : ∀ {e} → Universe ₀ e
U𝟘 = record { U = 𝟘; El = λ() }

-- Or Uconst
U𝟙 : ∀ {ℓ} → ★_ ℓ → Universe ₀ ℓ
U𝟙 A = record { U = 𝟙; El = λ _ → A }

open Universe.Universe renaming (U to Code)

record Map {u u'}(U : Universe u u')
           {v v'}(V : Universe v v') : ★_ (u ⊔ v ⊔ u' ⊔ v') where
    constructor mk
    field
      map-Code : Code U → Code V
      map-El   : ∀ {u} → El U u → El V (map-Code u)

    {- This one has contravariant mapping of El's -}
record CoMap {u u'}(U : Universe u u')
             {v v'}(V : Universe v v') : ★_ (u ⊔ v ⊔ u' ⊔ v') where
    constructor mk
    field
      map-Code : Code U → Code V
      comap-El : ∀ {u} → El V (map-Code u) → El U u

module _
  {e u v}(U : Universe u e)
         (V : Universe v e)
  where
    record _⊏_ : ★_ (u ⊔ v ⊔ ₛ e) where
      constructor mk
      field
        ⊏-Code : Code U → Code V
        ⊏-El   : ∀ A → El U A ≃ El V (⊏-Code A)

module _
  {e u v}{U : Universe u e}
         {V : Universe v e}
  where
  ⊏-Map : U ⊏ V → Map U V
  ⊏-Map (mk f e) = mk f (·→ (e _))

  ⊏-CoMap : U ⊏ V → CoMap U V
  ⊏-CoMap (mk f e) = mk f (·← (e _))

✓⊏Fin : U✓ ⊏ UFin
✓⊏Fin = mk 𝟚▹ℕ [0: ≃-! Fin0≃𝟘
                 1: ≃-! Fin1≃𝟙 ]

module _ {u e}(U : Universe u e) where
    private
      U★ = U★_ e

    ⊏-refl : U ⊏ U
    ⊏-refl = mk _ λ _ → ≃-refl

    𝟘⊏_ : U𝟘 ⊏ U
    𝟘⊏_ = mk (λ()) (λ())

    _⊏★ : U ⊏ U★
    _⊏★ = mk (El U) λ _ → ≃-refl

    -- derived...

    idMap : Map U U
    idMap = ⊏-Map ⊏-refl

    idCoMap : CoMap U U
    idCoMap = ⊏-CoMap ⊏-refl

    Map𝟘 : Map U𝟘 U
    Map𝟘 = ⊏-Map 𝟘⊏_

    CoMap𝟘 : CoMap U𝟘 U
    CoMap𝟘 = ⊏-CoMap 𝟘⊏_

    Map★ : Map U U★
    Map★ = ⊏-Map _⊏★

    CoMap★ : CoMap U U★
    CoMap★ = ⊏-CoMap _⊏★

module _ {a b}{F : ★_ a → ★_ b} where
    mapF : (∀ {A} → A → F A) → Map (U★ a) (U★ b)
    mapF = mk F

    coMapF : (∀ {A} → F A → A) → CoMap (U★ a) (U★ b)
    coMapF = mk F

module _ {a}{F : ★_ a → ★_ a} where
    ⊏F : (∀ A → A ≃ F A) → U★ a ⊏ U★ a
    ⊏F = mk F

module _ {e u v w}{U : Universe u e}
                  {V : Universe v e}
                  {W : Universe w e} where
  ⊏-trans : U ⊏ V → V ⊏ W → U ⊏ W
  ⊏-trans (mk _ UV) (mk _ VW) = mk _ λ _ → ≃-trans (UV _) (VW _)

  -- could be more lax on univ levels
  Map-∘ : Map U V → Map V W → Map U W
  Map-∘ (mk _ UV) (mk _ VW) = mk _ (VW ∘ UV)

  -- could be more lax on univ levels
  CoMap-∘ : CoMap U V → CoMap V W → CoMap U W
  CoMap-∘ (mk _ UV) (mk _ VW) = mk _ (UV ∘ VW)

module _ {e u v}(U : Universe u e)(V : Universe v e) where
  _⊎ᵁ_ : Universe (u ⊔ v) e
  _⊎ᵁ_ = record { El = [inl: El U ,inr: El V ] }

  _×ᵁ_ : Universe (u ⊔ v) e
  _×ᵁ_ = record { El = λ { (A , B) → El U A × El V B } }

module _ {e u v}(U : Universe u e)(V : Universe v e) where
  inlᵁ : U ⊏ (U ⊎ᵁ V)
  inlᵁ = mk inl λ _ → ≃-refl

  inrᵁ : V ⊏ (U ⊎ᵁ V)
  inrᵁ = mk inr λ _ → ≃-refl

  fstᵁ : Map (U ×ᵁ V) U
  fstᵁ = mk fst fst

  sndᵁ : Map (U ×ᵁ V) V
  sndᵁ = mk snd snd

module _
  {u e}(U : Universe u e)
  {p}(P : Code U → ★_ p)
  where
    Σᵁ : Universe (u ⊔ p) e
    Σᵁ = record { U = Σ (Code U) P; El = El U ∘ fst }

    Σᵁ-fst : CoMap Σᵁ U
    Σᵁ-fst = mk fst id

{-
module _
  {u e}(U : Universe u e)
  {b}(B : ★_ b)
  where
    Πᵁ' : Universe u (e ⊔ b)
    Πᵁ' = record { U = Code U ; El = λ A → B → El U A }

    todo' : B → CoMap U Πᵁ'
    todo' b = mk id (λ f → f b)

module _
  {u e}(U : Universe u e)
  (F : ★_ e → ★_ e)
  where
  bla : (∀ {A} → El U A → F (El U A)) → Map U (record { El = F ∘ El U })
  bla = mk id

module _
  {u e}(U : Universe u e)
  {p}(P : ∀ {A} → El U A → ★_ p)
  where
    Πᵁ : Universe u (e ⊔ p)
    Πᵁ = record { U = Code U ; El = λ A → Π (El U A) P }

    todo : Map Πᵁ U
    todo = mk id {!!}
-}

module _
  {u e}(U : Universe u e)
  {p}(P : ∀ {A} → El U A → ★_ p)
  where
    ΣEl : Code U → ★_ _
    ΣEl A = Σ (El U A) P

    ΣElᵁ : Universe u (e ⊔ p)
    ΣElᵁ = record { El = ΣEl }

    ΣEl-fst : CoMap U ΣElᵁ
    ΣEl-fst = mk id fst

-- TODO: Move elsewhere
Finite : ★₀ → ★₁
Finite A = Σ ℕ λ n → A ≡ Fin n

UFinite : Universe _ _
UFinite = Σᵁ U★₀ Finite

finite : CoMap UFinite U★₀
finite = Σᵁ-fst U★₀ Finite
-- -}
-- -}
-- -}
-- -}

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


module Text.Printer where

open import Data.String
open import Data.Nat
open import Data.Nat.Show
open import Data.Bool
open import Function
open import Relation.Nullary
open import Relation.Nullary.Decidable

ShowS : Set
ShowS = String → String

Pr : Set → Set
Pr A = A → ShowS

`_ : String → ShowS
(` s) tail = Data.String._++_ s tail

parenBase : ShowS → ShowS
parenBase doc = ` "(" ∘ doc ∘ ` ")"

record PrEnv : Set where
  constructor mk
  field
    level : ℕ

  withLevel : ℕ → PrEnv
  withLevel x = record { level = x }

open PrEnv

paren : (PrEnv → PrEnv) → PrEnv → ShowS → ShowS
paren f Δ = if ⌊ level (f Δ) ≤? level Δ ⌋ then id else parenBase

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


rewind-on-success.agda

rewind-on-success.agda

open import Type
open import Function
open import Data.Vec hiding (sum)
import Data.Fin as Fin
open Fin using (Fin; zero; suc)
open import Data.Nat.NP hiding (_≥_)
open import Data.Two hiding (_²; _==_)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Binary.PropositionalEquality.NP renaming (subst to tr)
open import HoTT

module rewind-on-success where

module _ {a} {A : ★_ a} where
    infixr 4 _♦_
    _♦_ : ∀ {n} → Vec A n → (ℕ → A) → (ℕ → A)
    ([]     ♦ f) i = f i
    (x ∷ xs ♦ f) zero    = x
    (x ∷ xs ♦ f) (suc i) = (xs ♦ f) i

    ♦-spec1 : ∀ {n} (xs : Vec A n) (f : ℕ → A) i → (xs ♦ f) (Fin.toℕ i) ≡ lookup i xs
    ♦-spec1 [] f ()
    ♦-spec1 (x ∷ xs) f zero    = refl
    ♦-spec1 (x ∷ xs) f (suc i) = ♦-spec1 xs f i

    ♦-spec2 : ∀ {n} (xs : Vec A n) (f : ℕ → A) i → (xs ♦ f) (n + i) ≡ f i
    ♦-spec2 []       f i = refl
    ♦-spec2 (x ∷ xs) f i = ♦-spec2 xs f i

    takeS : ∀ n (f : ℕ → A) → Vec A n
    takeS zero    f = []
    takeS (suc n) f = f 0 ∷ takeS n (f ∘ suc)

    lookup-takeS : ∀ {n} (f : ℕ → A) i → f (Fin.toℕ i) ≡ lookup i (takeS n f)
    lookup-takeS f zero    = refl
    lookup-takeS f (suc i) = lookup-takeS (f ∘ suc) i

module _
  (Symbol Output : ★)
  (success? : Output → 𝟚)

  (adversaryS : (r : ℕ → Symbol) → ℕ)
  (adversaryO : (r : ℕ → Symbol) → Output)
  where

  Transcript = Vec Symbol

  transcript : (r : ℕ → Symbol) → Transcript (adversaryS r)
  transcript r = takeS (adversaryS r) r

  adversary : (r : ℕ → Symbol) → ℕ × Output
  adversary r = adversaryS r , adversaryO r

  Adversary-spec = ∀ (r s : ℕ → Symbol) → adversary r ≡ adversary (transcript r ♦ s)

  _∧°_ : ∀ {Ω : ★} (f g : Ω → 𝟚) → Ω → 𝟚
  (f ∧° g) x = f x ∧ g x

  infix 2 _↔_
  _↔_ : (A B : ★) → ★
  A ↔ B = (A → B) × (B → A)

  record PartitionV1 (Ω : ★) : ★ where
    field
      B : ℕ → Ω → 𝟚
      B-∃ : ∀ w → ∃ λ i → ✓ (B i w)
      B-! : ∀ i j w → ✓ (B i w) → ✓ (B j w) → i ≡ j

  record Partition (Ω : ★) : ★₁ where
    field
      F      : ℕ → ★
      F-part : Ω ≡ Σ ℕ F

    v1 : PartitionV1 Ω
    v1 = record {B = B; B-∃ = B-∃; B-! = B-!} where
        g : Ω → ℕ
        g = fst ∘ coe F-part

        B : ℕ → Ω → 𝟚
        B i w = i == g w

        B-∃ : ∀ w → ∃ λ i → ✓ (B i w)
        B-∃ w = g w , ==.refl {g w}

        B-! : ∀ i j w → ✓ (B i w) → ✓ (B j w) → i ≡ j
        B-! i j w Biw Bjw = ==.sound i _ Biw ∙ ! ==.sound j _ Bjw

    open PartitionV1 v1 public

  module _ {A : ★}{B : ★}{C : A → B → ★} where
    pair='' : ∀ {x y : Σ A (Σ B ∘ C)}
                (p : fst x ≡ fst y)
                (q : fst (snd x) ≡ fst (snd y))
              → tr (λ x₁ → C x₁ (fst (snd y))) p (tr (C (fst x)) q (snd (snd x))) ≡ snd (snd y) → x ≡ y
    pair='' refl refl = ap (λ x → _ , _ , x)

  ✓-prop : (b : 𝟚)(x y : ✓ b) → x ≡ y
  ✓-prop 1₂ pf pf' = refl
  ✓-prop 0₂ () pf'

  module V1→ {Ω} (v1 : PartitionV1 Ω) {{_ : UA}} where
    open PartitionV1 v1
    open Equivalences
    part : Partition Ω
    part = record { F = F ; F-part = F-part }
      where
        F : ℕ → ★
        F i = Σ Ω λ w → ✓ (B i w)

        Ω→ : Ω → Σ ℕ F
        Ω→ w = fst (B-∃ w) , w , snd (B-∃ w)

        →Ω : Σ ℕ F → Ω
        →Ω (i , w , pf) = w

        Ω→Ω : ∀ w → →Ω (Ω→ w) ≡ w
        Ω→Ω w = refl

        →Ω→ : ∀ x → Ω→ (→Ω x) ≡ x
        →Ω→ (i , w , pf) = pair='' (B-! (fst (B-∃ w)) i w (snd (B-∃ w)) pf) refl (✓-prop (B i w) _ pf)

        F-part : Ω ≡ Σ ℕ F
        F-part = ua (equiv Ω→ →Ω →Ω→ Ω→Ω)

  record ProbTheory : ★₁ where
    field
      ℝ : ★
      0ᵣ 1ᵣ : ℝ
      _·_ _/_ : ℝ → ℝ → ℝ
    _² : ℝ → ℝ
    _² = λ x → x · x
    field
      _≥_ : ℝ → ℝ → ★
      Pr[_] : {Ω : ★}(f : Ω → 𝟚) → ℝ
      Pr≥0 : ∀ {Ω} (f : Ω → 𝟚) → Pr[ f ] ≥ 0ᵣ
      PrΩ≡1 : ∀ {Ω} → Pr[ (λ (_ : Ω) → 1₂) ] ≡ 1ᵣ
      Pr[_∥_] : {Ω : ★}(f g : Ω → 𝟚) → ℝ
      Pr[_∥_]-spec : ∀ {Ω} (f g : Ω → 𝟚) → Pr[ f ∥ g ] ≡ (Pr[ f ∧° g ] / Pr[ g ])
      sum : {A : ★} → (A → ℝ) → ℝ
      ttt : ∀ {Ω}(f : Ω → 𝟚)
                         (p : Partition Ω)
                       → Pr[ sum λ (n : ℕ) → Partition.B p n ] ≡ sum λ (n : ℕ) → Pr[ Partition.B p n ]
      law-total-prob : ∀ {Ω}(f : Ω → 𝟚)
                         (p : Partition Ω)
                       → Pr[ f ] ≡ sum λ (n : ℕ) → Pr[ Partition.B p n ] · Pr[ f ∥ Partition.B p n ]
      E[_] : {Ω : ★}(f : Ω → ℝ) → ℝ
    _²' : {Ω : ★}(f : Ω → ℝ) → Ω → ℝ
    _²' = λ f x → (f x)²
    field
      E² : ∀ {Ω} (X : Ω → ℝ) → E[ X ²' ] ≥ E[ X ] ²

  module _
    (adversary-spec : Adversary-spec)

    (process : ∀ {n}(t : Transcript n){n′}(t′ : Transcript n′) → {!!})
    where

    M : (r s : ℕ → Symbol) → {!!}
    M r s = case success? o
              0: {!!}
              1: process t t′
      where
        n = adversaryS r
        o = adversaryO r
        t = transcript r
        #h = {!!}
        h  = takeS #h r
        r′ = h ♦ s
        n′ = adversaryS r′
        o′ = adversaryO r′
        t′ = transcript r′

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

error: pathspec 'rewind-on-success.agda' did not match any file(s) known to git


Add a broken attempt at simplifying Nat.GCD: Nat.GCD.NP

module Data.Nat.GCD.NP where

open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Divisibility as Div
open import Relation.Binary
private module P = Poset Div.poset
open import Data.Product
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)
open import Induction
open import Induction.Nat
open import Induction.Lexicographic
open import Function
open import Data.Nat.GCD.Lemmas

------------------------------------------------------------------------
-- Greatest common divisor

module GCD where

  -- Specification of the greatest common divisor (gcd) of two natural
  -- numbers.

  record GCD (m n gcd : ℕ) : Set where
    constructor is
    field
      -- The gcd is a common divisor.
      commonDivisor : gcd ∣ m × gcd ∣ n

      -- All common divisors divide the gcd, i.e. the gcd is the
      -- greatest common divisor according to the partial order _∣_.
      greatest : ∀ {d} → d ∣ m × d ∣ n → d ∣ gcd

  open GCD public

  -- The gcd is unique.

  unique : ∀ {d₁ d₂ m n} → GCD m n d₁ → GCD m n d₂ → d₁ ≡ d₂
  unique d₁ d₂ = P.antisym (GCD.greatest d₂ (GCD.commonDivisor d₁))
                           (GCD.greatest d₁ (GCD.commonDivisor d₂))

  -- The gcd relation is "symmetric".

  sym : ∀ {d m n} → GCD m n d → GCD n m d
  sym g = is (swap $ GCD.commonDivisor g) (GCD.greatest g ∘ swap)

  -- The gcd relation is "reflexive".

  refl : ∀ {n} → GCD n n n
  refl = is (P.refl , P.refl) proj₁

  -- The GCD of 0 and n is n.

  base : ∀ {n} → GCD 0 n n
  base {n} = is (n ∣0 , P.refl) proj₂

  -- If d is the gcd of n and k, then it is also the gcd of n and
  -- n + k.

  step : ∀ {n k d} → GCD n k d → GCD n (n + k) d
  step g with GCD.commonDivisor g
  step {n} {k} {d} g | (d₁ , d₂) = is (d₁ , ∣-+ d₁ d₂) greatest′
    where
    greatest′ : ∀ {d′} → d′ ∣ n × d′ ∣ n + k → d′ ∣ d
    greatest′ (d₁ , d₂) = GCD.greatest g (d₁ , ∣-∸ d₂ d₁)

open GCD public using (GCD)

------------------------------------------------------------------------
-- Calculating the gcd

-- The calculation also proves Bézout's lemma.

module Bézout where

  module Identity where

    -- If m and n have greatest common divisor d, then one of the
    -- following two equations is satisfied, for some numbers x and y.
    -- The proof is "lemma" below (Bézout's lemma).
    --
    -- (If this identity was stated using integers instead of natural
    -- numbers, then it would not be necessary to have two equations.)

    data Identity (d m n : ℕ) : Set where
    --  +- : (x y : ℕ) (eq : d + y * n ≡ x * m) → Identity d m n
      -+ : (x y : ℕ) (eq : d + x * m ≡ y * n) → Identity d m n

    -- Various properties about Identity.

{-
    sym : ∀ {d} → Symmetric (Identity d)
    sym (+- x y eq) = -+ y x eq
    sym (-+ x y eq) = +- y x eq
    -}

    refl : ∀ {d} → Identity d d d
    refl = -+ 0 1 PropEq.refl

    base : ∀ {d} → Identity d 0 d
    base = -+ 0 1 PropEq.refl

    private
      infixl 7 _⊕_

      _⊕_ : ℕ → ℕ → ℕ
      m ⊕ n = 1 + m + n

    step : ∀ {d n k} → Identity d n k → Identity d n (n + k)
    {-
    step {d}     (+-  x  y       eq) with compare x y
    step {d}     (+- .x .x       eq) | equal x     = +- (2 * x)     x       (lem₂ d x   eq)
    step {d}     (+- .x .(x ⊕ i) eq) | less x i    = +- (2 * x ⊕ i) (x ⊕ i) (lem₃ d x   eq)
    step {d} {n} (+- .(y ⊕ i) .y eq) | greater y i = +- (2 * y ⊕ i) y       (lem₄ d y n eq)
    -}
    step {d}     (-+  x  y       eq) with compare x y
    step {d}     (-+ .x .x       eq) | equal x     = -+ (2 * x)     x       (lem₅ d x   eq)
    step {d}     (-+ .x .(x ⊕ i) eq) | less x i    = -+ (2 * x ⊕ i) (x ⊕ i) (lem₆ d x   eq)
    step {d} {n} (-+ .(y ⊕ i) .y eq) | greater y i = -+ (2 * y ⊕ i) y       (lem₇ d y n eq)

  open Identity public using (Identity) -- ; +-; -+)

  module Lemma where

    -- This type packs up the gcd, the proof that it is a gcd, and the
    -- proof that it satisfies Bézout's identity.

    data Lemma (m n : ℕ) : Set where
      result : (d : ℕ) (g : GCD m n d) (b : Identity d m n) → Lemma m n

    -- Various properties about Lemma.

    {-
    sym : Symmetric Lemma
    sym (result d g b) = result d (GCD.sym g) (Identity.sym b)
    -}

    base : ∀ d → Lemma 0 d
    base d = result d GCD.base Identity.base

    refl : ∀ d → Lemma d d
    refl d = result d GCD.refl Identity.refl

    stepˡ : ∀ {n k} → Lemma n (suc k) → Lemma n (suc (n + k))
    stepˡ {n} {k} (result d g b) =
      PropEq.subst (Lemma n) (lem₀ n k) $
        result d (GCD.step g) (Identity.step b)

    {-
    stepʳ : ∀ {n k} → Lemma (suc k) n → Lemma (suc (n + k)) n
    stepʳ = sym ∘ stepˡ ∘ sym
    -}

  open Lemma public using (Lemma; result)

  -- Bézout's lemma proved using some variant of the extended
  -- Euclidean algorithm.

  lemma : (m n : ℕ) → Lemma m n
  lemma zero n = Lemma.base n
  lemma m zero = {!Lemma.sym (Lemma.base m)!}
  lemma (suc m) (suc n) = build [ <-rec-builder ⊗ <-rec-builder ] P gcd (m , n)
    where
    P : ℕ × ℕ → Set
    P (m , n) = Lemma (suc m) (suc n)

    gcd : ∀ p → (<-Rec ⊗ <-Rec) P p → P p
    gcd (m , n           ) rec with compare m n
    gcd (m , .m          ) rec | equal .m     = Lemma.refl (suc m)
    gcd (m , .(suc m + k)) rec | less .m k    =
                      -- "gcd m k"
                      -- k < n
                      -- m < n
                      -- n = suc m + k
                      -- dist m n = suc k

                      -- m + k < m + suc m + k
                      --    k < suc m + k
                      --    0 < suc m
      Lemma.stepˡ $ proj₁ rec k (≤⇒≤′ (s≤s (≤-steps {k} {k} m (≤′⇒≤ ≤′-refl))))
    gcd (.(suc n + k) , n) rec | greater .n k =
                      -- "gcd k n"
                      -- m > n
                      -- m ≡ suc n + k
                      -- dist m n = suc k

                      -- k + n < suc n + k + n
                      --    k < suc n + k
                      --    0 < suc n
                      -- gcd n k
      {!Lemma.stepʳ $ proj₂ rec k (≤⇒≤′ (s≤s (≤-steps {k} {k} n (≤′⇒≤ ≤′-refl)))) n!}

  -- Bézout's identity can be recovered from the GCD.

  identity : ∀ {m n d} → GCD m n d → Identity d m n
  identity {m} {n} g with lemma m n
  identity g | result d g′ b with GCD.unique g g′
  identity g | result d g′ b | PropEq.refl = b

-- Calculates the gcd of the arguments.

gcd : (m n : ℕ) → ∃ λ d → GCD m n d
gcd m n with Bézout.lemma m n
gcd m n | Bézout.result d g _ = (d , g)
-- -}
-- -}
-- -}
-- -}
-- -}

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


Add alternative defintion for IND CPA

Add alternative defintion for IND CPA

{-# OPTIONS --without-K #-}
open import Type
open import Data.Product
open import Data.Bit

module Game.IND-CPA-alt
  (PubKey     : ★)
  (SecKey     : ★)
  (Message    : ★)
  (CipherText : ★)

  -- randomness supply for: encryption, key-generation, adversary, extensions
  (Rₑ Rₖ Rₐ : ★)

  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)

where

M² = Bit → Message

-- IND-CPA adversary in two parts
Adv : ★
Adv = Rₐ → PubKey → (M² × (CipherText → Bit))

-- IND-CPA randomness supply
R : ★
R = (Rₐ × Rₖ × Rₑ)

-- IND-CPA games:
--   * input: adversary and randomness supply
--   * output b: adversary claims we are in game ⅁ b
Game : ★
Game = Adv → R → Bit

-- The game step by step:
-- (pk) key-generation, only the public-key is needed
-- (mb) send randomness, public-key and bit
--      receive which message to encrypt
-- (c)  encrypt the message
-- (b′) send randomness, public-key and ciphertext
--      receive the guess from the adversary
⅁ : Bit → Game
⅁ b m (rₐ , rₖ , rₑ) = b′
  where
  pk = proj₁ (KeyGen rₖ)
  ad = m rₐ pk
  mb = proj₁ ad b
  c  = Enc pk mb rₑ
  b′ = proj₂ ad c

⅁₀ ⅁₁ : Game
⅁₀ = ⅁ 0b
⅁₁ = ⅁ 1b

error: pathspec 'Game/IND-CPA-alt.agda' did not match any file(s) known to git


Added draft about the accesibility relation.

Ignore-this: 4464636b2ef8f930696708c29bdaf37a

darcs-hash:20110221161001-3bd4e-55f9c66f8e4147045286838c732c521ac519dd40.gz

----------------------------------------------------------------------------
-- Well-founded induction on LT using the accesibility relation
----------------------------------------------------------------------------

module Draft.Accesibility.WellFoundedInduction where

open import FOTC.Base

open import Common.Function

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

----------------------------------------------------------------------------
-- Accesibility stuff for the FOTC natural numbers

-- Adapted from
-- http://www.iis.sinica.edu.tw/~scm/2008/well-founded-recursion-and-accessibility/

data AccN (_<_ : D → D → Set) : D → Set where
 accN : ∀ {x} → N x → (∀ {y} → N y → y < x → AccN _<_ y) → AccN _<_ x

acc-elimN : (_<_ : D → D → Set) {P : D → Set} →
            (∀ {x} → N x → (∀ {y} → N y → y < x → AccN _<_ y) →
                 (∀ {y} → N y → y < x → P y) → P x) →
            ∀ {x} → N x → AccN _<_ x → P x
acc-elimN _<_ Φ Nx (accN _ h) = Φ Nx h (λ Ny y<x → acc-elimN _<_ Φ Ny (h Ny y<x))

acc-foldN : (R : D → D → Set) {P : D → Set} →
            (∀ {x} → N x → (∀ {y} → N y → R y x → P y) → P x) →
            ∀ {x} → N x → AccN R x → P x
acc-foldN R f Nx (accN _ h) = f Nx (λ Ny yRx → acc-foldN R f Ny (h Ny yRx))

well-foundN : (D → D → Set) → Set
well-foundN _<_ = ∀ {x} → N x → AccN _<_ x

rec-wfN : {_<_ : D → D → Set} {P : D → Set} →
          well-foundN _<_ →
          (∀ {x} → N x → (∀ {y} → N y → y < x → P y) → P x) →
          ∀ {x} → N x → P x
rec-wfN {_<_} wf f Nx = acc-foldN _<_ f Nx (wf Nx)

-- The LT relation is well-founded.
LT-wf : well-foundN LT
LT-wf Nn = accN Nn (helper Nn)

  where
    helper : ∀ {m n} → N m → N n → LT n m → AccN LT n
    helper zN     Nn n<0  = ⊥-elim $ x<0→⊥ Nn n<0
    helper (sN _) zN 0<Sm = accN zN (λ Nn' n'<0 → ⊥-elim $ x<0→⊥ Nn' n'<0)

    helper (sN {m} Nm) (sN {n} Nn) Sn<Sm = accN (sN Nn)
      (λ {n'} Nn' n'<Sn →
        let n<m : LT n m
            n<m = Sx<Sy→x<y Sn<Sm

            n'<m : LT n' m
            n'<m = [ (λ n'<n → <-trans Nn' Nn Nm n'<n n<m)
                   , (λ n'≡n → x≡y→y<z→x<z n'≡n n<m)
                   ] (x<Sy→x<y∨x≡y Nn' Nn n'<Sn)

        in  helper Nm Nn' n'<m
      )

wfInd-LT : (P : D → Set) →
           (∀ {m} → N m → (∀ {n} → N n → LT n m → P n) → P m) →
           ∀ {n} → N n → P n
wfInd-LT P = rec-wfN LT-wf

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


Added Empty version for LF.

Added Empty version for LF.

Ignore-this: 2cc68c08e10e526379c3ec6c4c331c06

darcs-hash:20111215163330-3bd4e-c65169a77e39acb5940ec3e70168e6c39f2cfc0a.gz

-- Tested with Agda 2.3.1 on 15 December 2011.

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

module Empty where

postulate
  ⊥      : Set
  ⊥-elim : {A : Set} → ⊥ → A

error: pathspec 'notes/thesis/logical-framework/Empty.agda' did not match any file(s) known to git


alternative to BCD subtyping

alternative to BCD subtyping

open import Data.Nat using (ℕ; suc ; zero; _+_; _≤′_; _<′_; _<_; _≤_;
    z≤n; s≤s; ≤′-refl; ≤′-step; _≟_) renaming (_⊔_ to max)
open import Data.Nat.Properties
  using (n≤0⇒n≡0; ≤-refl; ≤-trans; m≤m⊔n; n≤m⊔n; ≤-step; ⊔-mono-≤;
         +-mono-≤; +-mono-≤-<; +-mono-<-≤; +-comm; +-assoc; n≤1+n;
         ≤-pred; m≤m+n; n≤m+n; ≤-reflexive; ≤′⇒≤; ≤⇒≤′; +-suc)
open Data.Nat.Properties.≤-Reasoning using (begin_; _≤⟨_⟩_; _∎)
open import Data.Bool  using (Bool) renaming (_≟_ to _=?_)
open import Data.Product using (_×_; Σ; Σ-syntax; ∃; ∃-syntax; proj₁; proj₂)
  renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Empty using (⊥-elim) renaming (⊥ to Bot)
open import Data.Unit using (⊤; tt)
open import Data.Maybe
open import Data.List using (List ; _∷_ ; []; _++_)
open import Relation.Nullary using (¬_)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong)
open Relation.Binary.PropositionalEquality.≡-Reasoning renaming (begin_ to start_; _∎ to _□)

module extra.Value where

data Base : Set where
  Nat : Base
  𝔹 : Base

data Prim : Set where
  base : Base → Prim
  _⇒_ : Base → Prim → Prim

base-rep : Base → Set
base-rep Nat = ℕ
base-rep 𝔹 = Bool

rep : Prim → Set
rep (base b) = base-rep b
rep (b ⇒ p) = base-rep b → rep p

base-eq? : (B : Base) → (B' : Base) → Dec (B ≡ B')
base-eq? Nat Nat = yes refl
base-eq? Nat 𝔹 = no (λ ())
base-eq? 𝔹 Nat = no (λ ())
base-eq? 𝔹 𝔹 = yes refl

base-rep-eq? : ∀{B} → (k : base-rep B) (k′ : base-rep B) → Dec (k ≡ k′)
base-rep-eq? {Nat} k k′ = k ≟ k′
base-rep-eq? {𝔹} k k′ = k =? k′

infixr 7 _↦_
infixl 6 _⊔_

data Value : Set

data Value where
  ⊥ : Value
  const : {b : Base} → base-rep b → Value
  _↦_ : Value → Value → Value
  _⊔_ : (u : Value) → (v : Value) → Value

infix 5 _∈_

_∈_ : Value → Value → Set
u ∈ ⊥ = u ≡ ⊥
u ∈ const {B} k = u ≡ const {B} k
u ∈ v ↦ w = u ≡ v ↦ w
u ∈ (v ⊔ w) = u ∈ v ⊎ u ∈ w

infix 5 _⊆_

_⊆_ : Value → Value → Set
v ⊆ w = ∀{u} → u ∈ v → u ∈ w

AllFun : (u : Value) → Set
AllFun ⊥ = Bot
AllFun (const x) = Bot
AllFun (v ↦ w) = ⊤
AllFun (u ⊔ v) = AllFun u × AllFun v

dom : (u : Value) → Value
dom ⊥ = ⊥
dom (const k) = ⊥
dom (v ↦ w) = v
dom (u ⊔ v) = dom u ⊔ dom v

cod : (u : Value) → Value
cod ⊥  = ⊥
cod (const k) = ⊥
cod (v ↦ w) = w
cod (u ⊔ v) = cod u ⊔ cod v

infix 4 _⊑_

data _⊑_ : Value → Value → Set where

  ⊑-⊥ : ∀ {v} → ⊥ ⊑ v

  ⊑-const : ∀ {B}{k} → const {B} k ⊑ const {B} k

  ⊑-conj-L : ∀ {u v w}
        → v ⊑ u
        → w ⊑ u
          -----------
        → v ⊔ w ⊑ u

  ⊑-conj-R1 : ∀ {u v w}
       → u ⊑ v
         ------------------
       → u ⊑ v ⊔ w

  ⊑-conj-R2 : ∀ {u v w}
       → u ⊑ w
         -----------
       → u ⊑ v ⊔ w

  ⊑-fun : ∀ {u u′ v w}
       → u′ ⊆ u
       → AllFun u′
       → dom u′ ⊑ v
       → w ⊑ cod u′
         -------------------
       → v ↦ w ⊑ u

⊑-refl : ∀{v} → v ⊑ v
⊑-refl {⊥} = ⊑-⊥
⊑-refl {const k} = ⊑-const
⊑-refl {v ↦ w} = ⊑-fun{v ↦ w}{v ↦ w} (λ {u} z → z) tt (⊑-refl{v}) ⊑-refl
⊑-refl {v₁ ⊔ v₂} = ⊑-conj-L (⊑-conj-R1 ⊑-refl) (⊑-conj-R2 ⊑-refl)

factor : (u : Value) → (u′ : Value) → (v : Value) → (w : Value) → Set
factor u u′ v w = AllFun u′ × u′ ⊆ u × dom u′ ⊑ v × w ⊑ cod u′

⊑-fun-inv : ∀{u₁ u₂ v w}
      → u₁ ⊑ u₂
      → v ↦ w ∈ u₁
      → Σ[ u₃ ∈ Value ] factor u₂ u₃ v w
⊑-fun-inv {.⊥} {u₂} {v} {w} ⊑-⊥ ()
⊑-fun-inv {.(const _)} {.(const _)} {v} {w} ⊑-const ()
⊑-fun-inv {u11 ⊔ u12} {u₂} {v} {w} (⊑-conj-L u₁⊑u₂ u₁⊑u₃) (inj₁ x) =
    ⊑-fun-inv u₁⊑u₂ x
⊑-fun-inv {u11 ⊔ u12} {u₂} {v} {w} (⊑-conj-L u₁⊑u₂ u₁⊑u₃) (inj₂ y) =
    ⊑-fun-inv u₁⊑u₃ y
⊑-fun-inv {u₁} {u21 ⊔ u22} {v} {w} (⊑-conj-R1 u₁⊑u₂) v↦w∈u₁
    with ⊑-fun-inv {u₁} {u21} {v} {w} u₁⊑u₂ v↦w∈u₁
... | ⟨ u₃ , ⟨ afu₃ , ⟨ u3⊆u₁ , ⟨ du₃⊑v , w⊑codu₃ ⟩ ⟩ ⟩ ⟩ =
    ⟨ u₃ , ⟨ afu₃ , ⟨ (λ {x} x₁ → inj₁ (u3⊆u₁ x₁)) , ⟨ du₃⊑v , w⊑codu₃ ⟩ ⟩ ⟩ ⟩
⊑-fun-inv {u₁} {u21 ⊔ u22} {v} {w} (⊑-conj-R2 u₁⊑u₂) v↦w∈u₁
    with ⊑-fun-inv {u₁} {u22} {v} {w} u₁⊑u₂ v↦w∈u₁
... | ⟨ u₃ , ⟨ afu₃ , ⟨ u3⊆u₁ , ⟨ du₃⊑v , w⊑codu₃ ⟩ ⟩ ⟩ ⟩ =
    ⟨ u₃ , ⟨ afu₃ , ⟨ (λ {x} x₁ → inj₂ (u3⊆u₁ x₁)) , ⟨ du₃⊑v , w⊑codu₃ ⟩ ⟩ ⟩ ⟩
⊑-fun-inv {u11 ↦ u21} {u₂} {v} {w} (⊑-fun{u′ = u′} u′⊆u₂ afu′ du′⊑u11 u21⊑cu′)
    refl =
      ⟨ u′ , ⟨ afu′ , ⟨ u′⊆u₂ , ⟨ du′⊑u11 , u21⊑cu′ ⟩ ⟩ ⟩ ⟩

sub-inv-trans : ∀{u′ u₂ u : Value}
    → AllFun u′  →  u′ ⊆ u
    → (∀{v′ w′} → v′ ↦ w′ ∈ u′ → Σ[ u₃ ∈ Value ] factor u₂ u₃ v′ w′)
      ---------------------------------------------------------------
    → Σ[ u₃ ∈ Value ] factor u₂ u₃ (dom u′) (cod u′)
sub-inv-trans {⊥} {u₂} {u} () u′⊆u IH
sub-inv-trans {const k} {u₂} {u} () u′⊆u IH
sub-inv-trans {u₁′ ↦ u₂′} {u₂} {u} fu′ u′⊆u IH = IH refl
sub-inv-trans {u₁′ ⊔ u₂′} {u₂} {u} ⟨ afu₁′ , afu₂′ ⟩ u′⊆u IH
    with sub-inv-trans {u₁′} {u₂} {u} afu₁′
               (λ {u₁} z → u′⊆u (inj₁ z)) (λ {v′} {w′} z → IH (inj₁ z))
    | sub-inv-trans {u₂′} {u₂} {u} afu₂′
               (λ {u₁} z → u′⊆u (inj₂ z)) (λ {v′} {w′} z → IH (inj₂ z))
... | ⟨ u₃ , ⟨ afu₃ , ⟨ u₃⊆ , ⟨ du₃⊑ , ⊑cu₃ ⟩ ⟩ ⟩ ⟩
    | ⟨ u₄ , ⟨ afu₄ , ⟨ u₄⊆ , ⟨ du₄⊑ , ⊑cu₄ ⟩ ⟩ ⟩ ⟩ =

      ⟨ (u₃ ⊔ u₄) , ⟨ ⟨ afu₃ , afu₄ ⟩ , ⟨ G , ⟨ H , I ⟩ ⟩ ⟩ ⟩
    where
    G : ∀ {u₁} → u₁ ∈ u₃ ⊎ u₁ ∈ u₄ → u₁ ∈ u₂
    G {u₁} (inj₁ x) = u₃⊆ x
    G {u₁} (inj₂ y) = u₄⊆ y

    H : dom u₃ ⊔ dom u₄ ⊑ dom u₁′ ⊔ dom u₂′
    H = ⊑-conj-L (⊑-conj-R1 du₃⊑) (⊑-conj-R2 du₄⊑)

    I : cod u₁′ ⊔ cod u₂′ ⊑ cod u₃ ⊔ cod u₄
    I = ⊑-conj-L (⊑-conj-R1 ⊑cu₃) (⊑-conj-R2 ⊑cu₄)

⊔⊑R : ∀{B C A}
    → B ⊔ C ⊑ A
    → B ⊑ A
⊔⊑R (⊑-conj-L B⊔C⊑A B⊔C⊑A₁) = B⊔C⊑A
⊔⊑R (⊑-conj-R1 B⊔C⊑A) = ⊑-conj-R1 (⊔⊑R B⊔C⊑A)
⊔⊑R (⊑-conj-R2 B⊔C⊑A) = ⊑-conj-R2 (⊔⊑R B⊔C⊑A)

⊔⊑L : ∀{B C A}
    → B ⊔ C ⊑ A
    → C ⊑ A
⊔⊑L (⊑-conj-L B⊔C⊑A B⊔C⊑A₁) = B⊔C⊑A₁
⊔⊑L (⊑-conj-R1 B⊔C⊑A) = ⊑-conj-R1 (⊔⊑L B⊔C⊑A)
⊔⊑L (⊑-conj-R2 B⊔C⊑A) = ⊑-conj-R2 (⊔⊑L B⊔C⊑A)

u∈v⊑w→u⊑w : ∀{B A C} → C ∈ B → B ⊑ A → C ⊑ A
u∈v⊑w→u⊑w {⊥} C∈B B⊑A  rewrite C∈B = B⊑A
u∈v⊑w→u⊑w {const k} C∈B B⊑A rewrite C∈B = B⊑A
u∈v⊑w→u⊑w {B₁ ↦ B₂} C∈B B⊑A rewrite C∈B = B⊑A
u∈v⊑w→u⊑w {B₁ ⊔ B₂}{A}{C} (inj₁ C∈B₁) B⊑A = u∈v⊑w→u⊑w {B₁}{A}{C} C∈B₁ (⊔⊑R B⊑A)
u∈v⊑w→u⊑w {B₁ ⊔ B₂}{A}{C} (inj₂ C∈B₂) B⊑A = u∈v⊑w→u⊑w {B₂}{A}{C} C∈B₂ (⊔⊑L B⊑A)

u⊆v⊑w→u⊑w : ∀{u v w} → u ⊆ v → v ⊑ w → u ⊑ w
u⊆v⊑w→u⊑w {⊥} {v} {w} u⊆v v⊑w = ⊑-⊥
u⊆v⊑w→u⊑w {const k} {v} {w} u⊆v v⊑w
    with u⊆v refl
... | k∈v = u∈v⊑w→u⊑w k∈v v⊑w
u⊆v⊑w→u⊑w {u₁ ↦ u₂} {v} {w} u⊆v v⊑w
    with u⊆v refl
... | u₁↦u₂∈v = u∈v⊑w→u⊑w u₁↦u₂∈v v⊑w
u⊆v⊑w→u⊑w {u₁ ⊔ u₂} {v} {w} u⊆v v⊑w =
    ⊑-conj-L (u⊆v⊑w→u⊑w u₁⊆v v⊑w) (u⊆v⊑w→u⊑w u₂⊆v v⊑w)
    where
    u₁⊆v : u₁ ⊆ v
    u₁⊆v {u′} u′∈u₁ = u⊆v (inj₁ u′∈u₁)
    u₂⊆v : u₂ ⊆ v
    u₂⊆v {u′} u′∈u₂ = u⊆v (inj₂ u′∈u₂)

depth : (v : Value) → ℕ
depth ⊥ = zero
depth (const k) = zero
depth (v ↦ w) = suc (max (depth v) (depth w))
depth (v₁ ⊔ v₂) = max (depth v₁) (depth v₂)

size : (v : Value) → ℕ
size ⊥ = zero
size (const k) = zero
size (v ↦ w) = suc (size v + size w)
size (v₁ ⊔ v₂) = suc (size v₁ + size v₂)

∈→depth≤ : ∀{v u : Value} → u ∈ v → depth u ≤ depth v
∈→depth≤ {⊥} {u} u∈v rewrite u∈v = _≤_.z≤n
∈→depth≤ {const x} {u} u∈v rewrite u∈v = _≤_.z≤n
∈→depth≤ {v ↦ w} {u} u∈v rewrite u∈v = ≤-refl
∈→depth≤ {v₁ ⊔ v₂} {u} (inj₁ x) =
    ≤-trans (∈→depth≤ {v₁} {u} x) (m≤m⊔n (depth v₁) (depth v₂))
∈→depth≤ {v₁ ⊔ v₂} {u} (inj₂ y) =
    ≤-trans (∈→depth≤ {v₂} {u} y) (n≤m⊔n (depth v₁) (depth v₂))

max-lub : ∀{x y z : ℕ} → x ≤ z → y ≤ z → max x y ≤ z
max-lub {.0} {y} {z} _≤_.z≤n y≤z = y≤z
max-lub {suc x} {.0} {suc z} (_≤_.s≤s x≤z) _≤_.z≤n = _≤_.s≤s x≤z
max-lub {suc x} {suc y} {suc z} (_≤_.s≤s x≤z) (_≤_.s≤s y≤z) =
  let max-xy≤z = max-lub {x}{y}{z} x≤z y≤z in
  _≤_.s≤s max-xy≤z

⊔⊆-inv : ∀{u v w : Value}
       → (u ⊔ v) ⊆ w
         ---------------
       → u ⊆ w  ×  v ⊆ w
⊔⊆-inv uvw = ⟨ (λ x → uvw (inj₁ x)) , (λ x → uvw (inj₂ x)) ⟩

⊆→depth≤ : ∀{u v : Value} → u ⊆ v → depth u ≤ depth v
⊆→depth≤ {⊥} {v} u⊆v = _≤_.z≤n
⊆→depth≤ {const x} {v} u⊆v = _≤_.z≤n
⊆→depth≤ {u₁ ↦ u₂} {v} u⊆v = ∈→depth≤ (u⊆v refl)
⊆→depth≤ {u₁ ⊔ u₂} {v} u⊆v
    with ⊔⊆-inv u⊆v
... | ⟨ u₁⊆v , u₂⊆v ⟩ =
    let u₁≤v = ⊆→depth≤ u₁⊆v in
    let u₂≤v = ⊆→depth≤ u₂⊆v in
    max-lub u₁≤v u₂≤v

dom-depth-≤ : ∀{u : Value} → depth (dom u) ≤ depth u
dom-depth-≤ {⊥} = _≤_.z≤n
dom-depth-≤ {const k} = _≤_.z≤n
dom-depth-≤ {v ↦ w} = ≤-step (m≤m⊔n (depth v) (depth w))
dom-depth-≤ {u ⊔ v} =
  let ih1 = dom-depth-≤ {u} in
  let ih2 = dom-depth-≤ {v} in
  ⊔-mono-≤ ih1 ih2

cod-depth-≤ : ∀{u : Value} → depth (cod u) ≤ depth u
cod-depth-≤ {⊥} = _≤_.z≤n
cod-depth-≤ {const k} = _≤_.z≤n
cod-depth-≤ {v ↦ w} = ≤-step (n≤m⊔n (depth v) (depth w))
cod-depth-≤ {u ⊔ v} =
  let ih1 = cod-depth-≤ {u} in
  let ih2 = cod-depth-≤ {v} in
  ⊔-mono-≤ ih1 ih2

≤′-trans : ∀{x y z} → x ≤′ y → y ≤′ z → x ≤′ z
≤′-trans x≤′y y≤′z = ≤⇒≤′ (≤-trans (≤′⇒≤ x≤′y) (≤′⇒≤ y≤′z))

data _<<_ : ℕ × ℕ → ℕ × ℕ → Set where
  fst : ∀{x x' y y'} → x <′ x' → ⟨ x , y ⟩ << ⟨ x' , y' ⟩
  snd : ∀{x x' y y'} → x ≤′ x' → y <′ y' → ⟨ x , y ⟩ << ⟨ x' , y' ⟩

<<-nat-wf : (P : ℕ → ℕ → Set) →
         (∀ x y → (∀ {x' y'} → ⟨ x' , y' ⟩ << ⟨ x , y ⟩ → P x' y') → P x y) →
         ∀ x y → P x y
<<-nat-wf P ih x y = ih x y (help x y)
  where help : (x y : ℕ) → ∀{ x' y'} → ⟨ x' , y' ⟩ << ⟨ x , y ⟩ → P x' y'
        help .(suc x') y {x'}{y'} (fst ≤′-refl) =
            ih x' y' (help x' y')
        help .(suc x) y {x'}{y'} (fst (≤′-step {x} q)) =
            help x y {x'}{y'} (fst q)
        help x .(suc y) {x'}{y} (snd x'≤x ≤′-refl) =
            let h : ∀ {x₁} {x₂} → (⟨ x₁ , x₂ ⟩ << ⟨ x , y ⟩) → P x₁ x₂
                h = help x y in
            ih x' y G
            where
            G : ∀ {x'' y'} → ⟨ x'' , y' ⟩ << ⟨ x' , y ⟩ → P x'' y'
            G {x''} {y'} (fst x''<x') =
               help x y (fst {y = y'}{y' = y} (≤′-trans x''<x' x'≤x))
            G {x''} {y'} (snd x''≤x' y'<y) =
               help x y {x''}{y'} (snd (≤′-trans x''≤x' x'≤x) y'<y)
        help x .(suc y) {x'}{y'} (snd x′≤x (≤′-step {y} q)) =
            help x y {x'}{y'} (snd x′≤x q)

⊑-trans-P : ℕ → ℕ → Set
⊑-trans-P d s = ∀{u v w} → d ≡ depth u + depth w → s ≡ size u + size v
                         → u ⊑ v → v ⊑ w → u ⊑ w

⊑-trans-rec : ∀ d s → ⊑-trans-P d s
⊑-trans-rec = <<-nat-wf ⊑-trans-P helper
  where
  helper : ∀ x y
         → (∀ {x' y'} → ⟨ x' , y' ⟩ << ⟨ x , y ⟩ → ⊑-trans-P x' y')
         → ⊑-trans-P x y
  helper d s IH {.⊥} {v} {w} d≡ s≡ ⊑-⊥ v⊑w = ⊑-⊥
  helper d s IH {.(const _)} {.(const _)} {w} d≡ s≡ ⊑-const v⊑w = v⊑w
  helper d s IH {u₁ ⊔ u₂} {v} {w} d≡ s≡ (⊑-conj-L u₁⊑v u₂⊑v) v⊑w
      rewrite d≡ | s≡ =
      let u₁⊑w = IH M1 {u₁}{v}{w} refl refl u₁⊑v v⊑w in
      let u₂⊑w = IH M2 {u₂}{v}{w} refl refl u₂⊑v v⊑w in
      ⊑-conj-L u₁⊑w u₂⊑w
      where
      M1a = begin
               depth u₁ + depth w
             ≤⟨ +-mono-≤ (m≤m⊔n (depth u₁) (depth u₂)) ≤-refl ⟩
               max (depth u₁) (depth u₂) + depth w
            ∎
      M1b = begin
               suc (size u₁ + size v)
            ≤⟨ s≤s (+-mono-≤ ≤-refl (n≤m+n (size u₂) (size v))) ⟩
               suc (size u₁ + (size u₂ + size v))
            ≤⟨ s≤s (≤-reflexive (sym (+-assoc (size u₁) (size u₂) (size v)))) ⟩
               suc (size u₁ + size u₂ + size v)
            ∎
      M1 : ⟨ depth u₁ + depth w , size u₁ + size v ⟩ <<
           ⟨ max (depth u₁) (depth u₂) + depth w ,
             suc (size u₁ + size u₂ + size v) ⟩
      M1 = snd (≤⇒≤′ M1a) (≤⇒≤′ M1b)
      M2a = begin
               depth u₂ + depth w
             ≤⟨ +-mono-≤ (n≤m⊔n (depth u₁) (depth u₂)) ≤-refl ⟩
               max (depth u₁) (depth u₂) + depth w
            ∎
      M2b = begin
               suc (size u₂ + size v)
            ≤⟨ s≤s (+-mono-≤ (n≤m+n (size u₁) (size u₂)) ≤-refl) ⟩
               suc ((size u₁ + size u₂) + size v)
            ∎
      M2 : ⟨ depth u₂ + depth w , size u₂ + size v ⟩ <<
           ⟨ max (depth u₁) (depth u₂) + depth w ,
             suc (size u₁ + size u₂ + size v) ⟩
      M2 = snd (≤⇒≤′ M2a) (≤⇒≤′ M2b)
  helper d s IH {u} {v₁ ⊔ v₂} {w} d≡ s≡ (⊑-conj-R1 u⊑v₁) v₁⊔v₂⊑w
      rewrite d≡ | s≡ =
      let v₁⊑w = ⊔⊑R v₁⊔v₂⊑w in
      IH M {u}{v₁}{w} refl refl u⊑v₁ v₁⊑w
      where
      Ma = begin
              suc (size u + size v₁)
           ≤⟨ ≤-reflexive (sym (+-suc (size u) (size v₁))) ⟩
              size u + suc (size v₁)
           ≤⟨ +-mono-≤ ≤-refl (s≤s (m≤m+n (size v₁) (size v₂))) ⟩
              size u + suc (size v₁ + size v₂)
           ∎
      M : ⟨ depth u + depth w , size u + size v₁ ⟩ <<
          ⟨ depth u + depth w , size u + suc (size v₁ + size v₂) ⟩
      M = snd (≤⇒≤′ ≤-refl) (≤⇒≤′ Ma)
  helper d s IH {u} {v₁ ⊔ v₂} {w} d≡ s≡ (⊑-conj-R2 u⊑v₂) v₁⊔v₂⊑w
      rewrite d≡ | s≡ =
      let v₂⊑w = ⊔⊑L v₁⊔v₂⊑w in
      IH M {u}{v₂}{w} refl refl u⊑v₂ v₂⊑w
      where
      Ma = begin
              suc (size u + size v₂)
           ≤⟨ ≤-reflexive (sym (+-suc (size u) (size v₂))) ⟩
              size u + suc (size v₂)
           ≤⟨ +-mono-≤ ≤-refl (s≤s (n≤m+n (size v₁) (size v₂))) ⟩
              size u + suc (size v₁ + size v₂)
           ∎
      M : ⟨ depth u + depth w , size u + size v₂ ⟩ <<
          ⟨ depth u + depth w , size u + suc (size v₁ + size v₂) ⟩
      M = snd (≤⇒≤′ ≤-refl) (≤⇒≤′ Ma)
  helper d s IH {u₁ ↦ u₂}{v}{w}d≡ s≡ (⊑-fun{u′ = v′}v′⊆v afv′ dv′⊑u₁ u₂⊑cv′) v⊑w
      rewrite d≡ | s≡
      with sub-inv-trans afv′ v′⊆v
                (λ {v₁}{v₂} v₁↦v₂∈v′ → ⊑-fun-inv {v′} {w} (u⊆v⊑w→u⊑w v′⊆v v⊑w)
                                         v₁↦v₂∈v′)
  ... | ⟨ w′ , ⟨ afw′ , ⟨ w′⊆w , ⟨ dw′⊑dv′ , cv′⊑cw′ ⟩ ⟩ ⟩ ⟩ =
        let dw′⊑u₁ = IH M1 {dom w′}{dom v′}{u₁} refl refl dw′⊑dv′ dv′⊑u₁ in
        let u₂⊑cw′ = IH M2 {u₂}{cod v′}{cod w′} refl refl u₂⊑cv′ cv′⊑cw′ in
        ⊑-fun{u′ = w′} w′⊆w afw′ dw′⊑u₁ u₂⊑cw′
      where
      dw′≤w : depth (dom w′) ≤ depth w
      dw′≤w = ≤-trans (dom-depth-≤{w′}) (⊆→depth≤ w′⊆w)
      cw′≤w : depth (cod w′) ≤ depth w
      cw′≤w = ≤-trans (cod-depth-≤{w′}) (⊆→depth≤ w′⊆w)

      M1a = begin
               suc (depth (dom w′) + depth u₁)
            ≤⟨ s≤s (≤-reflexive (+-comm (depth (dom w′)) (depth u₁))) ⟩
               suc (depth u₁ + depth (dom w′))
            ≤⟨ s≤s (+-mono-≤ (m≤m⊔n (depth u₁) (depth u₂)) dw′≤w) ⟩
               suc (max (depth u₁) (depth u₂) + depth w)
            ∎
      M1 : ⟨ depth (dom w′) + depth u₁ , size (dom w′) + size (dom v′) ⟩
        << ⟨ suc (max (depth u₁) (depth u₂) + depth w) ,
             suc (size u₁ + size u₂ + size v) ⟩
      M1 = fst (≤⇒≤′ M1a)
      M2a = begin
               suc (depth u₂ + depth (cod w′))
            ≤⟨ s≤s (+-mono-≤ (n≤m⊔n (depth u₁) (depth u₂)) cw′≤w) ⟩
               suc (max (depth u₁) (depth u₂) + depth w)
            ∎
      M2 : ⟨ depth u₂ + depth (cod w′) ,
             size u₂ + size (cod v′) ⟩
        << ⟨ suc (max (depth u₁) (depth u₂) + depth w) ,
             suc (size u₁ + size u₂ + size v) ⟩
      M2 = fst (≤⇒≤′ M2a)

⊑-trans : ∀{u v w} → u ⊑ v → v ⊑ w → u ⊑ w
⊑-trans {u} {v} {w} u⊑v v⊑w =
    ⊑-trans-rec (depth u + depth w) (size u + size v) refl refl u⊑v v⊑w

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


init commit of ITyping-Norm

init commit of ITyping-Norm

module ITyping-Norm where

open import Data.Empty
open import Data.List
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Data.List.Properties
open import Data.List.Any as LAny
open LAny.Membership-≡
open import Relation.Nullary
open import Relation.Binary.Core
open import Relation.Binary.PropositionalEquality using (sym)

open import Core
open import Core-Lemmas
open import ChurchRosser
open import Typing
open import Typed-Core
open import ITyping-Core
open import ITyping-Subst

data NF : ∀ {A} -> Λ A -> Set where
  bvN : ∀ {t i} -> NF (bv {t} i)
  fvN : ∀ {t x} -> NF (fv {t} x)
  lamN : ∀ L {A B} {m : Λ B} ->
    ( cf : ∀ {x} -> (x∉L : x ∉ L) -> NF (Λ[ 0 >> fv {A} x ] m) ) -> NF (lam A m)
  appBvN : ∀ {t s i m} -> NF m -> NF (app {t} {s} (bv i) m)
  appFvN : ∀ {t s i m} -> NF m -> NF (app {t} {s} (fv i) m)
  YN : ∀ {t} -> NF (Y t)

HasNF : ∀ {A} (m : Λ A) -> Set
HasNF m = ¬ (∃ (λ m' -> m ->Λβ m'))

bvHasNF : ∀ {t i} -> HasNF (bv {t} i)
bvHasNF (m' , ())

fvHasNF : ∀ {t i} -> HasNF (fv {t} i)
fvHasNF (m' , ())

NF->HasNF : ∀ {A} {m : Λ A} -> NF m -> HasNF m
NF->HasNF bvN (m' , ())
NF->HasNF fvN (m' , ())
NF->HasNF (lamN L cf) (_ , (abs L' {m = m} {m'} cf')) = ih (Λ[ 0 >> fv x ] m' , cf' x∉L')
  where
  x = ∃fresh (L ++ L')

  x∉ : x ∉ L ++ L'
  x∉ = ∃fresh-spec (L ++ L')

  x∉L : x ∉ L
  x∉L = ∉-cons-l _ L' x∉

  x∉L' : x ∉ L'
  x∉L' = ∉-cons-r L L' x∉

  ih : HasNF (Λ[ 0 >> fv x ] m)
  ih = NF->HasNF (cf x∉L)
NF->HasNF (appBvN {i = i} _) (_ , redL {m' = m'} _ bvi->Λβm') = ih (m' , bvi->Λβm')
  where
  ih : HasNF (bv i)
  ih = bvHasNF
NF->HasNF (appBvN NFn) (_ , redR {n = n} {n'} _ n->Λβn') = ih (n' , n->Λβn')
  where
  ih : HasNF n
  ih = NF->HasNF NFn
NF->HasNF (appFvN {i = i} _) (_ , redL {m' = m'} _ bvi->Λβm') = ih (m' , bvi->Λβm')
  where
  ih : HasNF (fv i)
  ih = fvHasNF
NF->HasNF (appFvN NFn) (_ , redR {n = n} {n'} _ n->Λβn') = ih (n' , n->Λβn')
  where
  ih : HasNF n
  ih = NF->HasNF NFn
NF->HasNF YN (m' , ())

--Type->∃IType : ∀ A -> ∃(λ τ ->  τ ∷' A)
--Type->∃ITypeₗ : ∀ A -> ∃(λ τ ->  τ ∷'ₗ A)

--Type->∃IType σ = o , base
--Type->∃IType (A ⟶ A₁) = (ω ~> ω) , arr nil nil
--Type->∃ITypeₗ σ = ω , nil
--Type->∃ITypeₗ (A ⟶ A₁) = ω , nil

_∈Γ_ : ∀ {A} → Atom → List (Atom × A) → Set _
x ∈Γ xs = x ∈ (dom xs)

_∈Γ?_ : ∀ {A} → Decidable {A = Atom} (_∈Γ_ {A})
x ∈Γ? [] = no λ ()
x ∈Γ? ((x' , y) ∷ xs) with x ≟ x'
x ∈Γ? ((.x , y) ∷ xs) | yes refl = yes (here refl)
x ∈Γ? ((x' , y) ∷ xs) | no _ with x ∈Γ? xs
x ∈Γ? ((x' , y) ∷ xs) | no _ | yes x∈xs = yes (there x∈xs)
x ∈Γ? ((x' , y) ∷ xs) | no x≠x' | no x∉xs =
  no (λ x∈x'∷xs → x∉xs (∈-∷-elim x (dom xs) (λ x'≡x → x≠x' (sym x'≡x)) x∈x'∷xs))

⊆-list-trans : {A : Set}{xs ys zs : List A} -> xs ⊆ ys -> ys ⊆ zs -> xs ⊆ zs
⊆-list-trans {A} {xs} {ys} {zs} xs⊆ys ys⊆zs = λ {x} z → ys⊆zs (xs⊆ys z)

∈Γ-∃ : ∀ {x Γ} -> x ∈Γ Γ -> Wf-ICtxt Γ -> ∃(λ Γ' -> ∃(λ τ -> ∃(λ A -> Γ ⊆ ((x , τ , A) ∷ Γ') × ((x , τ , A) ∷ Γ') ⊆ Γ × Wf-ICtxt ((x , τ , A) ∷ Γ'))))
∈Γ-∃ {Γ = []} () _
∈Γ-∃ {Γ = (_ , τ , A) ∷ Γ} (here refl) wf-Γ = Γ , τ , A , (λ {x} z → z) , (λ {x} z → z) , wf-Γ
∈Γ-∃ {x} {(y , τ , A) ∷ Γ} (there x∈Γ) (cons y∉ τ∷A wf-Γ) with ∈Γ-∃ x∈Γ wf-Γ
∈Γ-∃ {x} {(y , τ , A) ∷ Γ} (there x∈Γ) (cons y∉ τ∷A wf-Γ) |
  Γ' , τ' , A' , Γ⊆x,τ,A∷Γ' , x,τ,A∷Γ'⊆Γ , wf-x,τ,A∷Γ'  =
  ((y , τ , A) ∷ Γ') ,
  τ' ,
  A' ,
  ⊆-list-trans (cons-⊆ Γ⊆x,τ,A∷Γ') (help _ _ Γ') ,
  ⊆-list-trans (help _ _ Γ') (cons-⊆ x,τ,A∷Γ'⊆Γ) ,
  wfI-Γ-exchange (cons (λ y∈x∷Γ' → y∉ (help₂ y∈x∷Γ' x,τ,A∷Γ'⊆Γ)) τ∷A wf-x,τ,A∷Γ')
  where
  help : {A : Set} (x y : A) (xs : List A) -> x ∷ y ∷ xs ⊆ y ∷ x ∷ xs
  help x y₁ xs (here refl) = there (here refl)
  help x₁ y xs (there (here refl)) = here refl
  help x₁ y xs (there (there x'∈x∷y∷xs)) = there (there x'∈x∷y∷xs)

  help₁ : ∀ {x} {Γ : ICtxt} -> x ∈ dom Γ -> ∃(λ τ -> (x , τ) ∈ Γ)
  help₁ {Γ = []} ()
  help₁ {Γ = (_ , τ) ∷ Γ} (here refl) = τ , here refl
  help₁ {Γ = y ∷ Γ} (there x∈domΓ) with help₁ x∈domΓ
  help₁ {x} {y ∷ Γ} (there x∈domΓ) | τ , x∈Γ = τ , there x∈Γ

  help₂ : ∀ {x} {Γ Γ' : ICtxt} -> x ∈ dom Γ -> Γ ⊆ Γ' -> x ∈ dom Γ'
  help₂ x∈domΓ Γ⊆Γ' with help₁ x∈domΓ
  help₂ x∈domΓ Γ⊆Γ' | τ , x∈Γ = ∈-imp-∈dom (Γ⊆Γ' x∈Γ)

NF->⊩ : ∀ {A} {m : Λ A} -> NF m -> ΛTerm m -> ∃ (λ Γ -> ∃ (λ τ -> Γ ⊩ m ∶ τ))
NF->⊩ bvN ()
NF->⊩ {σ} (fvN {x = x}) var =
  [ (x , [ o ] , σ) ] ,
  o ,
  var
    (cons (λ ()) (cons base nil) nil)
    (here refl)
    (cons (o , here refl , base) (nil (cons base nil)))
NF->⊩ {A ⟶ B} (fvN {x = x}) var =
  [ (x , [ ω ~> ω ] , A ⟶ B) ] ,
  ω ~> ω ,
  var
    (cons (λ ()) (cons (arr nil nil) nil) nil)
    (here refl)
     (cons ((ω ~> ω) , here refl , arr (nil nil) (nil nil)) (nil (cons (arr nil nil) nil)))
NF->⊩ (lamN L {A} {B} {m} cf) (lam L' cf') = body x∉FVm Γ⊩m^x∶τ
  -- Γ ,
  -- (ω ~> [ τ ]) ,
  -- abs
  --   (x ∷ L ++ L')
  --   (λ x∉L'' →
  --     cons
  --     {!Γ⊩m^x∶τ!}
  --       (nil (cons {!x∉L''!} nil {!!})))
  where
  x = ∃fresh (ΛFV m ++ L ++ L')

  x∉ : x ∉ ΛFV m ++ L ++ L'
  x∉ = ∃fresh-spec (ΛFV m ++ L ++ L')

  x∉FVm : x ∉ ΛFV m
  x∉FVm = ∉-cons-l _ _ x∉

  x∉L : x ∉ L
  x∉L = ∉-cons-l _ _ (∉-cons-r (ΛFV m) _ x∉)

  x∉L' : x ∉ L'
  x∉L' = ∉-cons-r L L' (∉-cons-r (ΛFV m) _ x∉)

  ih : ∃ (λ Γ -> ∃ (λ τ -> Γ ⊩ (Λ[ 0 >> fv x ] m) ∶ τ))
  ih = NF->⊩ (cf x∉L) (cf' x∉L')

  Γ = proj₁ ih
  τ = proj₁ (proj₂ ih)
  Γ⊩m^x∶τ = proj₂ (proj₂ ih)

  body : ∀ {Γ A B τ x} {m : Λ B} -> x ∉ ΛFV m -> Γ ⊩ (Λ[ 0 >> fv {A} x ] m) ∶ τ -> ∃ (λ Γ -> ∃ (λ τ -> Γ ⊩ (lam A m) ∶ τ))
  body {Γ} {A} {B} {τ} {x = x} x∉FVm Γ⊩m^x∶τ with x ∈Γ? Γ
  body {Γ} {τ = τ} {x} {m} x∉FVm Γ⊩m^x∶τ | yes x∈Γ with ∈Γ-∃ x∈Γ (⊩-wf-Γ Γ⊩m^x∶τ)
  body {Γ} {τ = τ} {x} {m} x∉FVm Γ⊩m^x∶τ | yes x∈Γ | Γ' , τ' , A' , Γ⊆x∷Γ' , _ , wf-x∷Γ' = {!!}
    where
    Γ⊆Γx∷Γ' = ⊆Γ-⊆ wf-x∷Γ' Γ⊆x∷Γ'

    x∷Γ'⊩m^x∶τ : ((x , τ' , A') ∷ Γ') ⊩ Λ[ 0 >> fv x ] m ∶ τ
    x∷Γ'⊩m^x∶τ = subΓ Γ⊩m^x∶τ Γ⊆Γx∷Γ'

  body {Γ} {τ = τ} {x} {m} x∉FVm Γ⊩m^x∶τ | no x∉Γ =
    Γ ,
    (ω ~> [ τ ]) ,
    (abs (x ∷ (dom Γ ++ ΛFV m)) (λ {y} y∉L →
      cons
        (aux {x = x}
          m
          (proj₂ (∃~T m))
          (∉-∷-elim _ (∉-cons-l _ _ y∉L))
          x∉FVm
          (∉-cons-r (dom Γ) (ΛFV m) (∉-∷-elim _ y∉L))
          (λ x≡y → y∉L (here (sym x≡y)))
          (subΓ Γ⊩m^x∶τ (⊆Γ-⊆ (cons x∉Γ nil (⊩-wf-Γ Γ⊩m^x∶τ)) (λ {x₁} → there))))
          (nil (cons (∉-∷-elim _ (∉-cons-l _ _ y∉L)) nil (⊩-wf-Γ Γ⊩m^x∶τ)))))

NF->⊩ (appBvN NFm) (app () trm-m)
NF->⊩ (appFvN {A} {B} {x} {m} NFm) (app trm trm-m) = {!!}
  -- (x , [ [ τ ] ~> ω ] , A ⟶ B) ∷ Γ ,
  -- [ τ ] ~> ω ,
  -- app
  --   (var {!!} {!!} {!!})
  --   (cons {!!} (nil {!!}))
  --   {!!}
  -- where
  -- ih : ∃ (λ Γ -> ∃ (λ τ -> Γ ⊩ m ∶ τ))
  -- ih = NF->⊩ NFm trm-m

  -- Γ = proj₁ ih
  -- τ = proj₁ (proj₂ ih)
  -- Γ⊩m∶τ = proj₂ (proj₂ ih)
NF->⊩ (YN {t = A}) Y =
  [] ,
  [ ω ~> ω ] ~> ω ,
  Y {τ = ω}
    nil
    (cons ((ω ~> ω) , here refl , arr (nil nil) (nil nil)) (nil (cons (arr nil nil) nil)))
    (nil nil)

--HasNF->⊩ : ∀ {A Γ τ} {m n : Λ A} -> NF n -> m ->Λβ n -> Γ ⊩ n ∶ τ -> Γ ⊩ m ∶ τ
--HasNF->⊩ = {!!}

P : ∀ A -> IType -> Λ A -> Set
Pₗ : ∀ {A} -> List IType -> Λ A -> Set

P σ o m = [] ⊩ m ∶ o × NF m
P σ (_ ~> _) _ = ⊥
P (_ ⟶ _) o _ = ⊥
P (A ⟶ B) (τ ~> τ') m = [] ⊩ m ∶ (τ ~> τ') × (∀ {n : Λ A} -> Pₗ τ n -> Pₗ τ' (app m n))

Pₗ [] m = [] ⊩ₗ m ∶ ω
Pₗ {A} (τ ∷ τᵢ) m = P A τ m × Pₗ τᵢ m

--data P where
--  base : ∀ {A} {m : Λ A} -> [] ⊩ m ∶ o -> NF m -> P o m
--  arr : ∀ {A B τ τ'} {m : Λ (A ⟶ B)} ->
--    [] ⊩ m ∶ (τ ~> τ') ->
--    (∀ {n : Λ A} -> Pₗ τ n -> Pₗ τ' (app m n)) ->
--    P (τ ~> τ') m

--data Pₗ where
--  nil : ∀ {A} {m : Λ A} -> [] ⊩ₗ m ∶ ω -> Pₗ ω m
--  cons : ∀ {A τ τᵢ} {m : Λ A} -> P τ m -> Pₗ τᵢ m -> Pₗ (τ ∷ τᵢ) m

error: pathspec 'Agda/ITyping-Norm.agda' did not match any file(s) known to git