FromAdequate-sum: sum-ext

FromAdequate-sum: sum-ext

{-# OPTIONS --without-K #-}
-- Constructions on top of exploration functions

open import Level.NP
open import Type hiding (★)
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Algebra.FunctionProperties.NP
open import Data.Two.Base
open import Data.Indexed
open import Data.Nat.NP hiding (_⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin) renaming (zero to fzero)
open import Data.Maybe.NP
open import Algebra
open import Data.Product.NP renaming (map to ×-map) hiding (first)
open import Data.Sum.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Nullary.NP
open import Relation.Binary
open import Relation.Binary.Sum using (_⊎-cong_)
open import Relation.Binary.Product.Pointwise using (_×-cong_)
import Function.Related as FR
import Relation.Binary.PropositionalEquality.NP as ≡
open import HoTT
open Equivalences
open ≡ using (_≡_)

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM

module Explore.Explorable where

module _ {m a} {A : ★ a} where
  open EM {a} m
  gfilter-explore : ∀ {B} → (A →? B) → Explore m A → Explore m B
  gfilter-explore f eᴬ = eᴬ >>= λ x → maybe (λ η → point-explore η) empty-explore (f x)

  filter-explore : (A → 𝟚) → Explore m A → Explore m A
  filter-explore p = gfilter-explore λ x → [0: nothing 1: just x ] (p x)

  -- monoidal exploration: explore A with a monoid M
  explore-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-monoid eᴬ M = eᴬ ε _·_ where open Mon M renaming (_∙_ to _·_)

  explore-endo : Explore m A → Explore m A
  explore-endo eᴬ ε op f = eᴬ id _∘′_ (op ∘ f) ε

  explore-endo-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-endo-monoid = explore-monoid ∘ explore-endo

  explore-backward : Explore m A → Explore m A
  explore-backward eᴬ ε _∙_ f = eᴬ ε (flip _∙_) f

  -- explore-backward ∘ explore-backward = id
  -- (m : a comm monoid) → explore-backward m = explore m

private
  module FindForward {a} {A : ★ a} (explore : Explore a A) where
    find? : Find? A
    find? = explore nothing (M?._∣_ _)

    first : Maybe A
    first = find? just

    findKey : FindKey A
    findKey pred = find? (λ x → [0: nothing 1: just x ] (pred x))

module ExplorePlug {ℓ a} {A : ★ a} where
  record ExploreIndKit p (P : Explore ℓ A → ★ p) : ★ (a ⊔ ₛ ℓ ⊔ p) where
    constructor mk
    field
      Pε : P empty-explore
      P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁)
      Pf : ∀ x → P (point-explore x)

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

  _,-kit_ : ∀ {p} {P : Explore ℓ A → ★ p}{Q : Explore ℓ A → ★ p}
            → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
  Pk ,-kit Qk = mk (Pε Pk , Pε Qk)
                   (λ x y → P∙ Pk (fst x) (fst y) , P∙ Qk (snd x) (snd y))
                   (λ x → Pf Pk x , Pf Qk x)
               where open ExploreIndKit

  ExploreInd-Extra : ∀ p → Explore ℓ A → ★ _
  ExploreInd-Extra p exp =
    ∀ (Q     : Explore ℓ A → ★ p)
      (Q-kit : ExploreIndKit p Q)
      (P     : Explore ℓ A → ★ p)
      (Pε    : P empty-explore)
      (P∙    : ∀ {e₀ e₁ : Explore ℓ A} → Q e₀ → Q e₁ → P e₀ → P e₁
               → P (merge-explore e₀ e₁))
      (Pf    : ∀ x → P (point-explore x))
    → P exp

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

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

  plugKit : ∀ {m} (M : Monoid ℓ m) → ExploreIndKit _ (ExplorePlug M)
  plugKit M = mk (λ _ → fst identity)
                 (λ Ps Ps' f x →
                    trans (∙-cong (! Ps _ _) refl)
                          (trans (assoc _ _ _)
                                 (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
                 (λ x f _ → ∙-cong (snd identity (f x)) refl)
       where open Mon M

module FromExplore
    {a} {A : ★ a}
    (explore : ∀ {ℓ} → Explore ℓ A) where

  module _ {ℓ} where
    with-monoid : ∀ {m} → ExploreMon ℓ m A
    with-monoid = explore-monoid explore

    with∘ : Explore ℓ A
    with∘ = explore-endo explore

    with-endo-monoid : ∀ {m} → ExploreMon ℓ m A
    with-endo-monoid = explore-endo-monoid explore

    backward : Explore ℓ A
    backward = explore-backward explore

    gfilter : ∀ {B} → (A →? B) → Explore ℓ B
    gfilter f = gfilter-explore f explore

    filter : (A → 𝟚) → Explore ℓ A
    filter p = filter-explore p explore

  sum : Sum A
  sum = explore 0 _+_

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (𝟚▹ℕ ∘ f)

  product : (A → ℕ) → ℕ
  product = explore 1 _*_

  big-∧ and big-∨ or big-xor : (A → 𝟚) → 𝟚

  big-∧ = explore 1₂ _∧_
  and   = big-∧
  all   = big-∧

  big-∨ = explore 0₂ _∨_
  or    = big-∨
  any   = big-∨

  big-xor = explore 0₂ _xor_

  bin-tree : BinTree A
  bin-tree = explore empty fork leaf

  list : List A
  list = explore List.[] _++_ List.[_]

  module FindBackward = FindForward backward

  findLast? : Find? A
  findLast? = FindBackward.find?

  last : Maybe A
  last = FindBackward.first

  findLastKey : FindKey A
  findLastKey = FindBackward.findKey

  open FindForward explore public

module FromExploreInd
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (explore-ind : ∀ {p ℓ} → ExploreInd {ℓ} p explore)
    where

  open FromExplore explore public

  module _ {ℓ p} where
    explore-mon-ext : ExploreMonExt {ℓ} p explore
    explore-mon-ext m {f} {g} f≈°g = explore-ind (λ s → s _ _ f ≈ s _ _ g) refl ∙-cong f≈°g
      where open Mon m

    explore-mono : ExploreMono {ℓ} p explore
    explore-mono _⊆_ z⊆ _∙-mono_ {f} {g} f⊆°g =
      explore-ind (λ e → e _ _ f ⊆ e _ _ g) z⊆ _∙-mono_ f⊆°g

    open ExplorePlug {ℓ} {a} {A}

    explore∘-plug : (M : Monoid ℓ ℓ) → ExplorePlug M explore
    explore∘-plug M = explore-ind $kit plugKit M

    module _ (M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = explore-ind (λ e → ∀ z → e ε _∙_ f ∙ z ≈ explore-endo e z _∙_ f)
                                                (fst identity) (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _))) (λ _ _ → refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

    explore∘-ind : ∀ (M : Monoid ℓ ℓ) → BigOpMonInd ℓ M (with-endo-monoid M)
    explore∘-ind M P Pε P∙ Pf P≈ =
      snd (explore-ind (λ e → ExplorePlug M e × P (λ f → e id _∘′_ (_∙_ ∘ f) ε))
                 (const (fst identity) , Pε)
                 (λ {e} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {e} {s'} (fst Ps) (fst Ps')
                                    , P≈ (λ f → fst Ps f _) (P∙ (snd Ps) (snd Ps')))
                 (λ x → ExploreIndKit.Pf (plugKit M) x
                      , P≈ (λ f → ! snd identity _) (Pf x)))
      where open Mon M

    explore-swap : ∀ {b} → ExploreSwap {ℓ} p explore {b}
    explore-swap mon {eᴮ} eᴮ-ε pf f =
      explore-ind (λ e → e _ _ (eᴮ ∘ f) ≈ eᴮ (e _ _ ∘ flip f))
                  (! eᴮ-ε)
                  (λ p q → trans (∙-cong p q) (! pf _ _))
                  (λ _ → refl)
      where open Mon mon

    explore-ε : Exploreε {ℓ} p explore
    explore-ε M = explore-ind (λ e → e ε _ (const ε) ≈ ε)
                              refl
                              (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (fst identity ε))
                              (λ _ → refl)
      where open Mon M

    explore-hom : ExploreHom {ℓ} p explore
    explore-hom cm f g = explore-ind (λ e → e _ _ (f ∙° g) ≈ e _ _ f ∙ e _ _ g)
                                     (! fst identity ε)
                                     (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _))
                                     (λ _ → refl)
      where open CMon cm

    explore-linˡ : ExploreLinˡ {ℓ} p explore
    explore-linˡ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → k ◎ f x) ≈ k ◎ e ε _∙_ f) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    explore-linʳ : ExploreLinʳ {ℓ} p explore
    explore-linʳ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → f x ◎ k) ≈ e ε _∙_ f ◎ k) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    module ProductMonoid
        {M : ★₀} (εₘ : M) (_⊕ₘ_ : Op₂ M)
        {N : ★₀} (εₙ : N) (_⊕ₙ_ : Op₂ N)
        where
        ε = (εₘ , εₙ)
        _⊕_ : Op₂ (M × N)
        (xₘ , xₙ) ⊕ (yₘ , yₙ) = (xₘ ⊕ₘ yₘ , xₙ ⊕ₙ yₙ)

        explore-product-monoid :
          ∀ fₘ fₙ → explore ε _⊕_ < fₘ , fₙ > ≡ (explore εₘ _⊕ₘ_ fₘ , explore εₙ _⊕ₙ_ fₙ)
        explore-product-monoid fₘ fₙ =
          explore-ind (λ e → e ε _⊕_ < fₘ , fₙ > ≡ (e εₘ _⊕ₘ_ fₘ , e εₙ _⊕ₙ_ fₙ)) ≡.refl (≡.ap₂ _⊕_) (λ _ → ≡.refl)
  {-
  empty-explore:
    ε ≡ (εₘ , εₙ) ✓
  point-explore (x , y):
    < fₘ , fₙ > (x , y) ≡ (fₘ x , fₙ y) ✓
  merge-explore e₀ e₁:
    e₀ ε _⊕_ < fₘ , fₙ > ⊕ e₁ ε _⊕_ < fₘ , fₙ >
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ) ⊕ (e₁ εₘ _⊕ₘ_ fₘ , e₁ εₙ _⊕ₙ_ fₙ)
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ ⊕ e₁ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ ⊕ e₁ εₙ _⊕ₙ_ fₙ)
  -}

  module _ {ℓ} where
    reify : Reify {ℓ} explore
    reify = explore-ind (λ eᴬ → Πᵉ eᴬ _) _ _,_

    unfocus : Unfocus {ℓ} explore
    unfocus = explore-ind Unfocus (λ{ (lift ()) }) (λ P Q → [ P , Q ]) (λ η → _,_ η)

    module _ {ℓᵣ aᵣ} {Aᵣ : A → A → ★ aᵣ}
             (Aᵣ-refl : Reflexive Aᵣ) where
      ⟦explore⟧ : ⟦Explore⟧ ℓᵣ Aᵣ (explore {ℓ}) (explore {ℓ})
      ⟦explore⟧ Mᵣ zᵣ ∙ᵣ fᵣ = explore-ind (λ e → Mᵣ (e _ _ _) (e _ _ _)) zᵣ (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

    explore-ext : ExploreExt {ℓ} explore
    explore-ext ε op = explore-ind (λ e → e _ _ _ ≡ e _ _ _) ≡.refl (≡.ap₂ op)

  module LiftHom
       {m p}
       {S T : ★ m}
       (_≈_ : T → T → ★ p)
       (≈-refl : Reflexive _≈_)
       (≈-trans : Transitive _≈_)
       (zero : S)
       (_+_  : Op₂ S)
       (one  : T)
       (_*_  : Op₂ T)
       (≈-cong-* : _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
       (f   : S → T)
       (g   : A → S)
       (hom-0-1 : f zero ≈ one)
       (hom-+-* : ∀ {x y} → (f (x + y)) ≈ (f x * f y))
       where

        lift-hom : f (explore zero _+_ g) ≈ explore one _*_ (f ∘ g)
        lift-hom = explore-ind (λ e → f (e zero _+_ g) ≈ e one _*_ (f ∘ g))
                               hom-0-1
                               (λ p q → ≈-trans hom-+-* (≈-cong-* p q))
                               (λ _ → ≈-refl)

  module _ {ℓ} {P : A → ★_ ℓ} where
    open LiftHom {S = ★_ ℓ} {★_ ℓ} (λ A B → B → A) id _∘′_
                 (Lift 𝟘) _⊎_ (Lift 𝟙) _×_
                 (λ f g → ×-map f g) Dec P (const (no (λ{ (lift ()) })))
                 (uncurry Dec-⊎)
                 public renaming (lift-hom to lift-Dec)

  module FromFocus {p} (focus : Focus {p} explore) where
    Dec-Σ : ∀ {P} → Π A (Dec ∘ P) → Dec (Σ A P)
    Dec-Σ = map-Dec unfocus focus ∘ lift-Dec ∘ reify

  lift-hom-≡ :
      ∀ {m} {S T : ★ m}
        (zero : S)
        (_+_  : Op₂ S)
        (one  : T)
        (_*_  : Op₂ T)
        (f    : S → T)
        (g    : A → S)
        (hom-0-1 : f zero ≡ one)
        (hom-+-* : ∀ {x y} → f (x + y) ≡ f x * f y)
      → f (explore zero _+_ g) ≡ explore one _*_ (f ∘ g)
  lift-hom-≡ z _+_ o _*_ = LiftHom.lift-hom _≡_ ≡.refl ≡.trans z _+_ o _*_ (≡.ap₂ _*_)

  sum-ind : SumInd sum
  sum-ind P P0 P+ Pf = explore-ind (λ e → P (e 0 _+_)) P0 P+ Pf

  sum-ext : SumExt sum
  sum-ext = explore-ext 0 _+_

  sum-zero : SumZero sum
  sum-zero = explore-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = explore-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = explore-mono _≤_ z≤n _+-mono_

  sum-swap' : SumSwap sum
  sum-swap' {sumᴮ = sᴮ} sᴮ-0 hom f =
    sum-ind (λ s → s (sᴮ ∘ f) ≡ sᴮ (s ∘ flip f))
            (! sᴮ-0)
            (λ p q → (ap₂ _+_ p q) ∙ (! hom _ _)) (λ _ → refl)
    where open ≡

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.ap₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  sum-const : SumConst sum
  sum-const x = sum-ext (λ _ → ! snd ℕ°.*-identity x) ∙ sum-lin (const 1) x ∙ ℕ°.*-comm x Card
    where open ≡

  exploreStableUnder→sumStableUnder : ∀ {p} → StableUnder explore p → SumStableUnder sum p
  exploreStableUnder→sumStableUnder SU-p = SU-p 0 _+_

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong 𝟚▹ℕ ∘ f≗g)

  sumStableUnder→countStableUnder : ∀ {p} → SumStableUnder sum p → CountStableUnder count p
  sumStableUnder→countStableUnder sumSU-p f = sumSU-p (𝟚▹ℕ ∘ f)

  diff-list = with-endo-monoid (List.monoid A) List.[_]

  {-
  list≡diff-list : list ≡ diff-list
  list≡diff-list = {!explore-endo-monoid-spec (List.monoid A) List.[_]!}
  -}

  lift-op₂ : ∀ {a}{A : ★_ a}(op : Op₂ A){ℓ} → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A
  lift-op₂ op (lift x) (lift y) = lift (op x y)

  lift-sum : ∀ ℓ → Sum A
  lift-sum ℓ f = lower {₀} {ℓ} (explore (lift 0) (lift-op₂ _+_) (lift ∘ f))

  Fin-lower-sum≡Σᵉ-Fin : ∀ {{_ : UA}}(f : A → ℕ) → Fin (lift-sum _ f) ≡ Σᵉ explore (Fin ∘ f)
  Fin-lower-sum≡Σᵉ-Fin f = LiftHom.lift-hom _≡_ ≡.refl ≡.trans (lift 0) (lift-op₂ _+_) (Lift 𝟘) _⊎_ ⊎= (Fin ∘ lower) (lift ∘ f) (Fin0≡𝟘 ∙ ! Lift≡id) (! Fin-⊎-+)
    where open ≡

module FromTwoExploreInd
    {a} {A : ★ a}
    {eᴬ : ∀ {ℓ} → Explore ℓ A}
    (eᴬ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴬ)
    {b} {B : ★ b}
    {eᴮ : ∀ {ℓ} → Explore ℓ B}
    (eᴮ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴮ)
    where

    module A = FromExploreInd eᴬ-ind
    module B = FromExploreInd eᴮ-ind

    module _ {c ℓ}(cm : CommutativeMonoid c ℓ) where
        open CMon cm

        opᴬ = eᴬ ε _∙_
        opᴮ = eᴮ ε _∙_

        -- TODO use lift-hom
        explore-swap' : ∀ f → opᴬ (opᴮ ∘ f) ≈ opᴮ (opᴬ ∘ flip f)
        explore-swap' = A.explore-swap m (B.explore-ε m) (B.explore-hom cm)

    sum-swap : ∀ f → A.sum (B.sum ∘ f) ≡ B.sum (A.sum ∘ flip f)
    sum-swap = explore-swap' ℕ°.+-commutativeMonoid

module FromTwoAdequate-sum
  {{_ : UA}}{{_ : FunExt}}
  {A}{B}
  {sumᴬ : Sum A}{sumᴮ : Sum B}
  (open Adequacy _≡_)
  (sumᴬ-adq : Adequate-sum sumᴬ)
  (sumᴮ-adq : Adequate-sum sumᴮ) where

  open ≡
  sumStableUnder : (p : A ≃ B)(f : B → ℕ)
                 → sumᴬ (f ∘ ·→ p) ≡ sumᴮ f
  sumStableUnder p f = Fin-injective (sumᴬ-adq (f ∘ ·→ p)
                                      ∙ Σ-fst≃ p _
                                      ∙ ! sumᴮ-adq f)

  sumStableUnder′ : (p : A ≃ B)(f : A → ℕ)
                 → sumᴬ f ≡ sumᴮ (f ∘ <– p)
  sumStableUnder′ p f = Fin-injective (sumᴬ-adq f
                                      ∙ Σ-fst≃′ p _
                                      ∙ ! sumᴮ-adq (f ∘ <– p))

module FromAdequate-sum
  {A}
  {sum : Sum A}
  (open Adequacy _≡_)
  (sum-adq : Adequate-sum sum)
  {{_ : UA}}{{_ : FunExt}}
  where

  open FromTwoAdequate-sum sum-adq sum-adq public
  open ≡

  sum-ext : SumExt sum
  sum-ext = ap sum ∘ λ=

  private
    count : Count A
    count f = sum (𝟚▹ℕ ∘ f)

  private
    module M {p q : A → 𝟚}(same-count : count p ≡ count q) where
      private

        P = λ x → p x ≡ 1₂
        Q = λ x → q x ≡ 1₂
        ¬P = λ x → p x ≡ 0₂
        ¬Q = λ x → q x ≡ 0₂

        π : Σ A P ≡ Σ A Q
        π = ! Σ=′ _ (count-≡ p)
            ∙ ! (sum-adq (𝟚▹ℕ ∘ p))
            ∙ ap Fin same-count
            ∙ sum-adq (𝟚▹ℕ ∘ q)
            ∙ Σ=′ _ (count-≡ q)

        lem1 : ∀ px qx → 𝟚▹ℕ qx ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ (not px) * 𝟚▹ℕ qx
        lem1 1₂ 1₂ = ≡.refl
        lem1 1₂ 0₂ = ≡.refl
        lem1 0₂ 1₂ = ≡.refl
        lem1 0₂ 0₂ = ≡.refl

        lem2 : ∀ px qx → 𝟚▹ℕ px ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ px * 𝟚▹ℕ (not qx)
        lem2 1₂ 1₂ = ≡.refl
        lem2 1₂ 0₂ = ≡.refl
        lem2 0₂ 1₂ = ≡.refl
        lem2 0₂ 0₂ = ≡.refl

        lemma1 : ∀ px qx → (qx ≡ 1₂) ≡ (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 0₂ × qx ≡ 1₂))
        lemma1 px qx = ! Fin-≡-≡1₂ qx
                     ∙ ap Fin (lem1 px qx)
                     ∙ ! Fin-⊎-+
                     ∙ ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡0₂ px) (Fin-≡-≡1₂ qx))

        lemma2 : ∀ px qx → (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 1₂ × qx ≡ 0₂)) ≡ (px ≡ 1₂)
        lemma2 px qx = ! ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡1₂ px) (Fin-≡-≡0₂ qx)) ∙ Fin-⊎-+ ∙ ap Fin (! lem2 px qx) ∙ Fin-≡-≡1₂ px

        π' : (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x →  P x × ¬Q x))
           ≡ (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x → ¬P x ×  Q x))
        π' = ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl
           ∙ ! Σ⊎-split
           ∙ Σ=′ _ (λ x → lemma2 (p x) (q x))
           ∙ π
           ∙ Σ=′ _ (λ x → lemma1 (p x) (q x))
           ∙ Σ⊎-split
           ∙ ! ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl

        π'' : Σ A (P ×° ¬Q) ≡ Σ A (¬P ×° Q)
        π'' = Fin⊎-injective (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) π'

      open EquivalentSubsets π'' public

  same-count→iso : ∀{p q : A → 𝟚}(same-count : count p ≡ count q) → p ≡ q ∘ M.π {p} {q} same-count
  same-count→iso {p} {q} sc = M.prop {p} {q} sc

module From⟦Explore⟧
    {-a-} {A : ★₀ {- a-}}
    {explore   : ∀ {ℓ} → Explore ℓ A}
    (⟦explore⟧ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ explore explore)
    {{_ : UA}}
    where
  open FromExplore explore

  module AlsoInFromExploreInd
          {ℓ}(M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = ⟦explore⟧ ₀ {C} {C → C}
                                              (λ r s → ∀ z → r ∙ z ≈ s z)
                                              (fst identity)
                                              (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _)))
                                              (λ xᵣ _ → ∙-cong (reflexive (≡.ap f xᵣ)) refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

  open ≡
  module _ (f : A → ℕ) where
    sum⇒Σᵉ : Fin (explore 0 _+_ f) ≡ explore (Lift 𝟘) _⊎_ (Fin ∘ f)
    sum⇒Σᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ n X → Fin n ≡ X)
                (Fin0≡𝟘 ∙ ! Lift≡id)
                (λ p q → ! Fin-⊎-+ ∙ ⊎= p q)
                (ap (Fin ∘ f))

    product⇒Πᵉ : Fin (explore 1 _*_ f) ≡ explore (Lift 𝟙) _×_ (Fin ∘ f)
    product⇒Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                    (λ n X → Fin n ≡ X)
                    (Fin1≡𝟙 ∙ ! Lift≡id)
                    (λ p q → ! Fin-×-* ∙ ×= p q)
                    (ap (Fin ∘ f))

  module _ (f : A → 𝟚) where
    ✓all-Πᵉ : ✓ (all f) ≡ Πᵉ explore (✓ ∘ f)
    ✓all-Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ b X → ✓ b ≡ X)
                (! Lift≡id)
                (λ p q → ✓-∧-× _ _ ∙ ×= p q)
                (ap (✓ ∘ f))

    ✓any→Σᵉ : ✓ (any f) → Σᵉ explore (✓ ∘ f)
    ✓any→Σᵉ p = ⟦explore⟧ {₀} {ₛ ₀} ₁
                         (λ b (X : ★₀) → Lift (✓ b) → X)
                         (λ x → lift (lower x))
                         (λ { {0₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inr (yᵣ zᵣ)
                            ; {1₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inl (xᵣ _) })
                         (λ xᵣ x → tr (✓ ∘ f) xᵣ (lower x)) (lift p)

  module FromAdequate-Σᵉ
           (adequate-Σᵉ : ∀ {ℓ} → Adequate-Σ {ℓ} (Σᵉ explore))
          where
    open Adequacy

    adequate-sum : Adequate-sum _≡_ sum
    adequate-sum f = sum⇒Σᵉ f ∙ adequate-Σᵉ (Fin ∘ f)

    open FromAdequate-sum adequate-sum public

    adequate-any : Adequate-any -→- any
    adequate-any f e = coe (adequate-Σᵉ (✓ ∘ f)) (✓any→Σᵉ f e)

  module FromAdequate-Πᵉ
           (adequate-Πᵉ : ∀ {ℓ} → Adequate-Π {ℓ} (Πᵉ explore))
          where
    open Adequacy

    adequate-product : Adequate-product _≡_ product
    adequate-product f = product⇒Πᵉ f ∙ adequate-Πᵉ (Fin ∘ f)

    adequate-all : Adequate-all _≡_ all
    adequate-all f = ✓all-Πᵉ f ∙ adequate-Πᵉ _

    check! : (f : A → 𝟚) {pf : ✓ (all f)} → (∀ x → ✓ (f x))
    check! f {pf} = coe (adequate-all f) pf

{-
module ExplorableRecord where
    record Explorable A : ★₁ where
      constructor mk
      field
        explore     : Explore₀ A
        explore-ind : ExploreInd₀ explore

      open FromExploreInd explore-ind
      field
        adequate-sum     : Adequate-sum sum
    --  adequate-product : AdequateProduct product

      open FromExploreInd explore-ind public

    open Explorable public

    ExploreForFun : ★₀ → ★₁
    ExploreForFun A = ∀ {X} → Explorable X → Explorable (A → X)

    record Funable A : ★₂ where
      constructor _,_
      field
        explorable : Explorable A
        negative   : ExploreForFun A

    module DistFun {A} (μA : Explorable A)
                       (μA→ : ExploreForFun A)
                       {B} (μB : Explorable B){X}
                       (_≈_ : X → X → ★ ₀)
                       (0′  : X)
                       (_+_ : X → X → X)
                       (_*_ : X → X → X) where

      Σᴮ = explore μB 0′ _+_
      Π' = explore μA 0′ _*_
      Σ' = explore (μA→ μB) 0′ _+_

      DistFun = ∀ f → Π' (Σᴮ ∘ f) ≈ Σ' (Π' ∘ _ˢ_ f)

    DistFun : ∀ {A} → Explorable A → ExploreForFun A → ★₁
    DistFun μA μA→ = ∀ {B} (μB : Explorable B) c → let open CMon {₀}{₀} c in
                       ∀ _*_ → Zero _≈_ ε _*_ → _DistributesOver_ _≈_ _*_ _∙_ → _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
                       → DistFun.DistFun μA μA→ μB _≈_ ε _∙_ _*_

    DistFunable : ∀ {A} → Funable A → ★₁
    DistFunable (μA , μA→) = DistFun μA μA→

    module _ {{_ : UA}}{{_ : FunExt}} where
        μ-iso : ∀ {A B} → (A ≃ B) → Explorable A → Explorable B
        μ-iso {A}{B} A≃B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
          where
            open ≡
            A→B = –> A≃B
            ade = λ f → adequate-sum μA (f ∘ A→B) ∙ Σ-fst≃ A≃B _

        -- I guess this could be more general
        μ-iso-preserve : ∀ {A B} (A≃B : A ≃ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A≃B μA) (f ∘ <– A≃B)
        μ-iso-preserve A≃B f μA = sum-ext μA (λ x → ap f (! (<–-inv-l A≃B x)))
          where open ≡

          {-
        μLift : ∀ {A} → Explorable A → Explorable (Lift A)
        μLift = μ-iso {!(! Lift↔id)!}
          where open ≡
          -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
-- Constructions on top of exploration functions

open import Level.NP
open import Type hiding (★)
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Algebra.FunctionProperties.NP
open import Data.Two.Base
open import Data.Indexed
open import Data.Nat.NP hiding (_⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin) renaming (zero to fzero)
open import Data.Maybe.NP
open import Algebra
open import Data.Product.NP renaming (map to ×-map) hiding (first)
open import Data.Sum.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Nullary.NP
open import Relation.Binary
open import Relation.Binary.Sum using (_⊎-cong_)
open import Relation.Binary.Product.Pointwise using (_×-cong_)
import Function.Related as FR
import Relation.Binary.PropositionalEquality.NP as ≡
open import HoTT
open Equivalences
open ≡ using (_≡_)

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM

module Explore.Explorable where

module _ {m a} {A : ★ a} where
  open EM {a} m
  gfilter-explore : ∀ {B} → (A →? B) → Explore m A → Explore m B
  gfilter-explore f eᴬ = eᴬ >>= λ x → maybe (λ η → point-explore η) empty-explore (f x)

  filter-explore : (A → 𝟚) → Explore m A → Explore m A
  filter-explore p = gfilter-explore λ x → [0: nothing 1: just x ] (p x)

  -- monoidal exploration: explore A with a monoid M
  explore-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-monoid eᴬ M = eᴬ ε _·_ where open Mon M renaming (_∙_ to _·_)

  explore-endo : Explore m A → Explore m A
  explore-endo eᴬ ε op f = eᴬ id _∘′_ (op ∘ f) ε

  explore-endo-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-endo-monoid = explore-monoid ∘ explore-endo

  explore-backward : Explore m A → Explore m A
  explore-backward eᴬ ε _∙_ f = eᴬ ε (flip _∙_) f

  -- explore-backward ∘ explore-backward = id
  -- (m : a comm monoid) → explore-backward m = explore m

private
  module FindForward {a} {A : ★ a} (explore : Explore a A) where
    find? : Find? A
    find? = explore nothing (M?._∣_ _)

    first : Maybe A
    first = find? just

    findKey : FindKey A
    findKey pred = find? (λ x → [0: nothing 1: just x ] (pred x))

module ExplorePlug {ℓ a} {A : ★ a} where
  record ExploreIndKit p (P : Explore ℓ A → ★ p) : ★ (a ⊔ ₛ ℓ ⊔ p) where
    constructor mk
    field
      Pε : P empty-explore
      P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁)
      Pf : ∀ x → P (point-explore x)

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

  _,-kit_ : ∀ {p} {P : Explore ℓ A → ★ p}{Q : Explore ℓ A → ★ p}
            → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
  Pk ,-kit Qk = mk (Pε Pk , Pε Qk)
                   (λ x y → P∙ Pk (fst x) (fst y) , P∙ Qk (snd x) (snd y))
                   (λ x → Pf Pk x , Pf Qk x)
               where open ExploreIndKit

  ExploreInd-Extra : ∀ p → Explore ℓ A → ★ _
  ExploreInd-Extra p exp =
    ∀ (Q     : Explore ℓ A → ★ p)
      (Q-kit : ExploreIndKit p Q)
      (P     : Explore ℓ A → ★ p)
      (Pε    : P empty-explore)
      (P∙    : ∀ {e₀ e₁ : Explore ℓ A} → Q e₀ → Q e₁ → P e₀ → P e₁
               → P (merge-explore e₀ e₁))
      (Pf    : ∀ x → P (point-explore x))
    → P exp

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

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

  plugKit : ∀ {m} (M : Monoid ℓ m) → ExploreIndKit _ (ExplorePlug M)
  plugKit M = mk (λ _ → fst identity)
                 (λ Ps Ps' f x →
                    trans (∙-cong (! Ps _ _) refl)
                          (trans (assoc _ _ _)
                                 (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
                 (λ x f _ → ∙-cong (snd identity (f x)) refl)
       where open Mon M

module FromExplore
    {a} {A : ★ a}
    (explore : ∀ {ℓ} → Explore ℓ A) where

  module _ {ℓ} where
    with-monoid : ∀ {m} → ExploreMon ℓ m A
    with-monoid = explore-monoid explore

    with∘ : Explore ℓ A
    with∘ = explore-endo explore

    with-endo-monoid : ∀ {m} → ExploreMon ℓ m A
    with-endo-monoid = explore-endo-monoid explore

    backward : Explore ℓ A
    backward = explore-backward explore

    gfilter : ∀ {B} → (A →? B) → Explore ℓ B
    gfilter f = gfilter-explore f explore

    filter : (A → 𝟚) → Explore ℓ A
    filter p = filter-explore p explore

  sum : Sum A
  sum = explore 0 _+_

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (𝟚▹ℕ ∘ f)

  product : (A → ℕ) → ℕ
  product = explore 1 _*_

  big-∧ and big-∨ or big-xor : (A → 𝟚) → 𝟚

  big-∧ = explore 1₂ _∧_
  and   = big-∧
  all   = big-∧

  big-∨ = explore 0₂ _∨_
  or    = big-∨
  any   = big-∨

  big-xor = explore 0₂ _xor_

  bin-tree : BinTree A
  bin-tree = explore empty fork leaf

  list : List A
  list = explore List.[] _++_ List.[_]

  module FindBackward = FindForward backward

  findLast? : Find? A
  findLast? = FindBackward.find?

  last : Maybe A
  last = FindBackward.first

  findLastKey : FindKey A
  findLastKey = FindBackward.findKey

  open FindForward explore public

module FromExploreInd
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (explore-ind : ∀ {p ℓ} → ExploreInd {ℓ} p explore)
    where

  open FromExplore explore public

  module _ {ℓ p} where
    explore-mon-ext : ExploreMonExt {ℓ} p explore
    explore-mon-ext m {f} {g} f≈°g = explore-ind (λ s → s _ _ f ≈ s _ _ g) refl ∙-cong f≈°g
      where open Mon m

    explore-mono : ExploreMono {ℓ} p explore
    explore-mono _⊆_ z⊆ _∙-mono_ {f} {g} f⊆°g =
      explore-ind (λ e → e _ _ f ⊆ e _ _ g) z⊆ _∙-mono_ f⊆°g

    open ExplorePlug {ℓ} {a} {A}

    explore∘-plug : (M : Monoid ℓ ℓ) → ExplorePlug M explore
    explore∘-plug M = explore-ind $kit plugKit M

    module _ (M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = explore-ind (λ e → ∀ z → e ε _∙_ f ∙ z ≈ explore-endo e z _∙_ f)
                                                (fst identity) (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _))) (λ _ _ → refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

    explore∘-ind : ∀ (M : Monoid ℓ ℓ) → BigOpMonInd ℓ M (with-endo-monoid M)
    explore∘-ind M P Pε P∙ Pf P≈ =
      snd (explore-ind (λ e → ExplorePlug M e × P (λ f → e id _∘′_ (_∙_ ∘ f) ε))
                 (const (fst identity) , Pε)
                 (λ {e} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {e} {s'} (fst Ps) (fst Ps')
                                    , P≈ (λ f → fst Ps f _) (P∙ (snd Ps) (snd Ps')))
                 (λ x → ExploreIndKit.Pf (plugKit M) x
                      , P≈ (λ f → ! snd identity _) (Pf x)))
      where open Mon M

    explore-swap : ∀ {b} → ExploreSwap {ℓ} p explore {b}
    explore-swap mon {eᴮ} eᴮ-ε pf f =
      explore-ind (λ e → e _ _ (eᴮ ∘ f) ≈ eᴮ (e _ _ ∘ flip f))
                  (! eᴮ-ε)
                  (λ p q → trans (∙-cong p q) (! pf _ _))
                  (λ _ → refl)
      where open Mon mon

    explore-ε : Exploreε {ℓ} p explore
    explore-ε M = explore-ind (λ e → e ε _ (const ε) ≈ ε)
                              refl
                              (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (fst identity ε))
                              (λ _ → refl)
      where open Mon M

    explore-hom : ExploreHom {ℓ} p explore
    explore-hom cm f g = explore-ind (λ e → e _ _ (f ∙° g) ≈ e _ _ f ∙ e _ _ g)
                                     (! fst identity ε)
                                     (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _))
                                     (λ _ → refl)
      where open CMon cm

    explore-linˡ : ExploreLinˡ {ℓ} p explore
    explore-linˡ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → k ◎ f x) ≈ k ◎ e ε _∙_ f) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    explore-linʳ : ExploreLinʳ {ℓ} p explore
    explore-linʳ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → f x ◎ k) ≈ e ε _∙_ f ◎ k) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    module ProductMonoid
        {M : ★₀} (εₘ : M) (_⊕ₘ_ : Op₂ M)
        {N : ★₀} (εₙ : N) (_⊕ₙ_ : Op₂ N)
        where
        ε = (εₘ , εₙ)
        _⊕_ : Op₂ (M × N)
        (xₘ , xₙ) ⊕ (yₘ , yₙ) = (xₘ ⊕ₘ yₘ , xₙ ⊕ₙ yₙ)

        explore-product-monoid :
          ∀ fₘ fₙ → explore ε _⊕_ < fₘ , fₙ > ≡ (explore εₘ _⊕ₘ_ fₘ , explore εₙ _⊕ₙ_ fₙ)
        explore-product-monoid fₘ fₙ =
          explore-ind (λ e → e ε _⊕_ < fₘ , fₙ > ≡ (e εₘ _⊕ₘ_ fₘ , e εₙ _⊕ₙ_ fₙ)) ≡.refl (≡.ap₂ _⊕_) (λ _ → ≡.refl)
  {-
  empty-explore:
    ε ≡ (εₘ , εₙ) ✓
  point-explore (x , y):
    < fₘ , fₙ > (x , y) ≡ (fₘ x , fₙ y) ✓
  merge-explore e₀ e₁:
    e₀ ε _⊕_ < fₘ , fₙ > ⊕ e₁ ε _⊕_ < fₘ , fₙ >
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ) ⊕ (e₁ εₘ _⊕ₘ_ fₘ , e₁ εₙ _⊕ₙ_ fₙ)
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ ⊕ e₁ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ ⊕ e₁ εₙ _⊕ₙ_ fₙ)
  -}

  module _ {ℓ} where
    reify : Reify {ℓ} explore
    reify = explore-ind (λ eᴬ → Πᵉ eᴬ _) _ _,_

    unfocus : Unfocus {ℓ} explore
    unfocus = explore-ind Unfocus (λ{ (lift ()) }) (λ P Q → [ P , Q ]) (λ η → _,_ η)

    module _ {ℓᵣ aᵣ} {Aᵣ : A → A → ★ aᵣ}
             (Aᵣ-refl : Reflexive Aᵣ) where
      ⟦explore⟧ : ⟦Explore⟧ ℓᵣ Aᵣ (explore {ℓ}) (explore {ℓ})
      ⟦explore⟧ Mᵣ zᵣ ∙ᵣ fᵣ = explore-ind (λ e → Mᵣ (e _ _ _) (e _ _ _)) zᵣ (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

    explore-ext : ExploreExt {ℓ} explore
    explore-ext ε op = explore-ind (λ e → e _ _ _ ≡ e _ _ _) ≡.refl (≡.ap₂ op)

  module LiftHom
       {m p}
       {S T : ★ m}
       (_≈_ : T → T → ★ p)
       (≈-refl : Reflexive _≈_)
       (≈-trans : Transitive _≈_)
       (zero : S)
       (_+_  : Op₂ S)
       (one  : T)
       (_*_  : Op₂ T)
       (≈-cong-* : _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
       (f   : S → T)
       (g   : A → S)
       (hom-0-1 : f zero ≈ one)
       (hom-+-* : ∀ {x y} → (f (x + y)) ≈ (f x * f y))
       where

        lift-hom : f (explore zero _+_ g) ≈ explore one _*_ (f ∘ g)
        lift-hom = explore-ind (λ e → f (e zero _+_ g) ≈ e one _*_ (f ∘ g))
                               hom-0-1
                               (λ p q → ≈-trans hom-+-* (≈-cong-* p q))
                               (λ _ → ≈-refl)

  module _ {ℓ} {P : A → ★_ ℓ} where
    open LiftHom {S = ★_ ℓ} {★_ ℓ} (λ A B → B → A) id _∘′_
                 (Lift 𝟘) _⊎_ (Lift 𝟙) _×_
                 (λ f g → ×-map f g) Dec P (const (no (λ{ (lift ()) })))
                 (uncurry Dec-⊎)
                 public renaming (lift-hom to lift-Dec)

  module FromFocus {p} (focus : Focus {p} explore) where
    Dec-Σ : ∀ {P} → Π A (Dec ∘ P) → Dec (Σ A P)
    Dec-Σ = map-Dec unfocus focus ∘ lift-Dec ∘ reify

  lift-hom-≡ :
      ∀ {m} {S T : ★ m}
        (zero : S)
        (_+_  : Op₂ S)
        (one  : T)
        (_*_  : Op₂ T)
        (f    : S → T)
        (g    : A → S)
        (hom-0-1 : f zero ≡ one)
        (hom-+-* : ∀ {x y} → f (x + y) ≡ f x * f y)
      → f (explore zero _+_ g) ≡ explore one _*_ (f ∘ g)
  lift-hom-≡ z _+_ o _*_ = LiftHom.lift-hom _≡_ ≡.refl ≡.trans z _+_ o _*_ (≡.ap₂ _*_)

  sum-ind : SumInd sum
  sum-ind P P0 P+ Pf = explore-ind (λ e → P (e 0 _+_)) P0 P+ Pf

  sum-ext : SumExt sum
  sum-ext = explore-ext 0 _+_

  sum-zero : SumZero sum
  sum-zero = explore-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = explore-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = explore-mono _≤_ z≤n _+-mono_

  sum-swap' : SumSwap sum
  sum-swap' {sumᴮ = sᴮ} sᴮ-0 hom f =
    sum-ind (λ s → s (sᴮ ∘ f) ≡ sᴮ (s ∘ flip f))
            (! sᴮ-0)
            (λ p q → (ap₂ _+_ p q) ∙ (! hom _ _)) (λ _ → refl)
    where open ≡

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.ap₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  sum-const : SumConst sum
  sum-const x = sum-ext (λ _ → ! snd ℕ°.*-identity x) ∙ sum-lin (const 1) x ∙ ℕ°.*-comm x Card
    where open ≡

  exploreStableUnder→sumStableUnder : ∀ {p} → StableUnder explore p → SumStableUnder sum p
  exploreStableUnder→sumStableUnder SU-p = SU-p 0 _+_

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong 𝟚▹ℕ ∘ f≗g)

  sumStableUnder→countStableUnder : ∀ {p} → SumStableUnder sum p → CountStableUnder count p
  sumStableUnder→countStableUnder sumSU-p f = sumSU-p (𝟚▹ℕ ∘ f)

  diff-list = with-endo-monoid (List.monoid A) List.[_]

  {-
  list≡diff-list : list ≡ diff-list
  list≡diff-list = {!explore-endo-monoid-spec (List.monoid A) List.[_]!}
  -}

  lift-op₂ : ∀ {a}{A : ★_ a}(op : Op₂ A){ℓ} → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A
  lift-op₂ op (lift x) (lift y) = lift (op x y)

  lift-sum : ∀ ℓ → Sum A
  lift-sum ℓ f = lower {₀} {ℓ} (explore (lift 0) (lift-op₂ _+_) (lift ∘ f))

  Fin-lower-sum≡Σᵉ-Fin : ∀ {{_ : UA}}(f : A → ℕ) → Fin (lift-sum _ f) ≡ Σᵉ explore (Fin ∘ f)
  Fin-lower-sum≡Σᵉ-Fin f = LiftHom.lift-hom _≡_ ≡.refl ≡.trans (lift 0) (lift-op₂ _+_) (Lift 𝟘) _⊎_ ⊎= (Fin ∘ lower) (lift ∘ f) (Fin0≡𝟘 ∙ ! Lift≡id) (! Fin-⊎-+)
    where open ≡

module FromTwoExploreInd
    {a} {A : ★ a}
    {eᴬ : ∀ {ℓ} → Explore ℓ A}
    (eᴬ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴬ)
    {b} {B : ★ b}
    {eᴮ : ∀ {ℓ} → Explore ℓ B}
    (eᴮ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴮ)
    where

    module A = FromExploreInd eᴬ-ind
    module B = FromExploreInd eᴮ-ind

    module _ {c ℓ}(cm : CommutativeMonoid c ℓ) where
        open CMon cm

        opᴬ = eᴬ ε _∙_
        opᴮ = eᴮ ε _∙_

        -- TODO use lift-hom
        explore-swap' : ∀ f → opᴬ (opᴮ ∘ f) ≈ opᴮ (opᴬ ∘ flip f)
        explore-swap' = A.explore-swap m (B.explore-ε m) (B.explore-hom cm)

    sum-swap : ∀ f → A.sum (B.sum ∘ f) ≡ B.sum (A.sum ∘ flip f)
    sum-swap = explore-swap' ℕ°.+-commutativeMonoid

module FromTwoAdequate-sum
  {{_ : UA}}{{_ : FunExt}}
  {A}{B}
  {sumᴬ : Sum A}{sumᴮ : Sum B}
  (open Adequacy _≡_)
  (sumᴬ-adq : Adequate-sum sumᴬ)
  (sumᴮ-adq : Adequate-sum sumᴮ) where

  open ≡
  sumStableUnder : (p : A ≃ B)(f : B → ℕ)
                 → sumᴬ (f ∘ ·→ p) ≡ sumᴮ f
  sumStableUnder p f = Fin-injective (sumᴬ-adq (f ∘ ·→ p)
                                      ∙ Σ-fst≃ p _
                                      ∙ ! sumᴮ-adq f)

  sumStableUnder′ : (p : A ≃ B)(f : A → ℕ)
                 → sumᴬ f ≡ sumᴮ (f ∘ <– p)
  sumStableUnder′ p f = Fin-injective (sumᴬ-adq f
                                      ∙ Σ-fst≃′ p _
                                      ∙ ! sumᴮ-adq (f ∘ <– p))

module FromAdequate-sum
  {A}
  {sum : Sum A}
  (open Adequacy _≡_)
  (sum-adq : Adequate-sum sum)
  {{_ : UA}}{{_ : FunExt}}
  where

  open FromTwoAdequate-sum sum-adq sum-adq public
  open ≡

  private
    count : Count A
    count f = sum (𝟚▹ℕ ∘ f)

  private
    module M {p q : A → 𝟚}(same-count : count p ≡ count q) where
      private

        P = λ x → p x ≡ 1₂
        Q = λ x → q x ≡ 1₂
        ¬P = λ x → p x ≡ 0₂
        ¬Q = λ x → q x ≡ 0₂

        π : Σ A P ≡ Σ A Q
        π = ! Σ=′ _ (count-≡ p)
            ∙ ! (sum-adq (𝟚▹ℕ ∘ p))
            ∙ ap Fin same-count
            ∙ sum-adq (𝟚▹ℕ ∘ q)
            ∙ Σ=′ _ (count-≡ q)

        lem1 : ∀ px qx → 𝟚▹ℕ qx ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ (not px) * 𝟚▹ℕ qx
        lem1 1₂ 1₂ = ≡.refl
        lem1 1₂ 0₂ = ≡.refl
        lem1 0₂ 1₂ = ≡.refl
        lem1 0₂ 0₂ = ≡.refl

        lem2 : ∀ px qx → 𝟚▹ℕ px ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ px * 𝟚▹ℕ (not qx)
        lem2 1₂ 1₂ = ≡.refl
        lem2 1₂ 0₂ = ≡.refl
        lem2 0₂ 1₂ = ≡.refl
        lem2 0₂ 0₂ = ≡.refl

        lemma1 : ∀ px qx → (qx ≡ 1₂) ≡ (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 0₂ × qx ≡ 1₂))
        lemma1 px qx = ! Fin-≡-≡1₂ qx
                     ∙ ap Fin (lem1 px qx)
                     ∙ ! Fin-⊎-+
                     ∙ ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡0₂ px) (Fin-≡-≡1₂ qx))

        lemma2 : ∀ px qx → (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 1₂ × qx ≡ 0₂)) ≡ (px ≡ 1₂)
        lemma2 px qx = ! ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡1₂ px) (Fin-≡-≡0₂ qx)) ∙ Fin-⊎-+ ∙ ap Fin (! lem2 px qx) ∙ Fin-≡-≡1₂ px

        π' : (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x →  P x × ¬Q x))
           ≡ (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x → ¬P x ×  Q x))
        π' = ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl
           ∙ ! Σ⊎-split
           ∙ Σ=′ _ (λ x → lemma2 (p x) (q x))
           ∙ π
           ∙ Σ=′ _ (λ x → lemma1 (p x) (q x))
           ∙ Σ⊎-split
           ∙ ! ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl

        π'' : Σ A (P ×° ¬Q) ≡ Σ A (¬P ×° Q)
        π'' = Fin⊎-injective (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) π'

      open EquivalentSubsets π'' public

  same-count→iso : ∀{p q : A → 𝟚}(same-count : count p ≡ count q) → p ≡ q ∘ M.π {p} {q} same-count
  same-count→iso {p} {q} sc = M.prop {p} {q} sc

module From⟦Explore⟧
    {-a-} {A : ★₀ {- a-}}
    {explore   : ∀ {ℓ} → Explore ℓ A}
    (⟦explore⟧ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ explore explore)
    {{_ : UA}}
    where
  open FromExplore explore

  module AlsoInFromExploreInd
          {ℓ}(M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = ⟦explore⟧ ₀ {C} {C → C}
                                              (λ r s → ∀ z → r ∙ z ≈ s z)
                                              (fst identity)
                                              (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _)))
                                              (λ xᵣ _ → ∙-cong (reflexive (≡.ap f xᵣ)) refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

  open ≡
  module _ (f : A → ℕ) where
    sum⇒Σᵉ : Fin (explore 0 _+_ f) ≡ explore (Lift 𝟘) _⊎_ (Fin ∘ f)
    sum⇒Σᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ n X → Fin n ≡ X)
                (Fin0≡𝟘 ∙ ! Lift≡id)
                (λ p q → ! Fin-⊎-+ ∙ ⊎= p q)
                (ap (Fin ∘ f))

    product⇒Πᵉ : Fin (explore 1 _*_ f) ≡ explore (Lift 𝟙) _×_ (Fin ∘ f)
    product⇒Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                    (λ n X → Fin n ≡ X)
                    (Fin1≡𝟙 ∙ ! Lift≡id)
                    (λ p q → ! Fin-×-* ∙ ×= p q)
                    (ap (Fin ∘ f))

  module _ (f : A → 𝟚) where
    ✓all-Πᵉ : ✓ (all f) ≡ Πᵉ explore (✓ ∘ f)
    ✓all-Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ b X → ✓ b ≡ X)
                (! Lift≡id)
                (λ p q → ✓-∧-× _ _ ∙ ×= p q)
                (ap (✓ ∘ f))

    ✓any→Σᵉ : ✓ (any f) → Σᵉ explore (✓ ∘ f)
    ✓any→Σᵉ p = ⟦explore⟧ {₀} {ₛ ₀} ₁
                         (λ b (X : ★₀) → Lift (✓ b) → X)
                         (λ x → lift (lower x))
                         (λ { {0₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inr (yᵣ zᵣ)
                            ; {1₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inl (xᵣ _) })
                         (λ xᵣ x → tr (✓ ∘ f) xᵣ (lower x)) (lift p)

  module FromAdequate-Σᵉ
           (adequate-Σᵉ : ∀ {ℓ} → Adequate-Σ {ℓ} (Σᵉ explore))
          where
    open Adequacy

    adequate-sum : Adequate-sum _≡_ sum
    adequate-sum f = sum⇒Σᵉ f ∙ adequate-Σᵉ (Fin ∘ f)

    open FromAdequate-sum adequate-sum public

    adequate-any : Adequate-any -→- any
    adequate-any f e = coe (adequate-Σᵉ (✓ ∘ f)) (✓any→Σᵉ f e)

  module FromAdequate-Πᵉ
           (adequate-Πᵉ : ∀ {ℓ} → Adequate-Π {ℓ} (Πᵉ explore))
          where
    open Adequacy

    adequate-product : Adequate-product _≡_ product
    adequate-product f = product⇒Πᵉ f ∙ adequate-Πᵉ (Fin ∘ f)

    adequate-all : Adequate-all _≡_ all
    adequate-all f = ✓all-Πᵉ f ∙ adequate-Πᵉ _

    check! : (f : A → 𝟚) {pf : ✓ (all f)} → (∀ x → ✓ (f x))
    check! f {pf} = coe (adequate-all f) pf

{-
module ExplorableRecord where
    record Explorable A : ★₁ where
      constructor mk
      field
        explore     : Explore₀ A
        explore-ind : ExploreInd₀ explore

      open FromExploreInd explore-ind
      field
        adequate-sum     : Adequate-sum sum
    --  adequate-product : AdequateProduct product

      open FromExploreInd explore-ind public

    open Explorable public

    ExploreForFun : ★₀ → ★₁
    ExploreForFun A = ∀ {X} → Explorable X → Explorable (A → X)

    record Funable A : ★₂ where
      constructor _,_
      field
        explorable : Explorable A
        negative   : ExploreForFun A

    module DistFun {A} (μA : Explorable A)
                       (μA→ : ExploreForFun A)
                       {B} (μB : Explorable B){X}
                       (_≈_ : X → X → ★ ₀)
                       (0′  : X)
                       (_+_ : X → X → X)
                       (_*_ : X → X → X) where

      Σᴮ = explore μB 0′ _+_
      Π' = explore μA 0′ _*_
      Σ' = explore (μA→ μB) 0′ _+_

      DistFun = ∀ f → Π' (Σᴮ ∘ f) ≈ Σ' (Π' ∘ _ˢ_ f)

    DistFun : ∀ {A} → Explorable A → ExploreForFun A → ★₁
    DistFun μA μA→ = ∀ {B} (μB : Explorable B) c → let open CMon {₀}{₀} c in
                       ∀ _*_ → Zero _≈_ ε _*_ → _DistributesOver_ _≈_ _*_ _∙_ → _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
                       → DistFun.DistFun μA μA→ μB _≈_ ε _∙_ _*_

    DistFunable : ∀ {A} → Funable A → ★₁
    DistFunable (μA , μA→) = DistFun μA μA→

    module _ {{_ : UA}}{{_ : FunExt}} where
        μ-iso : ∀ {A B} → (A ≃ B) → Explorable A → Explorable B
        μ-iso {A}{B} A≃B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
          where
            open ≡
            A→B = –> A≃B
            ade = λ f → adequate-sum μA (f ∘ A→B) ∙ Σ-fst≃ A≃B _

        -- I guess this could be more general
        μ-iso-preserve : ∀ {A B} (A≃B : A ≃ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A≃B μA) (f ∘ <– A≃B)
        μ-iso-preserve A≃B f μA = sum-ext μA (λ x → ap f (! (<–-inv-l A≃B x)))
          where open ≡

          {-
        μLift : ∀ {A} → Explorable A → Explorable (Lift A)
        μLift = μ-iso {!(! Lift↔id)!}
          where open ≡
          -}
-- -}
-- -}
-- -}
-- -}


README.agda

README.agda

module README where

open import composition-sem-sec-reduction

open import one-time-semantic-security

open import flat-funs
open import composable
open import vcomp
open import forkable

open import program-distance
open import diff

open import flipbased
open import flipbased-implem

open import bit-guessing-game

open import circuit

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


Add FunUniverse/Fin/Op.agda

Add FunUniverse/Fin/Op.agda

open import Type
open import Function
open import Data.Nat.NP using (ℕ; module ℕ°)
open import Data.Fin.NP as Fin using (Fin; inject+; raise; bound; free)
open import Data.Vec.NP using (lookup)
open import FunUniverse.Data
open import FunUniverse.Core
open import FunUniverse.Rewiring.Linear
open import FunUniverse.Category
open import FunUniverse.Category.Op
open import FunUniverse.Fin

module FunUniverse.Fin.Op where

_ᶠ→_ : (i o : ℕ) → ★
i ᶠ→ o = Fin o → Fin i

finOpFunU : FunUniverse ℕ
finOpFunU = Bits-U , _ᶠ→_

finOpCat : Category _ᶠ→_
finOpCat = op finCat

open FunUniverse finOpFunU
open Cong-*1 _`→_

finOpLinRewiring : LinRewiring finOpFunU
finOpLinRewiring = mk finOpCat first (λ {x} → swap {x}) (λ {x} → assoc {x}) id id <_×_> (λ {x} → second {x}) id id id id
  where
    -- NOTE that doing:
    --   swap {A} {B} rewrite ℕ°.+-comm A B = id
    -- would be totally wrong.
    swap : ∀ {A B} → (A `× B) `→ (B `× A)
    swap {A} {B} x with Fin.cmp B A x
    swap {A} {B} ._ | Fin.bound y = raise A y
    swap {A} {B} ._ | Fin.free  y = inject+ B y

    -- Since the order of elements is preserved this is OK to rewrite
    assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
    assoc {A} {B} {C} rewrite ℕ°.+-assoc A B C = id

    <_×_>  : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
    <_×_> {A} {B} {C} {D} f g x with Fin.cmp C D x
    <_×_> {A} {B} {C} {D} f g ._ | Fin.bound y = inject+ B (f y)
    <_×_> {A} {B} {C} {D} f g ._ | Fin.free  y = raise A   (g y)

    idᶠ : ∀ {A} → A `→ A
    idᶠ = id

    first : ∀ {A B C} → (A `→ B) → (A `× C) `→ (B `× C)
    first f = < f × id >

    second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
    second {A} f = < idᶠ {A} × f >

finOpRewiring : Rewiring finOpFunU
finOpRewiring = mk finOpLinRewiring (λ ()) dup (λ()) (λ f g → dup ⁏ < f × g >) (inject+ _) (λ {x} → raise x) cong-*1 (cong-*1 ∘ flip lookup)
  where
    open LinRewiring finOpLinRewiring using (<_×_>; _⁏_)
    dup : ∀ {A} → A `→ (A `× A)
    dup {A} x with Fin.cmp A A x
    dup    ._ | Fin.bound y = y
    dup    ._ | Fin.free  y = y

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


Forking-lemma: definitions

Forking-lemma: definitions

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Function.NP
open import Data.Nat.NP hiding (_==_)
open import Data.Vec
open import Data.Maybe
open import Data.One using (𝟙)
open import Data.Two.Base hiding (_==_)
open import Data.Fin.NP as Fin hiding (_+_; _-_; _≤_)
open import Data.Product.NP
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

module forking-lemma where

_≥1 : ∀ {n} → Fin n → 𝟚
zero  ≥1 = 0₂
suc _ ≥1 = 1₂

infix 8 _‼_
_‼_ : ∀ {n a}{A : Set a} → Vec A n → Fin n → A
_‼_ = flip lookup

replace : ∀ {A : Type} {q} (I : Fin q)
            (hs hs' : Vec A q) → Vec A q
replace zero    hs             hs' = hs'
replace (suc I) (h ∷ hs) (_ ∷ hs') = h ∷ replace I hs hs'

test-replace : replace (suc zero) (40 ∷ 41 ∷ 42 ∷ []) (60 ∷ 61 ∷ 62 ∷ []) ≡ 40 ∷ 61 ∷ 62 ∷ []
test-replace = refl

≡-prefix : ∀ {A : Type} {q} (I : Fin (suc q))
             (v₀ v₁ : Vec A q) → Type
≡-prefix zero    _         _         = 𝟙
≡-prefix (suc I) (x₀ ∷ v₀) (x₁ ∷ v₁) = (x₀ ≡ x₁) × ≡-prefix I v₀ v₁

≡-prefix (suc ()) [] []

postulate
  -- Pub    : Type
  Res    : Type -- Side output
  RndAdv : Type -- Coin
  {-RndIG  : Type-}

  -- IG : RndIG → Pub

  q     : ℕ

  instance
    q≥1   : q ≥ 1

  #h     : ℕ
  #h≥2   : #h ≥ 2

H : Type
H = Fin #h

Adv = {-(x : Pub)-}(hs : Vec H q)(ρ : RndAdv) → Fin (suc q) × Res

postulate
  A : Adv
-- A x hs ρ
-- A x hs = ρ ←$ ...H ; A x hs ρ

-- IO : Type → Type
-- print : String → IO ()
-- #r : ℕ
-- #r≥1 : #r ≥ 1
-- Rnd = Fin #r
-- random : IO Rnd
-- run : (A : Input → Rnd → Res) → Input → IO Res
-- run A i = do r ← random
--              return (A i r)

-- Not used yet
well-def : Adv → Type
well-def A =
  ∀ {-x-} hs ρ →
    case A {-x-} hs ρ of λ { (I , σ) →
    ∀ hs' → ≡-prefix I hs hs' →  A {-x-} hs' ρ ≡ (I , σ) }

record Ω : Type where
  field
    -- rIG : RndIG
    hs hs' : Vec H q
    ρ      : RndAdv

Event = Ω → 𝟚

module M (r : Ω) where
  open Ω r

  F' : (I-1 : Fin q)(σ : Res) → Maybe (Res × Res)
  F' I-1 σ =
    case I=I' ∧ h=h' of λ
    { 1₂ → just (σ , σ')
    ; 0₂ → nothing
    }
    module F' where
      res' = A (replace I-1 hs hs') ρ
      I'   = fst res'
      σ'   = snd res'
      h    = hs  ‼ I-1
      h'   = hs' ‼ I-1
      I    = suc I-1
      I=I' = I == I'
      h=h' = h == h'

  F : Maybe (Res × Res)
  F =
    case I of λ
    { zero      → nothing
    ; (suc I-1) → F' I-1 σ
    }
    module F where
      res  = A hs ρ
      I    = fst res
      σ    = snd res
      I≥1  = not (I == zero)

-- Acceptance event for A
acc : Event
acc r = J ≥1
  where open Ω r
     -- x = IG rIG
        J = fst (A {-x-} hs ρ)

frk : Event
frk r = case M.F r of λ { (just _) → 1₂ ; nothing → 0₂ }

instance
    #h≥1 : #h ≥ 1
    #h≥1 = ℕ≤.trans (s≤s z≤n) #h≥2

infix 0 _≥'_
infixr 2 _≥⟨_⟩_ _≡⟨_⟩_
infix 2 _∎

postulate
  [0,1] : Type
  Pr : Event → [0,1]
  _-_ _·_ : [0,1] → [0,1] → [0,1]
  _≥'_ : [0,1] → [0,1] → Type
  1/_ : (d : ℕ){{_ : d ≥ 1}} → [0,1]

  _≥⟨_⟩_ : ∀ x {y} → x ≥' y → ∀ {z} → y ≥' z → x ≥' z
  _≡⟨_⟩_ : ∀ x {y} → x ≡  y → ∀ {z} → y ≥' z → x ≥' z
  _∎ : ∀ x → x ≥' x

_/_ : [0,1] → (d : ℕ){{_ : d ≥ 1}} → [0,1]
x / y = x · 1/ y

{-
lemma3 : Pr frk ≥' Pr acc · ((Pr acc / q) - (1/ #h))
lemma3 = Pr frk
       ≡⟨ {!!} ⟩
         Pr {!λ r → I=I' r ∧ I≥1 r!}
       ≥⟨ {!!} ⟩
         Pr acc · ((Pr acc / q) - (1/ #h))
       ∎
  where
    open M.F
    -- open M.F' I-1 σ

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

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


Darkwing Duck!

Darkwing Duck!

Starting to model the One-True-Data-Declaration(TM).

Here datatype parameters are encoded as first-class telescopes,
similar to descriptions. Indices are a function from the
interpretation of a parameters telescope to an indices telescope.

First-class parameters allow for them to be treaty specially
when defining generic constructors, interpreting the parametric
constructor arguments as implicit arguments.

Subsequent commits should extend this development with my generic
eliminator construction, where parameters also become implicit arguments
for the generic eliminator.

Additionally, this development makes it obvious that we also need
a generic type former, to complement our generic constructors and eliminators.

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Data.Nat
open import Relation.Binary.PropositionalEquality
open import Function
module Spire.Examples.DarkwingDuck where

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

Label : Set
Label = String

Enum : Set
Enum = List Label

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

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

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

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

data Tel : Set where
  End : Tel
  Arg : (A : Set) (B : A → Tel) → Tel

Elᵀ  : Tel → Set
Elᵀ End = ⊤
Elᵀ (Arg A B) = Σ A (λ a → Elᵀ (B a))

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

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

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

ISet : Set → Set
ISet I = I → Set

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

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

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

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

record Data : Set where
  field
    P : Tel
    I : Elᵀ P → Tel
    E : Enum
    B : (A : Elᵀ P) → Branches E (λ _ → Desc (Elᵀ (I A)))

  T : Set
  T = Tag E

  C : (A : Elᵀ P) → T → Desc (Elᵀ (I A))
  C A = case (λ _ → Desc (Elᵀ (I A))) (B A)

  D : (A : Elᵀ P) → Desc (Elᵀ (I A))
  D A = Arg T (C A)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedBranches [] P X = X
CurriedBranches (l ∷ E) P X = P here → CurriedBranches E (λ t → P (there t)) X

curryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches {[]} f = f tt
curryBranches {l ∷ E} f = λ c → curryBranches (λ cs → f (c , cs))

uncurryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → CurriedBranches E P X → UncurriedBranches E P X
uncurryBranches {[]} x tt = x
uncurryBranches {l ∷ E} f (c , cs) = uncurryBranches (f c) cs

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

UncurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
UncurriedElᵀ T X = (xs : Elᵀ T) → X xs

CurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
CurriedElᵀ End X = X tt
CurriedElᵀ (Arg A B) X = {a : A} → CurriedElᵀ (B a) (λ b → X (a , b))

curryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → CurriedElᵀ T X
curryElᵀ End X f = f tt
curryElᵀ (Arg A B) X f = λ {a} → curryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

uncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → CurriedElᵀ T X → UncurriedElᵀ T X
uncurryElᵀ End X x tt = x
uncurryElᵀ (Arg A B) X f (a , b) = uncurryElᵀ (B a) (λ b → X (a , b)) f b

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

UncurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
UncurriedElᴰ D X = ∀{i} → Elᴰ D X i → X i

CurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedElᴰ (End i) X = X i
CurriedElᴰ (Rec i D) X = (x : X i) → CurriedElᴰ D X
CurriedElᴰ (Arg A B) X = (a : A) → CurriedElᴰ (B a) X

curryElᴰ : {I : Set} (D : Desc I) (X : ISet I)
  → UncurriedElᴰ D X → CurriedElᴰ D X
curryElᴰ (End i) X cn = cn refl
curryElᴰ (Rec i D) X cn = λ x → curryElᴰ D X (λ xs → cn (x , xs))
curryElᴰ (Arg A B) X cn = λ a → curryElᴰ (B a) X (λ xs → cn (a , xs))

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

injUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ A
  → let D = Data.D R A
  in CurriedElᴰ D (μ D)
injUncurried R A t =
  curryElᴰ (Data.C R A t) (μ (Data.D R A))
    (λ xs → init (t , xs))

inj : (R : Data)
  → CurriedElᵀ (Data.P R) λ A
  → let D = Data.D R A
  in CurriedElᴰ D (μ D)
inj R = curryElᵀ _ _ (injUncurried R)

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

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

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

ℕT : Set
ℕT = Tag ℕE

VecT : Set
VecT = Tag VecE

zeroT : ℕT
zeroT = here

sucT : ℕT
sucT = there here

nilT : VecT
nilT = here

consT : VecT
consT = there here

VecR : Data
VecR = record
  { P = Arg Set (λ _ → End)
  ; I = λ _ → Arg ℕ (λ _ → End)
  ; E = VecE
  ; B = λ A →
      End (zero , tt)
    , Arg ℕ (λ n → Arg (proj₁ A) λ _ → Rec (n , tt) (End (suc n , tt)))
    , tt
  }

Vec : (A : Set) → ℕ → Set
Vec A n = μ (Data.D VecR (A , tt)) (n , tt)

nil : {A : Set} → Vec A zero
nil = inj VecR nilT

cons : {A : Set} (n : ℕ) (x : A) (xs : Vec A n) → Vec A (suc n)
cons = inj VecR consT

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

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


sha1.agda

-- https://upload.wikimedia.org/wikipedia/commons/e/e2/SHA-1.svg
-- http://www.faqs.org/rfcs/rfc3174.html
open import Type
open import Data.Nat
--open import Data.Product
open import Function.NP hiding (id)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

module sha1
  {t}
  {T : ★_ t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

open FunUniverse funU renaming (`⊤ to `𝟙; `Bit to `𝟚)
open FunOps funOps hiding (_∘_)

Word : T
Word = `Bits 32

map²ʷ : (`𝟚 `× `𝟚 `→ `𝟚) → Word `× Word `→ Word
map²ʷ = zipWith

mapʷ : (`𝟚 `→ `𝟚) → Word `→ Word
mapʷ = map

lift : ∀ {Γ A B} → (A `→ B) → Γ `→ A → Γ `→ B
lift f g = g ⁏ f

lift₂ : ∀ {Γ A B C} → (A `× B `→ C) → Γ `→ A → Γ `→ B → Γ `→ C
lift₂ op₂ f₀ f₁ = < f₀ , f₁ > ⁏ op₂

`not : ∀ {Γ} (f : Γ `→ Word) → Γ `→ Word
`not = lift (mapʷ not)

infixr 3 _`⊕_
_`⊕_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
_`⊕_ = lift₂ (map²ʷ <xor>)

infixr 3 _`∧_
_`∧_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
_`∧_ = lift₂ (map²ʷ <and>)

infixr 2 _`∨_
_`∨_ : ∀ {Γ} (f₀ f₁ : Γ `→ Word) → Γ `→ Word
_`∨_ = lift₂ (map²ʷ <or>)

open import Solver.Linear
open import Data.Vec as Vec using ([]; _∷_)

module STest n M = Syntax T _`×_ `𝟙 _`→_ id _⁏_ fst <id,tt> snd <tt,id> <_×_> first second assoc′ assoc swap n M

iter : ∀ {n A B C D} → (D `× A `× B `→ D `× C) → D `× `Vec A n `× `Vec B n `→ `Vec C n
iter {zero}  F = <[]>
iter {suc n} F = < id × < uncons × uncons > >
               ⁏ (helper ⁏ < F × id > ⁏ < swap × id > ⁏ assoc ⁏ < id × iter F >)
               ⁏ <∷>

  where
    helper : ∀ {A B D VA VB} → (D `× (A `× VA) `× (B `× VB)) `→ (D `× A `× B) `× (VA `× VB)
    helper {A} {B} {D} {VA} {VB} = solve (! 2 , (! 0 , ! 3) , (! 1 , ! 4))
                                 ((! 2 , ! 0 , ! 1) , (! 3 , ! 4)) _ where
      open STest 5 (λ i → Vec.lookup i (A ∷ B ∷ D ∷ VA ∷ VB ∷ [])) renaming (rewire to solve; #_ to !_)

<⊞> adder : Word `× Word `→ Word
adder = <tt⁏ <0b> , id > ⁏ iter full-adder
<⊞> = adder

infixl 4 _`⊞_
_`⊞_ : ∀ {A} (f g : A `→ Word) → A `→ Word
_`⊞_ = lift₂ <⊞>

<_,_,_> : ∀ {Γ A B C} → Γ `→ A → Γ `→ B → Γ `→ C → Γ `→ (A `× B `× C)
< f₀ , f₁ , f₂ > = < f₀ , < f₁ , f₂ > >

<_,_,_,_,_> : ∀ {Γ A B C D E} → Γ `→ A → Γ `→ B → Γ `→ C
                              → Γ `→ D → Γ `→ E
                              → Γ `→ (A `× B `× C `× D `× E)
< f₀ , f₁ , f₂ , f₃ , f₄ > = < f₀ , < f₁ , < f₂ , f₃ , f₄ > > >

<<<₅ : Word `→ Word
<<<₅ = rot-left 5

<<<₃₀ : Word `→ Word
<<<₃₀ = rot-left 30

Word² = Word `× Word
Word³ = Word `× Word²
Word⁴ = Word `× Word³
Word⁵ = Word `× Word⁴

iterateⁿ : ∀ {A} n → (Fin n → A `→ A) → A `→ A
iterateⁿ zero    f = id
iterateⁿ (suc n) f = f zero ⁏ iterateⁿ n (f ∘ suc)

_²⁰ : ∀ {A} → (Fin 20 → A `→ A) → (A `→ A)
_²⁰ = iterateⁿ 20

A-E : T
A-E = Word⁵

module _ (#ʷ : ℕ → `𝟙 `→ Word) where

  module Iterations
    (A B C D E : A-E `→ Word)
    where

    module _ (F : A-E `→ Word)
             (K : `𝟙  `→ Word)
             (W : `𝟙  `→ Word) where
        Iteration = < A' , A , (B ⁏ <<<₃₀) , C , D >
         where A' = F `⊞ E `⊞ (A ⁏ <<<₅) `⊞ (tt ⁏ W) `⊞ (tt ⁏ K)

    module _
        (W : Fin 80 → `𝟙 `→ Word) where

        Iteration⁸⁰ =
              (Iteration F₀ K₀ ∘ W₀)²⁰ ⁏
              (Iteration F₂ K₂ ∘ W₂)²⁰ ⁏
              (Iteration F₄ K₄ ∘ W₄)²⁰ ⁏
              (Iteration F₆ K₆ ∘ W₆)²⁰
          where
            F₀ = B `∧ C `∨ `not B `∧ D
            F₂ = B `⊕ C `⊕ D
            F₄ = B `∧ C `∨ B `∧ D `∨ C `∧ D
            F₆ = F₂

            K₀ = #ʷ 0x5A827999
            K₂ = #ʷ 0x6ED9EBA1
            K₄ = #ʷ 0x8F1BBCDC
            K₆ = #ʷ 0xCA62C1D6

            W₀ W₂ W₄ W₆ : Fin 20 → `𝟙 `→ Word
            W₀ = W ∘ inject+ 60
            W₂ = W ∘ inject+ 40 ∘ raise 20
            W₄ = W ∘ inject+ 20 ∘ raise 40
            W₆ = W              ∘ raise 60

  SHA1 : (Fin 80 → `𝟙 `→ Word) → A-E `→ A-E
  SHA1 = Iterations.Iteration⁸⁰ H0 H1 H2 H3 H4
   where
    H0 = tt ⁏ #ʷ 0x67452301
    H1 = tt ⁏ #ʷ 0xEFCDAB89
    H2 = tt ⁏ #ʷ 0x98BADCFE
    H3 = tt ⁏ #ʷ 0x10325476
    H4 = tt ⁏ #ʷ 0xC3D2E1F0

-- -}

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


Added note on internal syntax.

Added note on internal syntax.

------------------------------------------------------------------------------
-- Agda internal syntax
------------------------------------------------------------------------------

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

-- Tested with Agda development version on 25 February 2013.

module InternalSyntax where

------------------------------------------------------------------------------
-- Sets

postulate A B C : Set

-- El {getSort = Type (Max [ClosedLevel 1]), unEl = Sort (Type (Max []))}

postulate A₁ : Set₁

-- El {getSort = Type (Max [ClosedLevel 2]), unEl = Sort (Type (Max [ClosedLevel 1]))}

------------------------------------------------------------------------------
-- The term is Def

postulate def : A

-- El {getSort = Type (Max []), unEl = Def InternalSyntax.A []}

------------------------------------------------------------------------------
-- The term is Pi

postulate fun₁ : A → B

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--              (NoAbs "_" El {getSort = Type (Max []), unEl = Def InternalSyntax.B []})}

postulate fun₂ : A → B → C

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--           (NoAbs "_" El {getSort = Type (Max []),
--                      unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.B []})
--                            (NoAbs "_" El {getSort = Type (Max []), unEl = Def InternalSyntax.C []})})}

postulate fun₃ : (a : A) → B

-- El (Type (Max []))
--    (Pi r(El (Type (Max []))
--             (Def InternalSyntax.A []))
--        (Abs "a" El (Type (Max []))
--                 (Def InternalSyntax.B [])))

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--              (NoAbs "a" El {getSort = Type (Max []), unEl = Def InternalSyntax.B []})}

postulate P : A → Set

-- El {getSort = Type (Max [ClosedLevel 1]),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--              (NoAbs "_" El {getSort = Type (Max [ClosedLevel 1]), unEl = Sort (Type (Max []))})}

postulate fun₅ : (a : A) → P a

-- El {getSort = Type (Max []),
--    unEl = Pi []r(El {getSort = Type (Max []), unEl = Def InternalSyntax.A []})
--             (Abs "a" El {getSort = Type (Max []), unEl = Def InternalSyntax.P [[]r(Var 0 [])]})}

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


Preparation for a draft.

Preparation for a draft.

Ignore-this: 947ddfe84d510e12ffaaad540d34ace7

darcs-hash:20120608053614-3bd4e-6bb3eb8d7cbb274965a86b3c321a524e68e1ee66.gz

------------------------------------------------------------------------------
-- Well-founded induction on the lexicographic order on natural numbers
------------------------------------------------------------------------------

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

-- From the thesis: The induction principle $\Conid{Lexi-wfind}$ is
-- proved by well-founded induction on the usual order $\Conid{LT}$ on
-- (partial) natural numbers which, in turn, can be proved by pattern
-- matching on the proof that the numbers are total.

module Draft.FOTC.Data.Nat.Induction.NonAcc.LexicographicI where

open import Common.Function

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

open import FOTC.Data.Nat.Induction.NonAcc.WellFoundedInductionI
open module WFI = FOTC.Data.Nat.Induction.NonAcc.WellFoundedInductionI.WFInd

open import FOTC.Data.Nat.Type

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

Lexi-wfind :
  (A : D → D → Set) →
  (∀ {m₁ n₁} → N m₁ → N n₁ →
     (∀ {m₂ n₂} → N m₂ → N n₂ → Lexi m₂ n₂ m₁ n₁ → A m₂ n₂) → A m₁ n₁) →
  ∀ {m n} → N m → N n → A m n
Lexi-wfind A accH {m} Nm Nn = LT-wfind {!!} {!!} {!!}

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


Added partial proof that parametricity implies causality ("Causality for free!")

open import FRP.JS.Level using ( Level ; _⊔_ ) renaming ( zero to o ; suc to ↑ )
open import FRP.JS.Time using ( Time ; _≟_ ; _≤_ ; _<_ )
open import FRP.JS.True using ( True )
open import FRP.JS.Nat using ( ℕ ; zero ; suc )

module FRP.JS.Model where

-- Preliminaries

infixr 4 _+_

record ⊤ {α} : Set α where
  constructor tt

open ⊤ public

record Σ {α β} (A : Set α) (B : A → Set β) : Set (α ⊔ β) where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

_×_ : ∀ {α β} → Set α → Set β → Set (α ⊔ β)
A × B = Σ A (λ a → B)

data _≡_ {α} {A : Set α} (a : A) : A → Set α where
  refl : a ≡ a

-- Relations on Set

_∋_↔_ : ∀ α → Set α → Set α → Set (↑ α)
α ∋ A ↔ B = A → B → Set α

-- RSets and relations on RSet

RSet : ∀ α → Set (↑ α)
RSet α = Time → Set α

RSet₀ = RSet o
RSet₁ = RSet (↑ o)

_∋_⇔_ : ∀ α → RSet α → RSet α → Set (↑ α)
α ∋ A ⇔ B = ∀ t → (α ∋ A t ↔ B t)

--- Level sequences

data Levels : Set where
  ε : Levels
  _,_ : ∀ (αs : Levels) (α : Level) → Levels

max : Levels → Level
max ε = o
max (αs , α) = max αs ⊔ α

-- Sequences of Sets

Sets : ∀ αs → Set (↑ (max αs))
Sets ε        = ⊤
Sets (αs , α) = Sets αs × Set α

⟨_∋_⟩ : ∀ αs → Sets αs → Set (max αs)
⟨ ε ∋ tt ⟩ = ⊤
⟨ (αs , α) ∋ (As , A) ⟩ = ⟨ αs ∋ As ⟩ × A

_∋_↔*_ : ∀ αs → Sets αs → Sets αs → Set (↑ (max αs))
ε        ∋ tt       ↔* tt       = ⊤
(αs , α) ∋ (As , A) ↔* (Bs , B) = (αs ∋ As ↔* Bs) × (α ∋ A ↔ B)

⟨_∋_⟩² : ∀ αs {As Bs} → (αs ∋ As ↔* Bs) → (max αs ∋ ⟨ αs ∋ As ⟩ ↔ ⟨ αs ∋ Bs ⟩)
⟨ ε        ∋ tt       ⟩² tt       tt       = ⊤
⟨ (αs , α) ∋ (ℜs , ℜ) ⟩² (as , a) (bs , b) = (⟨ αs ∋ ℜs ⟩² as bs) × (ℜ a b)

-- Sequences of RSets

RSets : ∀ αs → Set (↑ (max αs))
RSets ε        = ⊤
RSets (αs , α) = RSets αs × RSet α

_∋_⇔*_ : ∀ αs → RSets αs → RSets αs → Set (↑ (max αs))
ε        ∋ tt       ⇔* tt       = ⊤
(αs , α) ∋ (As , A) ⇔* (Bs , B) = (αs ∋ As ⇔* Bs) × (α ∋ A ⇔ B)

-- Concatenation of sequences

_+_ : Levels → Levels → Levels
αs + ε        = αs
αs + (βs , β) = (αs + βs) , β

_∋_++_∋_ : ∀ αs → RSets αs → ∀ βs → RSets βs → RSets (αs + βs)
αs ∋ As ++ ε        ∋ tt       = As
αs ∋ As ++ (βs , β) ∋ (Bs , B) = ((αs ∋ As ++ βs ∋ Bs) , B)

_∋_++²_∋_ : ∀ αs {As Bs} → (αs ∋ As ⇔* Bs) → ∀ βs {Cs Ds} → (βs ∋ Cs ⇔* Ds) →
  ((αs + βs) ∋ (αs ∋ As ++ βs ∋ Cs) ⇔* (αs ∋ Bs ++ βs ∋ Ds))
αs ∋ ℜs ++² ε        ∋ tt       = ℜs
αs ∋ ℜs ++² (βs , β) ∋ (ℑs , ℑ) = ((αs ∋ ℜs ++² βs ∋ ℑs) , ℑ)

-- Type variables

data TVar : Levels → Set₁ where
  zero : ∀ {αs α} → TVar (αs , α)
  suc : ∀ {αs α} → (τ : TVar αs) → TVar (αs , α)

τlevel : ∀ {αs} → TVar αs → Level
τlevel (zero {α = α}) = α
τlevel (suc τ) = τlevel τ

τ⟦_⟧ : ∀ {αs} (τ : TVar αs) → RSets αs → RSet (τlevel τ)
τ⟦ zero ⟧  (As , A) = A
τ⟦ suc τ ⟧ (As , A) = τ⟦ τ ⟧ As

τ⟦_⟧² : ∀ {αs As Bs} (τ : TVar αs) (ℜs : αs ∋ As ⇔* Bs) → (τlevel τ ∋ τ⟦ τ ⟧ As ⇔ τ⟦ τ ⟧ Bs)
τ⟦ zero ⟧²  (ℜs , ℜ) t a b = ℜ t a b
τ⟦ suc τ ⟧² (ℜs , ℜ) t a b = τ⟦ τ ⟧² ℜs t a b

-- Types

data Typ (αs : Levels) : Set₁ where
  ⟨_⟩ : (A : Set) → Typ αs
  _∧_ _⇒_ : (T : Typ αs) → (U : Typ αs) → Typ αs
  var : (τ : TVar αs) → Typ αs
  univ : ∀ α → (T : Typ (αs , α)) → Typ αs

tlevel : ∀ {αs} → Typ αs → Level
tlevel ⟨ A ⟩ = o
tlevel (T ∧ U) = tlevel T ⊔ tlevel U
tlevel (T ⇒ U) = tlevel T ⊔ tlevel U
tlevel (var τ) = τlevel τ
tlevel (univ α T) = ↑ α ⊔ tlevel T

T⟦_⟧ : ∀ {αs} (T : Typ αs) → RSets αs → RSet (tlevel T)
T⟦ ⟨ A ⟩ ⟧    As t = A
T⟦ T ∧ U ⟧    As t = T⟦ T ⟧ As t × T⟦ U ⟧ As t
T⟦ T ⇒ U ⟧    As t = T⟦ T ⟧ As t → T⟦ U ⟧ As t
T⟦ var τ ⟧    As t = τ⟦ τ ⟧ As t
T⟦ univ α T ⟧ As t = ∀ (A : RSet α) → T⟦ T ⟧ (As , A) t

T⟦_⟧² : ∀ {αs As Bs} (T : Typ αs) (ℜs : αs ∋ As ⇔* Bs) → (tlevel T ∋ T⟦ T ⟧ As ⇔ T⟦ T ⟧ Bs)
T⟦ ⟨ A ⟩ ⟧²    ℜs t a       b       = a ≡ b
T⟦ T ∧ U ⟧²    ℜs t (a , b) (c , d) = T⟦ T ⟧² ℜs t a c × T⟦ U ⟧² ℜs t b d
T⟦ T ⇒ U ⟧²    ℜs t f       g       = ∀ {a b} → T⟦ T ⟧² ℜs t a b → T⟦ U ⟧² ℜs t (f a) (g b)
T⟦ var τ ⟧²    ℜs t v       w       = τ⟦ τ ⟧² ℜs t v w
T⟦ univ α T ⟧² ℜs t f       g       = ∀ {A B} (ℜ : α ∋ A ⇔ B) → T⟦ T ⟧² (ℜs , ℜ) t (f A) (g B)

-- Contexts

data Ctxt (αs : Levels) : Set₁ where
  ε : Ctxt αs
  _,_at_ : (Γ : Ctxt αs) (T : Typ αs) (t : Time) → Ctxt αs

clevels : ∀ {αs} → Ctxt αs → Levels
clevels ε            = ε
clevels (Γ , T at t) = (clevels Γ , tlevel T)

Γ⟦_⟧ : ∀ {αs} (Γ : Ctxt αs) → RSets αs → Sets (clevels Γ)
Γ⟦ ε ⟧          As = tt
Γ⟦ Γ , T at t ⟧ As = (Γ⟦ Γ ⟧ As , T⟦ T ⟧ As t)

Γ⟦_⟧² : ∀ {αs As Bs} (Γ : Ctxt αs) (ℜs : αs ∋ As ⇔* Bs) → (clevels Γ ∋ Γ⟦ Γ ⟧ As ↔* Γ⟦ Γ ⟧ Bs)
Γ⟦ ε ⟧²          ℜs = tt
Γ⟦ Γ , T at t ⟧² ℜs = (Γ⟦ Γ ⟧² ℜs , T⟦ T ⟧² ℜs t)

-- Weakening of type variables

τweaken : ∀ {αs} α βs → TVar (αs + βs) → TVar ((αs , α) + βs)
τweaken α ε        τ       = suc τ
τweaken α (βs , β) zero    = zero
τweaken α (βs , β) (suc τ) = suc (τweaken α βs τ)

⟦τweaken⟧ : ∀ {αs} α βs (τ : TVar (αs + βs)) As A Bs t →
  τ⟦ τ ⟧ (αs ∋ As ++ βs ∋ Bs) t → τ⟦ τweaken α βs τ ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t
⟦τweaken⟧ α ε        τ       As A Bs       t a = a
⟦τweaken⟧ α (βs , β) zero    As A Bs       t a = a
⟦τweaken⟧ α (βs , β) (suc τ) As A (Bs , B) t a = ⟦τweaken⟧ α βs τ As A Bs t a

⟦τweaken⁻¹⟧ : ∀ {αs} α βs (τ : TVar (αs + βs)) As A Bs t →
  τ⟦ τweaken α βs τ ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t → τ⟦ τ ⟧ (αs ∋ As ++ βs ∋ Bs) t
⟦τweaken⁻¹⟧ α ε        τ       As A Bs       t a = a
⟦τweaken⁻¹⟧ α (βs , β) zero    As A Bs       t a = a
⟦τweaken⁻¹⟧ α (βs , β) (suc τ) As A (Bs , B) t a = ⟦τweaken⁻¹⟧ α βs τ As A Bs t a

⟦τweaken⟧² : ∀ {αs} α βs (τ : TVar (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
  τ⟦ τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
  τ⟦ τweaken α βs τ ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t (⟦τweaken⟧ α βs τ As A Cs t a) (⟦τweaken⟧ α βs τ Bs B Ds t b)
⟦τweaken⟧² α ε        τ       ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⟧² α (βs , β) zero    ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⟧² α (βs , β) (suc τ) ℜs ℜ (ℑs , ℑ) t aℜb = ⟦τweaken⟧² α βs τ ℜs ℜ ℑs t aℜb

⟦τweaken⁻¹⟧² : ∀ {αs} α βs (τ : TVar (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
  τ⟦ τweaken α βs τ ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t a b →
  τ⟦ τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦τweaken⁻¹⟧ α βs τ As A Cs t a) (⟦τweaken⁻¹⟧ α βs τ Bs B Ds t b)
⟦τweaken⁻¹⟧² α ε        τ       ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⁻¹⟧² α (βs , β) zero    ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⁻¹⟧² α (βs , β) (suc τ) ℜs ℜ (ℑs , ℑ) t aℜb = ⟦τweaken⁻¹⟧² α βs τ ℜs ℜ ℑs t aℜb

-- Weakening of types

tweaken : ∀ {αs} α βs → Typ (αs + βs) → Typ ((αs , α) + βs)
tweaken α βs ⟨ A ⟩      = ⟨ A ⟩
tweaken α βs (T ∧ U)    = tweaken α βs T ∧ tweaken α βs U
tweaken α βs (T ⇒ U)    = tweaken α βs T ⇒ tweaken α βs U
tweaken α βs (var τ)    = var (τweaken α βs τ)
tweaken α βs (univ β T) = univ β (tweaken α (βs , β) T)

mutual

  ⟦tweaken⟧ : ∀ {αs} α βs (T : Typ (αs + βs)) As A Bs t →
    T⟦ T ⟧ (αs ∋ As ++ βs ∋ Bs) t → T⟦ tweaken α βs T ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t
  ⟦tweaken⟧ α βs ⟨ B ⟩      As A Bs t a       = a
  ⟦tweaken⟧ α βs (T ∧ U)    As A Bs t (a , b) = (⟦tweaken⟧ α βs T As A Bs t a , ⟦tweaken⟧ α βs U As A Bs t b)
  ⟦tweaken⟧ α βs (T ⇒ U)    As A Bs t f       = λ a → ⟦tweaken⟧ α βs U As A Bs t (f (⟦tweaken⁻¹⟧ α βs T As A Bs t a))
  ⟦tweaken⟧ α βs (var τ)    As A Bs t a       = ⟦τweaken⟧ α βs τ As A Bs t a
  ⟦tweaken⟧ α βs (univ β T) As A Bs t f       = λ B → ⟦tweaken⟧ α (βs , β) T As A (Bs , B) t (f B)

  ⟦tweaken⁻¹⟧ : ∀ {αs} α βs (T : Typ (αs + βs)) As A Bs t →
    T⟦ tweaken α βs T ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t → T⟦ T ⟧ (αs ∋ As ++ βs ∋ Bs) t
  ⟦tweaken⁻¹⟧ α βs ⟨ B ⟩      As A Bs t a       = a
  ⟦tweaken⁻¹⟧ α βs (T ∧ U)    As A Bs t (a , b) = (⟦tweaken⁻¹⟧ α βs T As A Bs t a , ⟦tweaken⁻¹⟧ α βs U As A Bs t b)
  ⟦tweaken⁻¹⟧ α βs (T ⇒ U)    As A Bs t f       = λ a → ⟦tweaken⁻¹⟧ α βs U As A Bs t (f (⟦tweaken⟧ α βs T As A Bs t a))
  ⟦tweaken⁻¹⟧ α βs (var τ)    As A Bs t a       = ⟦τweaken⁻¹⟧ α βs τ As A Bs t a
  ⟦tweaken⁻¹⟧ α βs (univ β T) As A Bs t f       = λ B → ⟦tweaken⁻¹⟧ α (βs , β) T As A (Bs , B) t (f B)

mutual

  ⟦tweaken⟧² : ∀ {αs} α βs (T : Typ (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
    T⟦ T ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
    T⟦ tweaken α βs T ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t (⟦tweaken⟧ α βs T As A Cs t a) (⟦tweaken⟧ α βs T Bs B Ds t b)
  ⟦tweaken⟧² α βs ⟨ B ⟩      ℜs ℜ ℑs t aℜb         = aℜb
  ⟦tweaken⟧² α βs (T ∧ U)    ℜs ℜ ℑs t (aℜb , cℜd) = (⟦tweaken⟧² α βs T ℜs ℜ ℑs t aℜb , ⟦tweaken⟧² α βs U ℜs ℜ ℑs t cℜd)
  ⟦tweaken⟧² α βs (T ⇒ U)    ℜs ℜ ℑs t fℜg         = λ aℜb → ⟦tweaken⟧² α βs U ℜs ℜ ℑs t (fℜg (⟦tweaken⁻¹⟧² α βs T ℜs ℜ ℑs t aℜb))
  ⟦tweaken⟧² α βs (var τ)    ℜs ℜ ℑs t aℜb         = ⟦τweaken⟧² α βs τ ℜs ℜ ℑs t aℜb
  ⟦tweaken⟧² α βs (univ β T) ℜs ℜ ℑs t fℜg         = λ ℑ → ⟦tweaken⟧² α (βs , β) T ℜs ℜ (ℑs , ℑ) t (fℜg ℑ)

  ⟦tweaken⁻¹⟧² : ∀ {αs} α βs (T : Typ (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
    T⟦ tweaken α βs T ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t a b →
    T⟦ T ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦tweaken⁻¹⟧ α βs T As A Cs t a) (⟦tweaken⁻¹⟧ α βs T Bs B Ds t b)
  ⟦tweaken⁻¹⟧² α βs ⟨ B ⟩      ℜs ℜ ℑs t aℜb         = aℜb
  ⟦tweaken⁻¹⟧² α βs (T ∧ U)    ℜs ℜ ℑs t (aℜb , cℜd) = (⟦tweaken⁻¹⟧² α βs T ℜs ℜ ℑs t aℜb , ⟦tweaken⁻¹⟧² α βs U ℜs ℜ ℑs t cℜd)
  ⟦tweaken⁻¹⟧² α βs (T ⇒ U)    ℜs ℜ ℑs t fℜg         = λ aℜb → ⟦tweaken⁻¹⟧² α βs U ℜs ℜ ℑs t (fℜg (⟦tweaken⟧² α βs T ℜs ℜ ℑs t aℜb))
  ⟦tweaken⁻¹⟧² α βs (var τ)    ℜs ℜ ℑs t aℜb         = ⟦τweaken⁻¹⟧² α βs τ ℜs ℜ ℑs t aℜb
  ⟦tweaken⁻¹⟧² α βs (univ β T) ℜs ℜ ℑs t fℜg         = λ ℑ → ⟦tweaken⁻¹⟧² α (βs , β) T ℜs ℜ (ℑs , ℑ) t (fℜg ℑ)

-- Weakening of contexts

cweaken : ∀ {αs} α → Ctxt αs → Ctxt (αs , α)
cweaken α ε            = ε
cweaken α (Γ , T at t) = (cweaken α Γ , tweaken α ε T at t)

⟦cweaken⟧ : ∀ {αs} α (Γ : Ctxt αs) As A → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → ⟨ clevels (cweaken α Γ) ∋ Γ⟦ cweaken α Γ ⟧ (As , A) ⟩
⟦cweaken⟧ α ε            As A tt       = tt
⟦cweaken⟧ α (Γ , T at t) As A (as , a) = (⟦cweaken⟧ α Γ As A as , ⟦tweaken⟧ α ε T As A tt t a)

⟦cweaken⟧² : ∀ {αs} α (Γ : Ctxt αs) {As Bs A B} ℜs ℜ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs →
  ⟨ clevels (cweaken α Γ) ∋ Γ⟦ cweaken α Γ ⟧² (ℜs , ℜ) ⟩² (⟦cweaken⟧ α Γ As A as) (⟦cweaken⟧ α Γ Bs B bs)
⟦cweaken⟧² α ε            ℜs ℜ tt            = tt
⟦cweaken⟧² α (Γ , T at t) ℜs ℜ (asℜbs , aℜb) = (⟦cweaken⟧² α Γ ℜs ℜ asℜbs , ⟦tweaken⟧² α ε T ℜs ℜ tt t aℜb)

-- Substitution into type variables

τsubst : ∀ {αs} (T : Typ αs) βs → TVar ((αs , tlevel T) + βs) → Typ (αs + βs)
τsubst T ε        zero    = T
τsubst T ε        (suc τ) = var τ
τsubst T (βs , β) zero    = var zero
τsubst T (βs , β) (suc τ) = tweaken β ε (τsubst T βs τ)

⟦τsubst⟧ : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) As Bs t →
  τ⟦ τ ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t →
  T⟦ τsubst T βs τ ⟧ (αs ∋ As ++ βs ∋ Bs) t
⟦τsubst⟧      T ε        zero    As Bs       t a = a
⟦τsubst⟧      T ε        (suc τ) As Bs       t a = a
⟦τsubst⟧      T (βs , β) zero    As Bs       t a = a
⟦τsubst⟧ {αs} T (βs , β) (suc τ) As (Bs , B) t a =
  ⟦tweaken⟧ β ε (τsubst T βs τ) (αs ∋ As ++ βs ∋ Bs) B tt t
    (⟦τsubst⟧ T βs τ As Bs t a)

⟦τsubst⁻¹⟧ : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) As Bs t →
  T⟦ τsubst T βs τ ⟧ (αs ∋ As ++ βs ∋ Bs) t →
  τ⟦ τ ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t
⟦τsubst⁻¹⟧      T ε        zero    As Bs       t a = a
⟦τsubst⁻¹⟧      T ε        (suc τ) As Bs       t a = a
⟦τsubst⁻¹⟧      T (βs , β) zero    As Bs       t a = a
⟦τsubst⁻¹⟧ {αs} T (βs , β) (suc τ) As (Bs , B) t a =
  ⟦τsubst⁻¹⟧ T βs τ As Bs t
    (⟦tweaken⁻¹⟧ β ε (τsubst T βs τ) (αs ∋ As ++ βs ∋ Bs) B tt t a)

⟦τsubst⟧² : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
  τ⟦ τ ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t a b →
  T⟦ τsubst T βs τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦τsubst⟧ T βs τ As Bs t a) (⟦τsubst⟧ T βs τ Cs Ds t b)
⟦τsubst⟧²      T ε        zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧²      T ε        (suc τ) ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧²      T (βs , β) zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧² {αs} T (βs , β) (suc τ) ℜs (ℑs , ℑ) t aℜb =
  ⟦tweaken⟧² β ε (τsubst T βs τ) (αs ∋ ℜs ++² βs ∋ ℑs) ℑ tt t
    (⟦τsubst⟧² T βs τ ℜs ℑs t aℜb)

⟦τsubst⁻¹⟧² : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
  T⟦ τsubst T βs τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
  τ⟦ τ ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t (⟦τsubst⁻¹⟧ T βs τ As Bs t a) (⟦τsubst⁻¹⟧ T βs τ Cs Ds t b)
⟦τsubst⁻¹⟧²      T ε        zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧²      T ε        (suc τ) ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧²      T (βs , β) zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧² {αs} T (βs , β) (suc τ) ℜs (ℑs , ℑ) t aℜb =
  ⟦τsubst⁻¹⟧² T βs τ ℜs ℑs t
    (⟦tweaken⁻¹⟧² β ε (τsubst T βs τ) (αs ∋ ℜs ++² βs ∋ ℑs) ℑ tt t aℜb)

-- Substitution into types

tsubst : ∀ {αs} (T : Typ αs) βs → Typ ((αs , tlevel T) + βs) → Typ (αs + βs)
tsubst T βs ⟨ A ⟩ = ⟨ A ⟩
tsubst T βs (U ∧ V) = tsubst T βs U ∧ tsubst T βs V
tsubst T βs (U ⇒ V) = tsubst T βs U ⇒ tsubst T βs V
tsubst T βs (var τ) = τsubst T βs τ
tsubst T βs (univ β U) = univ β (tsubst T (βs , β) U)

mutual

  ⟦tsubst⟧ : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) As Bs t →
    T⟦ U ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t →
    T⟦ tsubst T βs U ⟧ (αs ∋ As ++ βs ∋ Bs) t
  ⟦tsubst⟧ T βs ⟨ A ⟩      As Bs t a       = a
  ⟦tsubst⟧ T βs (U ∧ V)    As Bs t (a , b) = (⟦tsubst⟧ T βs U As Bs t a , ⟦tsubst⟧ T βs V As Bs t b)
  ⟦tsubst⟧ T βs (U ⇒ V)    As Bs t f       = λ a → ⟦tsubst⟧ T βs V As Bs t (f (⟦tsubst⁻¹⟧ T βs U As Bs t a))
  ⟦tsubst⟧ T βs (var τ)    As Bs t a       = ⟦τsubst⟧ T βs τ As Bs t a
  ⟦tsubst⟧ T βs (univ β U) As Bs t f       = λ B → ⟦tsubst⟧ T (βs , β) U As (Bs , B) t (f B)

  ⟦tsubst⁻¹⟧ : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) As Bs t →
    T⟦ tsubst T βs U ⟧ (αs ∋ As ++ βs ∋ Bs) t →
    T⟦ U ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t
  ⟦tsubst⁻¹⟧ T βs ⟨ A ⟩      As Bs t a       = a
  ⟦tsubst⁻¹⟧ T βs (U ∧ V)    As Bs t (a , b) = (⟦tsubst⁻¹⟧ T βs U As Bs t a , ⟦tsubst⁻¹⟧ T βs V As Bs t b)
  ⟦tsubst⁻¹⟧ T βs (U ⇒ V)    As Bs t f       = λ a → ⟦tsubst⁻¹⟧ T βs V As Bs t (f (⟦tsubst⟧ T βs U As Bs t a))
  ⟦tsubst⁻¹⟧ T βs (var τ)    As Bs t a       = ⟦τsubst⁻¹⟧ T βs τ As Bs t a
  ⟦tsubst⁻¹⟧ T βs (univ β U) As Bs t f       = λ B → ⟦tsubst⁻¹⟧ T (βs , β) U As (Bs , B) t (f B)

mutual

  ⟦tsubst⟧² : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
    T⟦ U ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t a b →
    T⟦ tsubst T βs U ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦tsubst⟧ T βs U As Bs t a) (⟦tsubst⟧ T βs U Cs Ds t b)
  ⟦tsubst⟧² T βs ⟨ A ⟩      ℜs ℑs t aℜb         = aℜb
  ⟦tsubst⟧² T βs (U ∧ V)    ℜs ℑs t (aℜb , cℜd) = (⟦tsubst⟧² T βs U ℜs ℑs t aℜb , ⟦tsubst⟧² T βs V ℜs ℑs t cℜd)
  ⟦tsubst⟧² T βs (U ⇒ V)    ℜs ℑs t fℜg         = λ aℜb → ⟦tsubst⟧² T βs V ℜs ℑs t (fℜg (⟦tsubst⁻¹⟧² T βs U ℜs ℑs t aℜb))
  ⟦tsubst⟧² T βs (var τ)    ℜs ℑs t aℜb         = ⟦τsubst⟧² T βs τ ℜs ℑs t aℜb
  ⟦tsubst⟧² T βs (univ β U) ℜs ℑs t fℜg         = λ ℑ → ⟦tsubst⟧² T (βs , β) U ℜs (ℑs , ℑ) t (fℜg ℑ)

  ⟦tsubst⁻¹⟧² : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
    T⟦ tsubst T βs U ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
    T⟦ U ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t (⟦tsubst⁻¹⟧ T βs U As Bs t a) (⟦tsubst⁻¹⟧ T βs U Cs Ds t b)
  ⟦tsubst⁻¹⟧² T βs ⟨ A ⟩      ℜs ℑs t aℜb         = aℜb
  ⟦tsubst⁻¹⟧² T βs (U ∧ V)    ℜs ℑs t (aℜb , cℜd) = (⟦tsubst⁻¹⟧² T βs U ℜs ℑs t aℜb , ⟦tsubst⁻¹⟧² T βs V ℜs ℑs t cℜd)
  ⟦tsubst⁻¹⟧² T βs (U ⇒ V)    ℜs ℑs t fℜg         = λ aℜb → ⟦tsubst⁻¹⟧² T βs V ℜs ℑs t (fℜg (⟦tsubst⟧² T βs U ℜs ℑs t aℜb))
  ⟦tsubst⁻¹⟧² T βs (var τ)    ℜs ℑs t aℜb         = ⟦τsubst⁻¹⟧² T βs τ ℜs ℑs t aℜb
  ⟦tsubst⁻¹⟧² T βs (univ β U) ℜs ℑs t fℜg         = λ ℑ → ⟦tsubst⁻¹⟧² T (βs , β) U ℜs (ℑs , ℑ) t (fℜg ℑ)

-- Variables

data Var {αs} (T : Typ αs) (t : Time) : (Γ : Ctxt αs) → Set₁ where
  zero : ∀ {Γ : Ctxt αs} → Var T t (Γ , T at t)
  suc : ∀ {Γ : Ctxt αs} {U : Typ αs} {u} → Var T t Γ → Var T t (Γ , U at u)

v⟦_⟧ : ∀ {αs} {Γ : Ctxt αs} {T : Typ αs} {t} → Var T t Γ → ∀ As → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → T⟦ T ⟧ As t
v⟦ zero ⟧  As (as , a) = a
v⟦ suc v ⟧ As (as , a) = v⟦ v ⟧ As as

v⟦_⟧² : ∀ {αs As Bs} {Γ : Ctxt αs} {T : Typ αs} {t} (τ : Var T t Γ) (ℜs : αs ∋ As ⇔* Bs) →
  ∀ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs → T⟦ T ⟧² ℜs t (v⟦ τ ⟧ As as) (v⟦ τ ⟧ Bs bs)
v⟦ zero ⟧²  ℜs (asℜbs , aℜb) = aℜb
v⟦ suc v ⟧² ℜs (asℜbs , aℜb) = v⟦ v ⟧² ℜs asℜbs

-- Expressions

data Exp : ∀ {αs} → Ctxt αs → Typ αs → RSet₁ where
  const : ∀ {αs Γ A t} → (a : A) → Exp {αs} Γ ⟨ A ⟩ t
  pair : ∀ {αs Γ T U t} → (e : Exp Γ T t) → (f : Exp Γ U t) → Exp {αs} Γ (T ∧ U) t
  fst : ∀ {αs Γ T U t} → (e : Exp Γ (T ∧ U) t) → Exp {αs} Γ T t
  snd : ∀ {αs Γ T U t} → (e : Exp Γ (T ∧ U) t) → Exp {αs} Γ U t
  abs : ∀ {αs Γ T U t} → (e : Exp (Γ , T at t) U t) → Exp {αs} Γ (T ⇒ U) t
  app : ∀ {αs Γ T U t} → (f : Exp Γ (T ⇒ U) t) → (e : Exp Γ T t) → Exp {αs} Γ U t
  var : ∀ {αs Γ T t} → (v : Var T t Γ) → Exp {αs} Γ T t
  tabs : ∀ {αs Γ} α {T t} → (e : Exp (cweaken α Γ) T t) → Exp {αs} Γ (univ α T) t
  tapp : ∀ {αs Γ t} (T : Typ αs) {U} → (e : Exp Γ (univ (tlevel T) U) t) → Exp {αs} Γ (tsubst T ε U) t

e⟦_⟧ : ∀ {αs} {Γ : Ctxt αs} {T : Typ αs} {t} → Exp Γ T t → ∀ As → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → T⟦ T ⟧ As t
e⟦ const a ⟧                  As as = a
e⟦ pair e f ⟧                 As as = (e⟦ e ⟧ As as , e⟦ f ⟧ As as)
e⟦ fst e ⟧                    As as = proj₁ (e⟦ e ⟧ As as)
e⟦ snd e ⟧                    As as = proj₂ (e⟦ e ⟧ As as)
e⟦ abs e ⟧                    As as = λ a → e⟦ e ⟧ As (as , a)
e⟦ app f e ⟧                  As as = e⟦ f ⟧ As as (e⟦ e ⟧ As as)
e⟦ var v ⟧                    As as = v⟦ v ⟧ As as
e⟦ tabs {Γ = Γ} α e ⟧         As as = λ A → e⟦ e ⟧ (As , A) (⟦cweaken⟧ α Γ As A as)
e⟦ tapp {t = t} T {U = U} e ⟧ As as = ⟦tsubst⟧ T ε U As tt t (e⟦ e ⟧ As as (T⟦ T ⟧ As))

e⟦_⟧² : ∀ {αs As Bs} {Γ : Ctxt αs} {T : Typ αs} {t} (e : Exp Γ T t) (ℜs : αs ∋ As ⇔* Bs) →
  ∀ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs → T⟦ T ⟧² ℜs t (e⟦ e ⟧ As as) (e⟦ e ⟧ Bs bs)
e⟦ const a ⟧²                  ℜs asℜbs = refl
e⟦ pair e f ⟧²                 ℜs asℜbs = (e⟦ e ⟧² ℜs asℜbs , e⟦ f ⟧² ℜs asℜbs)
e⟦ fst e ⟧²                    ℜs asℜbs = proj₁ (e⟦ e ⟧² ℜs asℜbs)
e⟦ snd e ⟧²                    ℜs asℜbs = proj₂ (e⟦ e ⟧² ℜs asℜbs)
e⟦ abs e ⟧²                    ℜs asℜbs = λ aℜb → e⟦ e ⟧² ℜs (asℜbs , aℜb)
e⟦ app f e ⟧²                  ℜs asℜbs = e⟦ f ⟧² ℜs asℜbs (e⟦ e ⟧² ℜs asℜbs)
e⟦ var v ⟧²                    ℜs asℜbs = v⟦ v ⟧² ℜs asℜbs
e⟦ tabs {Γ = Γ} α e ⟧²         ℜs asℜbs = λ ℜ → e⟦ e ⟧² (ℜs , ℜ) (⟦cweaken⟧² α Γ ℜs ℜ asℜbs)
e⟦ tapp {t = t} T {U = U} e ⟧² ℜs asℜbs = ⟦tsubst⟧² T ε U ℜs tt t (e⟦ e ⟧² ℜs asℜbs (T⟦ T ⟧² ℜs))

-- Surface level types

data STyp : Set₁ where
  ⟨_⟩ : (A : Set) → STyp
  _∧_ _⇒_ : (T : STyp) → (U : STyp) → STyp

-- Translation of surface level types into types

⟪_⟫ : STyp → Typ (ε , o)
⟪ ⟨ A ⟩ ⟫ = ⟨ A ⟩
⟪ T ∧ U ⟫ = ⟪ T ⟫ ∧ ⟪ U ⟫
⟪ T ⇒ U ⟫ = ⟪ T ⟫ ⇒ ⟪ U ⟫

T⟪_⟫ : STyp → RSet₀
T⟪ ⟨ A ⟩ ⟫ t = A
T⟪ T ∧ U ⟫ t = T⟪ T ⟫ t × T⟪ U ⟫ t
T⟪ T ⇒ U ⟫ t = T⟪ T ⟫ t → T⟪ U ⟫ t

World : RSet₀
World t = ⊤

mutual

  trans : ∀ T {s} → T⟪ T ⟫ s → T⟦ ⟪ T ⟫ ⟧ (tt , World) s
  trans ⟨ A ⟩   a       = a
  trans (T ∧ U) (a , b) = (trans T a , trans U b)
  trans (T ⇒ U) f       = λ a → trans U (f (trans⁻¹ T a))

  trans⁻¹ : ∀ T {s} → T⟦ ⟪ T ⟫ ⟧ (tt , World) s → T⟪ T ⟫ s
  trans⁻¹ ⟨ A ⟩   a       = a
  trans⁻¹ (T ∧ U) (a , b) = (trans⁻¹ T a , trans⁻¹ U b)
  trans⁻¹ (T ⇒ U) f       = λ a → trans⁻¹ U (f (trans T a))

-- Causality

_at_∋_≈[_∵_]_ : ∀ T s → T⟪ T ⟫ s → ∀ u → True (s ≤ u) → T⟪ T ⟫ s → Set
⟨ A ⟩   at s ∋ a       ≈[ u ∵ s≤u ] b       = a ≡ b
(T ∧ U) at s ∋ (a , b) ≈[ u ∵ s≤u ] (c , d) = (T at s ∋ a ≈[ u ∵ s≤u ] c) × (U at s ∋ b ≈[ u ∵ s≤u ] d)
(T ⇒ U) at s ∋ f       ≈[ u ∵ s≤u ] g       = ∀ {a b} → (T at s ∋ a ≈[ u ∵ s≤u ] b) → (U at s ∋ f a ≈[ u ∵ s≤u ] g b)

Causal : ∀ T U s → T⟪ T ⇒ U ⟫ s → Set
Causal T U s f = ∀ u s≤u {a b} → (T at s ∋ a ≈[ u ∵ s≤u ] b) → (U at s ∋ f a ≈[ u ∵ s≤u ] f b)

-- Parametricity implies causality

ℜ[_] : Time → (o ∋ World ⇔ World)
ℜ[ u ] t tt tt = True (t ≤ u)

mutual

  ℜ-impl-≈ : ∀ T s u s≤u {a b} →
    T⟦ ⟪ T ⟫ ⟧² (tt , ℜ[ u ]) s a b →
    (T at s ∋ trans⁻¹ T a ≈[ u ∵ s≤u ] trans⁻¹ T b)
  ℜ-impl-≈ ⟨ A ⟩   s u s≤u aℜb         = aℜb
  ℜ-impl-≈ (T ∧ U) s u s≤u (aℜc , bℜd) = (ℜ-impl-≈ T s u s≤u aℜc , ℜ-impl-≈ U s u s≤u bℜd)
  ℜ-impl-≈ (T ⇒ U) s u s≤u fℜg         = λ a≈b → ℜ-impl-≈ U s u s≤u (fℜg (≈-impl-ℜ T s u s≤u a≈b))

  ≈-impl-ℜ : ∀ T s u s≤u {a b} →
    (T at s ∋ a ≈[ u ∵ s≤u ] b) →
    T⟦ ⟪ T ⟫ ⟧² (tt , ℜ[ u ]) s (trans T a) (trans T b)
  ≈-impl-ℜ ⟨ A ⟩   s u s≤u a≈b         = a≈b
  ≈-impl-ℜ (T ∧ U) s u s≤u (a≈c , b≈d) = (≈-impl-ℜ T s u s≤u a≈c , ≈-impl-ℜ U s u s≤u b≈d)
  ≈-impl-ℜ (T ⇒ U) s u s≤u f≈g         = λ aℜb → ≈-impl-ℜ U s u s≤u (f≈g (ℜ-impl-≈ T s u s≤u aℜb))

-- Every expression is causal

e⟪_at_∋_⟫ : ∀ T t → Exp ε ⟪ T ⟫ t → T⟪ T ⟫ t
e⟪ T at t ∋ e ⟫ = trans⁻¹ T (e⟦ e ⟧ (tt , World) tt)

causality : ∀ T U s f → Causal T U s e⟪ (T ⇒ U) at s ∋ f ⟫
causality T U s f u s≤u = ℜ-impl-≈ (T ⇒ U) s u s≤u (e⟦ f ⟧² (tt , ℜ[ u ]) tt)

error: pathspec 'src/agda/FRP/JS/Model.agda' did not match any file(s) known to git


Start a new approach: encode Smyth in Agda.

module Text.Greek.Smyth where

open import Data.Char
open import Data.Maybe

-- Smyth §1
data Letter : Set where
  α′ β′ γ′ δ′ ε′ ζ′ η′ θ′ ι′ κ′ λ′ μ′ ν′ ξ′ ο′ π′ ρ′ σ′ τ′ υ′ φ′ χ′ ψ′ ω′ : Letter

data LetterCase : Set where
  capital small : LetterCase

form : Letter → LetterCase → Char
form α′ capital = 'Α'
form α′ small = 'α'
form β′ capital = 'Β'
form β′ small = 'β'
form γ′ capital = 'Γ'
form γ′ small = 'γ'
form δ′ capital = 'Δ'
form δ′ small = 'δ'
form ε′ capital = 'Ε'
form ε′ small = 'ε'
form ζ′ capital = 'Ζ'
form ζ′ small = 'ζ'
form η′ capital = 'Η'
form η′ small = 'η'
form θ′ capital = 'Θ'
form θ′ small = 'θ'
form ι′ capital = 'Ι'
form ι′ small = 'ι'
form κ′ capital = 'Κ'
form κ′ small = 'κ'
form λ′ capital = 'Λ'
form λ′ small = 'λ'
form μ′ capital = 'Μ'
form μ′ small = 'μ'
form ν′ capital = 'Ν'
form ν′ small = 'ν'
form ξ′ capital = 'Ξ'
form ξ′ small = 'ξ'
form ο′ capital = 'Ο'
form ο′ small = 'ο'
form π′ capital = 'Π'
form π′ small = 'π'
form ρ′ capital = 'Ρ'
form ρ′ small = 'ρ'
form σ′ capital = 'Σ'
form σ′ small = 'σ'
form τ′ capital = 'Τ'
form τ′ small = 'τ'
form υ′ capital = 'Υ'
form υ′ small = 'υ'
form φ′ capital = 'Φ'
form φ′ small = 'φ'
form χ′ capital = 'Χ'
form χ′ small = 'χ'
form ψ′ capital = 'Ψ'
form ψ′ small = 'ψ'
form ω′ capital = 'Ω'
form ω′ small = 'ω'

-- Smyth §1 a
data PositionInWord : Set where
  not-end : PositionInWord
  end-of-word : PositionInWord

form-in-word : Letter → LetterCase → PositionInWord → Char
form-in-word σ′ small end-of-word = 'ς'
form-in-word ℓ c _ = form ℓ c

-- Smyth §3
data OlderLetter : Set where
  Ϝ′ : OlderLetter
  Ϙ′ : OlderLetter
  ϡ′ : OlderLetter

-- Smyth §4
data Vowel : Letter → Set where
  α-vowel : Vowel α′
  ε-vowel : Vowel ε′
  η-vowel : Vowel η′
  ι-vowel : Vowel ι′
  ο-vowel : Vowel ο′
  υ-vowel : Vowel υ′
  ω-vowel : Vowel ω′

data AlwaysShort : Letter → Set where
  ε-always-short : Vowel ε′ → AlwaysShort ε′
  ο-always-short : Vowel ο′ → AlwaysShort ο′

data AlwaysLong : Letter → Set where
  η-always-long : Vowel η′ → AlwaysLong η′
  ω-always-long : Vowel ω′ → AlwaysLong ω′

-- Smyth §4 All vowels with the circumflex (149) are long

-- Smyth §149
data Accent : Set where
  acute circumflex grave : Accent

error: pathspec 'agda2/Text/Greek/Smyth.agda' did not match any file(s) known to git


IDesc model: type-in-type, so it goes... :-(

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


Implement NbE for lambda calculus with base types (see #50).

Old-commit-hash: 26dd0dee4e73552fe51a52999922812354a03188

module NormalizationByEvaluation where

-- NORMALIZATION BY EVALUATION
--
-- for the simply-typed λ calculus with base types

open import Level hiding (Lift; lift)
open import Data.Bool

open import Relation.Binary hiding (_⇒_)

-- The rest of this file is parametric in the set of base types.

module Parametric (Base : Set) where

  -- SYNTAX OF TYPES
  --
  -- We support function types and base types.

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

  open import Syntactic.Contexts Type public

  -- DOMAIN CONSTRUCTION
  --
  -- The meaning of types is defined using Kripke structures.

  record IsKripke {w ℓ₁ ℓ₂} {World : Set w}
                  (_≈_ : Rel World ℓ₁)
                  (_≤_ : Rel World ℓ₂)
                  (_⊩⟦_⟧Base : World → Base → Set (ℓ₂ ⊔ w))
                  : Set (w ⊔ ℓ₁ ⊔ ℓ₂) where
    Lift : ∀ {A : Set} (_⊩⟦_⟧ : World → A → Set (ℓ₂ ⊔ w)) → Set (ℓ₂ ⊔ w)
    Lift _⊩⟦_⟧ = ∀ {a w₁ w₂} → w₁ ≤ w₂ → w₁ ⊩⟦ a ⟧ → w₂ ⊩⟦ a ⟧

    field
      isPreorder : IsPreorder _≈_ _≤_
      liftBase : Lift _⊩⟦_⟧Base

    open IsPreorder isPreorder public

    _⊩⟦_⟧Type : World → Type → Set (ℓ₂ ⊔ w)
    w₁ ⊩⟦ τ₁ ⇒ τ₂ ⟧Type = ∀ {w₂} → w₁ ≤ w₂ → w₂ ⊩⟦ τ₁ ⟧Type → w₂ ⊩⟦ τ₂ ⟧Type
    w₁ ⊩⟦ base b ⟧Type = w₁ ⊩⟦ b ⟧Base

    liftType : Lift _⊩⟦_⟧Type
    liftType {τ₁ ⇒ τ₂} w₁≤w₂ w₁⊩τ₁⇒τ₂ = λ w₂≤w₃ w₃⊩τ₁ → w₁⊩τ₁⇒τ₂ (trans w₁≤w₂ w₂≤w₃) w₃⊩τ₁
    liftType {base b} w₁≤w₂ w₁⊩b = liftBase w₁≤w₂ w₁⊩b

    module _ (w : World) where
      open import Denotational.Environments Type (λ τ → w ⊩⟦ τ ⟧Type) public
        renaming (⟦_⟧Context to _⊩⟦_⟧Context; ⟦_⟧Var to _⊩⟦_⟧Var)

    liftContext : Lift {Context} _⊩⟦_⟧Context
    liftContext {∅} w₁≤w₂ w₁⊩Γ = ∅
    liftContext {τ • Γ} w₁≤w₂ (w₁⊩τ • w₁⊩Γ) = liftType {τ} w₁≤w₂ w₁⊩τ • liftContext w₁≤w₂ w₁⊩Γ

  record Kripke w ℓ₁ ℓ₂ : Set (suc (w ⊔ ℓ₁ ⊔ ℓ₂)) where
    field
      World : Set w
      _≈_ : Rel World ℓ₁
      _≤_ : Rel World ℓ₂
      _⊩⟦_⟧Base : World → Base → Set (ℓ₂ ⊔ w)
      isKripke : IsKripke _≈_ _≤_ _⊩⟦_⟧Base

    open IsKripke isKripke public

  -- TERMS
  --
  -- The syntax of terms is parametric in the set of constants.

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

    weaken : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Term Γ₁ τ → Term Γ₂ τ
    weaken Γ₁≼Γ₂ (abs t) = abs (weaken (keep _ • Γ₁≼Γ₂) t)
    weaken Γ₁≼Γ₂ (app t₁ t₂) = app (weaken Γ₁≼Γ₂ t₁) (weaken Γ₁≼Γ₂ t₂)
    weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
    weaken Γ₁≼Γ₂ (con c) = con c

  -- SYMBOLIC EXECUTION and REIFICATION
  --
  -- The Kripke structure of symbolic computation, using typing
  -- contexts as worlds. Base types are interpreted as
  -- terms. This is parametric in the set of available constants.

  module Symbolic (Constant : Type → Set) where
    open import Relation.Binary.PropositionalEquality
    open Terms Constant

    BaseTerm : Context → Base → Set
    BaseTerm Γ b = Term Γ (base b)

    isKripke : IsKripke _≡_ _≼_ BaseTerm
    isKripke = record {
      isPreorder = ≼-isPreorder;
      liftBase = weaken }

    symbolic : Kripke zero zero zero
    symbolic = record {
      World = Context;
      _≈_ = _≡_;
      _≤_ = _≼_;
      _⊩⟦_⟧Base = BaseTerm;
      isKripke = isKripke }

    open Kripke symbolic

    ↓ : ∀ {Γ} τ → Γ ⊩⟦ τ ⟧Type → Term Γ τ
    ↑ : ∀ {Γ} τ → Term Γ τ → Γ ⊩⟦ τ ⟧Type

    ↓ (τ₁ ⇒ τ₂) v = abs (↓ τ₂ (v (drop τ₁ • ≼-refl) (↑ τ₁ (var this))))
    ↓ (base b) v = v

    ↑ (τ₁ ⇒ τ₂) t = λ Γ₁≼Γ₂ v → ↑ τ₂ (app (weaken Γ₁≼Γ₂ t) (↓ τ₁ v))
    ↑ (base b) t = t

    Γ⊩Γ : ∀ {Γ} → Γ ⊩⟦ Γ ⟧Context
    Γ⊩Γ {∅} = ∅
    Γ⊩Γ {τ • Γ} = ↑ τ (var this) • liftContext (drop τ • ≼-refl) Γ⊩Γ

  -- EVALUATION
  --
  -- Evaluation is defined for every Kripke structure and every
  -- set of constants. We have to provide the interpretation of
  -- the constants in the choosen Kripke structure, though.
  module _ {w ℓ₁ ℓ₂} (K : Kripke w ℓ₁ ℓ₂) where
    open Kripke K

    module Evaluation (Constant : Type → Set)
                      (_⊩⟦_⟧Constant : ∀ w {τ} → Constant τ → w ⊩⟦ τ ⟧Type) where
      open Terms Constant

      _⊩⟦_⟧Term_ : ∀ w {Γ τ} → Term Γ τ → w ⊩⟦ Γ ⟧Context → w ⊩⟦ τ ⟧Type
      w₁ ⊩⟦ abs t ⟧Term w₁⊩Γ = λ {w₂} w₁≤w₂ w₂⊩τ₁ → w₂ ⊩⟦ t ⟧Term (w₂⊩τ₁ • liftContext w₁≤w₂ w₁⊩Γ)
      w₁ ⊩⟦ app t₁ t₂ ⟧Term w₁⊩Γ = (w₁ ⊩⟦ t₁ ⟧Term w₁⊩Γ) refl (w₁ ⊩⟦ t₂ ⟧Term w₁⊩Γ)
      w₁ ⊩⟦ var x ⟧Term w₁⊩Γ = (w₁ ⊩⟦ x ⟧Var) w₁⊩Γ
      w₁ ⊩⟦ con c ⟧Term w₁⊩Γ = w₁ ⊩⟦ c ⟧Constant

  -- NORMALIZATION
  --
  -- Given a set of constants and their interpretation in the
  -- Kripke structure for symbolic computation, we can normalize
  -- terms.

  module _ (Constant : Type → Set) where
    open Terms Constant
    open Symbolic Constant
    open Kripke symbolic

    module Normalization (_⊩⟦_⟧Constant : ∀ Γ {τ} → Constant τ → Γ ⊩⟦ τ ⟧Type) where
      open Evaluation symbolic Constant _⊩⟦_⟧Constant

      norm : ∀ {Γ τ} → Term Γ τ → Term Γ τ
      norm {Γ} {τ} t = ↓ τ (Γ ⊩⟦ t ⟧Term Γ⊩Γ)

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


add a "simple" circuit adder capable of 11+31=42

open import Type
open import Data.Nat.NP
open import Data.Bool using (if_then_else_)
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Function.NP hiding (id)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

module adder where

module FunAdder
  {t}
  {T : ★_ t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

    open FunUniverse funU renaming (`⊤ to `𝟙; `Bit to `𝟚)
    open FunOps funOps renaming (_∘_ to _`∘_)

    open import Solver.Linear

    module LinSolver = Syntaxᶠ linRewiring

    --iter : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ `Vec B n

    iter : ∀ {n A B C D} → (D `× A `× B `→ D `× C) → D `× `Vec A n `× `Vec B n `→ `Vec C n
    iter {zero}  F = <[]>
    iter {suc n} F = < id × < uncons × uncons > >
                  ⁏ (helper ⁏ < F ⁏ swap × id > ⁏ assoc ⁏ < id × iter F >)
                  ⁏ <∷>

      where
        open LinSolver
        helper = λ {A} {B} {D} {VA} {VB} →
          rewireᶠ (A ∷ B ∷ D ∷ VA ∷ VB ∷ [])
                  (λ a b d va vb → (d , (a , va) , (b , vb)) ↦ (d , a , b) , (va , vb))

    -- TODO reverses all over the places... switch to lsb first?

    adder : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
    adder = <tt⁏ <0b> , < reverse × reverse > > ⁏ iter full-adder ⁏ reverse

    open import Data.Digit

    bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    bits ℓ n₀ = constBits (V.reverse (L▹V (L.map F▹𝟚 (proj₁ (toDigits 2 n₀)))))
      where open import Data.List as L
            open import Data.Product
            open import Data.Two
            L▹V : ∀ {n} → List 𝟚 → Vec 𝟚 n
            L▹V {zero} xs = []
            L▹V {suc n} [] = V.replicate 0'
            L▹V {suc n} (x ∷ xs) = x ∷ L▹V xs
            F▹𝟚 : Fin 2 → 𝟚
            F▹𝟚 zero    = 0'
            F▹𝟚 (suc _) = 1'

open import IO
import IO.Primitive
open import Data.One
open import Data.Two
open import Data.Product
open import Coinduction
open import FunUniverse.Agda
open FunAdder agdaFunOps
open FunOps agdaFunOps
putBit : 𝟚 → IO 𝟙
putBit 1' = putStr "1"
putBit 0' = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
arg1   = bits 8 0x0b _
arg2   = bits 8 0x1f _
result = adder (arg1 , arg2)
mainIO : IO 𝟙
mainIO = ♯ putBits arg1 >>
      ♯ (♯ putStr " + " >>
      ♯ (♯ putBits arg2 >>
      ♯ (♯ putStr " = " >>
         ♯ putBits result)))
main : IO.Primitive.IO 𝟙
main = IO.run mainIO

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


Added test on polymorphic lists.

Added test on polymorphic lists.

------------------------------------------------------------------------------
-- Testing polymorphic lists
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --universal-quantified-propositional-functions #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Polymorphism.List where

open import FOTC.Base
open import FOTC.Base.List

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

-- NB. The data type list is in *Set₁*.
data List (A : D → Set) : D → Set₁ where
  lnil  :                              List A []
  lcons : ∀ {x xs} → A x → List A xs → List A (x ∷ xs)
{-# ATP axiom lnil lcons #-}

postulate foo : ∀ x → x ≡ x
{-# ATP prove foo #-}

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


Equalizer unit, counit naturality

Equalizer unit, counit naturality

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/zeitraffer/agda-cats.git/'