-- NOTE with-K
module Solver.Linear where

open import FunUniverse.Types
open import FunUniverse.Rewiring.Linear
open import Data.Two hiding (_≟_)
open import Data.Nat as ℕ using (ℕ)
import Solver.Linear.Syntax as LinSyn
open import Relation.Nullary.Decidable
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl; _≢_)
open import Relation.Nullary
import Data.String as String
module String≤ = StrictTotalOrder String.strictTotalOrder
open import Data.Fin using (Fin)
open import Data.Fin.Props using (strictTotalOrder) renaming (_≟_ to _≟ᶠ_)
open import Data.Vec using (Vec; lookup)
open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
open import Data.Vec using (allFin) renaming (map to vmap)

module Syntax
  {Var : Set}
  (_≤V₂_ : Var → Var → 𝟚)
  (_≟V_ : Decidable (_≡_ {A = Var}))
  {a} {A : Set a}
  {funU : FunUniverse A}
  (linRewiring : LinRewiring funU)
  (Γ : Var → A)
 where

  open FunUniverse funU
  open LinRewiring linRewiring
  open LinSyn Var

  eval : Syn → A
  eval (var x) = Γ x
  eval tt = `⊤
  eval (s , s₁) = eval s `× eval s₁

  EvalEq : Eq → Set
  EvalEq e = eval (LHS e) `→ eval (RHS e)

  data R : Syn → Syn → Set a where
    _``∻_ : ∀ {A B C} → R A B → R B C → R A C
    `<id,tt>⁻¹ : ∀ {A} → R (A , tt) A
    `<tt,id>⁻¹ : ∀ {A} → R (tt , A) A
    `<tt,id> : ∀ {A} → R A (tt , A)
    `<id,tt> : ∀ {A} → R A (A , tt)
    ⟨_``×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    `assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    `assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    `id : ∀ {A} → R A A
    `swap : ∀ {A B} → R (A , B) (B , A)

  `⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  `⟨ `id × `id ⟩ = `id
  `⟨ r₁  ×  r₂ ⟩ = ⟨ r₁ ``× r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  `id ∻ r₂ = r₂
  r₁ ∻ `id = r₁
  `<tt,id>⁻¹ ∻ `<tt,id> = `id
  `<id,tt>⁻¹ ∻ `<id,tt> = `id
  `<tt,id> ∻ `<tt,id>⁻¹ = `id
  `<id,tt> ∻ `<id,tt>⁻¹ = `id
  `swap ∻ `<id,tt>⁻¹ = `<tt,id>⁻¹
  `swap ∻ `<tt,id>⁻¹ = `<id,tt>⁻¹
  `<id,tt> ∻ `swap = `<tt,id>
  `<tt,id> ∻ `swap = `<id,tt>
  `assoc ∻ `assoc⁻¹ = `id
  `assoc ∻ (`assoc⁻¹ ``∻ r) = r
  `assoc⁻¹ ∻ `assoc = `id
  `assoc⁻¹ ∻ (`assoc ``∻ r) = r
  `swap ∻ `swap = `id
  `swap ∻ (`swap ``∻ r) = r
  (r₁ ``∻ r₂) ∻ r₃ = r₁ ``∻ (r₂ ∻ r₃)
  ⟨ r₁ ``× r₂ ⟩ ∻ ⟨ r₃ ``× r₄ ⟩ = ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ⟨ r₁ ``× r₂ ⟩ ∻ ( ⟨ r₃ ``× r₄ ⟩ ``∻ r₅) with ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ... | `id = r₅
  ... | r₆ = r₆ ``∻ r₅
  r₁ ∻ r₂ = r₁ ``∻ r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ``∻ r₁) = sym r₁ ∻ sym r
  sym `<id,tt> = `<id,tt>⁻¹
  sym `<tt,id> = `<tt,id>⁻¹
  sym `<id,tt>⁻¹ = `<id,tt>
  sym `<tt,id>⁻¹ = `<tt,id>
  sym ⟨ r ``× r₁ ⟩ = ⟨ sym r ``× sym r₁ ⟩
  sym `assoc = `assoc⁻¹
  sym `assoc⁻¹ = `assoc
  sym `id = `id
  sym `swap = `swap

  proof₁ : ∀ {S S'} → R S S' → eval S `→ eval S'
  proof₁ (r ``∻ r₁) = proof₁ r ⁏ proof₁ r₁
  proof₁ `<id,tt> = <id,tt>
  proof₁ `<tt,id> = <tt,id>
  proof₁ `<id,tt>⁻¹ = fst<,tt>
  proof₁ `<tt,id>⁻¹ = snd<tt,>
  proof₁ ⟨ `id ``× r ⟩ = second (proof₁ r)
  proof₁ ⟨ r ``× `id ⟩ = first  (proof₁ r)
  proof₁ ⟨ r ``× r₁ ⟩  = < proof₁ r × proof₁ r₁ >
  proof₁ `assoc = assoc′
  proof₁ `assoc⁻¹ = assoc
  proof₁ `id = id
  proof₁ `swap = swap

  proof₂ : ∀ {S S'} → R S S' → eval S' `→ eval S
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set a where
    tt : NF tt
    var : ∀ x → NF (var x)
    var_::_ : ∀ {S} i → NF S → NF (var i , S)

  record NFP S : Set a where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ `<tt,id>
  merge (var i) n2 = (var i :: n2) ⊢ `id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ `assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ `id
  norm tt = tt ⊢ `id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 ``× p2 ⟩)

  insert : ∀ {S} x → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ `<id,tt>
  insert y (var i) with y ≤V₂ i
  ... | 1₂ = (var y :: var i) ⊢ `id
  ... | 0₂ = (var i :: var y) ⊢ `swap
  insert y (var i :: n1) with y ≤V₂ i
  ... | 1₂ = (var y :: (var i :: n1)) ⊢ `id
  ... | 0₂ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ (`assoc ∻ (⟨ `swap ``× `id ⟩ ∻ `assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ `id
  sort (var i) = var i ⊢ `id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ `id ``× p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = `id

  var-inj : ∀ {i j} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x ≟V x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  data equation-not-ok : Set where

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = equation-not-ok

  EqOk? : Eq → Set
  EqOk? e = CHECK (NFP.S' (normal (LHS e))) (NFP.S' (normal (RHS e)))

  rewire : (e : Eq) {prf : EqOk? e} → EvalEq e
  rewire (s₁ ↦ s₂) {eq} with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire (_ ↦ _) {()} | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

module Syntaxᶠ {a} {A : Set a} {funU : FunUniverse A} (linRewiring : LinRewiring funU) where
  module _ {n} where
    open LinSyn (Fin n) public

  module _ {n} (Γ : Vec A n)
           (f : N-ary n (LinSyn.Syn (Fin n)) (LinSyn.Eq (Fin n)))
           where
    open Syntax {Fin n} ((λ x y → ⌊ StrictTotalOrder._<?_ (strictTotalOrder n) x y ⌋))
                _≟ᶠ_ {a} {A} {funU} linRewiring (λ i → lookup i Γ) public

    private
      e = f $ⁿ vmap Syn.var (allFin n)

    rewireᶠ : {e-ok : EqOk? e} → EvalEq e
    rewireᶠ {e-ok} = rewire e {e-ok}

module Syntaxˢ {a} {A} {funU} linRewiring Γ where
  open Syntax (λ x y → ⌊ String≤._<?_ x y ⌋) String._≟_ {a} {A} {funU} linRewiring Γ public
  open import Solver.Linear.Parser

  rewireˢ : ∀ s {s-ok} →
            let e = parseEqˢ s {s-ok} in
            {e-ok : EqOk? e} → EvalEq e
  rewireˢ s {s-ok} {e-ok} = rewire (parseEqˢ s {s-ok}) {e-ok}
-- -}
-- -}
-- -}

-- NOTO with-K
module Solver.Linear where

open import FunUniverse.Types
open import FunUniverse.Rewiring.Linear
open import Data.Two hiding (_≟_)
open import Data.Nat as ℕ using (ℕ)
import Solver.Linear.Syntax as LinSyn
open import Relation.Nullary.Decidable
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl; _≢_)
open import Relation.Nullary
import Data.String as String
module String≤ = StrictTotalOrder String.strictTotalOrder
open import Data.Fin using (Fin)
open import Data.Fin.Props using (strictTotalOrder) renaming (_≟_ to _≟ᶠ_)
open import Data.Vec using (Vec; lookup)
open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
open import Data.Vec using (allFin) renaming (map to vmap)

module Syntax
  {Var : Set}
  (_≤V₂_ : Var → Var → 𝟚)
  (_≟V_ : Decidable (_≡_ {A = Var}))
  {a} {A : Set a}
  {funU : FunUniverse A}
  (linRewiring : LinRewiring funU)
  (Γ : Var → A)
 where

  open FunUniverse funU
  open LinRewiring linRewiring
  open LinSyn Var

  eval : Syn → A
  eval (var x) = Γ x
  eval tt = `⊤
  eval (s , s₁) = eval s `× eval s₁

  EvalEq : Eq → Set
  EvalEq e = eval (LHS e) `→ eval (RHS e)

  data R : Syn → Syn → Set a where
    _``∻_ : ∀ {A B C} → R A B → R B C → R A C
    `<id,tt>⁻¹ : ∀ {A} → R (A , tt) A
    `<tt,id>⁻¹ : ∀ {A} → R (tt , A) A
    `<tt,id> : ∀ {A} → R A (tt , A)
    `<id,tt> : ∀ {A} → R A (A , tt)
    ⟨_``×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    `assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    `assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    `id : ∀ {A} → R A A
    `swap : ∀ {A B} → R (A , B) (B , A)

  `⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  `⟨ `id × `id ⟩ = `id
  `⟨ r₁  ×  r₂ ⟩ = ⟨ r₁ ``× r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  `id ∻ r₂ = r₂
  r₁ ∻ `id = r₁
  `<tt,id>⁻¹ ∻ `<tt,id> = `id
  `<id,tt>⁻¹ ∻ `<id,tt> = `id
  `<tt,id> ∻ `<tt,id>⁻¹ = `id
  `<id,tt> ∻ `<id,tt>⁻¹ = `id
  `swap ∻ `<id,tt>⁻¹ = `<tt,id>⁻¹
  `swap ∻ `<tt,id>⁻¹ = `<id,tt>⁻¹
  `<id,tt> ∻ `swap = `<tt,id>
  `<tt,id> ∻ `swap = `<id,tt>
  `assoc ∻ `assoc⁻¹ = `id
  `assoc ∻ (`assoc⁻¹ ``∻ r) = r
  `assoc⁻¹ ∻ `assoc = `id
  `assoc⁻¹ ∻ (`assoc ``∻ r) = r
  `swap ∻ `swap = `id
  `swap ∻ (`swap ``∻ r) = r
  (r₁ ``∻ r₂) ∻ r₃ = r₁ ``∻ (r₂ ∻ r₃)
  ⟨ r₁ ``× r₂ ⟩ ∻ ⟨ r₃ ``× r₄ ⟩ = ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ⟨ r₁ ``× r₂ ⟩ ∻ ( ⟨ r₃ ``× r₄ ⟩ ``∻ r₅) with ⟨ r₁ ∻ r₃ ``× r₂ ∻ r₄ ⟩
  ... | `id = r₅
  ... | r₆ = r₆ ``∻ r₅
  r₁ ∻ r₂ = r₁ ``∻ r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ``∻ r₁) = sym r₁ ∻ sym r
  sym `<id,tt> = `<id,tt>⁻¹
  sym `<tt,id> = `<tt,id>⁻¹
  sym `<id,tt>⁻¹ = `<id,tt>
  sym `<tt,id>⁻¹ = `<tt,id>
  sym ⟨ r ``× r₁ ⟩ = ⟨ sym r ``× sym r₁ ⟩
  sym `assoc = `assoc⁻¹
  sym `assoc⁻¹ = `assoc
  sym `id = `id
  sym `swap = `swap

  proof₁ : ∀ {S S'} → R S S' → eval S `→ eval S'
  proof₁ (r ``∻ r₁) = proof₁ r ⁏ proof₁ r₁
  proof₁ `<id,tt> = <id,tt>
  proof₁ `<tt,id> = <tt,id>
  proof₁ `<id,tt>⁻¹ = fst<,tt>
  proof₁ `<tt,id>⁻¹ = snd<tt,>
  proof₁ ⟨ `id ``× r ⟩ = second (proof₁ r)
  proof₁ ⟨ r ``× `id ⟩ = first  (proof₁ r)
  proof₁ ⟨ r ``× r₁ ⟩  = < proof₁ r × proof₁ r₁ >
  proof₁ `assoc = assoc′
  proof₁ `assoc⁻¹ = assoc
  proof₁ `id = id
  proof₁ `swap = swap

  proof₂ : ∀ {S S'} → R S S' → eval S' `→ eval S
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set a where
    tt : NF tt
    var : ∀ x → NF (var x)
    var_::_ : ∀ {S} i → NF S → NF (var i , S)

  record NFP S : Set a where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ `<tt,id>
  merge (var i) n2 = (var i :: n2) ⊢ `id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ `assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ `id
  norm tt = tt ⊢ `id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 ``× p2 ⟩)

  insert : ∀ {S} x → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ `<id,tt>
  insert y (var i) with y ≤V₂ i
  ... | 1₂ = (var y :: var i) ⊢ `id
  ... | 0₂ = (var i :: var y) ⊢ `swap
  insert y (var i :: n1) with y ≤V₂ i
  ... | 1₂ = (var y :: (var i :: n1)) ⊢ `id
  ... | 0₂ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ `id ``× p ⟩ ∻ (`assoc ∻ (⟨ `swap ``× `id ⟩ ∻ `assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ `id
  sort (var i) = var i ⊢ `id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ `id ``× p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = `id

  var-inj : ∀ {i j} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x ≟V x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  data equation-not-ok : Set where

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = equation-not-ok

  EqOk? : Eq → Set
  EqOk? e = CHECK (NFP.S' (normal (LHS e))) (NFP.S' (normal (RHS e)))

  rewire : (e : Eq) {prf : EqOk? e} → EvalEq e
  rewire (s₁ ↦ s₂) {eq} with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire (_ ↦ _) {()} | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

module Syntaxᶠ {a} {A : Set a} {funU : FunUniverse A} (linRewiring : LinRewiring funU) where
  module _ {n} where
    open LinSyn (Fin n) public

  module _ {n} (Γ : Vec A n)
           (f : N-ary n (LinSyn.Syn (Fin n)) (LinSyn.Eq (Fin n)))
           where
    open Syntax {Fin n} ((λ x y → ⌊ StrictTotalOrder._<?_ (strictTotalOrder n) x y ⌋))
                _≟ᶠ_ {a} {A} {funU} linRewiring (λ i → lookup i Γ) public

    private
      e = f $ⁿ vmap Syn.var (allFin n)

    rewireᶠ : {e-ok : EqOk? e} → EvalEq e
    rewireᶠ {e-ok} = rewire e {e-ok}

module Syntaxˢ {a} {A} {funU} linRewiring Γ where
  open Syntax (λ x y → ⌊ String≤._<?_ x y ⌋) String._≟_ {a} {A} {funU} linRewiring Γ public
  open import Solver.Linear.Parser

  rewireˢ : ∀ s {s-ok} →
            let e = parseEqˢ s {s-ok} in
            {e-ok : EqOk? e} → EvalEq e
  rewireˢ s {s-ok} {e-ok} = rewire (parseEqˢ s {s-ok}) {e-ok}
-- -}
-- -}
-- -}

Fix a note

Fix a note


{-# OPTIONS --without-K #-}
open import Level.NP
open import Type
open import FunUniverse.Types
open import Data.One using (𝟙)
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_)
import FunUniverse.Category
import FunUniverse.Defaults.FirstPart as Defaults⟨first-part⟩

module FunUniverse.Rewiring.Linear where

record LinRewiring {t} {T : ★_ t} (funU : FunUniverse T) : ★_ t where
  constructor mk
  open FunUniverse funU
  open FunUniverse.Category _`→_

  field
    cat : Category
  open Category cat

  field
    -- Products (group 2 primitive functions or derived from group 1)
    first    : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
    swap     : ∀ {A B} → (A `× B) `→ (B `× A)
    assoc    : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
    <tt,id>  : ∀ {A} → A `→ `𝟙 `× A
    snd<tt,> : ∀ {A} → `𝟙 `× A `→ A

    -- Products (derived from group 1 or 2)
    <_×_>  : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
    second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)

    -- Vectors
    tt→[]  : ∀ {A} → `𝟙 `→ `Vec A 0
    []→tt  : ∀ {A} → `Vec A 0 `→ `𝟙
    <∷>    : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

  open Defaults⟨first-part⟩ funU
  open CompositionNotations _∘_ public
  open DefaultAssoc′ _∘_ assoc swap first public

  infixr 3 _***_
  _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  f *** g = < f × g >

  <id,tt> : ∀ {A} → A `→ A `× `𝟙
  <id,tt> = <tt,id> ⁏ swap

  <tt⁏_,_> : ∀ {A B C} → (`𝟙 `→ B) → (A `→ C) → A `→ B `× C
  <tt⁏ f , g > = <tt,id> ⁏ < f × g >

  <_,tt⁏_> : ∀ {A B C} → (A `→ B) → (`𝟙 `→ C) → A `→ B `× C
  < f ,tt⁏ g > = <tt⁏ g , f > ⁏ swap

  fst<,tt> : ∀ {A} → A `× `𝟙 `→ A
  fst<,tt> = swap ⁏ snd<tt,>

  fst<,[]> : ∀ {A B} → A `× `Vec B 0 `→ A
  fst<,[]> = second []→tt ⁏ fst<,tt>

  snd<[],> : ∀ {A B} → `Vec A 0 `× B `→ B
  snd<[],> = first []→tt ⁏ snd<tt,>

  -- Like first, but applies on a triple associated the other way
  assoc-first : ∀ {A B C D E} → (A `× B `→ D `× E) → A `× B `× C `→ D `× E `× C
  assoc-first f = assoc′ ⁏ first f ⁏ assoc

  -- Like assoc-first but for second
  assoc-second : ∀ {A B C D E} → (B `× C `→ E `× D) → (A `× B) `× C `→ (A `× E) `× D
  assoc-second f = assoc ⁏ second f ⁏ assoc′

  swap-top : ∀ {A B C} → A `× B `× C `→ B `× A `× C
  swap-top = assoc-first swap

  around : ∀ {A B C D X} → (A `× B `→ C `× D) → A `× X `× B `→ C `× X `× D
  around f = swap-top ⁏ second f ⁏ swap-top

  inner : ∀ {A B C D} → (A `→ B) → C `× A `× D `→ C `× B `× D
  inner f = swap-top ⁏ first f ⁏ swap-top

  {-

  X ------------> X
        +---+
  A --->|   |---> C
        | f |
  B --->|   |---> D
        +---+
  Y ------------> Y

  -}
  inner2 : ∀ {A B C D X Y} → (A `× B `→ C `× D) → (X `× A) `× (B `× Y) `→ (X `× C) `× (D `× Y)
  inner2 f = assoc-first (assoc-second f)

  <_×₁_> : ∀ {A B C D E F} → (A `× B `→ D `× E) → (C `→ F) → A `× B `× C `→ D `× E `× F
  < f ×₁ g > = assoc′ ⁏ < f × g > ⁏ assoc

  <_×₂_> : ∀ {A B C D E F} → (A `→ D) → (B `× C `→ E `× F) → (A `× B) `× C `→ (D `× E) `× F
  < f ×₂ g > = assoc ⁏ < f × g > ⁏ assoc′

  <_`zip`_> : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  < f `zip` g > = inner2 swap ⁏ < f × g >

  <_∷′_> : ∀ {n A B C} → (A `→ C) → (B `→ `Vec C n)
                       → A `× B `→ `Vec C (1 + n)
  < f ∷′ g > = < f × g > ⁏ <∷>

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons ⁏ < f ∷′ g >

  <tt⁏_∷′_> : ∀ {n A B} → (`𝟙 `→ B) → (A `→ `Vec B n)
                       → A `→ `Vec B (1 + n)
  <tt⁏ f ∷′ g > = <tt⁏ f , g > ⁏ <∷>

  <_∷′tt⁏_> : ∀ {n A B} → (A `→ B) → (`𝟙 `→ `Vec B n)
                        → A `→ `Vec B (1 + n)
  < f ∷′tt⁏ g > = < f ,tt⁏ g > ⁏ <∷>

  <_∷[]> : ∀ {A B} → (A `→ B) → A `→ `Vec B 1
  < f ∷[]> = < f ∷′tt⁏ tt→[] >

  <∷[]> : ∀ {A} → A `→ `Vec A 1
  <∷[]> = < id ∷[]>

  <[],_> : ∀ {A B C} → (A `→ B) → A `→ `Vec C 0 `× B
  <[], f > = <tt⁏ tt→[] , f >

  <_,[]> : ∀ {A B C} → (A `→ B) → A `→ B `× `Vec C 0
  < f ,[]> = < f ,tt⁏ tt→[] >

  head<∷> : ∀ {A} → `Vec A 1 `→ A
  head<∷> = uncons ⁏ fst<,[]>

  constVec⊤ : ∀ {n a} {A : ★_ a} {B} → (A → `𝟙 `→ B) → Vec A n → `𝟙 `→ `Vec B n
  constVec⊤ f [] = tt→[]
  constVec⊤ f (x ∷ xs) = <tt⁏ f x ∷′ constVec⊤ f xs >

  []→[] : ∀ {A B} → `Vec A 0 `→ `Vec B 0
  []→[] = []→tt ⁏ tt→[]

  <[],[]>→[] : ∀ {A B C} → (`Vec A 0 `× `Vec B 0) `→ `Vec C 0
  <[],[]>→[] = fst<,[]> ⁏ []→[]

  <_⊛> : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  <_⊛> []       = []→[]
  <_⊛> (f ∷ fs) = < f ∷ < fs ⊛> >

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst<,[]>
  foldl {suc n} f = second uncons
                  ⁏ assoc′
                  ⁏ first f
                  ⁏ foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons ⁏ foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd<[],>
  foldr {suc n} f = first uncons
                  ⁏ assoc
                  ⁏ second (foldr f)
                  ⁏ f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons ⁏ swap ⁏ foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map f = < V.replicate f ⊛>

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = <[],[]>→[]
  zipWith {suc n} f = < uncons × uncons >
                    ⁏ < f `zip` (zipWith f) >
                    ⁏ <∷>

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith id

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = < snd<[],> ∷[]>
  snoc {suc n} = first uncons ⁏ assoc ⁏ second snoc ⁏ <∷>

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = id
  reverse {suc n} = uncons ⁏ swap ⁏ first reverse ⁏ snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd<[],>
  append {suc m} = first uncons
                 ⁏ assoc
                 ⁏ second append
                 ⁏ <∷>

  <_++_> : ∀ {m n A} → (`𝟙 `→ `Vec A m) → (`𝟙 `→ `Vec A n) →
                         `𝟙 `→ `Vec A (m + n)
  < f ++ g > = <tt⁏ f , g > ⁏ append

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = <[], id >
  splitAt (suc m) = uncons
                  ⁏ second (splitAt m)
                  ⁏ assoc′
                  ⁏ first <∷>

  rot-left : ∀ m {n A} → `Vec A (m + n) `→ `Vec A (n + m)
  rot-left m = splitAt m ⁏ swap ⁏ append

  rot-right : ∀ {m} n {A} → `Vec A (m + n) `→ `Vec A (n + m)
  rot-right {m} _ = rot-left m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head<∷>
  folda (suc n) f = splitAt (2^ n) ⁏ < folda n f × folda n f > ⁏ f

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = []→[]
  concat {n = suc n} = uncons ⁏ second concat ⁏ append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = []→[]
  group (suc n) k = splitAt k ⁏ second (group n k) ⁏ <∷>

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f ⁏ concat

  replicate⊤ : ∀ n → `𝟙 `→ `Vec `𝟙 n
  replicate⊤ _ = constVec⊤ (λ _ → id) (V.replicate {A = 𝟙} _)

  open Category cat public

{-# OPTIONS --without-K #-}
open import Level.NP
open import Type
open import FunUniverse.Types
open import Data.One using (𝟙)
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_)
import FunUniverse.Category
import FunUniverse.Defaults.FirstPart as Defaults⟨first-part⟩

module FunUniverse.Rewiring.Linear where

record LinRewiring {t} {T : ★_ t} (funU : FunUniverse T) : ★_ t where
  constructor mk
  open FunUniverse funU
  open FunUniverse.Category _`→_

  field
    cat : Category
  open Category cat

  field
    -- Products (group 2 primitive functions or derived from group 1)
    first    : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
    swap     : ∀ {A B} → (A `× B) `→ (B `× A)
    assoc    : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
    <tt,id>  : ∀ {A} → A `→ `𝟙 `× A
    snd<tt,> : ∀ {A} → `𝟙 `× A `→ A

    -- Products (derived from group 1 or 2)
    <_×_>  : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
    second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)

    -- Vectors
    tt→[]  : ∀ {A} → `𝟙 `→ `Vec A 0
    []→tt  : ∀ {A} → `Vec A 0 `→ `𝟙
    <∷>    : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

  open Defaults⟨first-part⟩ funU
  open CompositionNotations _∘_ public
  open DefaultAssoc′ _∘_ assoc swap first public

  infixr 3 _***_
  _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  f *** g = < f × g >

  <id,tt> : ∀ {A} → A `→ A `× `𝟙
  <id,tt> = <tt,id> ⁏ swap

  <tt⁏_,_> : ∀ {A B C} → (`𝟙 `→ B) → (A `→ C) → A `→ B `× C
  <tt⁏ f , g > = <tt,id> ⁏ < f × g >

  <_,tt⁏_> : ∀ {A B C} → (A `→ B) → (`𝟙 `→ C) → A `→ B `× C
  < f ,tt⁏ g > = <tt⁏ g , f > ⁏ swap

  fst<,tt> : ∀ {A} → A `× `𝟙 `→ A
  fst<,tt> = swap ⁏ snd<tt,>

  fst<,[]> : ∀ {A B} → A `× `Vec B 0 `→ A
  fst<,[]> = second []→tt ⁏ fst<,tt>

  snd<[],> : ∀ {A B} → `Vec A 0 `× B `→ B
  snd<[],> = first []→tt ⁏ snd<tt,>

  -- Like first, but applies on a triple associated the other way
  assoc-first : ∀ {A B C D E} → (A `× B `→ D `× E) → A `× B `× C `→ D `× E `× C
  assoc-first f = assoc′ ⁏ first f ⁏ assoc

  -- Like assoc-first but for second
  assoc-second : ∀ {A B C D E} → (B `× C `→ E `× D) → (A `× B) `× C `→ (A `× E) `× D
  assoc-second f = assoc ⁏ second f ⁏ assoc′

  swap-top : ∀ {A B C} → A `× B `× C `→ B `× A `× C
  swap-top = assoc-first swap

  around : ∀ {A B C D X} → (A `× B `→ C `× D) → A `× X `× B `→ C `× X `× D
  around f = swap-top ⁏ second f ⁏ swap-top

  inner : ∀ {A B C D} → (A `→ B) → C `× A `× D `→ C `× B `× D
  inner f = swap-top ⁏ first f ⁏ swap-top

  {-

  X ------------> X
        +---+
  A --->|   |---> C
        | f |
  B --->|   |---> D
        +---+
  Y ------------> Y

  -}
  inner2 : ∀ {A B C D X Y} → (A `× B `→ C `× D) → (X `× A) `× (B `× Y) `→ (X `× C) `× (D `× Y)
  inner2 f = assoc-first (assoc-second f)

  <_×₁_> : ∀ {A B C D E F} → (A `× B `→ D `× E) → (C `→ F) → A `× B `× C `→ D `× E `× F
  < f ×₁ g > = assoc′ ⁏ < f × g > ⁏ assoc

  <_×₂_> : ∀ {A B C D E F} → (A `→ D) → (B `× C `→ E `× F) → (A `× B) `× C `→ (D `× E) `× F
  < f ×₂ g > = assoc ⁏ < f × g > ⁏ assoc′

  <_`zip`_> : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  < f `zip` g > = inner2 swap ⁏ < f × g >

  <_∷′_> : ∀ {n A B C} → (A `→ C) → (B `→ `Vec C n)
                       → A `× B `→ `Vec C (1 + n)
  < f ∷′ g > = < f × g > ⁏ <∷>

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons ⁏ < f ∷′ g >

  <tt⁏_∷′_> : ∀ {n A B} → (`𝟙 `→ B) → (A `→ `Vec B n)
                       → A `→ `Vec B (1 + n)
  <tt⁏ f ∷′ g > = <tt⁏ f , g > ⁏ <∷>

  <_∷′tt⁏_> : ∀ {n A B} → (A `→ B) → (`𝟙 `→ `Vec B n)
                        → A `→ `Vec B (1 + n)
  < f ∷′tt⁏ g > = < f ,tt⁏ g > ⁏ <∷>

  <_∷[]> : ∀ {A B} → (A `→ B) → A `→ `Vec B 1
  < f ∷[]> = < f ∷′tt⁏ tt→[] >

  <∷[]> : ∀ {A} → A `→ `Vec A 1
  <∷[]> = < id ∷[]>

  <[],_> : ∀ {A B C} → (A `→ B) → A `→ `Vec C 0 `× B
  <[], f > = <tt⁏ tt→[] , f >

  <_,[]> : ∀ {A B C} → (A `→ B) → A `→ B `× `Vec C 0
  < f ,[]> = < f ,tt⁏ tt→[] >

  head<∷> : ∀ {A} → `Vec A 1 `→ A
  head<∷> = uncons ⁏ fst<,[]>

  constVec⊤ : ∀ {n a} {A : ★_ a} {B} → (A → `𝟙 `→ B) → Vec A n → `𝟙 `→ `Vec B n
  constVec⊤ f [] = tt→[]
  constVec⊤ f (x ∷ xs) = <tt⁏ f x ∷′ constVec⊤ f xs >

  []→[] : ∀ {A B} → `Vec A 0 `→ `Vec B 0
  []→[] = []→tt ⁏ tt→[]

  <[],[]>→[] : ∀ {A B C} → (`Vec A 0 `× `Vec B 0) `→ `Vec C 0
  <[],[]>→[] = fst<,[]> ⁏ []→[]

  <_⊛> : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  <_⊛> []       = []→[]
  <_⊛> (f ∷ fs) = < f ∷ < fs ⊛> >

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst<,[]>
  foldl {suc n} f = second uncons
                  ⁏ assoc′
                  ⁏ first f
                  ⁏ foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons ⁏ foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd<[],>
  foldr {suc n} f = first uncons
                  ⁏ assoc
                  ⁏ second (foldr f)
                  ⁏ f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons ⁏ swap ⁏ foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map f = < V.replicate f ⊛>

  mapAccum : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ S `× `Vec B n
  mapAccum {zero}  F = second []→[]
  mapAccum {suc n} F = second uncons
                     ⁏ assoc-first F ⁏ around (mapAccum F)
                     ⁏ second <∷>

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = <[],[]>→[]
  zipWith {suc n} f = < uncons × uncons >
                    ⁏ < f `zip` (zipWith f) >
                    ⁏ <∷>

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith id

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = < snd<[],> ∷[]>
  snoc {suc n} = first uncons ⁏ assoc ⁏ second snoc ⁏ <∷>

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = id
  reverse {suc n} = uncons ⁏ swap ⁏ first reverse ⁏ snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd<[],>
  append {suc m} = first uncons
                 ⁏ assoc
                 ⁏ second append
                 ⁏ <∷>

  <_++_> : ∀ {m n A} → (`𝟙 `→ `Vec A m) → (`𝟙 `→ `Vec A n) →
                         `𝟙 `→ `Vec A (m + n)
  < f ++ g > = <tt⁏ f , g > ⁏ append

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = <[], id >
  splitAt (suc m) = uncons
                  ⁏ second (splitAt m)
                  ⁏ assoc′
                  ⁏ first <∷>

  rot-left : ∀ m {n A} → `Vec A (m + n) `→ `Vec A (n + m)
  rot-left m = splitAt m ⁏ swap ⁏ append

  rot-right : ∀ {m} n {A} → `Vec A (m + n) `→ `Vec A (n + m)
  rot-right {m} _ = rot-left m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head<∷>
  folda (suc n) f = splitAt (2^ n) ⁏ < folda n f × folda n f > ⁏ f

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = []→[]
  concat {n = suc n} = uncons ⁏ second concat ⁏ append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = []→[]
  group (suc n) k = splitAt k ⁏ second (group n k) ⁏ <∷>

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f ⁏ concat

  replicate⊤ : ∀ n → `𝟙 `→ `Vec `𝟙 n
  replicate⊤ _ = constVec⊤ (λ _ → id) (V.replicate {A = 𝟙} _)

  open Category cat public

add mapAccum

FunUniverse/Rewiring/Linear: add mapAccum


module Denotation.Specification.Canon-Popl14 where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality
⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (dρ : ΔEnv Γ) → Change τ

-- better name is: ⟦_⟧Δ reacts to future arguments
validity : ∀ {τ Γ} (t : Term Γ τ) (dρ : ΔEnv Γ) →
  valid {τ} (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)

-- better name is: ⟦_⟧Δ reacts to free variables
correctness : ∀ {τ Γ} {t : Term Γ τ} {dρ : ΔEnv Γ}
  → ⟦ t ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ ≡ ⟦ t ⟧ (update dρ)

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

⟦_⟧Δ (intlit n) dρ = + 0
⟦_⟧Δ (add s t) dρ = ⟦ s ⟧Δ dρ + ⟦ t ⟧Δ dρ
⟦_⟧Δ (minus t) dρ = - ⟦ t ⟧Δ dρ
⟦_⟧Δ empty dρ = emptyBag
⟦_⟧Δ (insert s t) dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) dρ = ⟦ s ⟧Δ dρ ++ ⟦ t ⟧Δ dρ
⟦_⟧Δ (negate t) dρ = negateBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (flatmap s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) dρ = sumBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (var x) dρ = ⟦ x ⟧ΔVar dρ
⟦_⟧Δ (app {σ} {τ} s t) dρ =
     (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)
  (validity {σ} t dρ))
⟦_⟧Δ (abs t) dρ = λ v →
  ⟦ t ⟧Δ (v • dρ)

validVar : ∀ {τ Γ} (x : Var Γ τ) →
  ∀ {dρ : ΔEnv Γ} → valid {τ} (⟦ x ⟧ (ignore dρ)) (⟦ x ⟧ΔVar dρ)
validVar this {cons v Δv R[v,Δv] • _} = R[v,Δv]
validVar {τ} (that x) {cons _ _ _ • dρ} = validVar {τ} x

validity (intlit n)    dρ = tt
validity (add s t)     dρ = tt
validity (minus t)     dρ = tt
validity (empty)       dρ = tt
validity (insert s t)  dρ = tt
validity (union s t)   dρ = tt
validity (negate t)    dρ = tt
validity (flatmap s t) dρ = tt
validity (sum t)       dρ = tt

validity {τ} (var x) dρ = validVar {τ} x

validity (app s t) dρ =
  let
    v = ⟦ t ⟧ (ignore dρ)
    Δv = ⟦ t ⟧Δ dρ
  in
    proj₁ (validity s dρ (cons v Δv (validity t dρ)))

validity {σ ⇒ τ} (abs t) dρ = λ v →
  let
    v′ = after {σ} v
    Δv′ = v′ ⊟₍ σ ₎ v′
    dρ₁ = v • dρ
    dρ₂ = nil-valid-change σ v′ • dρ
  in
    validity t dρ₁
    ,
    (begin
      ⟦ t ⟧ (ignore dρ₂) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₂
    ≡⟨ correctness {t = t} {dρ₂} ⟩
      ⟦ t ⟧ (update dρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (update dρ₁)
    ≡⟨ sym (correctness {t = t} {dρ₁}) ⟩
      ⟦ t ⟧ (ignore dρ₁) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₁
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {dρ : ΔEnv Γ} →
  ⟦ x ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ x ⟧ΔVar dρ ≡ ⟦ x ⟧ (update dρ)
correctVar {x = this  } {cons v dv R[v,dv] • dρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] • dρ} = correctVar {x = y} {dρ}

correctness {t = intlit n} = right-id-int n
correctness {t = add s t} {dρ} = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _+_ (correctness {t = s}) (correctness {t = t}))
correctness {t = minus t} {dρ} = trans
  (-m·-n=-mn {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong -_ (correctness {t = t}))

correctness {t = empty} = right-id-bag emptyBag
correctness {t = insert s t} {dρ} =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness {t = s}))
         (correctness {t = t}) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness {t = union s t} {dρ} = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _++_ (correctness {t = s}) (correctness {t = t}))
correctness {t = negate t} {dρ} = trans
  (-a·-b=-ab {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong negateBag (correctness {t = t}))

correctness {t = flatmap s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness {t = s}) (correctness {t = t}))
correctness {t = sum t} {dρ} =
  let
    b = ⟦ t ⟧ (ignore dρ)
    Δb = ⟦ t ⟧Δ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness {t = t}))

correctness {τ} {t = var x} = correctVar {τ} {x = x}
correctness {t = app {σ} {τ} s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ (ignore dρ)
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δu = ⟦ t ⟧Δ dρ
  in
    begin
      f u ⊞₍ τ ₎ Δf (cons u Δu (validity {σ} t dρ))
    ≡⟨ sym (proj₂ (validity {σ ⇒ τ} s dρ (cons u Δu (validity {σ} t dρ)))) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} {t = s} ⟨$⟩ correctness {σ} {t = t} ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} {abs t} {dρ} = ext (λ v →
  let
    dρ′ : ΔEnv (σ • Γ)
    dρ′ = nil-valid-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ′
    ≡⟨ correctness {τ} {t = t} {dρ′} ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv
corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {dρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore dρ) ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ dρ)
      (⟦ t ⟧ (ignore dρ) ⊞₍ σ ₎ ⟦ t ⟧Δ dρ)
  ≡ (⟦ s ⟧ (ignore dρ)) (⟦ t ⟧ (ignore dρ))
    ⊞₍ τ ₎
    (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ) (validity {σ} t dρ))

corollary {σ} {τ} s t {dρ} = proj₂
  (validity {σ ⇒ τ} s dρ (cons (⟦ t ⟧ (ignore dρ))
     (⟦ t ⟧Δ dρ) (validity {σ} t dρ)))

corollary-closed : ∀ {σ τ} {t : Term ∅ (σ ⇒ τ)}
  (v : ValidChange σ)
  → ⟦ t ⟧ ∅ (after {σ} v)
  ≡ ⟦ t ⟧ ∅ (before {σ} v) ⊞₍ τ ₎ ⟦ t ⟧Δ ∅ v

corollary-closed {σ} {τ} {t = t} v =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅
  in
    begin
      f (after {σ} v)
    ≡⟨ cong (λ hole → hole (after {σ} v))
            (sym (correctness {σ ⇒ τ} {t = t})) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} v)
    ≡⟨ proj₂ (validity {σ ⇒ τ} t ∅ v) ⟩
      f (before {σ} v) ⊞₍ τ ₎ Δf v
    ∎ where open ≡-Reasoning

module Denotation.Specification.Canon-Popl14 where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality
⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (dρ : ΔEnv Γ) → Change τ

-- better name is: ⟦_⟧Δ reacts to future arguments
validity : ∀ {τ Γ} (t : Term Γ τ) (dρ : ΔEnv Γ) →
  valid {τ} (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)

-- better name is: ⟦_⟧Δ reacts to free variables
correctness : ∀ {τ Γ} {t : Term Γ τ} {dρ : ΔEnv Γ}
  → ⟦ t ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ ≡ ⟦ t ⟧ (update dρ)

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

⟦_⟧Δ (intlit n) dρ = + 0
⟦_⟧Δ (add s t) dρ = ⟦ s ⟧Δ dρ + ⟦ t ⟧Δ dρ
⟦_⟧Δ (minus t) dρ = - ⟦ t ⟧Δ dρ
⟦_⟧Δ empty dρ = emptyBag
⟦_⟧Δ (insert s t) dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) dρ = ⟦ s ⟧Δ dρ ++ ⟦ t ⟧Δ dρ
⟦_⟧Δ (negate t) dρ = negateBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (flatmap s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) dρ = sumBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (var x) dρ = ⟦ x ⟧ΔVar dρ
⟦_⟧Δ (app {σ} {τ} s t) dρ =
     (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)
  (validity {σ} t dρ))
⟦_⟧Δ (abs t) dρ = λ v →
  ⟦ t ⟧Δ (v • dρ)

validVar : ∀ {τ Γ} (x : Var Γ τ) →
  (dρ : ΔEnv Γ) → valid {τ} (⟦ x ⟧ (ignore dρ)) (⟦ x ⟧ΔVar dρ)
validVar this (cons v Δv R[v,Δv] • _) = R[v,Δv]
validVar {τ} (that x) (cons _ _ _ • dρ) = validVar {τ} x dρ

validity (intlit n)    dρ = tt
validity (add s t)     dρ = tt
validity (minus t)     dρ = tt
validity (empty)       dρ = tt
validity (insert s t)  dρ = tt
validity (union s t)   dρ = tt
validity (negate t)    dρ = tt
validity (flatmap s t) dρ = tt
validity (sum t)       dρ = tt

validity {τ} (var x) dρ = validVar {τ} x dρ

validity (app s t) dρ =
  let
    v = ⟦ t ⟧ (ignore dρ)
    Δv = ⟦ t ⟧Δ dρ
  in
    proj₁ (validity s dρ (cons v Δv (validity t dρ)))

validity {σ ⇒ τ} (abs t) dρ = λ v →
  let
    v′ = after {σ} v
    Δv′ = v′ ⊟₍ σ ₎ v′
    dρ₁ = v • dρ
    dρ₂ = nil-valid-change σ v′ • dρ
  in
    validity t dρ₁
    ,
    (begin
      ⟦ t ⟧ (ignore dρ₂) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₂
    ≡⟨ correctness {t = t} {dρ₂} ⟩
      ⟦ t ⟧ (update dρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (update dρ₁)
    ≡⟨ sym (correctness {t = t} {dρ₁}) ⟩
      ⟦ t ⟧ (ignore dρ₁) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₁
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {dρ : ΔEnv Γ} →
  ⟦ x ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ x ⟧ΔVar dρ ≡ ⟦ x ⟧ (update dρ)
correctVar {x = this  } {cons v dv R[v,dv] • dρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] • dρ} = correctVar {x = y} {dρ}

correctness {t = intlit n} = right-id-int n
correctness {t = add s t} {dρ} = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _+_ (correctness {t = s}) (correctness {t = t}))
correctness {t = minus t} {dρ} = trans
  (-m·-n=-mn {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong -_ (correctness {t = t}))

correctness {t = empty} = right-id-bag emptyBag
correctness {t = insert s t} {dρ} =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness {t = s}))
         (correctness {t = t}) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness {t = union s t} {dρ} = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _++_ (correctness {t = s}) (correctness {t = t}))
correctness {t = negate t} {dρ} = trans
  (-a·-b=-ab {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong negateBag (correctness {t = t}))

correctness {t = flatmap s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness {t = s}) (correctness {t = t}))
correctness {t = sum t} {dρ} =
  let
    b = ⟦ t ⟧ (ignore dρ)
    Δb = ⟦ t ⟧Δ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness {t = t}))

correctness {τ} {t = var x} = correctVar {τ} {x = x}
correctness {t = app {σ} {τ} s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ (ignore dρ)
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δu = ⟦ t ⟧Δ dρ
  in
    begin
      f u ⊞₍ τ ₎ Δf (cons u Δu (validity {σ} t dρ))
    ≡⟨ sym (proj₂ (validity {σ ⇒ τ} s dρ (cons u Δu (validity {σ} t dρ)))) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} {t = s} ⟨$⟩ correctness {σ} {t = t} ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} {abs t} {dρ} = ext (λ v →
  let
    dρ′ : ΔEnv (σ • Γ)
    dρ′ = nil-valid-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ′
    ≡⟨ correctness {τ} {t = t} {dρ′} ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv
corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {dρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore dρ) ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ dρ)
      (⟦ t ⟧ (ignore dρ) ⊞₍ σ ₎ ⟦ t ⟧Δ dρ)
  ≡ (⟦ s ⟧ (ignore dρ)) (⟦ t ⟧ (ignore dρ))
    ⊞₍ τ ₎
    (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ) (validity {σ} t dρ))

corollary {σ} {τ} s t {dρ} = proj₂
  (validity {σ ⇒ τ} s dρ (cons (⟦ t ⟧ (ignore dρ))
     (⟦ t ⟧Δ dρ) (validity {σ} t dρ)))

corollary-closed : ∀ {σ τ} {t : Term ∅ (σ ⇒ τ)}
  (v : ValidChange σ)
  → ⟦ t ⟧ ∅ (after {σ} v)
  ≡ ⟦ t ⟧ ∅ (before {σ} v) ⊞₍ τ ₎ ⟦ t ⟧Δ ∅ v

corollary-closed {σ} {τ} {t = t} v =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅
  in
    begin
      f (after {σ} v)
    ≡⟨ cong (λ hole → hole (after {σ} v))
            (sym (correctness {σ ⇒ τ} {t = t})) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} v)
    ≡⟨ proj₂ (validity {σ ⇒ τ} t ∅ v) ⟩
      f (before {σ} v) ⊞₍ τ ₎ Δf v
    ∎ where open ≡-Reasoning

Make some arguments of validVar explicit.

Old-commit-hash: dc6d178e02b8bdd4f772dddbba1bf337f3b1d74c


open import Data.Bool
open import Data.List
open import Data.Nat

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

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

_∈_ : ℕ → List ℕ → Bool
x ∈ []       = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) ∧ (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []       = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) ∨ (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ []))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ []

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ []) (5 ∷ 3 ∷ 7 ∷ 7 ∷ [])) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (5 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ []) (6 ∷ 3 ∷ [])) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (6 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ []) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ []) (3 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ [])) ∷
  (model (10 ∷ 9 ∷ []) (1 ∷ [])) ∷
  (model (3 ∷ 4 ∷ 11 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 7 ∷ 1 ∷ []) (4 ∷ 11 ∷ 8 ∷ [])) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ []) (11 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ []) (11 ∷ 3 ∷ [])) ∷
  (model (3 ∷ 6 ∷ 5 ∷ []) ([])) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ []) (12 ∷ [])) ∷ []

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

main = (closure proofs (5 ∷ []))

open import Agda.Builtin.Bool

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

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

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

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

infixr 5 _∷_

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A
{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  ∘    #-}
{-# BUILTIN CONS _∷_  #-}

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ ∘

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (5 ∷ 3 ∷ 7 ∷ 7 ∷ ∘)) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (5 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (6 ∷ 3 ∷ ∘)) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (6 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ ∘) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ ∘) (3 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ ∘)) ∷
  (model (10 ∷ 9 ∷ ∘) (1 ∷ ∘)) ∷
  (model (3 ∷ 4 ∷ 11 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 7 ∷ 1 ∷ ∘) (4 ∷ 11 ∷ 8 ∷ ∘)) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ ∘) (11 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ ∘) (11 ∷ 3 ∷ ∘)) ∷
  (model (3 ∷ 6 ∷ 5 ∷ ∘) (∘)) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ ∘) (12 ∷ ∘)) ∷ ∘

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

main = (closure proofs (5 ∷ ∘))

Revert "Convert to stdlib"

Revert "Convert to stdlib"

This reverts commit 68af677d56d4f0a4c1aaa95134ae06f0813500c1.


import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

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

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

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    Change-base : Base → Set
    valid-base : ∀ {ι} → ⟦ ι ⟧Base → Change-base ι → Set
    apply-change-base : ∀ ι → ⟦ ι ⟧Base → Change-base ι → ⟦ ι ⟧Base
    diff-change-base : ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → Change-base ι
    R[v,u-v]-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → valid-base {ι} v (diff-change-base ι u v)
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-change-base ι v (diff-change-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  Change : Type → Set
  valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set

  apply-change : ∀ τ → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  diff-change : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ

  infixl 6 apply-change diff-change -- as with + - in GHC.Num
  syntax apply-change τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-change τ u v = u ⊟₍ τ ₎ v

  -- Lemma diff-is-valid
  R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟₍ τ ₎ v)

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (Change τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (Change (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- Change τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
  ValidChange : Type → Set
  ValidChange τ = Triple
    ⟦ τ ⟧
    (λ _ → Change τ)
    (λ v dv → valid {τ} v dv)

  -- Change : Type → Set
  Change (base ι) = Change-base ι
  Change (σ ⇒ τ) = ValidChange σ → Change τ

  before : ValidChange ⊆ ⟦_⟧
  before (cons v _ _) = v

  after : ValidChange ⊆ ⟦_⟧
  after {τ} (cons v dv R[v,dv]) = v ⊞₍ τ ₎ dv

  change : ValidChange ⊆ Change
  change (cons _ dv _) = dv

  diff-valid-change : ∀ τ → (u v : ⟦ τ ⟧) → ValidChange τ
  diff-valid-change τ u v = cons v (u ⊟₍ τ ₎ v) (R[v,u-v] {τ} {u} {v})

  nil-valid-change : ∀ τ → ⟦ τ ⟧ → ValidChange τ
  nil-valid-change τ v = diff-valid-change τ v v

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  n ⊞₍ base ι ₎ Δn = apply-change-base ι n Δn
  f ⊞₍ σ ⇒ τ ₎ Δf = λ v → f v ⊞₍ τ ₎ Δf (nil-valid-change σ v)

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  m ⊟₍ base ι ₎ n = diff-change-base ι m n
  g ⊟₍ σ ⇒ τ ₎ f = λ v → g (after v) ⊟₍ τ ₎ f (before v)

  -- valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set
  valid {base ι} n Δn = valid-base {ι} n Δn
  valid {σ ⇒ τ} f Δf =
    ∀ (v : ValidChange σ)
    → valid {τ} (f (before v)) (Δf v)
    -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
    × (f ⊞₍ σ ⇒ τ ₎ Δf) (after v) ≡ f (before v) ⊞₍ τ ₎ Δf v

  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  R[v,u-v] {base ι} {u} {v} = R[v,u-v]-base {ι} {u} {v}
  R[v,u-v] {σ ⇒ τ} {u} {v} = λ w →
    let
      w′ = after {σ} w
    in
      R[v,u-v] {τ}
      ,
      (begin
        (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w′
      ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
        u w′
      ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v (before {σ} w)}) ⟩
        v (before {σ} w) ⊞₍ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v) w
      ∎) where open ≡-Reasoning

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  -- applicative structure
  call-valid-change : ∀ σ τ →
    ValidChange (σ ⇒ τ) →
    ValidChange σ →
    ValidChange τ
  call-valid-change σ τ (cons f Δf R[f,Δf]) Δv =
    cons (f (before {σ} Δv)) (Δf Δv) (proj₁ (R[f,Δf] Δv))

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  ΔEnv : Context → Set
  ΔEnv = DependentList ValidChange

  ignore : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  ignore = map (λ {τ} → before {τ})

  update : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  update = map (λ {τ} → after {τ})

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

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

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

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    Change-base : Base → Set
    valid-base : ∀ {ι} → ⟦ ι ⟧Base → Change-base ι → Set
    apply-change-base : ∀ ι → ⟦ ι ⟧Base → Change-base ι → ⟦ ι ⟧Base
    diff-change-base : ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → Change-base ι
    R[v,u-v]-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → valid-base {ι} v (diff-change-base ι u v)
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-change-base ι v (diff-change-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  Change : Type → Set
  valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set

  apply-change : ∀ τ → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  diff-change : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ

  infixl 6 apply-change diff-change -- as with + - in GHC.Num
  syntax apply-change τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-change τ u v = u ⊟₍ τ ₎ v

  -- Lemma diff-is-valid
  R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟₍ τ ₎ v)

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (Change τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (Change (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- Change τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
  ValidChange : Type → Set
  ValidChange τ = Triple
    ⟦ τ ⟧
    (λ _ → Change τ)
    (λ v dv → valid {τ} v dv)

  -- Change : Type → Set
  Change (base ι) = Change-base ι
  Change (σ ⇒ τ) = ValidChange σ → Change τ

  before : ValidChange ⊆ ⟦_⟧
  before (cons v _ _) = v

  after : ValidChange ⊆ ⟦_⟧
  after {τ} (cons v dv R[v,dv]) = v ⊞₍ τ ₎ dv

  change : ValidChange ⊆ Change
  change (cons _ dv _) = dv

  apply-valid-change : ∀ τ → (v : ⟦ τ ⟧) (dv : ValidChange τ) → ⟦ τ ⟧
  apply-valid-change τ v dv = apply-change τ v (change dv)

  diff-valid-change : ∀ τ → (u v : ⟦ τ ⟧) → ValidChange τ
  diff-valid-change τ u v = cons v (u ⊟₍ τ ₎ v) (R[v,u-v] {τ} {u} {v})

  nil-valid-change : ∀ τ → ⟦ τ ⟧ → ValidChange τ
  nil-valid-change τ v = diff-valid-change τ v v

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  n ⊞₍ base ι ₎ Δn = apply-change-base ι n Δn
  f ⊞₍ σ ⇒ τ ₎ Δf = λ v → f v ⊞₍ τ ₎ Δf (nil-valid-change σ v)

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  m ⊟₍ base ι ₎ n = diff-change-base ι m n
  g ⊟₍ σ ⇒ τ ₎ f = λ v → g (after v) ⊟₍ τ ₎ f (before v)

  -- valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set
  valid {base ι} n Δn = valid-base {ι} n Δn
  valid {σ ⇒ τ} f Δf =
    ∀ (v : ValidChange σ)
    → valid {τ} (f (before v)) (Δf v)
    -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
    × (f ⊞₍ σ ⇒ τ ₎ Δf) (after v) ≡ f (before v) ⊞₍ τ ₎ Δf v

  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  R[v,u-v] {base ι} {u} {v} = R[v,u-v]-base {ι} {u} {v}
  R[v,u-v] {σ ⇒ τ} {u} {v} = λ w →
    let
      w′ = after {σ} w
    in
      R[v,u-v] {τ}
      ,
      (begin
        (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w′
      ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
        u w′
      ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v (before {σ} w)}) ⟩
        v (before {σ} w) ⊞₍ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v) w
      ∎) where open ≡-Reasoning

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  -- applicative structure
  call-valid-change : ∀ σ τ →
    ValidChange (σ ⇒ τ) →
    ValidChange σ →
    ValidChange τ
  call-valid-change σ τ (cons f Δf R[f,Δf]) Δv =
    cons (f (before {σ} Δv)) (Δf Δv) (proj₁ (R[f,Δf] Δv))

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  ΔEnv : Context → Set
  ΔEnv = DependentList ValidChange

  ignore : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  ignore = map (λ {τ} → before {τ})

  update : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  update = map (λ {τ} → after {τ})

Implement apply-valid-change.

Implement apply-valid-change.

Old-commit-hash: 64cc4483b462c94a945aa312124cbdf090ffd619


module incremental where

open import Relation.Binary.PropositionalEquality

open import meaning

-- SIMPLE TYPES

-- Syntax

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

  -- `Δ τ` is the type of changes to `τ`
  Δ : (τ : Type) → Type

infixr 5 _⇒_

-- Denotational Semantics

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

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

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

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

  -- `Δ x t` maps changes in `x` to changes in `t`
  Δ : ∀ {Γ τ₁ τ₂} → (x : Var Γ τ₁) → (t : Term Γ τ₂) → Term Γ (Δ τ₁ ⇒ Δ τ₂)

-- Denotational Semantics

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

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

-- 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 {Γ₁} {Γ₂} (Δ x t) = Δ (lift {Γ₁} {Γ₂} x) (weaken {Γ₁} {Γ₂} t)

module incremental where

open import Relation.Binary.PropositionalEquality

open import meaning

-- SIMPLE TYPES

-- Syntax

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

  -- `Δ τ` is the type of changes to `τ`
  Δ : (τ : Type) → Type

infixr 5 _⇒_

-- Denotational Semantics

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

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

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

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

  -- `Δ x dx t` maps changes `dx` in `x` to changes in `t`
  Δ : ∀ {Γ τ₁ τ₂} → (x : Var Γ τ₁) (dx : Var Γ (Δ τ₁)) → (t : Term Γ τ₂) → Term Γ (Δ τ₂)

-- Denotational Semantics

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

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

-- 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 {Γ₁} {Γ₂} (Δ x dx t) = Δ (lift {Γ₁} {Γ₂} x) (lift {Γ₁} {Γ₂} dx) (weaken {Γ₁} {Γ₂} t)

Change Δ to expect the change in a free variable.

Proposed by Paolo in a whiteboard discussion today.

Old-commit-hash: bce0357c249c6ae66ad8fe002147ad07623d842f


module Relation.Nullary.NP where

open import Type
open import Data.Sum
open import Relation.Nullary public

module _ {a b} {A : ★_ a} {B : ★_ b} where
    Dec-⊎ : Dec A → Dec B → Dec (A ⊎ B)
    Dec-⊎ (yes p) _       = yes (inj₁ p)
    Dec-⊎ (no ¬p) (yes p) = yes (inj₂ p)
    Dec-⊎ (no ¬p) (no ¬q) = no [ ¬p , ¬q ]

    module _ (to : A → B)(from : B → A) where

      map-Dec : Dec A → Dec B
      map-Dec (yes p) = yes (to p)
      map-Dec (no ¬p) = no (λ z → ¬p (from z))

module Relation.Nullary.NP where

open import Type
open import Function
open import Data.Zero
open import Data.One
open import Data.Sum
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Nullary public

Dec-𝟘 : Dec 𝟘
Dec-𝟘 = no id

Dec-𝟙 : Dec 𝟙
Dec-𝟙 = yes _

module _ {a b} {A : ★_ a} {B : ★_ b} where
    Dec-⊎ : Dec A → Dec B → Dec (A ⊎ B)
    Dec-⊎ (yes p) _       = yes (inj₁ p)
    Dec-⊎ (no ¬p) (yes q) = yes (inj₂ q)
    Dec-⊎ (no ¬p) (no ¬q) = no [ ¬p , ¬q ]

    Dec-× : Dec A → Dec B → Dec (A × B)
    Dec-× (no ¬p) _       = no  (¬p ∘ fst)
    Dec-× (yes _) (no ¬q) = no  (¬q ∘ snd)
    Dec-× (yes p) (yes q) = yes (p , q)

    Dec-→ : Dec A → Dec B → Dec (A → B)
    Dec-→ _       (yes q) = yes (λ _ → q)
    Dec-→ (no ¬p) _       = yes (𝟘-elim ∘ ¬p)
    Dec-→ (yes p) (no ¬q) = no  (λ f → ¬q (f p))

    module _ (to : A → B)(from : B → A) where

      map-Dec : Dec A → Dec B
      map-Dec (yes p) = yes (to p)
      map-Dec (no ¬p) = no  (¬p ∘ from)

add Dec-{𝟘,𝟙,×,→}

Dec: add Dec-{𝟘,𝟙,×,→}


module one-time-semantic-security where

open import Function
open import Data.Nat
open import Data.Product
open import Data.Vec using (splitAt; take; drop)
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≗_)

open import Data.Bits

open import flat-funs
open import program-distance
open import flipbased-implem

-- Capture the various size parameters required
-- for a cipher.
--
-- M  is the message space (|M| is the size of messages)
-- C  is the cipher text space
-- Rᵉ is the randomness used by the cipher.
record EncParams : Set where
  constructor mk
  field
    |M| |C| |R|ᵉ : ℕ

  M  = Bits |M|
  C  = Bits |C|
  Rᵉ = Bits |R|ᵉ

  -- The type of the encryption function
  Enc : Set
  Enc = M → ↺ |R|ᵉ C

module EncParams² (ep₀ ep₁ : EncParams) where
  open EncParams ep₀ public using ()
    renaming (|M| to |M|₀; |C| to |C|₀; |R|ᵉ to |R|ᵉ₀; M to M₀;
              C to C₀; Rᵉ to Rᵉ₀; Enc to Enc₀)
  open EncParams ep₁ public using ()
    renaming (|M| to |M|₁; |C| to |C|₁; |R|ᵉ to |R|ᵉ₁; M to M₁;
              C to C₁; Rᵉ to Rᵉ₁; Enc to Enc₁)
  Tr   = Enc₀ → Enc₁
  Tr⁻¹ = Enc₁ → Enc₀

module EncParams²-same-|R|ᵉ (ep₀ : EncParams) (|M|₁ |C|₁ : ℕ) where
  ep₁ = EncParams.mk |M|₁ |C|₁ (EncParams.|R|ᵉ ep₀)
  open EncParams² ep₀ ep₁ public

module ♭EncParams {t} {T : Set t}
                  (♭Funs : FlatFuns T)
                  (ep : EncParams) where
  open FlatFuns ♭Funs
  open EncParams ep public

  `M  = `Bits |M|
  `C  = `Bits |C|
  `Rᵉ = `Bits |R|ᵉ

module AbsSemSec {t} {T : Set t}
                 (♭Funs : FlatFuns T) where

  open FlatFuns ♭Funs

  record SemSecAdv (ep : EncParams) |R|ᵃ : Set where
    constructor mk

    open ♭EncParams ♭Funs ep

    field
      {|S|} : ℕ

    `S  = `Bits |S|
    S   =  Bits |S|

    -- Randomness adversary
    `Rᵃ = `Bits |R|ᵃ
    Rᵃ  =  Bits |R|ᵃ

    field
      step₀ : `Rᵃ `→ (`M `× `M) `× `S
      step₁ : `C `× `S `→ `Bit

    M²  = Bit → M
    `M² = `Bit `→ `M

    module Ops (♭ops : FlatFunsOps ♭Funs) where
      open FlatFunsOps ♭ops
      observe : `C `× `Rᵃ `→ (`M `× `M) `× `Bit
      observe = idO *** step₀ >>> ⟨C,⟨M,S⟩⟩→⟨M¸⟨C,S⟩⟩ >>> idO *** step₁
        where ⟨C,⟨M,S⟩⟩→⟨M¸⟨C,S⟩⟩ = < snd >>> fst , < fst , snd >>> snd > >

    open ♭EncParams ♭Funs ep public

  SemSecReduction : ∀ ep₀ ep₁ (f : Coins → Coins) → Set
  SemSecReduction ep₀ ep₁ f = ∀ {c} → SemSecAdv ep₀ c → SemSecAdv ep₁ (f c)

-- Here we use Agda functions for FlatFuns.
module FunSemSec (prgDist : PrgDist) where
  open PrgDist prgDist
  open AbsSemSec fun♭Funs
  open FlatFunsOps fun♭Ops

  module FunSemSecAdv {ep : EncParams} {|R|ᵃ} (A : SemSecAdv ep |R|ᵃ) where
    open SemSecAdv A public
    open Ops fun♭Ops public

    step₀F : Rᵃ → (M² × S)
    step₀F = step₀ >>> proj *** idO

    step₀↺ : ↺ |R|ᵃ (M² × S)
    step₀↺ = mk step₀F

    step₁F : S → C → Bit
    step₁F s c = step₁ (c , s)

  module RunSemSec (ep : EncParams) where
    open EncParams ep using (M; C; |R|ᵉ; Enc)

    -- Returing 0 means Chal wins, Adv looses
    --          1 means Adv  wins, Chal looses
    runSemSec : ∀ {|R|ᵃ} (E : Enc) (A : SemSecAdv ep |R|ᵃ) b → ↺ (|R|ᵃ + |R|ᵉ) Bit
    runSemSec E A b
      = A-step₀ >>= λ { (m , s) → map↺ (A-step₁ s) (E (m b)) }
      where open FunSemSecAdv A renaming (step₀↺ to A-step₀; step₁F to A-step₁)

    _⇄_ : ∀ {|R|ᵃ} (E : Enc) (A : SemSecAdv ep |R|ᵃ) b → ↺ (|R|ᵃ + |R|ᵉ) Bit
    _⇄_ = runSemSec

    _≗A_ : ∀ {p} (A₁ A₂ : SemSecAdv ep p) → Set
    A₀ ≗A A₁ = observe A₀ ≗ observe A₁
      where open FunSemSecAdv

    change-adv : ∀ {ca E} {A₁ A₂ : SemSecAdv ep ca} → A₁ ≗A A₂ → (E ⇄ A₁) ≗⅁ (E ⇄ A₂)
    change-adv {ca = ca} {A₁ = _} {_} pf b R with splitAt ca R
    change-adv {E = E} {A₁} {A₂} pf b ._ | pre Σ., post , ≡.refl = ≡.trans (≡.cong proj₂ (helper₀ A₁)) helper₂
       where open FunSemSecAdv
             helper₀ = λ A → pf (run↺ (E (proj (proj₁ (step₀ A pre)) b)) post , pre)
             helper₂ = ≡.cong (λ m → step₁ A₂ (run↺ (E (proj (proj₁ m) b)) post , proj₂ (step₀ A₂ pre)))
                              (helper₀ A₂)

    _≗E_ : ∀ (E₀ E₁ : Enc) → Set
    E₀ ≗E E₁ = ∀ m → E₀ m ≗↺ E₁ m

    ≗E→≗⅁ : ∀ {E₀ E₁} → E₀ ≗E E₁ → ∀ {c} (A : SemSecAdv ep c)
               → (E₀ ⇄ A) ≗⅁ (E₁ ⇄ A)
    ≗E→≗⅁ E₀≗E₁ {c} A b R
      rewrite E₀≗E₁ (proj (proj₁ (SemSecAdv.step₀ A (take c R))) b) (drop c R) = ≡.refl

    ≗E→⇓ : ∀ {E₀ E₁} → E₀ ≗E E₁ → ∀ {c} (A : SemSecAdv ep c) → (E₀ ⇄ A) ⇓ (E₁ ⇄ A)
    ≗E→⇓ E₀≗E₁ A = extensional-reduction (≗E→≗⅁ E₀≗E₁ A)

  module SemSecReductions (ep₀ ep₁ : EncParams) (f : Coins → Coins) where
    open EncParams² ep₀ ep₁
    open RunSemSec ep₀ public using () renaming (_⇄_ to _⇄₀_; _≗E_ to _≗E₀_; ≗E→⇓ to ≗E→⇓₀)
    open RunSemSec ep₁ public using () renaming (_⇄_ to _⇄₁_; _≗E_ to _≗E₁_; ≗E→⇓ to ≗E→⇓₁)

    Reduction : Set
    Reduction = SemSecReduction ep₁ ep₀ f

    SemSecTr : Tr → Set
    SemSecTr tr =
      ∃ λ (red : Reduction) →
        ∀ E {c} A → (tr E ⇄₁ A) ⇓ (E ⇄₀ red {c} A)

    SemSecTr⁻¹ : Tr⁻¹ → Set
    SemSecTr⁻¹ tr⁻¹ =
      ∃ λ (red : Reduction) →
        ∀ E {c} A → (E ⇄₁ A) ⇓ (tr⁻¹ E ⇄₀ red {c} A)

    SemSecTr→SemSecTr⁻¹ : ∀ tr tr⁻¹ (tr-right-inv : ∀ E → tr (tr⁻¹ E) ≗E₁ E)
                          → SemSecTr tr → SemSecTr⁻¹ tr⁻¹
    SemSecTr→SemSecTr⁻¹ _ tr⁻¹ tr-inv (red , pf) = red , helper
      where helper : ∀ E {c} A → (E ⇄₁ A) ⇓ (tr⁻¹ E ⇄₀ red {c} A)
            helper E A A-breaks-E = pf (tr⁻¹ E) A A-breaks-tr-tr⁻¹-E
              where A-breaks-tr-tr⁻¹-E = ≗E→⇓₁ (λ m R → ≡.sym (tr-inv E m R)) A A-breaks-E

    SemSecTr⁻¹→SemSecTr : ∀ tr tr⁻¹ (tr-left-inv : ∀ E → tr⁻¹ (tr E) ≗E₀ E)
                          → SemSecTr⁻¹ tr⁻¹ → SemSecTr tr
    SemSecTr⁻¹→SemSecTr tr _ tr-inv (red , pf) = red , helper
      where helper : ∀ E {c} A → (tr E ⇄₁ A) ⇓ (E ⇄₀ red {c} A)
            helper E {c} A A-breaks-E = ≗E→⇓₀ (tr-inv E) (red A) (pf (tr E) A A-breaks-E)

module one-time-semantic-security where

open import Function
open import Data.Nat
open import Data.Product using (∃; module Σ; _×_; _,_; proj₁; proj₂)
open import Data.Vec using (splitAt; take; drop)
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≗_)

open import Data.Bits

open import flat-funs
open import program-distance
open import flipbased-implem

-- Capture the various size parameters required
-- for a cipher.
--
-- M  is the message space (|M| is the size of messages)
-- C  is the cipher text space
-- Rᵉ is the randomness used by the cipher.
record EncParams : Set where
  constructor mk
  field
    |M| |C| |R|ᵉ : ℕ

  M  = Bits |M|
  C  = Bits |C|
  Rᵉ = Bits |R|ᵉ

  -- The type of the encryption function
  Enc : Set
  Enc = M → ↺ |R|ᵉ C

module EncParams² (ep₀ ep₁ : EncParams) where
  open EncParams ep₀ public using ()
    renaming (|M| to |M|₀; |C| to |C|₀; |R|ᵉ to |R|ᵉ₀; M to M₀;
              C to C₀; Rᵉ to Rᵉ₀; Enc to Enc₀)
  open EncParams ep₁ public using ()
    renaming (|M| to |M|₁; |C| to |C|₁; |R|ᵉ to |R|ᵉ₁; M to M₁;
              C to C₁; Rᵉ to Rᵉ₁; Enc to Enc₁)
  Tr   = Enc₀ → Enc₁
  Tr⁻¹ = Enc₁ → Enc₀

module EncParams²-same-|R|ᵉ (ep₀ : EncParams) (|M|₁ |C|₁ : ℕ) where
  ep₁ = EncParams.mk |M|₁ |C|₁ (EncParams.|R|ᵉ ep₀)
  open EncParams² ep₀ ep₁ public

module ♭EncParams {t} {T : Set t}
                  (♭Funs : FlatFuns T)
                  (ep : EncParams) where
  open FlatFuns ♭Funs
  open EncParams ep public

  `M  = `Bits |M|
  `C  = `Bits |C|
  `Rᵉ = `Bits |R|ᵉ

module ♭EncParams² {t} {T : Set t}
                   (♭Funs : FlatFuns T)
                   (ep₀ ep₁ : EncParams) where
  open EncParams² ep₀ ep₁ public
  open ♭EncParams ♭Funs ep₀ public using () renaming (`M to `M₀; `C to `C₀; `Rᵉ to `Rᵉ₀)
  open ♭EncParams ♭Funs ep₁ public using () renaming (`M to `M₁; `C to `C₁; `Rᵉ to `Rᵉ₁)

module AbsSemSec {t} {T : Set t}
                 (♭Funs : FlatFuns T) where

  open FlatFuns ♭Funs

  record SemSecAdv (ep : EncParams) |R|ᵃ : Set where
    constructor mk

    open ♭EncParams ♭Funs ep

    field
      {|S|} : ℕ

    `S  = `Bits |S|
    S   =  Bits |S|

    -- Randomness adversary
    `Rᵃ = `Bits |R|ᵃ
    Rᵃ  =  Bits |R|ᵃ

    field
      step₀ : `Rᵃ `→ (`M `× `M) `× `S
      step₁ : `C `× `S `→ `Bit

    M²  = Bit → M
    `M² = `Bit `→ `M

    module Ops (♭ops : FlatFunsOps ♭Funs) where
      open FlatFunsOps ♭ops
      observe : `C `× `Rᵃ `→ (`M `× `M) `× `Bit
      observe = idO *** step₀ >>> ⟨C,⟨M,S⟩⟩→⟨M¸⟨C,S⟩⟩ >>> idO *** step₁
        where ⟨C,⟨M,S⟩⟩→⟨M¸⟨C,S⟩⟩ = < snd >>> fst , < fst , snd >>> snd > >

    open ♭EncParams ♭Funs ep public

  SemSecReduction : ∀ ep₀ ep₁ (f : Coins → Coins) → Set
  SemSecReduction ep₀ ep₁ f = ∀ {c} → SemSecAdv ep₀ c → SemSecAdv ep₁ (f c)

-- Here we use Agda functions for FlatFuns.
module FunSemSec (prgDist : PrgDist) where
  open PrgDist prgDist
  open AbsSemSec fun♭Funs
  open FlatFunsOps fun♭Ops

  module FunSemSecAdv {ep : EncParams} {|R|ᵃ} (A : SemSecAdv ep |R|ᵃ) where
    open SemSecAdv A public
    open Ops fun♭Ops public

    step₀F : Rᵃ → (M² × S)
    step₀F = step₀ >>> proj *** idO

    step₀↺ : ↺ |R|ᵃ (M² × S)
    step₀↺ = mk step₀F

    step₁F : S → C → Bit
    step₁F s c = step₁ (c , s)

  module RunSemSec (ep : EncParams) where
    open EncParams ep using (M; C; |R|ᵉ; Enc)

    -- Returing 0 means Chal wins, Adv looses
    --          1 means Adv  wins, Chal looses
    runSemSec : ∀ {|R|ᵃ} (E : Enc) (A : SemSecAdv ep |R|ᵃ) b → ↺ (|R|ᵃ + |R|ᵉ) Bit
    runSemSec E A b
      = A-step₀ >>= λ { (m , s) → map↺ (A-step₁ s) (E (m b)) }
      where open FunSemSecAdv A renaming (step₀↺ to A-step₀; step₁F to A-step₁)

    _⇄_ : ∀ {|R|ᵃ} (E : Enc) (A : SemSecAdv ep |R|ᵃ) b → ↺ (|R|ᵃ + |R|ᵉ) Bit
    _⇄_ = runSemSec

    _≗A_ : ∀ {p} (A₁ A₂ : SemSecAdv ep p) → Set
    A₀ ≗A A₁ = observe A₀ ≗ observe A₁
      where open FunSemSecAdv

    change-adv : ∀ {ca E} {A₁ A₂ : SemSecAdv ep ca} → A₁ ≗A A₂ → (E ⇄ A₁) ≗⅁ (E ⇄ A₂)
    change-adv {ca = ca} {A₁ = _} {_} pf b R with splitAt ca R
    change-adv {E = E} {A₁} {A₂} pf b ._ | pre Σ., post , ≡.refl = ≡.trans (≡.cong proj₂ (helper₀ A₁)) helper₂
       where open FunSemSecAdv
             helper₀ = λ A → pf (run↺ (E (proj (proj₁ (step₀ A pre)) b)) post , pre)
             helper₂ = ≡.cong (λ m → step₁ A₂ (run↺ (E (proj (proj₁ m) b)) post , proj₂ (step₀ A₂ pre)))
                              (helper₀ A₂)

    _≗E_ : ∀ (E₀ E₁ : Enc) → Set
    E₀ ≗E E₁ = ∀ m → E₀ m ≗↺ E₁ m

    ≗E→≗⅁ : ∀ {E₀ E₁} → E₀ ≗E E₁ → ∀ {c} (A : SemSecAdv ep c)
               → (E₀ ⇄ A) ≗⅁ (E₁ ⇄ A)
    ≗E→≗⅁ E₀≗E₁ {c} A b R
      rewrite E₀≗E₁ (proj (proj₁ (SemSecAdv.step₀ A (take c R))) b) (drop c R) = ≡.refl

    ≗E→⇓ : ∀ {E₀ E₁} → E₀ ≗E E₁ → ∀ {c} (A : SemSecAdv ep c) → (E₀ ⇄ A) ⇓ (E₁ ⇄ A)
    ≗E→⇓ E₀≗E₁ A = extensional-reduction (≗E→≗⅁ E₀≗E₁ A)

  module SemSecReductions (ep₀ ep₁ : EncParams) (f : Coins → Coins) where
    open EncParams² ep₀ ep₁
    open RunSemSec ep₀ public using () renaming (_⇄_ to _⇄₀_; _≗E_ to _≗E₀_; ≗E→⇓ to ≗E→⇓₀)
    open RunSemSec ep₁ public using () renaming (_⇄_ to _⇄₁_; _≗E_ to _≗E₁_; ≗E→⇓ to ≗E→⇓₁)

    Reduction : Set
    Reduction = SemSecReduction ep₁ ep₀ f

    SemSecTr : Tr → Set
    SemSecTr tr =
      ∃ λ (red : Reduction) →
        ∀ E {c} A → (tr E ⇄₁ A) ⇓ (E ⇄₀ red {c} A)

    SemSecTr⁻¹ : Tr⁻¹ → Set
    SemSecTr⁻¹ tr⁻¹ =
      ∃ λ (red : Reduction) →
        ∀ E {c} A → (E ⇄₁ A) ⇓ (tr⁻¹ E ⇄₀ red {c} A)

    SemSecTr→SemSecTr⁻¹ : ∀ tr tr⁻¹ (tr-right-inv : ∀ E → tr (tr⁻¹ E) ≗E₁ E)
                          → SemSecTr tr → SemSecTr⁻¹ tr⁻¹
    SemSecTr→SemSecTr⁻¹ _ tr⁻¹ tr-inv (red , pf) = red , helper
      where helper : ∀ E {c} A → (E ⇄₁ A) ⇓ (tr⁻¹ E ⇄₀ red {c} A)
            helper E A A-breaks-E = pf (tr⁻¹ E) A A-breaks-tr-tr⁻¹-E
              where A-breaks-tr-tr⁻¹-E = ≗E→⇓₁ (λ m R → ≡.sym (tr-inv E m R)) A A-breaks-E

    SemSecTr⁻¹→SemSecTr : ∀ tr tr⁻¹ (tr-left-inv : ∀ E → tr⁻¹ (tr E) ≗E₀ E)
                          → SemSecTr⁻¹ tr⁻¹ → SemSecTr tr
    SemSecTr⁻¹→SemSecTr tr _ tr-inv (red , pf) = red , helper
      where helper : ∀ E {c} A → (tr E ⇄₁ A) ⇓ (E ⇄₀ red {c} A)
            helper E {c} A A-breaks-E = ≗E→⇓₀ (tr-inv E) (red A) (pf (tr E) A A-breaks-E)

add ♭EncParams²

one-time-semantic-security: add ♭EncParams²


-- NOTE with-K
module Data.Fin.Logical where

open import Data.Nat.Param.Binary
open import Data.Fin.Param.Binary

open import Function
open import Data.Fin
open import Relation.Binary
open import Relation.Binary.Logical

private
  module ⟦ℕ⟧s = Setoid ⟦ℕ⟧-setoid

{-
data ⟦Fin⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦★₀⟧) Fin Fin where
  ⟦zero⟧ : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} → ⟦Fin⟧ (suc nᵣ) zero zero
  ⟦suc⟧  : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} {x₁ x₂} (xᵣ : ⟦Fin⟧ nᵣ x₁ x₂) → ⟦Fin⟧ (suc nᵣ) (suc x₁) (suc x₂)
-}

private
  refl : ∀ {n} → Reflexive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  refl {x = zero}  = ⟦zero⟧
  refl {x = suc _} = ⟦suc⟧ refl

  sym : ∀ {n} → Symmetric (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  sym ⟦zero⟧ = ⟦zero⟧
  sym (⟦suc⟧ xᵣ) = ⟦suc⟧ (sym xᵣ)

  trans : ∀ {n} → Transitive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  trans ⟦zero⟧ xᵣ = xᵣ
  trans (⟦suc⟧ xᵣ) (⟦suc⟧ yᵣ) = ⟦suc⟧ (trans xᵣ yᵣ)

  subst : ∀ {ℓ n} → Substitutive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl) ℓ
  subst _ ⟦zero⟧    = id
  subst P (⟦suc⟧ xᵣ) = subst (P ∘ suc) xᵣ

  isEquivalence : ∀ {n} → IsEquivalence (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  isEquivalence = record { refl = refl; sym = sym; trans = trans }

{-# OPTIONS --with-K #-}
module Data.Fin.Logical where

open import Data.Nat.Logical
open import Data.Nat.Param.Binary
-- open import Data.Fin.Param.Binary

open import Function
open import Data.Fin
open import Relation.Binary
open import Relation.Binary.Logical

private
  module ⟦ℕ⟧s = Setoid ⟦ℕ⟧-setoid

data ⟦Fin⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦★₀⟧) Fin Fin where
  ⟦zero⟧ : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} → ⟦Fin⟧ (⟦suc⟧ nᵣ) zero zero
  ⟦suc⟧  : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} {x₁ x₂} (xᵣ : ⟦Fin⟧ nᵣ x₁ x₂) → ⟦Fin⟧ (⟦suc⟧ nᵣ) (suc x₁) (suc x₂)

private
  refl : ∀ {n} → Reflexive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  refl {x = zero}  = ⟦zero⟧
  refl {x = suc _} = ⟦suc⟧ refl

  sym : ∀ {n} → Symmetric (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  sym ⟦zero⟧ = ⟦zero⟧
  sym (⟦suc⟧ xᵣ) = ⟦suc⟧ (sym xᵣ)

  trans : ∀ {n} → Transitive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  trans ⟦zero⟧ xᵣ = xᵣ
  trans (⟦suc⟧ xᵣ) (⟦suc⟧ yᵣ) = ⟦suc⟧ (trans xᵣ yᵣ)

  subst : ∀ {ℓ n} → Substitutive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl) ℓ
  subst _ ⟦zero⟧    = id
  subst P (⟦suc⟧ xᵣ) = subst (P ∘ suc) xᵣ

  isEquivalence : ∀ {n} → IsEquivalence (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  isEquivalence = record { refl = refl; sym = sym; trans = trans }

Fix Data.Fin.Logical

Fix Data.Fin.Logical