universe: flip _*_ is better

universe: flip _*_ is better

module universe where

import Level as L
open import Function
open import Data.Nat.NP using (ℕ; _+_; _*_; _^_)
open import Data.Bits using (Bit)
open import Data.Unit using (⊤)
open import Data.Product using (Σ; _×_; _,_) renaming (zip to ×-zip)
open import Data.Vec using (Vec)

-- An interface for small, finite & discrete universes of types.
record Universe {t} (T : Set t) : Set t where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_

-- In Set-U, types are simply represented by Agda types (Set).
Set-U : Universe Set
Set-U = mk ⊤ Bit _×_ Vec

-- In Bits-U, a type is represented by a natural number
-- representing the width of the type in a binary representation.
-- A natural embedding in Set is the Bits type (aka Vec Bool).
Bits-U : Universe ℕ
Bits-U = mk 0 1 _+_ (flip _*_)

-- In Fin-U, a type is represented by a natural number
-- representing the cardinality of the type.
-- A natural embedding in Set is the Fin type.
Fin-U : Universe ℕ
Fin-U = mk 1 2 _*_ _^_

-- In ⊤-U, there is only one possible type.
⊤-U : Universe ⊤
⊤-U = mk _ _ _ _

-- Take the product of two universes. All types have two components, one from
-- each of the forming universes.
×-U : ∀ {s t} {S : Set s} {T : Set t} → Universe S → Universe T → Universe (S × T)
×-U S-U T-U = mk (S.`⊤ , T.`⊤) (S.`Bit , T.`Bit) (×-zip S._`×_ T._`×_)
                 (λ { (A₀ , A₁) n → S.`Vec A₀ n , T.`Vec A₁ n })
  where module S = Universe S-U
        module T = Universe T-U

-- Sym-U is a “symantic” (a mix of syntax and semantics) representation
-- for types. Symantic types are those defined only in term of the
-- Universe interface. [See the “Finally Tagless” approach by Oleg Kiselyov.]
Sym-U : ∀ t → Set (L.suc t)
Sym-U t = ∀ {T : Set t} → Universe T → T

-- Abstract syntax tree from types.
data Ty : Set where
  ⊤′ Bit′ : Ty
  _×′_    : Ty → Ty → Ty
  _^′_    : Ty → ℕ → Ty

-- Ty-U is the universe of the syntactic represented types.
Ty-U : Universe Ty
Ty-U = mk ⊤′ Bit′ _×′_ _^′_

-- Turn a syntactic type into a symantic one.
-- Alternatively:
--   * a syntactic type is turned into a type of any $given universe.
--   * the catamorphism for syntactic types.
fold-U : ∀ {t} → Ty → Sym-U t
fold-U u₀ {T} uni = go u₀
  where open Universe uni
        go : Ty → T
        go ⊤′         = `⊤
        go Bit′       = `Bit
        go (t₀ ×′ t₁) = go t₀ `× go t₁
        go (t ^′ n)   = go t `^ n

{-
Σ-U : ∀ {t} {T : Set t} → Universe T → (P : T → Set) → Universe (Σ T P)
Σ-U T-U P = mk (`⊤ , {!!}) {!!} {!!} {!!}
  where open Universe T-U
-}

-- The type of universe unary operators or universe transformers.
UniOp : ∀ {s t} (S : Set s) (T : Set t) → Set _
UniOp S T = Universe S → Universe T

-- The type of universe binary operators.
UniOp₂ : ∀ {r s t} (R : Set r) (S : Set s) (T : Set t) → Set _
UniOp₂ R S T = Universe R → Universe S → Universe T

module universe where

import Level as L
open import Data.Nat.NP using (ℕ; _+_; _*_; _^_)
open import Data.Bits using (Bit)
open import Data.Unit using (⊤)
open import Data.Product using (_×_; _,_) renaming (zip to ×-zip)
open import Data.Vec using (Vec)

-- An interface for small, finite & discrete universes of types.
record Universe {t} (T : Set t) : Set t where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_

-- In Set-U, types are simply represented by Agda types (Set).
Set-U : Universe Set
Set-U = mk ⊤ Bit _×_ Vec

-- In Bits-U, a type is represented by a natural number
-- representing the width of the type in a binary representation.
-- A natural embedding in Set is the Bits type (aka Vec Bool).
Bits-U : Universe ℕ
Bits-U = mk 0 1 _+_ _*_

-- In Fin-U, a type is represented by a natural number
-- representing the cardinality of the type.
-- A natural embedding in Set is the Fin type.
Fin-U : Universe ℕ
Fin-U = mk 1 2 _*_ _^_

-- In ⊤-U, there is only one possible type.
⊤-U : Universe ⊤
⊤-U = mk _ _ _ _

-- Take the product of two universes. All types have two components, one from
-- each of the forming universes.
×-U : ∀ {s t} {S : Set s} {T : Set t} → Universe S → Universe T → Universe (S × T)
×-U S-U T-U = mk (S.`⊤ , T.`⊤) (S.`Bit , T.`Bit) (×-zip S._`×_ T._`×_)
                 (λ { (A₀ , A₁) n → S.`Vec A₀ n , T.`Vec A₁ n })
  where module S = Universe S-U
        module T = Universe T-U

-- Sym-U is a “symantic” (a mix of syntax and semantics) representation
-- for types. Symantic types are those defined only in term of the
-- Universe interface. [See the “Finally Tagless” approach by Oleg Kiselyov.]
Sym-U : ∀ t → Set (L.suc t)
Sym-U t = ∀ {T : Set t} → Universe T → T

-- Abstract syntax tree from types.
data Ty : Set where
  ⊤′ Bit′ : Ty
  _×′_    : Ty → Ty → Ty
  _^′_    : Ty → ℕ → Ty

-- Ty-U is the universe of the syntactic represented types.
Ty-U : Universe Ty
Ty-U = mk ⊤′ Bit′ _×′_ _^′_

-- Turn a syntactic type into a symantic one.
-- Alternatively:
--   * a syntactic type is turned into a type of any $given universe.
--   * the catamorphism for syntactic types.
fold-U : ∀ {t} → Ty → Sym-U t
fold-U u₀ {T} uni = go u₀
  where open Universe uni
        go : Ty → T
        go ⊤′         = `⊤
        go Bit′       = `Bit
        go (t₀ ×′ t₁) = go t₀ `× go t₁
        go (t ^′ n)   = go t `^ n

{-
Σ-U : ∀ {t} {T : Set t} → Universe T → (P : T → Set) → Universe (Σ T P)
Σ-U T-U = ?
  where open Universe T-U
-}

-- The type of universe unary operators or universe transformers.
UniOp : ∀ {s t} (S : Set s) (T : Set t) → Set _
UniOp S T = Universe S → Universe T

-- The type of universe binary operators.
UniOp₂ : ∀ {r s t} (R : Set r) (S : Set s) (T : Set t) → Set _
UniOp₂ R S T = Universe R → Universe S → Universe T


Vec: add lemmas about ‼,group,concat,map,⊛

{-# OPTIONS --copatterns #-}
-- NOTE with-K
module Data.Vec.NP where

open import Algebra
open import Algebra.Structures
import Algebra.FunctionProperties
import Algebra.FunctionProperties.Eq
open import Type hiding (Type)
import Level as L
open import Category.Applicative
open import Data.Nat.NP using (ℕ; suc; zero; _+_; _*_; 2*_; module ℕ° ; +-interchange ; _≤_)
open import Data.Nat.Properties using (_+-mono_)
open import Data.Fin hiding (_≤_) renaming (_+_ to _+ᶠ_)
open import Data.Vec using (Vec; []; _∷_; head; tail; replicate; tabulate; foldr; _++_; lookup; splitAt; take; drop; sum; _∷ʳ_; concat)
import Data.Fin.Properties as F
open import Data.Bit
open import Data.Bool using (Bool; if_then_else_)
open import Data.Product hiding (map; zip; swap) renaming (proj₁ to fst; proj₂ to snd)
open import Function.NP
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; ap; ap₂; _∙_; !_) renaming (refl to idp)
import Data.Vec.Equality

module FunVec {a} {A : Type a} where
    _→ᵛ_ : ℕ → ℕ → Type a
    i →ᵛ o = Vec A i → Vec A o

ap-∷ : ∀ {a} {A : Type a} {n}
         {x y : A} {xs ys : Vec A n} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
ap-∷ = ap₂ _∷_

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

    infixl 4 _⊛_

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

    applicative : ∀ {a n} → RawApplicative (λ (A : Type a) → Vec A n)
    applicative = record
      { pure = replicate
      ; _⊛_  = _⊛_
      }

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

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

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

    tabulate-∘ : ∀ {n a b} {A : Type a} {B : Type b}
                 (f : A → B) (g : Fin n → A) →
                 tabulate (f ∘ g) ≡ map f (tabulate g)
    tabulate-∘ {zero}  f g = idp
    tabulate-∘ {suc n} f g = ap (_∷_ _) (tabulate-∘ f (g ∘ suc))

    tabulate-ext : ∀ {n a}{A : Type a}{f g : Fin n → A} → f ≗ g → tabulate f ≡ tabulate g
    tabulate-ext {zero}  f≗g = idp
    tabulate-ext {suc n} f≗g = ap-∷ (f≗g zero) (tabulate-ext (f≗g ∘ suc))

    -- map is functorial.

    map-id= : ∀ {a n} {A : Type a}{f : A → A}
             → f ≗ id → map f ≗ id {A = Vec A n}
    map-id= f= []       = idp
    map-id= f= (x ∷ xs) = ap-∷ (f= x) (map-id= f= xs)

    map-id : ∀ {a n} {A : Type a} → map id ≗ id {A = Vec A n}
    map-id = map-id= (λ _ → idp)

    map-∘= : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c}
               {f : B → C}{g : A → B}{h : A → C} →
               f ∘ g ≗ h →
               _≗_ {A = Vec A n} (map f ∘ map g) (map h)
    map-∘= fg= []       = idp
    map-∘= fg= (x ∷ xs) = ap-∷ (fg= x) (map-∘= fg= xs)

    map-∘ : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c}
              (f : B → C) (g : A → B) →
              _≗_ {A = Vec A n} (map (f ∘ g)) (map f ∘ map g)
    map-∘ f g v = ! map-∘= (λ _ → idp) v

    map-ext : ∀ {a b} {A : Type a} {B : Type b} {f g : A → B} {n} → f ≗ g → map f ≗ map {n = n} g
    map-ext f≗g []       = idp
    map-ext f≗g (x ∷ xs) = ap-∷ (f≗g x) (map-ext f≗g xs)

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

module With≈
    {a ℓ ℓ'}{A : Type a}
    (_≈_ : A → A → Type ℓ)
    {_≈ᵛ_ : ∀ {n}(xs ys : Vec A n) → Type ℓ'}
    ([]-cong  : [] ≈ᵛ [])
    (_∷-cong_ : ∀ {n} {x¹} {xs¹ : Vec A n} {x²} {xs² : Vec A n}
                  (x¹≈x² : x¹ ≈ x²) (xs¹≈xs² : xs¹ ≈ᵛ xs²) →
                  (x¹ ∷ xs¹) ≈ᵛ (x² ∷ xs²))
  where
  open Algebra.FunctionProperties

  module _ {_∙_ _∙∙_ : A → A → A}
           (assoc : ∀ x y z → ((x ∙ y) ∙∙ z) ≈ (x ∙ (y ∙∙ z))) where
    private
      _∙ᵛ_ _∙∙ᵛ_ : ∀ {n}(xs ys : Vec A n) → Vec A n
      _∙ᵛ_  = zipWith _∙_
      _∙∙ᵛ_ = zipWith _∙∙_

    zipWith-assoc : ∀ {n} (xs ys zs : Vec A n) → ((xs ∙ᵛ ys) ∙∙ᵛ zs) ≈ᵛ (xs ∙ᵛ (ys ∙∙ᵛ zs))
    zipWith-assoc [] [] [] = []-cong
    zipWith-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs)
       = assoc x y z ∷-cong (zipWith-assoc xs ys zs)

  module _ {_∙_ : A → A → A} where
    module _ (∙-comm : Commutative _≈_ _∙_) where
      zipWith-comm : ∀ {n} → Commutative _≈ᵛ_ (zipWith {n = n} _∙_)
      zipWith-comm [] [] = []-cong
      zipWith-comm (x ∷ xs) (y ∷ ys) = ∙-comm x y ∷-cong zipWith-comm xs ys

    module _ {ε : A} where
      module _ (∙-id-left : LeftIdentity _≈_ ε _∙_) where
        zipWith-id-left : ∀ {n} → LeftIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-left [] = []-cong
        zipWith-id-left (x ∷ xs) = ∙-id-left x ∷-cong zipWith-id-left xs

      module _ (∙-id-right : RightIdentity _≈_ ε _∙_) where
        zipWith-id-right : ∀ {n} → RightIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-right [] = []-cong
        zipWith-id-right (x ∷ xs) = ∙-id-right x ∷-cong zipWith-id-right xs

      module _ {_⁻¹ : A → A}
               (inverse : LeftInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-left-inverse : ∀ {n} → LeftInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-left-inverse [] = []-cong
        zipWith-left-inverse (x ∷ xs) = inverse x ∷-cong zipWith-left-inverse xs

      module _ {_⁻¹ : A → A}
               (inverse : RightInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-right-inverse : ∀ {n} → RightInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-right-inverse [] = []-cong
        zipWith-right-inverse (x ∷ xs) = inverse x ∷-cong zipWith-right-inverse xs

module WithSetoid {c ℓ} (S : Setoid c ℓ) where
  A = Setoid.Carrier S
  open Setoid S
  V = Vec A
  module V≈ = Data.Vec.Equality.Equality S
  open Algebra.FunctionProperties
  open V≈ hiding (_≈_)
  _≈ᵛ_ : ∀ {n} → V n → V n → Type _
  xs ≈ᵛ ys = V≈._≈_ xs ys

  open With≈ _≈_ {_≈ᵛ_} []-cong (λ x y → x ∷-cong y) public

  module _ {f : A → A} (f-cong : f Preserves _≈_ ⟶ _≈_) where
    map-cong : ∀ {n} → map {n = n} f Preserves _≈ᵛ_ ⟶ _≈ᵛ_
    map-cong []-cong = []-cong
    map-cong (x≈y ∷-cong xs≈ys) = f-cong x≈y ∷-cong map-cong xs≈ys

  module _ {f : A → A → A} (f-cong : f Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where
    zipWith-cong : ∀ {n} → zipWith {n = n} f Preserves₂ _≈ᵛ_ ⟶ _≈ᵛ_ ⟶ _≈ᵛ_
    zipWith-cong []-cong []-cong = []-cong
    zipWith-cong (x≈y ∷-cong xs≈ys) (z≈t ∷-cong zs≈ts) = f-cong x≈y z≈t ∷-cong zipWith-cong xs≈ys zs≈ts

∷= : ∀ {a}{A : Type a}{n x} {xs : Vec A n} {y} {ys : Vec A n}
       (p : x ≡ y) (q : xs ≡ ys) →
        x ∷ xs ≡ y ∷ ys
∷= idp idp = idp

module With≡ {a}{A : Type a} where
  open With≈ (_≡_ {A = A}) {_≡_} idp (λ x¹≈x² xs¹≈xs² → ∷= x¹≈x² xs¹≈xs²) public

module LiftSemigroup {c ℓ} (Sg : Semigroup c ℓ) where
    module Sg = Semigroup Sg
    open WithSetoid Sg.setoid public

    _∙ᵛ_ : ∀ {n} → V n → V n → V n
    _∙ᵛ_ = zipWith Sg._∙_

    -- this should be in Data.Vec.Equality
    isEquivalence : ∀ {n} → IsEquivalence (_≈ᵛ_ {n})
    isEquivalence = record { refl = λ {xs} → V≈.refl xs
                           ; sym = V≈.sym ; trans = V≈.trans }

    isSemigroup : ∀ {n} → IsSemigroup (_≈ᵛ_ {n}) _∙ᵛ_
    isSemigroup = record { isEquivalence = isEquivalence
                                       ; assoc = zipWith-assoc Sg.assoc
                                       ; ∙-cong = zipWith-cong Sg.∙-cong }

    semigroup : ∀ n → Semigroup c (ℓ L.⊔ c)
    semigroup n = record { isSemigroup = isSemigroup {n} }

module LiftMonoid {c ℓ} (M : Monoid c ℓ) where
    module M = Monoid M
    open LiftSemigroup M.semigroup public

    εᵛ : ∀ {n} → V n
    εᵛ = replicate M.ε

    isMonoid : ∀ {n} → IsMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isMonoid = record { isSemigroup = isSemigroup
                      ; identity = zipWith-id-left (fst M.identity)
                                 , zipWith-id-right (snd M.identity) }

    monoid : ℕ → Monoid c (ℓ L.⊔ c)
    monoid n = record { isMonoid = isMonoid {n} }

module LiftCommutativeMonoid {c ℓ} (CM : CommutativeMonoid c ℓ) where
    module CM = CommutativeMonoid CM
    open LiftMonoid CM.monoid public

    isCommutativeMonoid : ∀ {n} → IsCommutativeMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isCommutativeMonoid =
       record { isSemigroup = isSemigroup
                  ; identityˡ = zipWith-id-left  CM.identityˡ
                  ; comm = zipWith-comm CM.comm }

    commutative-monoid : ℕ → CommutativeMonoid c (ℓ L.⊔ c)
    commutative-monoid n = record { isCommutativeMonoid = isCommutativeMonoid {n} }

module LiftGroup {c ℓ} (G : Group c ℓ) where
    module G = Group G
    open LiftMonoid G.monoid public

    _⁻¹ᵛ : ∀ {n} → V n → V n
    _⁻¹ᵛ = map G._⁻¹

    isGroup : ∀ {n} → IsGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isGroup = record { isMonoid = isMonoid
                                ; inverse = (zipWith-left-inverse (fst G.inverse))
                                                , (zipWith-right-inverse (snd G.inverse))
                                ; ⁻¹-cong = map-cong G.⁻¹-cong }

    group : ℕ → Group c _
    group n = record { isGroup = isGroup {n} }

module LiftAbelianGroup {c ℓ} (AG : AbelianGroup c ℓ) where
    module AG = AbelianGroup AG
    open LiftGroup AG.group public

    isAbelianGroup : ∀ {n} → IsAbelianGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isAbelianGroup = record { isGroup = isGroup ; comm = zipWith-comm AG.comm }

    abelianGroup : ℕ → AbelianGroup c _
    abelianGroup n = record { isAbelianGroup = isAbelianGroup {n} }

open Algebra.FunctionProperties.Eq.Implicits

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-app : ∀ {a} {A : Type a} {m n} →
              Vec A n → Vec A m → Vec A (rev-+ n m)
    rev-app []       = id
    rev-app (x ∷ xs) = rev-app xs ∘ _∷_ x

    rev-aux : ∀ {a} {A : Type a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Type a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

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

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

RewireTbl : (i o : ℕ) → ★₀
RewireTbl i o = Vec (Fin i) o

sum-∷ʳ : ∀ {n} x (xs : Vec ℕ n) → sum (xs ∷ʳ x) ≡ sum xs + x
sum-∷ʳ x []        = ℕ°.+-comm x 0
sum-∷ʳ x (x₁ ∷ xs) = ap (_+_ x₁) (sum-∷ʳ x xs) ∙ !(ℕ°.+-assoc x₁ (sum xs) x)

sum-distribˡ : ∀ {A : ★₀} {n} f k (xs : Vec A n) → sum (map (λ x → k * f x) xs) ≡ k * sum (map f xs)
sum-distribˡ f k [] = ℕ°.*-comm 0 k
sum-distribˡ f k (x ∷ xs) rewrite sum-distribˡ f k xs = !(fst ℕ°.distrib k _ _)

sum-linear : ∀ {A : ★₀} {n} f g (xs : Vec A n) → sum (map (λ x → f x + g x) xs) ≡ sum (map f xs) + sum (map g xs)
sum-linear f g [] = idp
sum-linear f g (x ∷ xs) rewrite sum-linear f g xs = +-interchange (f x) (g x) (sum (map f xs)) (sum (map g xs))

sum-mono : ∀ {A : ★₀} {n f g} (mono : ∀ x → f x ≤ g x)(xs : Vec A n) → sum (map f xs) ≤ sum (map g xs)
sum-mono f≤°g [] = Data.Nat.NP.z≤n
sum-mono f≤°g (x ∷ xs) = f≤°g x +-mono sum-mono f≤°g xs

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

module _ {a} {A : Type a} where
  count-++ : ∀ {m n} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
              → count pred (xs ++ ys) ≡ count pred xs + count pred ys
  count-++ pred [] ys = idp
  count-++ pred (x ∷ xs) ys with pred x
  ... | 1b rewrite count-++ pred xs ys = idp
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                    | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = idp

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

  filter : ∀ {n} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
  filter pred [] = []
  filter pred (x ∷ xs) with pred x
  ... | 1b = x ∷ filter pred xs
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

  transpose : ∀ {m n} → Vec (Vec A m) n → Vec (Vec A n) m
  transpose [] = replicate []
  transpose (xs ∷ xss) = zipWith _∷_ xs (transpose xss)

  vap : ∀ {m b} {B : Type b} (f : Vec A m → B)
          → ∀ {n} → Vec (Vec A n) m → Vec B n
  vap f = map f ∘ transpose

  infixl 2 _‼_
  _‼_ : ∀ {n} → Vec A n → Fin n → A
  _‼_ = flip lookup

  η : ∀ {n} → Vec A n → Vec A n
  η = tabulate ∘ _‼_

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

  shallow-η : ∀ {n} (xs : Vec A (1 + n)) → xs ≡ head xs ∷ tail xs
  shallow-η (x ∷ xs) = idp

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

  ∷-uncons : ∀ {n} (xs : Vec A (1 + n)) → uncurry _∷_ (uncons xs) ≡ xs
  ∷-uncons (x ∷ xs) = idp

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

  group : ∀ n k → Vec A (n * k) → Vec (Vec A k) n
  group zero    k v = []
  group (suc n) k v = take k v ∷ group n k (drop k v)

  map2* : ∀ m n (f : Vec A m → Vec A n) → Vec A (2* m) → Vec A (2* n)
  map2* m _ f xs = f (take m xs) ++ f (drop m xs)

  map* : ∀ k {m n}(f : Vec A m → Vec A n) → Vec A (k * m) → Vec A (k * n)
  map* k f xs = concat (map f (group k _ xs))

  take2* : ∀ n → Bit → Vec A (2* n) → Vec A n
  take2* n 0b v = take n v
  take2* n 1b v = drop n v

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

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

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

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

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

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

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

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

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

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

  drop′-spec : ∀ m {n} → drop′ m {n} ≗ drop m {n}
  drop′-spec zero    _        = idp
  drop′-spec (suc m) (x ∷ xs) = drop′-spec m xs ∙ !(drop-∷ m x xs)

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

  take′-spec : ∀ m {n} → take′ m {n} ≗ take m {n}
  take′-spec zero    xs       = idp
  take′-spec (suc m) (x ∷ xs) = ap (_∷_ x) (take′-spec m xs) ∙ !(take-∷ m x xs)

  swap : ∀ m {n} → Vec A (m + n) → Vec A (n + m)
  swap m xs = drop m xs ++ take m xs

  swap-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
  swap-++ m xs ys = ap₂ _++_ (drop-++ m xs ys) (take-++ m xs ys)

  rewire : ∀ {i o} → (Fin o → Fin i) → Vec A i → Vec A o
  rewire f v = tabulate (_‼_ v ∘ f)

  take-drop= : ∀ m {n} (xs ys : Vec A (m + n))
                 → take m xs ≡ take m ys
                 → drop m xs ≡ drop m ys
                 → xs ≡ ys
  take-drop= m xs ys take= drop= =
    ! take-drop-lem m xs ∙ ap₂ _++_ take= drop= ∙ take-drop-lem m ys

  rewireTbl : ∀ {i o} → RewireTbl i o → Vec A i → Vec A o
  rewireTbl tbl v = map (_‼_ v) tbl

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

  ⊛-dist-0↔1 : ∀ {n}(fs : Vec (Endo A) n) xs → 0↔1 fs ⊛ 0↔1 xs ≡ 0↔1 (fs ⊛ xs)
  ⊛-dist-0↔1 _           []          = idp
  ⊛-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = idp
  ⊛-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = idp

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

  map-tail-id : ∀ {n} → map-tail id ≗ id {A = Vec A (suc n)}
  map-tail-id (x ∷ xs) = idp

  map-tail∘map-tail : ∀ {m n o}
                        (f : Vec A o → Vec A m)
                        (g : Vec A n → Vec A o)
                      → map-tail f ∘ map-tail g ≗ map-tail (f ∘ g)
  map-tail∘map-tail f g (x ∷ xs) = idp

  map-tail-≗ : ∀ {m n}(f g : Vec A m → Vec A n) → f ≗ g → map-tail f ≗ map-tail g
  map-tail-≗ f g f≗g (x ∷ xs) = ap (_∷_ x) (f≗g xs)

  dup : ∀ {n} → Vec A n → Vec A (n + n)
  dup xs = xs ++ xs

  dup-inj : ∀ {n} → Injective (dup {n})
  dup-inj = ++-inj₁

  rot₁ : ∀ {n} → Vec A n → Vec A n
  rot₁ []       = []
  rot₁ (x ∷ xs) = xs ∷ʳ x

  rot : ∀ {n} → ℕ → Vec A n → Vec A n
  rot zero    xs = xs
  rot (suc n) xs = rot n (rot₁ xs)

  map-∷ʳ : ∀ {n}(f : A → ℕ) x (xs : Vec A n) → map f (xs ∷ʳ x) ≡ map f xs ∷ʳ f x
  map-∷ʳ f x []       = idp
  map-∷ʳ f x (_ ∷ xs) = ap (_∷_ _) (map-∷ʳ f x xs)

  sum-map-rot₁ : ∀ {n}(f : A → ℕ) (xs : Vec A n) → sum (map f (rot₁ xs)) ≡ sum (map f xs)
  sum-map-rot₁ f [] = idp
  sum-map-rot₁ f (x ∷ xs) = ap sum (map-∷ʳ f x xs)
                          ∙ sum-∷ʳ (f x) (map f xs)
                          ∙ ℕ°.+-comm (sum (map f xs)) (f x)

  vec= : ∀ {n}{xs ys : Vec A n} → (∀ i → (xs ‼ i) ≡ (ys ‼ i)) → xs ≡ ys
  vec= {xs = []}     {[]}     f= = idp
  vec= {xs = x ∷ xs} {y ∷ ys} f= = ap-∷ (f= zero) (vec= (f= ∘ suc))

  concat-group : ∀ m n (xs : Vec A (m * n)) → concat (group m n xs) ≡ xs
  concat-group zero    n [] = idp
  concat-group (suc m) n xs rewrite concat-group m n (drop n xs) = take-drop-lem n xs

  group-concat : ∀ {m n}(xss : Vec (Vec A n) m) → group m n (concat xss) ≡ xss
  group-concat [] = idp
  group-concat (xs ∷ xss)
    rewrite take-++ _ xs (concat xss)
          | drop-++ _ xs (concat xss)
          | group-concat xss
          = idp

  -- These are also in the stdlib as Data.Vec.Properties.lookup-morphism
  ‼-replicate : ∀ {n}(i : Fin n)(x : A) → (replicate x ‼ i) ≡ x
  ‼-replicate zero    = λ _ → idp
  ‼-replicate (suc i) = ‼-replicate i

module _ {a b}{A : Type a}{B : Type b} where
  ‼-⊛= : ∀ {n} i {fs : Vec (A → B) n}{xs : Vec A n}{f x}
           (fs= : (fs ‼ i) ≡ f)
           (xs= : (xs ‼ i) ≡ x)
         → (fs ⊛ xs ‼ i) ≡ f x
  ‼-⊛= zero    {f ∷ fs} {x ∷ xs} f= xs= = ap₂ _$_ f= xs=
  ‼-⊛= (suc i) {f ∷ fs} {x ∷ xs} f= xs= = ‼-⊛= i f= xs=

  ‼-⊛ : ∀ {n} i (fs : Vec (A → B) n) (xs : Vec A n) →
          (fs ⊛ xs ‼ i) ≡ (fs ‼ i) (xs ‼ i)
  ‼-⊛ i fs xs = ‼-⊛= i idp idp

  ‼-map= : ∀ {n} i (f : A → B) {xs : Vec A n}{x : A}
             (xs= : (xs ‼ i) ≡ x)
           → (map f xs ‼ i) ≡ f x
  ‼-map= i f = ‼-⊛= i (‼-replicate i f)

  ‼-map : ∀ {n} i (f : A → B) (xs : Vec A n) →
            (map f xs ‼ i) ≡ f (xs ‼ i)
  ‼-map i f xs = ‼-map= i f idp

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

  count-∘ : ∀ {n}(f : A → B)(pred : B → Bool) →
              count {n} (pred ∘ f) ≗ count pred ∘ map f
  count-∘ f pred [] = idp
  count-∘ f pred (x ∷ xs) with pred (f x)
  ... | 1b rewrite count-∘ f pred xs = idp
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                 | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                 | count-∘ f pred xs = idp

sum-rot₁ : ∀ {n} (xs : Vec ℕ n) → sum xs ≡ sum (rot₁ xs)
sum-rot₁ []       = idp
sum-rot₁ (x ∷ xs) = ℕ°.+-comm x (sum xs) ∙ !(sum-∷ʳ x xs)

open import Data.Vec public hiding (_⊛_; zipWith; zip; map; applicative; group)
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --copatterns #-}
-- NOTE with-K
module Data.Vec.NP where

open import Algebra
open import Algebra.Structures
import Algebra.FunctionProperties
import Algebra.FunctionProperties.Eq
open import Type hiding (Type)
import Level as L
open import Category.Applicative
open import Data.Nat.NP using (ℕ; suc; zero; _+_; _*_; 2*_; module ℕ° ; +-interchange ; _≤_)
open import Data.Nat.Properties using (_+-mono_)
open import Data.Fin hiding (_≤_) renaming (_+_ to _+ᶠ_)
open import Data.Vec using (Vec; []; _∷_; head; tail; replicate; tabulate; foldr; _++_; lookup; splitAt; take; drop; sum; _∷ʳ_; concat)
import Data.Fin.Properties as F
open import Data.Bit
open import Data.Bool using (Bool; if_then_else_)
open import Data.Product hiding (map; zip; swap) renaming (proj₁ to fst; proj₂ to snd)
open import Function.NP
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; ap; ap₂; idp; _∙_; !_)
import Data.Vec.Equality

module FunVec {a} {A : Type a} where
    _→ᵛ_ : ℕ → ℕ → Type a
    i →ᵛ o = Vec A i → Vec A o

ap-∷ : ∀ {a} {A : Type a} {n}
         {x y : A} {xs ys : Vec A n} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
ap-∷ = ap₂ _∷_

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

    infixl 4 _⊛_

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

    applicative : ∀ {a n} → RawApplicative (λ (A : Type a) → Vec A n)
    applicative = record
      { pure = replicate
      ; _⊛_  = _⊛_
      }

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

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

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

    tabulate-∘ : ∀ {n a b} {A : Type a} {B : Type b}
                 (f : A → B) (g : Fin n → A) →
                 tabulate (f ∘ g) ≡ map f (tabulate g)
    tabulate-∘ {zero}  f g = idp
    tabulate-∘ {suc n} f g = ap (_∷_ _) (tabulate-∘ f (g ∘ suc))

    tabulate-ext : ∀ {n a}{A : Type a}{f g : Fin n → A} → f ≗ g → tabulate f ≡ tabulate g
    tabulate-ext {zero}  f≗g = idp
    tabulate-ext {suc n} f≗g = ap-∷ (f≗g zero) (tabulate-ext (f≗g ∘ suc))

    -- map is functorial.

    map-id : ∀ {a n} {A : Type a} → map id ≗ id {A = Vec A n}
    map-id []       = idp
    map-id (x ∷ xs) = ap (_∷_ x) (map-id xs)

    map-∘ : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c}
            (f : B → C) (g : A → B) →
            _≗_ {A = Vec A n} (map (f ∘ g)) (map f ∘ map g)
    map-∘ f g []       = idp
    map-∘ f g (x ∷ xs) = ap (_∷_ (f (g x))) (map-∘ f g xs)

    map-ext : ∀ {a b} {A : Type a} {B : Type b} {f g : A → B} {n} → f ≗ g → map f ≗ map {n = n} g
    map-ext f≗g []       = idp
    map-ext f≗g (x ∷ xs) = ap-∷ (f≗g x) (map-ext f≗g xs)

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

module With≈
    {a ℓ ℓ'}{A : Type a}
    (_≈_ : A → A → Type ℓ)
    {_≈ᵛ_ : ∀ {n}(xs ys : Vec A n) → Type ℓ'}
    ([]-cong  : [] ≈ᵛ [])
    (_∷-cong_ : ∀ {n} {x¹} {xs¹ : Vec A n} {x²} {xs² : Vec A n}
                  (x¹≈x² : x¹ ≈ x²) (xs¹≈xs² : xs¹ ≈ᵛ xs²) →
                  (x¹ ∷ xs¹) ≈ᵛ (x² ∷ xs²))
  where
  open Algebra.FunctionProperties

  module _ {_∙_ _∙∙_ : A → A → A}
           (assoc : ∀ x y z → ((x ∙ y) ∙∙ z) ≈ (x ∙ (y ∙∙ z))) where
    private
      _∙ᵛ_ _∙∙ᵛ_ : ∀ {n}(xs ys : Vec A n) → Vec A n
      _∙ᵛ_  = zipWith _∙_
      _∙∙ᵛ_ = zipWith _∙∙_

    zipWith-assoc : ∀ {n} (xs ys zs : Vec A n) → ((xs ∙ᵛ ys) ∙∙ᵛ zs) ≈ᵛ (xs ∙ᵛ (ys ∙∙ᵛ zs))
    zipWith-assoc [] [] [] = []-cong
    zipWith-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs)
       = assoc x y z ∷-cong (zipWith-assoc xs ys zs)

  module _ {_∙_ : A → A → A} where
    module _ (∙-comm : Commutative _≈_ _∙_) where
      zipWith-comm : ∀ {n} → Commutative _≈ᵛ_ (zipWith {n = n} _∙_)
      zipWith-comm [] [] = []-cong
      zipWith-comm (x ∷ xs) (y ∷ ys) = ∙-comm x y ∷-cong zipWith-comm xs ys

    module _ {ε : A} where
      module _ (∙-id-left : LeftIdentity _≈_ ε _∙_) where
        zipWith-id-left : ∀ {n} → LeftIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-left [] = []-cong
        zipWith-id-left (x ∷ xs) = ∙-id-left x ∷-cong zipWith-id-left xs

      module _ (∙-id-right : RightIdentity _≈_ ε _∙_) where
        zipWith-id-right : ∀ {n} → RightIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-right [] = []-cong
        zipWith-id-right (x ∷ xs) = ∙-id-right x ∷-cong zipWith-id-right xs

      module _ {_⁻¹ : A → A}
               (inverse : LeftInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-left-inverse : ∀ {n} → LeftInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-left-inverse [] = []-cong
        zipWith-left-inverse (x ∷ xs) = inverse x ∷-cong zipWith-left-inverse xs

      module _ {_⁻¹ : A → A}
               (inverse : RightInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-right-inverse : ∀ {n} → RightInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-right-inverse [] = []-cong
        zipWith-right-inverse (x ∷ xs) = inverse x ∷-cong zipWith-right-inverse xs

module WithSetoid {c ℓ} (S : Setoid c ℓ) where
  A = Setoid.Carrier S
  open Setoid S
  V = Vec A
  module V≈ = Data.Vec.Equality.Equality S
  open Algebra.FunctionProperties
  open V≈ hiding (_≈_)
  _≈ᵛ_ : ∀ {n} → V n → V n → Type _
  xs ≈ᵛ ys = V≈._≈_ xs ys

  open With≈ _≈_ {_≈ᵛ_} []-cong (λ x y → x ∷-cong y) public

  module _ {f : A → A} (f-cong : f Preserves _≈_ ⟶ _≈_) where
    map-cong : ∀ {n} → map {n = n} f Preserves _≈ᵛ_ ⟶ _≈ᵛ_
    map-cong []-cong = []-cong
    map-cong (x≈y ∷-cong xs≈ys) = f-cong x≈y ∷-cong map-cong xs≈ys

  module _ {f : A → A → A} (f-cong : f Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where
    zipWith-cong : ∀ {n} → zipWith {n = n} f Preserves₂ _≈ᵛ_ ⟶ _≈ᵛ_ ⟶ _≈ᵛ_
    zipWith-cong []-cong []-cong = []-cong
    zipWith-cong (x≈y ∷-cong xs≈ys) (z≈t ∷-cong zs≈ts) = f-cong x≈y z≈t ∷-cong zipWith-cong xs≈ys zs≈ts

∷= : ∀ {a}{A : Type a}{n x} {xs : Vec A n} {y} {ys : Vec A n}
       (p : x ≡ y) (q : xs ≡ ys) →
        x ∷ xs ≡ y ∷ ys
∷= ≡.refl ≡.refl = ≡.refl

module With≡ {a}{A : Type a} where
  open With≈ (_≡_ {A = A}) {_≡_} idp (λ x¹≈x² xs¹≈xs² → ∷= x¹≈x² xs¹≈xs²) public

module LiftSemigroup {c ℓ} (Sg : Semigroup c ℓ) where
    module Sg = Semigroup Sg
    open WithSetoid Sg.setoid public

    _∙ᵛ_ : ∀ {n} → V n → V n → V n
    _∙ᵛ_ = zipWith Sg._∙_

    -- this should be in Data.Vec.Equality
    isEquivalence : ∀ {n} → IsEquivalence (_≈ᵛ_ {n})
    isEquivalence = record { refl = λ {xs} → V≈.refl xs
                                         ; sym = V≈.sym ; trans = V≈.trans }

    isSemigroup : ∀ {n} → IsSemigroup (_≈ᵛ_ {n}) _∙ᵛ_
    isSemigroup = record { isEquivalence = isEquivalence
                                       ; assoc = zipWith-assoc Sg.assoc
                                       ; ∙-cong = zipWith-cong Sg.∙-cong }

    semigroup : ∀ n → Semigroup c (ℓ L.⊔ c)
    semigroup n = record { isSemigroup = isSemigroup {n} }

module LiftMonoid {c ℓ} (M : Monoid c ℓ) where
    module M = Monoid M
    open LiftSemigroup M.semigroup public

    εᵛ : ∀ {n} → V n
    εᵛ = replicate M.ε

    isMonoid : ∀ {n} → IsMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isMonoid = record { isSemigroup = isSemigroup
                      ; identity = zipWith-id-left (fst M.identity)
                                 , zipWith-id-right (snd M.identity) }

    monoid : ℕ → Monoid c (ℓ L.⊔ c)
    monoid n = record { isMonoid = isMonoid {n} }

module LiftCommutativeMonoid {c ℓ} (CM : CommutativeMonoid c ℓ) where
    module CM = CommutativeMonoid CM
    open LiftMonoid CM.monoid public

    isCommutativeMonoid : ∀ {n} → IsCommutativeMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isCommutativeMonoid =
       record { isSemigroup = isSemigroup
                  ; identityˡ = zipWith-id-left  CM.identityˡ
                  ; comm = zipWith-comm CM.comm }

    commutative-monoid : ℕ → CommutativeMonoid c (ℓ L.⊔ c)
    commutative-monoid n = record { isCommutativeMonoid = isCommutativeMonoid {n} }

module LiftGroup {c ℓ} (G : Group c ℓ) where
    module G = Group G
    open LiftMonoid G.monoid public

    _⁻¹ᵛ : ∀ {n} → V n → V n
    _⁻¹ᵛ = map G._⁻¹

    isGroup : ∀ {n} → IsGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isGroup = record { isMonoid = isMonoid
                                ; inverse = (zipWith-left-inverse (fst G.inverse))
                                                , (zipWith-right-inverse (snd G.inverse))
                                ; ⁻¹-cong = map-cong G.⁻¹-cong }

    group : ℕ → Group c _
    group n = record { isGroup = isGroup {n} }

module LiftAbelianGroup {c ℓ} (AG : AbelianGroup c ℓ) where
    module AG = AbelianGroup AG
    open LiftGroup AG.group public

    isAbelianGroup : ∀ {n} → IsAbelianGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isAbelianGroup = record { isGroup = isGroup ; comm = zipWith-comm AG.comm }

    abelianGroup : ℕ → AbelianGroup c _
    abelianGroup n = record { isAbelianGroup = isAbelianGroup {n} }

open Algebra.FunctionProperties.Eq.Implicits

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-app : ∀ {a} {A : Type a} {m n} →
              Vec A n → Vec A m → Vec A (rev-+ n m)
    rev-app []       = id
    rev-app (x ∷ xs) = rev-app xs ∘ _∷_ x

    rev-aux : ∀ {a} {A : Type a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Type a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

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

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

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

count-∘ : ∀ {n a b} {A : Type a} {B : Type b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = idp
count-∘ f pred (x ∷ xs) with pred (f x)
... | 1b rewrite count-∘ f pred xs = idp
... | 0b rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                  | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = idp

RewireTbl : (i o : ℕ) → ★₀
RewireTbl i o = Vec (Fin i) o

sum-∷ʳ : ∀ {n} x (xs : Vec ℕ n) → sum (xs ∷ʳ x) ≡ sum xs + x
sum-∷ʳ x []        = ℕ°.+-comm x 0
sum-∷ʳ x (x₁ ∷ xs) = ap (_+_ x₁) (sum-∷ʳ x xs) ∙ !(ℕ°.+-assoc x₁ (sum xs) x)

sum-distribˡ : ∀ {A : ★₀} {n} f k (xs : Vec A n) → sum (map (λ x → k * f x) xs) ≡ k * sum (map f xs)
sum-distribˡ f k [] = ℕ°.*-comm 0 k
sum-distribˡ f k (x ∷ xs) rewrite sum-distribˡ f k xs = !(fst ℕ°.distrib k _ _)

sum-linear : ∀ {A : ★₀} {n} f g (xs : Vec A n) → sum (map (λ x → f x + g x) xs) ≡ sum (map f xs) + sum (map g xs)
sum-linear f g [] = idp
sum-linear f g (x ∷ xs) rewrite sum-linear f g xs = +-interchange (f x) (g x) (sum (map f xs)) (sum (map g xs))

sum-mono : ∀ {A : ★₀} {n f g} (mono : ∀ x → f x ≤ g x)(xs : Vec A n) → sum (map f xs) ≤ sum (map g xs)
sum-mono f≤°g [] = Data.Nat.NP.z≤n
sum-mono f≤°g (x ∷ xs) = f≤°g x +-mono sum-mono f≤°g xs

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

module _ {a} {A : Type a} where
  count-++ : ∀ {m n} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
              → count pred (xs ++ ys) ≡ count pred xs + count pred ys
  count-++ pred [] ys = idp
  count-++ pred (x ∷ xs) ys with pred x
  ... | 1b rewrite count-++ pred xs ys = idp
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                    | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = idp

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

  filter : ∀ {n} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
  filter pred [] = []
  filter pred (x ∷ xs) with pred x
  ... | 1b = x ∷ filter pred xs
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

  transpose : ∀ {m n} → Vec (Vec A m) n → Vec (Vec A n) m
  transpose [] = replicate []
  transpose (xs ∷ xss) = zipWith _∷_ xs (transpose xss)

  vap : ∀ {m b} {B : Type b} (f : Vec A m → B)
          → ∀ {n} → Vec (Vec A n) m → Vec B n
  vap f = map f ∘ transpose

  infixl 2 _‼_
  _‼_ : ∀ {n} → Vec A n → Fin n → A
  _‼_ = flip lookup

  η : ∀ {n} → Vec A n → Vec A n
  η = tabulate ∘ _‼_

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

  shallow-η : ∀ {n} (xs : Vec A (1 + n)) → xs ≡ head xs ∷ tail xs
  shallow-η (x ∷ xs) = idp

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

  ∷-uncons : ∀ {n} (xs : Vec A (1 + n)) → uncurry _∷_ (uncons xs) ≡ xs
  ∷-uncons (x ∷ xs) = idp

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

  group : ∀ n k → Vec A (n * k) → Vec (Vec A k) n
  group zero    k v = []
  group (suc n) k v = take k v ∷ group n k (drop k v)

  map2* : ∀ m n (f : Vec A m → Vec A n) → Vec A (2* m) → Vec A (2* n)
  map2* m _ f xs = f (take m xs) ++ f (drop m xs)

  map* : ∀ k {m n}(f : Vec A m → Vec A n) → Vec A (k * m) → Vec A (k * n)
  map* k f xs = concat (map f (group k _ xs))

  take2* : ∀ n → Bit → Vec A (2* n) → Vec A n
  take2* n 0b v = take n v
  take2* n 1b v = drop n v

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

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

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

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

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

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

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

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

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

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

  drop′-spec : ∀ m {n} → drop′ m {n} ≗ drop m {n}
  drop′-spec zero    _        = idp
  drop′-spec (suc m) (x ∷ xs) = drop′-spec m xs ∙ !(drop-∷ m x xs)

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

  take′-spec : ∀ m {n} → take′ m {n} ≗ take m {n}
  take′-spec zero    xs       = idp
  take′-spec (suc m) (x ∷ xs) = ap (_∷_ x) (take′-spec m xs) ∙ !(take-∷ m x xs)

  swap : ∀ m {n} → Vec A (m + n) → Vec A (n + m)
  swap m xs = drop m xs ++ take m xs

  swap-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
  swap-++ m xs ys = ap₂ _++_ (drop-++ m xs ys) (take-++ m xs ys)

  rewire : ∀ {i o} → (Fin o → Fin i) → Vec A i → Vec A o
  rewire f v = tabulate (_‼_ v ∘ f)

  take-drop= : ∀ m {n} (xs ys : Vec A (m + n))
                 → take m xs ≡ take m ys
                 → drop m xs ≡ drop m ys
                 → xs ≡ ys
  take-drop= m xs ys take= drop= =
    ! take-drop-lem m xs ∙ ap₂ _++_ take= drop= ∙ take-drop-lem m ys

  rewireTbl : ∀ {i o} → RewireTbl i o → Vec A i → Vec A o
  rewireTbl tbl v = map (_‼_ v) tbl

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

  ⊛-dist-0↔1 : ∀ {n}(fs : Vec (Endo A) n) xs → 0↔1 fs ⊛ 0↔1 xs ≡ 0↔1 (fs ⊛ xs)
  ⊛-dist-0↔1 _           []          = idp
  ⊛-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = idp
  ⊛-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = idp

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

  map-tail-id : ∀ {n} → map-tail id ≗ id {A = Vec A (suc n)}
  map-tail-id (x ∷ xs) = idp

  map-tail∘map-tail : ∀ {m n o}
                        (f : Vec A o → Vec A m)
                        (g : Vec A n → Vec A o)
                      → map-tail f ∘ map-tail g ≗ map-tail (f ∘ g)
  map-tail∘map-tail f g (x ∷ xs) = idp

  map-tail-≗ : ∀ {m n}(f g : Vec A m → Vec A n) → f ≗ g → map-tail f ≗ map-tail g
  map-tail-≗ f g f≗g (x ∷ xs) = ap (_∷_ x) (f≗g xs)

  dup : ∀ {n} → Vec A n → Vec A (n + n)
  dup xs = xs ++ xs

  dup-inj : ∀ {n} → Injective (dup {n})
  dup-inj = ++-inj₁

  rot₁ : ∀ {n} → Vec A n → Vec A n
  rot₁ []       = []
  rot₁ (x ∷ xs) = xs ∷ʳ x

  rot : ∀ {n} → ℕ → Vec A n → Vec A n
  rot zero    xs = xs
  rot (suc n) xs = rot n (rot₁ xs)

  map-∷ʳ : ∀ {n}(f : A → ℕ) x (xs : Vec A n) → map f (xs ∷ʳ x) ≡ map f xs ∷ʳ f x
  map-∷ʳ f x []       = idp
  map-∷ʳ f x (_ ∷ xs) = ap (_∷_ _) (map-∷ʳ f x xs)

  sum-map-rot₁ : ∀ {n}(f : A → ℕ) (xs : Vec A n) → sum (map f (rot₁ xs)) ≡ sum (map f xs)
  sum-map-rot₁ f [] = idp
  sum-map-rot₁ f (x ∷ xs) = ap sum (map-∷ʳ f x xs)
                          ∙ sum-∷ʳ (f x) (map f xs)
                          ∙ ℕ°.+-comm (sum (map f xs)) (f x)

sum-rot₁ : ∀ {n} (xs : Vec ℕ n) → sum xs ≡ sum (rot₁ xs)
sum-rot₁ []       = idp
sum-rot₁ (x ∷ xs) = ℕ°.+-comm x (sum xs) ∙ !(sum-∷ʳ x xs)

open import Data.Vec public hiding (_⊛_; zipWith; zip; map; applicative; group)
-- -}
-- -}
-- -}
-- -}


universe.agda

universe.agda

module universe where

import Level as L
open import Data.Nat.NP using (ℕ; _+_; _*_; _^_)
open import Data.Bits using (Bit)
open import Data.Unit using (⊤)
open import Data.Product using (_×_; _,_) renaming (zip to ×-zip)
open import Data.Vec using (Vec)

-- An interface for small, finite & discrete universes of types.
record Universe {t} (T : Set t) : Set t where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_

-- In Set-U, types are simply represented by Agda types (Set).
Set-U : Universe Set
Set-U = mk ⊤ Bit _×_ Vec

-- In Bits-U, a type is represented by a natural number
-- representing the width of the type in a binary representation.
-- A natural embedding in Set is the Bits type (aka Vec Bool).
Bits-U : Universe ℕ
Bits-U = mk 0 1 _+_ _*_

-- In Fin-U, a type is represented by a natural number
-- representing the cardinality of the type.
-- A natural embedding in Set is the Fin type.
Fin-U : Universe ℕ
Fin-U = mk 1 2 _*_ _^_

-- In ⊤-U, there is only one possible type.
⊤-U : Universe ⊤
⊤-U = mk _ _ _ _

-- Take the product of two universes. All types have two components, one from
-- each of the forming universes.
×-U : ∀ {s t} {S : Set s} {T : Set t} → Universe S → Universe T → Universe (S × T)
×-U S-U T-U = mk (S.`⊤ , T.`⊤) (S.`Bit , T.`Bit) (×-zip S._`×_ T._`×_)
                 (λ { (A₀ , A₁) n → S.`Vec A₀ n , T.`Vec A₁ n })
  where module S = Universe S-U
        module T = Universe T-U

-- Sym-U is a “symantic” (a mix of syntax and semantics) representation
-- for types. Symantic types are those defined only in term of the
-- Universe interface. [See the “Finally Tagless” approach by Oleg Kiselyov.]
Sym-U : ∀ t → Set (L.suc t)
Sym-U t = ∀ {T : Set t} → Universe T → T

-- Abstract syntax tree from types.
data Ty : Set where
  ⊤′ Bit′ : Ty
  _×′_    : Ty → Ty → Ty
  _^′_    : Ty → ℕ → Ty

-- Ty-U is the universe of the syntactic represented types.
Ty-U : Universe Ty
Ty-U = mk ⊤′ Bit′ _×′_ _^′_

-- Turn a syntactic type into a symantic one.
-- Alternatively:
--   * a syntactic type is turned into a type of any $given universe.
--   * the catamorphism for syntactic types.
fold-U : ∀ {t} → Ty → Sym-U t
fold-U u₀ {T} uni = go u₀
  where open Universe uni
        go : Ty → T
        go ⊤′         = `⊤
        go Bit′       = `Bit
        go (t₀ ×′ t₁) = go t₀ `× go t₁
        go (t ^′ n)   = go t `^ n

{-
Σ-U : ∀ {t} {T : Set t} → Universe T → (P : T → Set) → Universe (Σ T P)
Σ-U T-U = ?
  where open Universe T-U
-}

-- The type of universe unary operators or universe transformers.
UniOp : ∀ {s t} (S : Set s) (T : Set t) → Set _
UniOp S T = Universe S → Universe T

-- The type of universe binary operators.
UniOp₂ : ∀ {r s t} (R : Set r) (S : Set s) (T : Set t) → Set _
UniOp₂ R S T = Universe R → Universe S → Universe T

module universe where

import Level as L
open import Data.Nat.NP using (ℕ; _+_; _*_; _^_)
open import Data.Bits using (Bit)
open import Data.Unit using (⊤)
open import Data.Product using (_×_; _,_) renaming (zip to ×-zip)
open import Data.Vec using (Vec)

-- An interface for small, finite & discrete universes of types.
record Universe {t} (T : Set t) : Set t where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_

-- In Set-U, types are simply represented by Agda types (Set).
Set-U : Universe Set
Set-U = mk ⊤ Bit _×_ Vec

-- In Bits-U, a type is represented by a natural number
-- representing the width of the type in a binary representation.
-- A natural embedding in Set is the Bits type (aka Vec Bool).
Bits-U : Universe ℕ
Bits-U = mk 0 1 _+_ _*_

-- In Fin-U, a type is represented by a natural number
-- representing the cardinality of the type.
-- A natural embedding in Set is the Fin type.
Fin-U : Universe ℕ
Fin-U = mk 1 2 _*_ _^_

-- In ⊤-U, there is only one possible type.
⊤-U : Universe ⊤
⊤-U = mk _ _ _ _

-- Take the product of two universes. All types have two components, one from
-- each of the forming universes.
×-U : ∀ {s t} {S : Set s} {T : Set t} → Universe S → Universe T → Universe (S × T)
×-U S-U T-U = mk (S.`⊤ , T.`⊤) (S.`Bit , T.`Bit) (×-zip S._`×_ T._`×_)
                 (λ { (A₀ , A₁) n → S.`Vec A₀ n , T.`Vec A₁ n })
  where module S = Universe S-U
        module T = Universe T-U

-- Sym-U is a “symantic” (a mix of syntax and semantics) representation
-- for types. Symantic types are those defined only in term of the
-- Universe interface. [See the “Finally Tagless” approach by Oleg Kiselyov.]
Sym-U : ∀ t → Set (L.suc t)
Sym-U t = ∀ {T : Set t} → Universe T → T

-- Abstract syntax tree from types.
data Ty : Set where
  ⊤′ Bit′ : Ty
  _×′_    : Ty → Ty → Ty
  _^′_    : Ty → ℕ → Ty

-- Ty-U is the universe of the syntactic represented types.
Ty-U : Universe Ty
Ty-U = mk ⊤′ Bit′ _×′_ _^′_

-- Turn a syntactic type into a symantic one.
-- Alternatively:
--   * a syntactic type is turned into a type of any $given universe.
--   * the catamorphism for syntactic types.
fold-U : ∀ {t} → Ty → Sym-U
fold-U {_} {T} u₀ uni = go u₀
  where open Universe uni
        go : Ty → T
        go ⊤′         = `⊤
        go Bit′       = `Bit
        go (t₀ ×′ t₁) = go t₀ `× go t₁
        go (t ^′ n)   = go t `^ n

{-
Σ-U : ∀ {t} {T : Set t} → Universe T → (P : T → Set) → Universe (Σ T P)
Σ-U T-U = ?
  where open Universe T-U
-}

-- The type of universe unary operators or universe transformers.
UniOp : ∀ {s t} (S : Set s) (T : Set t) → Set _
UniOp S T = Universe S → Universe T

-- The type of universe binary operators.
UniOp₂ : ∀ {r s t} (R : Set r) (S : Set s) (T : Set t) → Set _
UniOp₂ R S T = Universe R → Universe S → Universe T


agda: start implementing object-level change manipulation (see #25)

Old-commit-hash: 766e45dd4d6ce96f539297ae89703c6628adbdf2

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 Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

open import Relation.Binary.PropositionalEquality

-- LIFTING terms into Δ-Contexts

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

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

-- This version of lift-term′ uses just weakenOne to accomplish its
-- job.

lift-term′-weakenOne : ∀ {Γ τ} Γ′ →
  Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′-weakenOne {Γ} Γ′ t =
  substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
    (doWeakenMore (take Γ Γ′) (drop Γ Γ′)
      (substTerm (sym (take-drop Γ Γ′))
        t))
  where
    doWeakenMore : ∀ Γprefix Γrest {τ} →
      Term (Γprefix ⋎ Γrest) τ →
      Term (Γprefix ⋎ Δ-Context Γrest) τ

    doWeakenMore Γprefix ∅ t₁ = t₁
    doWeakenMore Γprefix (τ₂ • Γrest) t₁ =
      weakenOne Γprefix (Δ-Type τ₂)
        (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
          (doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
            (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ Γ′ (Δ t) = lift-term′-weakenOne Γ′ (Δ t)
lift-term′ {τ = τ} Γ′ (weakenOne Γ₁ τ₂ {Γ₃} t) = lift-weakened-term Γ₁ τ₂ Γ′ t
  where
    double-weakenOne :
      ∀ Γ₁ {Γ₃ τ} τ₂ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context (Γ₁ ⋎ (τ₂ • Γ₃))) τ
    double-weakenOne Γ₁ {Γ₃} τ₂ t =
      substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
        (weakenOne (Δ-Context Γ₁) _
          (weakenOne (Δ-Context Γ₁) _
            (substTerm (Δ-Context-⋎ Γ₁ Γ₃) (lift-term′ ∅ t))))

    lift-weakened-term :
      ∀ Γ₁ {Γ₃ τ} τ₂ Γ′ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context′ (Γ₁ ⋎ (τ₂ • Γ₃)) Γ′) τ
    lift-weakened-term ∅ τ₂ ∅ t = double-weakenOne ∅ τ₂ t
    lift-weakened-term Γ₁ τ₂ ∅ t = double-weakenOne Γ₁ τ₂ t
    lift-weakened-term ∅ τ₃ (.τ₃ • Γ′₁) t₁ = weakenOne ∅ τ₃ (lift-term′ Γ′₁ t₁)
    lift-weakened-term (τ₁ • Γ₁) {Γ₃} τ₂ (.τ₁ • Γ′₁) t₁ =
      lift-term′-weakenOne (τ₁ • Γ′₁) (weakenOne (τ₁ • Γ₁) τ₂ t₁)
    -- In the last case, I was not able to finish without using the expensive
    -- lift-term′-weakenOne

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- 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-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) 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′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | refl = lift-term-ignore′ Γ′ t₂
... | false | false | refl = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

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

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext-t (λ ρ →
  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₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    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))

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs {!!}
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) ({!Δ {Γ} (var this)!}))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term {τ ⇒ τ₁} = λ f₁ f₂ → {!diff-term (f₁ x) (f₂ x)!}
diff-term {bool} = _xor-term_

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = {!!}
apply-term {bool} = _xor-term_

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 true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (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-t (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}

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 Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

open import Relation.Binary.PropositionalEquality

-- LIFTING terms into Δ-Contexts

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

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

-- This version of lift-term′ uses just weakenOne to accomplish its
-- job.

lift-term′-weakenOne : ∀ {Γ τ} Γ′ →
  Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′-weakenOne {Γ} Γ′ t =
  substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
    (doWeakenMore (take Γ Γ′) (drop Γ Γ′)
      (substTerm (sym (take-drop Γ Γ′))
        t))
  where
    doWeakenMore : ∀ Γprefix Γrest {τ} →
      Term (Γprefix ⋎ Γrest) τ →
      Term (Γprefix ⋎ Δ-Context Γrest) τ

    doWeakenMore Γprefix ∅ t₁ = t₁
    doWeakenMore Γprefix (τ₂ • Γrest) t₁ =
      weakenOne Γprefix (Δ-Type τ₂)
        (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
          (doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
            (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ Γ′ (Δ t) = lift-term′-weakenOne Γ′ (Δ t)
lift-term′ {τ = τ} Γ′ (weakenOne Γ₁ τ₂ {Γ₃} t) = lift-weakened-term Γ₁ τ₂ Γ′ t
  where
    double-weakenOne :
      ∀ Γ₁ {Γ₃ τ} τ₂ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context (Γ₁ ⋎ (τ₂ • Γ₃))) τ
    double-weakenOne Γ₁ {Γ₃} τ₂ t =
      substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
        (weakenOne (Δ-Context Γ₁) _
          (weakenOne (Δ-Context Γ₁) _
            (substTerm (Δ-Context-⋎ Γ₁ Γ₃) (lift-term′ ∅ t))))

    lift-weakened-term :
      ∀ Γ₁ {Γ₃ τ} τ₂ Γ′ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context′ (Γ₁ ⋎ (τ₂ • Γ₃)) Γ′) τ
    lift-weakened-term ∅ τ₂ ∅ t = double-weakenOne ∅ τ₂ t
    lift-weakened-term Γ₁ τ₂ ∅ t = double-weakenOne Γ₁ τ₂ t
    lift-weakened-term ∅ τ₃ (.τ₃ • Γ′₁) t₁ = weakenOne ∅ τ₃ (lift-term′ Γ′₁ t₁)
    lift-weakened-term (τ₁ • Γ₁) {Γ₃} τ₂ (.τ₁ • Γ′₁) t₁ =
      lift-term′-weakenOne (τ₁ • Γ′₁) (weakenOne (τ₁ • Γ₁) τ₂ t₁)
    -- In the last case, I was not able to finish without using the expensive
    -- lift-term′-weakenOne

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- 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-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) 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′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | refl = lift-term-ignore′ Γ′ t₂
... | false | false | refl = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

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

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext-t (λ ρ →
  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₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    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))

diff-term : ∀ {Γ τ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term = {!!}

apply-term : ∀ {Γ τ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term = {!!}

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = {!!}

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! 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 true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (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-t (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}


Strategy: runT

Strategy: runT

module Control.Strategy where

open import Function.NP
open import Type using (★)
open import Category.Monad
open import Data.Product hiding (map)
open import Data.List using (List; []; _∷_)
open import Relation.Binary.PropositionalEquality.NP

data Strategy (Q : ★) (R : Q → ★) (A : ★) : ★ where
  ask  : (q? : Q) (cont : R q? → Strategy Q R A) → Strategy Q R A
  done : A → Strategy Q R A

infix 2 _≈_
data _≈_ {Q R A} : (s₀ s₁ : Strategy Q R A) → ★ where
  ask-ask : ∀ (q? : Q) {k₀ k₁} (cont : ∀ r → k₀ r ≈ k₁ r) → ask q? k₀ ≈ ask q? k₁
  done-done : ∀ x → done x ≈ done x

≈-refl : ∀ {Q R A} {s : Strategy Q R A} → s ≈ s
≈-refl {s = ask q? cont} = ask-ask q? (λ r → ≈-refl)
≈-refl {s = done x}      = done-done x

module _ {Q : ★} {R : Q → ★} where
  private
    M : ★ → ★
    M = Strategy Q R

  _=<<_ : ∀ {A B} → (A → M B) → M A → M B
  f =<< ask q? cont = ask q? (λ r → f =<< cont r)
  f =<< done x      = f x

  return : ∀ {A} → A → M A
  return = done

  map : ∀ {A B} → (A → B) → M A → M B
  map f s = (done ∘ f) =<< s

  join : ∀ {A} → M (M A) → M A
  join s = id =<< s

  _>>=_ : ∀ {A B} → M A → (A → M B) → M B
  _>>=_ = flip _=<<_

  rawMonad : RawMonad M
  rawMonad = record { return = return; _>>=_ = _>>=_ }

  return-=<< : ∀ {A} (m : M A) → return =<< m ≈ m
  return-=<< (ask q? cont) = ask-ask q? (λ r → return-=<< (cont r))
  return-=<< (done x)      = done-done x

  return->>= : ∀ {A B} (x : A) (f : A → M B) → return x >>= f ≡ f x
  return->>= _ _ = refl

  >>=-assoc : ∀ {A B C} (mx : M A) (my : A → M B) (f : B → M C) → (mx >>= λ x → (my x >>= f)) ≈ (mx >>= my) >>= f
  >>=-assoc (ask q? cont) my f = ask-ask q? (λ r → >>=-assoc (cont r) my f)
  >>=-assoc (done x)      my f = ≈-refl

  map-id : ∀ {A} (s : M A) → map id s ≈ s
  map-id = return-=<<

  map-∘ : ∀ {A B C} (f : A → B) (g : B → C) s → map (g ∘ f) s ≈ (map g ∘ map f) s
  map-∘ f g s = >>=-assoc s (done ∘ f) (done ∘ g)

  module EffectfulRun
           (E : ★ → ★)
           (_>>=E_  : ∀ {A B} → E A → (A → E B) → E B)
           (returnE : ∀ {A} → A → E A)
           (Oracle  : (q : Q) → E (R q)) where
    runE : ∀ {A} → M A → E A
    runE (ask q? cont) = Oracle q? >>=E (λ r → runE (cont r))
    runE (done x)      = returnE x

  module _ (Oracle : (q : Q) → R q) where
    run : ∀ {A} → M A → A
    run (ask q? cont) = run (cont (Oracle q?))
    run (done x)      = x

    module _ {A B : ★} (f : A → M B) where
        run->>= : (s : M A) → run (s >>= f) ≡ run (f (run s))
        run->>= (ask q? cont) = run->>= (cont (Oracle q?))
        run->>= (done x)      = refl

    module _ {A B : ★} (f : A → B) where
        run-map : (s : M A) → run (map f s) ≡ f (run s)
        run-map = run->>= (return ∘ f)

    module _ {A B : ★} where
        run-≈ : {s₀ s₁ : M A} → s₀ ≈ s₁ → run s₀ ≡ run s₁
        run-≈ (ask-ask q? cont) = run-≈ (cont (Oracle q?))
        run-≈ (done-done x)     = refl

  private
    State : (S A : ★) → ★
    State S A = S → A × S

  -- redundant since we have EffectfulRun, but...
  module StatefulRun {S : ★} (Oracle : (q : Q) → State S (R q)) where
    runS : ∀ {A} → M A → State S A
    runS (ask q? cont) s = case Oracle q? s of λ { (x , s') → runS (cont x) s' }
    runS (done x)      s = x , s

    evalS : ∀ {A} → M A → S → A
    evalS x s = proj₁ (runS x s)

    execS : ∀ {A} → M A → S → S
    execS x s = proj₂ (runS x s)

  private
    Transcript = List (Σ Q R)
  module TranscriptRun (Oracle : Transcript → Π Q R){A} where
    runT : M A → Transcript → A × Transcript
    runT (ask q? cont) t = let r = Oracle t q? in runT (cont r) ((q? , r) ∷ t)
    runT (done x)      t = x , t
-- -}
-- -}
-- -}
-- -}

module Control.Strategy where

open import Function
open import Type using (★)
open import Category.Monad
open import Data.Product hiding (map)
open import Relation.Binary.PropositionalEquality.NP

data Strategy (Q : ★) (R : Q → ★) (A : ★) : ★ where
  ask  : (q? : Q) (cont : R q? → Strategy Q R A) → Strategy Q R A
  done : A → Strategy Q R A

infix 2 _≈_
data _≈_ {Q R A} : (s₀ s₁ : Strategy Q R A) → ★ where
  ask-ask : ∀ (q? : Q) {k₀ k₁} (cont : ∀ r → k₀ r ≈ k₁ r) → ask q? k₀ ≈ ask q? k₁
  done-done : ∀ x → done x ≈ done x

≈-refl : ∀ {Q R A} {s : Strategy Q R A} → s ≈ s
≈-refl {s = ask q? cont} = ask-ask q? (λ r → ≈-refl)
≈-refl {s = done x}      = done-done x

module _ {Q : ★} {R : Q → ★} where
  private
    M : ★ → ★
    M = Strategy Q R

  _=<<_ : ∀ {A B} → (A → M B) → M A → M B
  f =<< ask q? cont = ask q? (λ r → f =<< cont r)
  f =<< done x      = f x

  return : ∀ {A} → A → M A
  return = done

  map : ∀ {A B} → (A → B) → M A → M B
  map f s = (done ∘ f) =<< s

  join : ∀ {A} → M (M A) → M A
  join s = id =<< s

  _>>=_ : ∀ {A B} → M A → (A → M B) → M B
  _>>=_ = flip _=<<_

  rawMonad : RawMonad M
  rawMonad = record { return = return; _>>=_ = _>>=_ }

  return-=<< : ∀ {A} (m : M A) → return =<< m ≈ m
  return-=<< (ask q? cont) = ask-ask q? (λ r → return-=<< (cont r))
  return-=<< (done x)      = done-done x

  return->>= : ∀ {A B} (x : A) (f : A → M B) → return x >>= f ≡ f x
  return->>= _ _ = refl

  >>=-assoc : ∀ {A B C} (mx : M A) (my : A → M B) (f : B → M C) → (mx >>= λ x → (my x >>= f)) ≈ (mx >>= my) >>= f
  >>=-assoc (ask q? cont) my f = ask-ask q? (λ r → >>=-assoc (cont r) my f)
  >>=-assoc (done x)      my f = ≈-refl

  map-id : ∀ {A} (s : M A) → map id s ≈ s
  map-id = return-=<<

  map-∘ : ∀ {A B C} (f : A → B) (g : B → C) s → map (g ∘ f) s ≈ (map g ∘ map f) s
  map-∘ f g s = >>=-assoc s (done ∘ f) (done ∘ g)

  module EffectfulRun
           (E : ★ → ★)
           (_>>=E_  : ∀ {A B} → E A → (A → E B) → E B)
           (returnE : ∀ {A} → A → E A)
           (Oracle  : (q : Q) → E (R q)) where
    runE : ∀ {A} → M A → E A
    runE (ask q? cont) = Oracle q? >>=E (λ r → runE (cont r))
    runE (done x)      = returnE x

  module _ (Oracle : (q : Q) → R q) where
    run : ∀ {A} → M A → A
    run (ask q? cont) = run (cont (Oracle q?))
    run (done x)      = x

    module _ {A B : ★} (f : A → M B) where
        run->>= : (s : M A) → run (s >>= f) ≡ run (f (run s))
        run->>= (ask q? cont) = run->>= (cont (Oracle q?))
        run->>= (done x)      = refl

    module _ {A B : ★} (f : A → B) where
        run-map : (s : M A) → run (map f s) ≡ f (run s)
        run-map = run->>= (return ∘ f)

    module _ {A B : ★} where
        run-≈ : {s₀ s₁ : M A} → s₀ ≈ s₁ → run s₀ ≡ run s₁
        run-≈ (ask-ask q? cont) = run-≈ (cont (Oracle q?))
        run-≈ (done-done x)     = refl

  private
    State : (S A : ★) → ★
    State S A = S → A × S

  -- redundant since we have EffectfulRun, but...
  module StatefulRun {S : ★} (Oracle : (q : Q) → State S (R q)) where
    runS : ∀ {A} → M A → State S A
    runS (ask q? cont) s = case Oracle q? s of λ { (x , s') → runS (cont x) s' }
    runS (done x)      s = x , s

    evalS : ∀ {A} → M A → S → A
    evalS x s = proj₁ (runS x s)

    execS : ∀ {A} → M A → S → S
    execS x s = proj₂ (runS x s)
-- -}
-- -}
-- -}
-- -}


Rename Atlas-diff to diff-base.

Rename Atlas-diff to diff-base.

Old-commit-hash: 8940b78431520f22d625a114d12ce0faee05542c

module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (ΔBase ι))
nil-term {Bool}   = curriedConst (nil-const {Bool})
nil-term {Map κ ι} = curriedConst (nil-const {Map κ ι})

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

diff-base : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
diff-base {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
diff-base {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs diff-base) m₁ m₂)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-apply {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-apply) m₁ m₂)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (ΔType τ)
diff = app₂ (lift-diff diff-base Atlas-apply)

apply : ∀ {τ Γ} →
  Term Γ (ΔType τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply diff-base Atlas-apply)

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (ΔBase ι))
nil-term {Bool}   = curriedConst (nil-const {Bool})
nil-term {Map κ ι} = curriedConst (nil-const {Map κ ι})

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
Atlas-diff {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-diff {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-diff) m₁ m₂)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-apply {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-apply) m₁ m₂)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (ΔType τ)
diff = app₂ (lift-diff Atlas-diff Atlas-apply)

apply : ∀ {τ Γ} →
  Term Γ (ΔType τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply Atlas-diff Atlas-apply)

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc


Added more files to the readme

Added more files to the readme

module EXPLORE-README where

open import Explore.Type

open import Explore.Derived
open import Explore.Explorable
open import Explore.Summable

-- Examples
open import Explore.BinTree
open import Explore.Product
open import Explore.Subset
open import Explore.Sum

-- Other
open import Explore.Monad
open import Explore.Syntax

module EXPLORE-README where

open import Explore.Type
open import Explore.Explorable
open import Explore.Sum

-- Examples
open import Explore.Sum
open import Explore.Product


game.agda

game.agda

module game where

open import Function.NP
open import Data.Nat.NP
open import Data.Product
open import Data.Bool -- hiding (_≟_)

{-
-- Game
data ⅁ ...
-}

data Strategy (☐_ : Set → Set) (R : Set) : Set₁ where
  say : R → Strategy ☐_ R
  ask : {A : Set} → ☐ A → (A → Strategy ☐_ R) → Strategy ☐_ R

run : ∀ {R} → Strategy id R → R
run (say r)   = r
run (ask a f) = run (f a)

open import Data.Bits

pattern looks-random = 0b
pattern not-random   = 1b

module CryptoGames where

  module CipherGames (|M| |C| : ℕ) where
    M : Set
    M = Bits |M|
    C : Set
    C = Bits |C|

    SemSecAdv : Set
    SemSecAdv = C → Bit

    CPAAdv : Set₁
    CPAAdv = ∀ {☐_} (enc : M → ☐ C) → Strategy ☐_ Bit

    data CPAWinner (enc : M → C) b : Strategy id Bit → Set₁ where
      win : CPAWinner enc b (say b)
      ask : ∀ {m f} → CPAWinner enc b (f (enc m)) → CPAWinner enc b (ask (enc m) f)

    CPA2Sem : SemSecAdv → CPAAdv
    CPA2Sem semAdv enc = ask (enc 0…) (λ c → say (semAdv c))

    CPA2Sem-correct : SemSecWinner semAdv → CPAWinner enc b (CPA2Sem semAdv)
    CPA2Sem-correct

  module MACGames (M T : Set) where
    MacAdv : Set₁
    MacAdv = ∀ {☐_} (mac : M → ☐ T) → Strategy ☐_ (M × T)

    data MACWinner (mac : M → T) : Strategy id (M × T) → Set₁ where
      win : ∀ {m} → MACWinner mac (say (m , mac m))
      ask : ∀ {m f} → MACWinner mac (f (mac m)) → MACWinner mac (ask (mac m) f)

module game where

open import Function.NP
open import Data.Nat.NP
open import Data.Product
open import Data.Bool -- hiding (_≟_)

{-
-- Game
data ⅁ ...
-}

data Strategy (☐_ : Set → Set) (R : Set) : Set₁ where
  say : R → Strategy ☐_ R
  ask : {A : Set} → ☐ A → (A → Strategy ☐_ R) → Strategy ☐_ R

run : ∀ {R} → Strategy id R → R
run (say r)   = r
run (ask a f) = run (f a)

open import Data.Bits

pattern looks-random = 0b
pattern not-random   = 1b

module CryptoGames where

  module CipherGames (M C : Set) where
    SemSecAdv : Set
    SemSecAdv = C → Bit

    CPAAdv : Set₁
    CPAAdv = ∀ {☐_} (enc : M → ☐ C) → Strategy ☐_ Bit

    data CPAWinner (enc : M → C) b : Strategy id Bit → Set₁ where
      win : CPAWinner enc b (say b)
      ask : ∀ {m f} → CPAWinner enc b (f (enc m)) → CPAWinner enc b (ask (enc m) f)

  module MACGames (M T : Set) where
    MacAdv : Set₁
    MacAdv = ∀ {☐_} (mac : M → ☐ T) → Strategy ☐_ (M × T)

    data MACWinner (mac : M → T) : Strategy id (M × T) → Set₁ where
      win : ∀ {m} → MACWinner mac (say (m , mac m))
      ask : ∀ {m f} → MACWinner mac (f (mac m)) → MACWinner mac (ask (mac m) f)


Relate further new-style to old-style validity

Extract, out of valid function changes in the "new style" from my PhD
thesis, something similar (but not equivalent) to function changes in
the "old style" of PLDI'14.

module Thesis.RelateToValidity where

open import Relation.Binary.PropositionalEquality public hiding ([_])

open import Thesis.Changes
open import Thesis.Lang

module _ {A : Set} {{CA : ChangeStructure A}} where
  fromto→valid fromto→valid-2 : ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) → valid a1 da
  fromto→valid da a1 a2 daa rewrite fromto→⊕ da a1 _ daa = daa
  fromto→valid-2 da a1 a2 daa = subst (ch da from a1 to_) (sym (fromto→⊕ da a1 a2 daa)) daa

  -- The "inverse" is so trivial to not be worth calling, hence commented out:
  -- valid→fromto : ∀ da (a : A) → (valid a da) → ch da from a to (a ⊕ da)
  -- valid→fromto _ _ daa = daa

module _
  {A : Set} {B : Set} {{CA : ChangeStructure A}} {{CB : ChangeStructure B}} where

  WellDefinedFunChangePoint : ∀ (f : A → B) → (df : Ch (A → B)) → ∀ a da → Set
  WellDefinedFunChangePoint f df a da = (f ⊕ df) (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChangeFromTo′ : ∀ (f1 : A → B) → (df : Ch (A → B)) → Set
  WellDefinedFunChangeFromTo′ f1 df = ∀ da a → valid a da → WellDefinedFunChangePoint f1 df a da

  open ≡-Reasoning
  open import Function

  fromto-incrementalization : ∀ {f1 f2 : A → B} {df} → ch df from f1 to f2 →
    ∀ {da a} → valid a da →
    f1 a ⊕ df a da ≡ f2 (a ⊕ da)
  fromto-incrementalization {f1 = f1} {f2} {df} dff {da} {a} daa = fromto→⊕ _ _ _ (dff da a _ daa)

  fromto→valid-fun : ∀ {f1 f2 : A → B} {df : Ch (A → B)} → ch df from f1 to f2 → ∀ {a da} (daa : valid a da) → valid (f1 a) (df a da)
  fromto→valid-fun {f1} {f2} {df} dff {a} {da} daa = fromto→valid (df a da) (f1 a) _ (dff da a _ daa)

  fromto→WellDefined′ : ∀ {f1 f2 df} → ch df from f1 to f2 →
    WellDefinedFunChangeFromTo′ f1 df
  fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
    begin
      (f1 ⊕ df) (a ⊕ da)
    ≡⟨ cong (_$ (a ⊕ da)) (fromto→⊕ df f1 f2 dff)⟩
      f2 (a ⊕ da)
    ≡⟨ sym (fromto-incrementalization dff daa) ⟩
      f1 a ⊕ df a da
    ∎

  -- Δ f is similar to function changes in PLDI'14, but PLDI'14 function changes
  -- need not be defined on invalid changes; instead, if (df, dff) : Δ f, then
  -- df is a function change that is also defined on invalid changes.
  --
  -- Next we define fΔ. It is closer to the PLDI'14 definition of function
  -- changes; but it is not defined recursively, so it still produces new-style
  -- function changes.
  --
  -- Hence this is sort of bigger than Δ f, though not really.
  fΔ : (A → B) → Set
  fΔ f = (a : A) → Δ a → Δ (f a)

  -- We can indeed map Δ f into fΔ f, via valid-functions-map-Δ. If this mapping
  -- were an injection, we could say that fΔ f is bigger than Δ f. But we'd need
  -- first to quotient Δ f to turn valid-functions-map-Δ into an injection:
  --
  -- 1. We need to quotient Δ f by extensional equivalence of functions.
  --    Luckily, we can just postulate it.
  --
  -- 2. We need to quotient Δ f by identifying functions that only differ by
  --    behavior on invalid changes; such functions can't be distinguished after
  --    being injected into fΔ f.
  valid-functions-map-Δ : ∀ (f : A → B) (df : Δ f) → fΔ f
  valid-functions-map-Δ f (df , dff) a (da , daa) = df a da , valid-res
    where
      valid-res : ch df a da from f a to (f a ⊕ df a da)
      valid-res rewrite sym (fromto→WellDefined′ dff da a daa) = dff da a (a ⊕ da) daa

  -- Two alternative proofs
  fromto-functions-map-Δ-1 fromto-functions-map-Δ-2 : ∀ (f1 f2 : A → B) (df : Ch (A → B)) → ch df from f1 to f2 → fΔ f1
  fromto-functions-map-Δ-1 f1 f2 df dff a (da , daa) = valid-functions-map-Δ f1 (df , fromto→valid df f1 f2 dff) a (da , daa)

  fromto-functions-map-Δ-2 f1 f2 df dff a (da , daa) = df a da , fromto→valid-fun dff daa

open import Thesis.LangChanges

fromto→WellDefined′Lang : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′Lang {f1 = f1} {f2} {df} dff da a daa =
  fromto→WellDefined′ dff da a daa

module Thesis.RelateToValidity where

open import Relation.Binary.PropositionalEquality public hiding ([_])

open import Thesis.Changes
open import Thesis.Lang

module _
  {A : Set} {B : Set} {{CA : ChangeStructure A}} {{CB : ChangeStructure B}} where

  WellDefinedFunChangePoint : ∀ (f : A → B) → (df : Ch (A → B)) → ∀ a da → Set
  WellDefinedFunChangePoint f df a da = (f ⊕ df) (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChangeFromTo′ : ∀ (f1 : A → B) → (df : Ch (A → B)) → Set
  WellDefinedFunChangeFromTo′ f1 df = ∀ da a → ch da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

  open ≡-Reasoning

  fromto→WellDefined′ : ∀ {f1 f2 df} → ch df from f1 to f2 →
    WellDefinedFunChangeFromTo′ f1 df
  fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
    begin
      (f1 ⊕ df) (a ⊕ da)
    ≡⟨ cong (λ □ → □ (a ⊕ da)) (fromto→⊕ df f1 f2 dff)⟩
      f2 (a ⊕ da)
    ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
      f1 a ⊕ df a da
    ∎

  -- This is similar (not equivalent) to the old definition of function changes.
  -- However, such a function need not be defined on invalid changes, unlike the
  -- functions.
  --
  -- Hence this is sort of bigger than Δ f, though not really.
  fΔ : (A → B) → Set
  fΔ f = (a : A) → Δ a → Δ (f a)

  -- We can indeed map Δ f into fΔ f, via valid-functions-map-Δ. If this mapping
  -- were an injection, we could say that fΔ f is bigger than Δ f. But we'd need
  -- first to quotient Δ f to turn valid-functions-map-Δ into an injection:
  --
  -- 1. We need to quotient Δ f by extensional equivalence of functions.
  --    Luckily, we can just postulate it.
  --
  -- 2. We need to quotient Δ f by identifying functions that only differ by
  --    behavior on invalid changes; such functions can't be distinguished after
  --    being injected into fΔ f.
  valid-functions-map-Δ : ∀ (f : A → B) (df : Δ f) → fΔ f
  valid-functions-map-Δ f (df , dff) a (da , daa) = df a da , valid-res
    where
      valid-res : ch df a da from f a to (f a ⊕ df a da)
      valid-res rewrite sym (fromto→WellDefined′ dff da a daa) = dff da a (a ⊕ da) daa

  fromto-functions-map-Δ : ∀ (f1 f2 : A → B) (df : Ch (A → B)) → ch df from f1 to f2 → fΔ f1
  fromto-functions-map-Δ f1 f2 df dff a (da , daa) = valid-functions-map-Δ f1 (df , dff′) a (da , daa)
    where
      dff′ : ch df from f1 to (f1 ⊕ df)
      dff′ = subst (ch df from f1 to_) (sym (fromto→⊕ df f1 f2 dff)) dff

open import Thesis.LangChanges

fromto→WellDefined′Lang : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′Lang {f1 = f1} {f2} {df} dff da a daa =
  fromto→WellDefined′ dff da a daa