------------------------------------------------------------------------
-- Code related to the paper "Higher Lenses"
--
-- Nils Anders Danielsson
--
-- The paper is coauthored with Paolo Capriotti and Andrea Vezzosi.
------------------------------------------------------------------------

-- Most of the code referenced below can be found in modules that are
-- parametrised by a notion of equality. One can use them both with
-- Cubical Agda paths and with the Cubical Agda identity type family.

-- Note that the code does not follow the paper exactly. For instance,
-- some definitions use bijections (functions with quasi-inverses)
-- instead of equivalences.

-- An attempt has also been made to track uses of univalence by
-- passing around explicit proofs of the univalence axiom (except in
-- certain README modules). However, univalence is provable in Cubical
-- Agda, and some library code that is used does not adhere to this
-- convention, so perhaps some use of univalence is not tracked in
-- this way. On the other hand some library code that is not defined
-- in Cubical Agda passes around explicit proofs of function
-- extensionality.

-- Some other differences are mentioned below.

-- Note that there is a known problem with guarded corecursion in
-- Agda. Due to "quantifier inversion" (see "Termination Checking in
-- the Presence of Nested Inductive and Coinductive Types" by Thorsten
-- Altenkirch and myself) certain types may not have the expected
-- semantics when the option --guardedness is used. I expect that the
-- results would still hold if this bug were fixed, but because I do
-- not know what the rules of a fixed version of Agda would be I do
-- not know if any changes to the code would be required.

{-# OPTIONS --cubical --guardedness #-}

module README.Higher-Lenses where

import Circle
import Coherently-constant
import Equality
import Equality.Decidable-UIP
import Equivalence
import Equivalence.Half-adjoint
import Function-universe
import H-level
import H-level.Truncation.Propositional
import H-level.Truncation.Propositional.Non-recursive
import H-level.Truncation.Propositional.One-step
import Preimage
import Surjection

import Lens.Non-dependent.Bijection as B
import Lens.Non-dependent.Equivalent-preimages as EP
import Lens.Non-dependent.Higher as E
import Lens.Non-dependent.Higher.Capriotti as F
import Lens.Non-dependent.Higher.Coinductive as C
import Lens.Non-dependent.Higher.Coherently.Coinductive as Coh
import Lens.Non-dependent.Higher.Coherently.Not-coinductive as NC
import Lens.Non-dependent.Higher.Coinductive.Small as S
import Lens.Non-dependent.Higher.Combinators as EC
import Lens.Non-dependent.Traditional as T
import Lens.Non-dependent.Traditional.Combinators as TC

import README.Not-a-set

------------------------------------------------------------------------
-- I: Introduction

-- Traditional lenses.

Lensᵀ = T.Lens

-- The function modify.

modify = T.Lens.modify

-- The two variants of Tm, and proofs showing that Tm A is not a set
-- if A is inhabited.

Tm₁       = README.Not-a-set.Tm
¬-Tm₁-set = README.Not-a-set.¬-Tm-set
Tm₂       = README.Not-a-set.Tmˢ
¬-Tm₂-set = README.Not-a-set.¬-Tmˢ-set

------------------------------------------------------------------------
-- II: Homotopy type theory

-- The cong function.
--
-- The axiomatisation of equality that is used makes it possible to
-- choose the implementation of cong. However, the implementation is
-- required to satisfy a property which implies that the definition is
-- unique.

cong        = Equality.Equality-with-J.cong
cong-refl   = Equality.Equality-with-J.cong-refl
cong-unique =
  Equality.Derived-definitions-and-properties.monomorphic-cong-canonical

-- Is-equivalence and _≃_.
--
-- Note that the syntax used for Σ-types in the paper is not valid
-- Agda syntax. Furthermore the code defines _≃_ as a record type
-- instead of using a Σ-type.

Is-equivalence = Equivalence.Half-adjoint.Is-equivalence
_≃_            = Equivalence._≃_

-- Lemma 6.

lemma-6 = Equivalence._≃_.left-right-lemma

-- H-level, Contractible, Is-proposition and Is-set.
--
-- Some of the definitions are slightly different from the ones given
-- in the paper.

H-level        = H-level.H-level
Contractible   = Equality.Reflexive-relation′.Contractible
Is-proposition = Equality.Reflexive-relation′.Is-proposition
Is-set         = Equality.Reflexive-relation′.Is-set

-- The circle.

𝕊¹ = Circle.𝕊¹

-- A function that is distinct from refl.

not-refl      = Circle.not-refl
not-refl≢refl = Circle.not-refl≢refl

-- The type base ≡ base is equivalent to ℤ.

base≡base≃ℤ = Circle.base≡base≃ℤ

-- The circle is not a set.

circle-not-set = Circle.¬-𝕊¹-set

-- The propositional truncation operator.

∥_∥ = H-level.Truncation.Propositional.∥_∥

------------------------------------------------------------------------
-- III: Traditional lenses

-- Lenses with equal setters have equal getters.

getters-equal-if-setters-equal = T.getters-equal-if-setters-equal

-- The identity lens.

id-traditional = TC.id

-- The lens used for the counterexamples.
--
-- This lens is a little different from the one in the text: the
-- source and view types are liftings of the circle instead of the
-- circle. This change also affects the proof of Lemma 12.

l = T.bad

-- Lemmas 12 and 13.

lemmas-12-and-13 = T.getter-equivalence-but-not-coherent

-- There are lenses with equal setters that are not equal.

equal-setters-but-not-equal =
  TC.equal-setters-and-equivalences-as-getters-but-not-equal

-- Lemma 14.

lemma-14 = T.lens-to-proposition↔

-- Lensᵀ A ⊤ is not necessarily a proposition (and thus not
-- necessarily equivalent to the unit type).

Traditional-lens-𝕊¹-⊤-not-propositional = T.¬-lens-to-⊤-propositional

-- Fibres.

_⁻¹_ = Preimage._⁻¹_

-- Lemmas 16 and 17, and a variant of Lemma 16 for lenses which
-- satisfy certain coherence laws.

lemma-16          = T.≃get⁻¹×
lemma-16-coherent = T.≃get⁻¹×-coherent
lemma-17          = T.≃Σ∥set⁻¹∥×

-- A variant of Lemma 17 without the requirement that the source type
-- is a set does not hold in general.

not-lemma-17-without-Is-set = TC.≄Σ∥set⁻¹∥×

------------------------------------------------------------------------
-- IV: Lenses based on bijections

-- Lenses based on bijections.

Lensᴮ = B.Lens

-- Lensᴮ ⊥ ⊥ is equivalent to Type.
--
-- Note that the definition of ⊥ that is used in the code can target
-- different universes, not just Type.

Lensᴮ-⊥-⊥≃Type = B.Lens-⊥-⊥≃Type

-- Lensᵀ ⊥ ⊥ is equivalent to ⊤.

Lensᵀ-⊥-⊥≃Type = T.lens-from-⊥≃⊤

------------------------------------------------------------------------
-- V: Higher lenses

-- Lensᴱ.
--
-- For performance reasons η-equality has been turned off for this
-- definition.

Lensᴱ = E.Lens

-- Lemma 20.

lemma-20 = E.isomorphism-to-lens

-- The functions get, remainder and set.

get       = E.Lens.get
remainder = E.Lens.remainder
set       = E.Lens.set

-- The inhabited field is equivalent to stating that the remainder
-- function is surjective.

inhabited≃remainder-surjective = E.inhabited≃remainder-surjective

-- Lemmas 24-27.

lemma-24 = E.Lens.get-set
lemma-25 = E.Lens.remainder-set
lemma-26 = E.Lens.set-get
lemma-27 = E.Lens.set-set

-- Traditional lenses that have stable view types and that satisfy two
-- coherence laws can be translated to higher lenses with the same
-- getters and setters.

coherent-to-higher                       = EP.coherent↠higher
coherent-to-higher-preserves-get-and-set =
  EP.coherent↠higher-preserves-getters-and-setters

------------------------------------------------------------------------
-- VI: Coherence laws

-- Lemmas 28-29.

lemma-28 = E.Lens.get-set-get
lemma-29 = E.Lens.get-set-set

------------------------------------------------------------------------
-- VII: Some equivalences

-- Lemmas 30-37.
--
-- Lemmas 31 and 33 are formulated slightly differently.

lemma-30 = E.lens-to-proposition↔get
lemma-31 = E.lens-to-contractible↔⊤
lemma-32 = E.lens-to-⊥↔¬
lemma-33 = E.lens-from-contractible↔codomain-contractible
lemma-34 = E.lens-from-⊥↔⊤
lemma-35 = E.get-equivalence≃inhabited-equivalence
lemma-36 = E.≃-≃-Σ-Lens-Is-equivalence-get
lemma-37 = E.remainder≃get⁻¹

-- Lemmas 32-34 hold for traditional lenses.

lemma-32-for-traditional = T.lens-to-⊥↔
lemma-33-for-traditional = T.lens-from-⊤≃codomain-contractible
lemma-34-for-traditional = T.lens-from-⊥≃⊤

-- The right-to-left direction of Lemma 36 returns the lens's getter
-- (and some proof).

lemma-36-right-to-left = E.to-from-≃-≃-Σ-Lens-Is-equivalence-get≡get

-- Lemma 36 does not in general hold for traditional lenses.

¬-lemma-36-traditional = TC.¬Π≃-≃-Σ-Lens-Is-equivalence-get

------------------------------------------------------------------------
-- VIII: Equality of lenses with equal setters

-- Lemmas 38-44.

lemma-38 = E.equality-characterisation₁
lemma-39 = E.equality-characterisation₄
lemma-40 = E.lenses-with-inhabited-codomains-equal-if-setters-equal
lemma-41 = E.lenses-equal-if-setters-equal
lemma-42 = E.lenses-equal-if-setters-equal-and-remainder-set
lemma-43 = E.¬-lenses-equal-if-setters-equal
lemma-44 = E.lenses-equal-if-setters-equal→constant→coherently-constant

-- Constant and CC.

Constant = Equality.Decidable-UIP.Constant
CC       = Coherently-constant.Coherently-constant

-- Lemma 47.

lemma-47 = Coherently-constant.¬-Constant→Coherently-constant

------------------------------------------------------------------------
-- IX: Homotopy levels

-- Lemmas 48-54.

lemma-48 = E.h-level-respects-lens-from-inhabited
lemma-49 = E.contractible-to-contractible
lemma-50 = E.no-first-projection-lens
lemma-51 = E.remainder-has-same-h-level-as-domain
lemma-52 = E.get-equivalence→remainder-propositional
lemma-53 = E.Contractible-closed-codomain
lemma-54 = E.Is-proposition-closed-codomain

-- Lemmas 48-50 for traditional lenses.

lemma-48-for-traditional = T.h-level-respects-lens-from-inhabited
lemma-49-for-traditional = T.contractible-to-contractible
lemma-50-for-traditional = T.no-first-projection-lens

------------------------------------------------------------------------
-- X: Higher and traditional lenses are equivalent for sets

-- Split surjections.

_↠_ = Surjection._↠_

-- Lemmas 55 and 56.
--
-- Lemma 55 takes an extra argument of type Unit, written as
-- Block "conversion". Some other definitions below also take such
-- arguments.

lemma-55 = E.¬Lens↠Traditional-lens
lemma-56 = E.Lens↔Traditional-lens

-- Lemma 56 preserves getters and setters in both directions.

lemma-56-preserves-get-and-set =
  E.Lens↔Traditional-lens-preserves-getters-and-setters

------------------------------------------------------------------------
-- XI: Identity and composition

-- The identity lens.

id = EC.id

-- Lemma 58.

lemma-58 = EC.id-unique

-- A composition operator for types in the same universe.

∘-same-universe = EC._∘_

-- A more general composition operator.

∘-more-general = EC.⟨_,_⟩_∘_

-- A lens from a type in a smaller universe to a type in a (possibly)
-- larger universe.

smaller-to-larger = E.↑-lens

-- Composition laws.

associativity  = EC.associativity
left-identity  = EC.left-identity
right-identity = EC.right-identity

-- Composition laws for traditional lenses.

associativity-traditional  = TC.associativity
left-identity-traditional  = TC.left-identity
right-identity-traditional = TC.right-identity

-- Lemma 60.
--
-- The lemma is formulated slightly differently.

lemma-60 = EC.∘-unique

-- The composition operator produces lenses for which the setter
-- satisfies certain equations.

setter-correct = EC.∘-set

-- Is-bi-invertible.

Is-bi-invertible = EC.Is-bi-invertible

-- Lemmas 62 and 63.

lemma-62 = EC.≃≃≊
lemma-63 = EC.Is-bi-invertible≃Is-equivalence-get

-- Lemma 62 maps bi-invertible lenses to their getter functions.

lemma-62-right-to-left = EC.to-from-≃≃≊≡get

-- Lemma 62 does not in general hold for traditional lenses.

not-lemma-62-for-traditional = TC.¬Π≃≃≊

-- A variant of Lemma 62 for traditional lenses (a split surjection in
-- the other direction).

lemma-62-for-traditional = TC.≊↠≃

-- Lemma 63 for traditional lenses.

lemma-63-for-traditional = TC.Is-bi-invertible≃Is-equivalence-get

-- A category of higher lenses between sets with the same universe
-- level.

category-higher = EC.category

-- A category of traditional lenses between sets with the same
-- universe level.

category-traditional = TC.category

-- The category of higher lenses is equal to the one for traditional
-- lenses (lifted, so that the two categories have the same type).

category≡category = EC.category≡category

-- Naive categories.

Naive-category = TC.Naive-category

-- A notion of univalence for naive categories.

Univalent = TC.Univalent

-- A naive category of higher lenses between types with the same
-- universe level.

naive-category-higher = EC.naive-category

-- This category is univalent.

naive-category-higher-univalent = EC.univalent

-- A naive category of traditional lenses between types with the same
-- universe level.

naive-category-traditional = TC.naive-category

-- This category is not univalent.

naive-category-traditional-not-univalent = TC.¬-univalent

------------------------------------------------------------------------
-- XII: Coherently constant families of fibres

-- Lens^F.

Lens^F = F.Lens

-- Lemma 65.

lemma-65 = F.Lens.get⁻¹-constant

-- A setter.

set^F = F.Lens.set

-- Lemma 67.
--
-- Unlike in the paper this lemma is defined in two steps, using a
-- minor variant of Lens^F "in the middle".

lemma-67 = F.Lens≃Higher-lens

-- Lemma 67 preserves getters and setters in both directions.

lemma-67-preserves-get-and-set =
  F.Lens≃Higher-lens-preserves-getters-and-setters

------------------------------------------------------------------------
-- XIII: Coinductive lenses

-- The one-step truncation operator, and its non-dependent eliminator.

∥_∥¹ = H-level.Truncation.Propositional.One-step.∥_∥¹
rec  = H-level.Truncation.Propositional.One-step.rec′

-- Lemma 70.

lemma-70 = H-level.Truncation.Propositional.Non-recursive.∥∥→≃

-- ∥_∥¹-out, ∥_∥¹-in and ∣_,_∣-in.

∥_∥¹-out = H-level.Truncation.Propositional.One-step.∥_∥¹-out-^
∥_∥¹-in  = H-level.Truncation.Propositional.One-step.∥_∥¹-in-^
∣_,_∣-in = H-level.Truncation.Propositional.One-step.∣_,_∣-in-^

-- Lemmas 74 and 75.

lemma-74 = H-level.Truncation.Propositional.One-step.∥∥¹-out-^≃∥∥¹-in-^
lemma-75 = H-level.Truncation.Propositional.One-step.∣∣≡∣,∣-in-^

-- Coherently and CC^C.

Coherently = Coh.Coherently
CC^C       = C.Coherently-constant

-- Coherently can be defined without using coinduction.

Coherently-without-coinduction            = NC.Coherently
Coherently≃Coherently-without-coinduction =
 Coh.Coherently≃Not-coinductive-coherently

-- But then Lens^C would not be small (at least with the definition we
-- came up with).

Lens^C-without-coinduction        = S.Not-coinductive-lens
Lens^C-without-coinduction≃Lens^C = S.Not-coinductive-lens≃Lens

-- Constant¹ and CC^C1.

Constant¹ = C.Constant′
CC^C1     = C.Coherently-constant′

-- Lemmas 80-86.
--
-- Lemma 84 is more general than in the paper.

lemma-80 = C.Constant≃Constant′
lemma-81 = C.Coherently-constant≃Coherently-constant′
lemma-82 = C.∥∥→≃
lemma-83 = Equivalence.Σ-preserves
lemma-84 = Function-universe.Π-cong-contra
lemma-85 = C.Coherently-constant′≃
lemma-86 = C.Coherently-constant≃Coherently-constant

-- Constant^S and CC^S.

Constant^S = S.Constant-≃
CC^S       = S.Coherently-constant

-- Lemma 89.

lemma-89 = S.Coinductive-coherently-constant≃Coherently-constant

-- Lens^C.

Lens^C = S.Lens

-- Lemmas 91-92.

lemma-91 = S.Higher-lens≃Lens
lemma-92 = S.Lens.get⁻¹-constant

-- Lemma 91 preserves getters and setters.

lemma-91-preserves-get-and-set =
  S.Higher-lens≃Lens-preserves-getters-and-setters

------------------------------------------------------------------------
-- XIV: Unrestricted composition

-- Lemmas 93 and 94.

lemma-93 = S.Coherently-constant-map
lemma-94 = S.Coherently-constant-Σ

-- Composition.

∘-most-general = S.⟨_,_⟩_∘_

-- Lemma 96.

lemma-96 = S.set-∘

-- Composition laws.

associativity-stable  = S.associativity
left-identity-stable  = S.left-identity
right-identity-stable = S.right-identity

-- An unrestricted composition operator for Lensᴱ.

∘-most-general′ = S.⟨_,_,_,_,_,_,_,_⟩_⊚_

-- This operator matches "∘-more-general" when all types have the same
-- universe level and the view type of the resulting lens is stable.

∘-more-general-matches-∘-most-general′ = S.⊚≡∘

------------------------------------------------------------------------
-- XV: Homotopy levels, continued

-- Coherently′.

Coherently′ = Coh.Coherently-with-restriction

-- Lemma 98.

lemma-98 = Coh.Coherently≃Coherently-with-restriction

-- Coherently′ can be expressed as an indexed M-type for a certain
-- indexed container.

Coherently′-as-M-type =
  Coh.Coherently-with-restriction≃Coherently-with-restriction′

-- Lemmas 99-103.

lemma-99  = Coh.H-level-Coherently-with-restriction
lemma-100 = Coh.H-level-Coherently-→Type
lemma-101 = S.H-level-Coherently-constant
lemma-102 = S.lens-preserves-h-level
lemma-103 = S.h-level-respects-lens-from-inhabited

-- Lemma 103 and a variant of Lemma 102 hold for traditional lenses.

lemma-102-for-traditional = T.lens-preserves-h-level
lemma-103-for-traditional = T.lens-from-⊤≃codomain-contractible

------------------------------------------------------------------------
-- XVI: Related work

-- Lemmas 104-106.

lemma-104 = E.grenrus-example
lemma-105 = E.grenrus-example₁-true
lemma-106 = E.grenrus-example₂-false

-- The lenses used in Lemmas 105 and 106 are equal.

lenses-equal = E.grenrus-example₁≡grenrus-example₂


module ModuleArgs where

open import Common.Nat
open import Common.IO
open import Common.Unit

module X (y : Nat) where
  addTo : Nat -> Nat
  addTo x = y + x

open X 23

-- should return 35
main : IO Unit
main = printNat (addTo 12)


------------------------------------------------------------------------
-- Rice's theorem
------------------------------------------------------------------------

open import Equality.Propositional
open import Prelude hiding (const; Decidable)

-- To simplify the development, let's work with actual natural numbers
-- as variables and constants (see
-- Atom.one-can-restrict-attention-to-χ-ℕ-atoms).

open import Atom

open import Chi            χ-ℕ-atoms
open import Coding         χ-ℕ-atoms
open import Free-variables χ-ℕ-atoms

import Coding.Instances.Nat

-- The theorem is stated and proved under the assumption that a
-- correct self-interpreter can be implemented.

module Rices-theorem
  (eval : Exp)
  (cl-eval : Closed eval)
  (eval₁ : ∀ p v → Closed p → p ⇓ v → apply eval ⌜ p ⌝ ⇓ ⌜ v ⌝)
  (eval₂ : ∀ p v → Closed p → apply eval ⌜ p ⌝ ⇓ v →
           ∃ λ v′ → p ⇓ v′ × v ≡ ⌜ v′ ⌝)
  where

open import H-level.Truncation.Propositional as Trunc hiding (rec)
open import Logical-equivalence using (_⇔_)
open import Tactic.By.Propositional

open import Double-negation equality-with-J
open import Equality.Decision-procedures equality-with-J
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import Monad equality-with-J

open import Cancellation  χ-ℕ-atoms
open import Compatibility χ-ℕ-atoms
open import Computability χ-ℕ-atoms hiding (_∘_)
open import Constants     χ-ℕ-atoms
open import Deterministic χ-ℕ-atoms
open import Propositional χ-ℕ-atoms
open import Reasoning     χ-ℕ-atoms
open import Termination   χ-ℕ-atoms
open import Values        χ-ℕ-atoms

open χ-atoms χ-ℕ-atoms

open import Combinators as χ hiding (id; if_then_else_)
open import Halting-problem
open import Internal-coding

------------------------------------------------------------------------
-- The theorem

-- Definition of "pointwise semantically equivalent".

Pointwise-semantically-equivalent : Closed-exp → Closed-exp → Type
Pointwise-semantically-equivalent e₁ e₂ =
  ∀ e v → semantics [ apply-cl e₁ e ]= v ⇔
          semantics [ apply-cl e₂ e ]= v

-- This relation is symmetric.

symmetric :
  ∀ e₁ e₂ →
  Pointwise-semantically-equivalent e₁ e₂ →
  Pointwise-semantically-equivalent e₂ e₁
symmetric _ _ eq = λ e v → inverse (eq e v)

-- Rice's theorem.

module _
  (P : Closed-exp →Bool)
  (let P′ = proj₁ P)
  (e∈ : Closed-exp)
  (Pe∈ : P′ [ e∈ ]= true)
  (e∉ : Closed-exp)
  (¬Pe∉ : P′ [ e∉ ]= false)
  (resp : ∀ e₁ e₂ {b} →
          Pointwise-semantically-equivalent e₁ e₂ →
          P′ [ e₁ ]= b → P′ [ e₂ ]= b)
  where

  private

    module Helper
      (p : Exp) (cl-p : Closed p)
      (hyp : ∀ e b → P′ [ e ]= b → apply p ⌜ e ⌝ ⇓ ⌜ b ⌝)
      where

      arg : Closed-exp → Closed-exp → Closed-exp
      arg e p =
          lambda v-x
            (apply (lambda v-underscore (apply (proj₁ e) (var v-x)))
                   (apply eval (proj₁ p)))
        , (Closed′-closed-under-lambda $
           Closed′-closed-under-apply
             (Closed′-closed-under-lambda $
              Closed′-closed-under-apply
                (Closed→Closed′ $ proj₂ e)
                (Closed′-closed-under-var (inj₂ (inj₁ refl))))
             (Closed′-closed-under-apply
                (Closed→Closed′ cl-eval)
                (Closed→Closed′ (proj₂ p))))

      coded-arg : Closed-exp → Exp
      coded-arg e =
        const c-lambda (⌜ v-x ⌝ ∷
          const c-apply (
            ⌜ Exp.lambda v-underscore (apply (proj₁ e) (var v-x)) ⌝ ∷
            const c-apply (
              ⌜ eval ⌝ ∷
              apply internal-code (var v-p) ∷
              []) ∷ []) ∷ [])

      branches : List Br
      branches =
        branch c-false [] (apply p (coded-arg e∈)) ∷
        branch c-true  [] (χ.not (apply p (coded-arg e∉))) ∷
        []

      const-loop : Closed-exp
      const-loop =
          lambda v-underscore loop
        , (Closed′-closed-under-lambda $
           Closed→Closed′ loop-closed)

      ⌜const-loop⌝ : Closed-exp
      ⌜const-loop⌝ = ⌜ proj₁ const-loop ⌝

      halts : Exp
      halts =
        lambda v-p (case (apply p (proj₁ ⌜const-loop⌝)) branches)

      cl-coded-arg : ∀ e → Closed′ (v-p ∷ []) (coded-arg e)
      cl-coded-arg e =
        Closed′-closed-under-const λ where
          _ (inj₂ (inj₂ ()))
          _ (inj₁ refl) →
            Closed→Closed′ (rep-closed v-x)
          _ (inj₂ (inj₁ refl)) →
            Closed′-closed-under-const λ where
              _ (inj₂ (inj₂ ()))
              _ (inj₁ refl) →
                Closed→Closed′ $
                rep-closed (Exp.lambda v-underscore (apply (proj₁ e) (var v-x)))
              _ (inj₂ (inj₁ refl)) →
                Closed′-closed-under-const λ where
                  _ (inj₂ (inj₂ ()))
                  _ (inj₁ refl) →
                    Closed→Closed′ $
                    rep-closed eval
                  _ (inj₂ (inj₁ refl)) →
                    Closed′-closed-under-apply
                      (Closed→Closed′ internal-code-closed)
                      (Closed′-closed-under-var (inj₁ refl))

      cl-halts : Closed halts
      cl-halts =
        Closed′-closed-under-lambda $
        Closed′-closed-under-case
          (Closed′-closed-under-apply
             (Closed→Closed′ cl-p)
             (Closed→Closed′ $ proj₂ ⌜const-loop⌝))
          (λ where
             (inj₁ refl)        →
               Closed′-closed-under-apply
                 (Closed→Closed′ cl-p)
                 (cl-coded-arg e∈)
             (inj₂ (inj₁ refl)) →
               not-closed $
               Closed′-closed-under-apply
                 (Closed→Closed′ cl-p)
                 (cl-coded-arg e∉)
             (inj₂ (inj₂ ())))

      coded-arg⇓⌜arg⌝ :
        (e p : Closed-exp) →
        coded-arg e [ v-p ← ⌜ p ⌝ ] ⇓ ⌜ arg e ⌜ p ⌝ ⌝
      coded-arg⇓⌜arg⌝ e p =
        coded-arg e [ v-p ← ⌜ p ⌝ ]                                    ⟶⟨⟩

        const c-lambda (⌜ v-x ⌝ ∷
          const c-apply (
            ⌜ Exp.lambda v-underscore (apply (proj₁ e) (var v-x)) ⌝
              [ v-p ← ⌜ p ⌝ ] ∷
            const c-apply (
              ⌜ eval ⌝ [ v-p ← ⌜ p ⌝ ] ∷
              apply (internal-code [ v-p ← ⌜ p ⌝ ]) ⌜ p ⌝ ∷
                []) ∷ []) ∷ [])                                        ≡⟨ cong (λ e → const _ (_ ∷ const _ (const _ (_ ∷
                                                                                const _ (e ∷ _) ∷ _) ∷ _) ∷ _))
                                                                               (subst-rep (proj₁ e)) ⟩⟶
        const c-lambda (⌜ v-x ⌝ ∷
          const c-apply (
            ⌜ Exp.lambda v-underscore (apply (proj₁ e) (var v-x)) ⌝ ∷
            const c-apply (
              ⟨ ⌜ eval ⌝ [ v-p ← ⌜ p ⌝ ] ⟩ ∷
              apply (internal-code [ v-p ← ⌜ p ⌝ ]) ⌜ p ⌝ ∷
                []) ∷ []) ∷ [])                                        ≡⟨ ⟨by⟩ (subst-rep eval) ⟩⟶

        const c-lambda (⌜ v-x ⌝ ∷
          const c-apply (
            ⌜ Exp.lambda v-underscore (apply (proj₁ e) (var v-x)) ⌝ ∷
            const c-apply (
              ⌜ eval ⌝ ∷
              apply ⟨ internal-code [ v-p ← ⌜ p ⌝ ] ⟩ ⌜ p ⌝ ∷
                []) ∷ []) ∷ [])                                        ≡⟨ ⟨by⟩ (subst-closed _ _ internal-code-closed) ⟩⟶

        const c-lambda (⌜ v-x ⌝ ∷
          const c-apply (
            ⌜ Exp.lambda v-underscore (apply (proj₁ e) (var v-x)) ⌝ ∷
            const c-apply (
              ⌜ eval ⌝ ∷
              apply internal-code ⌜ p ⌝ ∷
                []) ∷ []) ∷ [])                                        ⟶⟨ []⇓ (const (there (here (const (there (here
                                                                                (const (there (here ∙)))))))))
                                                                              (internal-code-correct (proj₁ p)) ⟩
        const c-lambda (⌜ v-x ⌝ ∷
          const c-apply (
            ⌜ Exp.lambda v-underscore (apply (proj₁ e) (var v-x)) ⌝ ∷
            const c-apply (
              ⌜ eval ⌝ ∷
              ⌜ ⌜ p ⌝ ⦂ Exp ⌝ ∷
                []) ∷ []) ∷ [])                                        ⟶⟨⟩

        ⌜ arg e ⌜ p ⌝ ⌝                                                ■⟨ rep-value (arg e ⌜ p ⌝) ⟩

      arg-lemma-⇓ :
        (e p : Closed-exp) →
        Terminates (proj₁ p) →
        Pointwise-semantically-equivalent (arg e ⌜ p ⌝) e
      arg-lemma-⇓ (e , cl-e) (p , cl-p) (vp , p⇓vp)
                  (e′ , cl-e′) (v , _) = record
        { to = λ where
            (apply {v₂ = ve′} lambda q₁
               (apply {v₂ = vp} lambda _
                  (apply {x = x} {e = e-body} {v₂ = ve″} q₂ q₃ q₄))) →

              apply ⟨ e ⟩ e′                                    ≡⟨ ⟨by⟩ (substs-closed e cl-e ((v-underscore , vp) ∷ (v-x , ve′) ∷ [])) ⟩⟶

              apply (e [ v-x ← ve′ ] [ v-underscore ← vp ]) e′  ⟶⟨ apply q₂ q₁ ⟩

              e-body [ x ← ⟨ ve′ ⟩ ]                            ≡⟨ ⟨by⟩ (values-only-compute-to-themselves (⇓-Value q₁) (

                  ve′                                                    ≡⟨ sym $ subst-closed _ _ (closed⇓closed q₁ cl-e′) ⟩⟶
                  ve′ [ v-underscore ← vp ]                              ⇓⟨ q₃ ⟩■
                  ve″                                                    )) ⟩⟶

              e-body [ x ← ve″ ]                                ⇓⟨ q₄ ⟩■

              v
        ; from = λ where
            (apply {v₂ = ve′} q₁ q₂ q₃) →

              proj₁ (apply-cl (arg (e , cl-e) ⌜ p ⌝) (e′ , cl-e′))       ⟶⟨ apply lambda q₂ ⟩

              apply (lambda v-underscore (apply ⟨ e [ v-x ← ve′ ] ⟩ ve′))
                    (apply eval ⌜ p ⌝ [ v-x ← ve′ ])                     ≡⟨ ⟨by⟩ (subst-closed _ _ cl-e) ⟩⟶

              apply (lambda v-underscore (apply e ve′))
                    ⟨ apply eval ⌜ p ⌝ [ v-x ← ve′ ] ⟩                   ≡⟨ ⟨by⟩ (subst-closed _ _ $
                                                                                Closed′-closed-under-apply cl-eval (rep-closed p)) ⟩⟶
              apply (lambda v-underscore (apply e ve′))
                    (apply eval ⌜ p ⌝)                                   ⟶⟨ apply lambda (eval₁ p _ cl-p p⇓vp) ⟩

              apply e ve′ [ v-underscore ← ⌜ vp ⌝ ]                      ≡⟨ subst-closed _ _ $
                                                                              Closed′-closed-under-apply cl-e (closed⇓closed q₂ cl-e′) ⟩⟶

              apply e ve′                                                ⇓⟨ apply q₁ (values-compute-to-themselves (⇓-Value q₂)) q₃ ⟩■

              v
        }

      arg-lemma-⇓-true :
        (e : Closed-exp) →
        Terminates (proj₁ e) →
        P′ [ arg e∈ ⌜ e ⌝ ]= true
      arg-lemma-⇓-true e e⇓ =      $⟨ Pe∈ ⟩
        P′ [ e∈ ]= true            ↝⟨ resp _ _ (symmetric (arg e∈ ⌜ e ⌝) e∈ (arg-lemma-⇓ e∈ e e⇓)) ⟩□
        P′ [ arg e∈ ⌜ e ⌝ ]= true  □

      arg-lemma-⇓-false :
        (e : Closed-exp) →
        Terminates (proj₁ e) →
        P′ [ arg e∉ ⌜ e ⌝ ]= false
      arg-lemma-⇓-false e e⇓ =      $⟨ ¬Pe∉ ⟩
        P′ [ e∉ ]= false            ↝⟨ resp _ _ (symmetric (arg e∉ ⌜ e ⌝) e∉ (arg-lemma-⇓ e∉ e e⇓)) ⟩□
        P′ [ arg e∉ ⌜ e ⌝ ]= false  □

      arg-lemma-¬⇓′ :
        (e p : Closed-exp) →
        ¬ Terminates (proj₁ p) →
        Pointwise-semantically-equivalent (arg e ⌜ p ⌝) const-loop
      arg-lemma-¬⇓′ (e , cl-e) (p , cl-p) ¬p⇓
                    (e′ , cl-e′) (v , _) = record
        { to = λ where
            (apply {v₂ = ve′} lambda _ (apply {v₂ = vp} _ q _)) →
              ⊥-elim $ ¬p⇓ $ Σ-map id proj₁ $
                eval₂ p vp cl-p (
                  apply eval ⌜ p ⌝                ≡⟨ sym $ subst-closed _ _ $ Closed′-closed-under-apply cl-eval (rep-closed p) ⟩⟶
                  apply eval ⌜ p ⌝ [ v-x ← ve′ ]  ⇓⟨ q ⟩■
                  vp)
        ; from = λ where
            (apply lambda _ loop⇓) → ⊥-elim $ ¬loop⇓ (_ , loop⇓)
        }

      arg-lemma-¬⇓ :
        ∀ {b} (e₀ e : Closed-exp) →
        ¬ Terminates (proj₁ e) →
        P′ [ const-loop ]= b →
        P′ [ arg e₀ ⌜ e ⌝ ]= b
      arg-lemma-¬⇓ {b} e₀ e ¬e⇓ =
        P′ [ const-loop ]= b    ↝⟨ resp _ _ (symmetric (arg e₀ ⌜ e ⌝) const-loop (arg-lemma-¬⇓′ e₀ e ¬e⇓)) ⟩□
        P′ [ arg e₀ ⌜ e ⌝ ]= b  □

      ∃Bool : Type
      ∃Bool = ∃ λ (b : Bool) →
                apply p (proj₁ ⌜const-loop⌝) ⇓ ⌜ b ⌝
                  ×
                P′ [ const-loop ]= b

      ¬¬∃ : ¬¬ ∃Bool
      ¬¬∃ =
        excluded-middle {A = P′ [ const-loop ]= true} >>= λ where
          (inj₁ P-const-loop) → return ( true
                                       , hyp const-loop true
                                           P-const-loop
                                       , P-const-loop
                                       )
          (inj₂ ¬P-const-loop) →
            proj₂ P const-loop >>= λ where
              (true  , P-const-loop)  → ⊥-elim (¬P-const-loop
                                                  P-const-loop)
              (false , ¬P-const-loop) →
                return ( false
                       , hyp const-loop false ¬P-const-loop
                       , ¬P-const-loop
                       )

      halts⇓-lemma :
        ∀ {v} →
        ∃Bool →
        (e : Closed-exp) →
        (P′ [ const-loop ]= false →
         apply p (⌜ arg e∈ ⌜ e ⌝ ⌝) ⇓ v) →
        (P′ [ const-loop ]= true →
         χ.not (apply p (⌜ arg e∉ ⌜ e ⌝ ⌝)) ⇓ v) →
        apply halts ⌜ e ⌝ ⇓ v
      halts⇓-lemma {v} ∃bool e e∈⇓v e∉⇓v =
        apply halts ⌜ e ⌝                                                 ⟶⟨ apply lambda (rep⇓rep e) ⟩

        case (apply ⟨ p [ v-p ← ⌜ e ⌝ ] ⟩ (proj₁ ⌜const-loop⌝))
          (branches [ v-p ← ⌜ e ⌝ ]B⋆)                                    ≡⟨ ⟨by⟩ (subst-closed _ _ cl-p) ⟩⟶

        case (apply p (proj₁ ⌜const-loop⌝)) (branches [ v-p ← ⌜ e ⌝ ]B⋆)  ⇓⟨ lemma ∃bool ⟩■

        v
        where
        lemma : ∃Bool → _
        lemma (true , p⌜const-loop⌝⇓true , P-const-loop) =
          case (apply p (proj₁ ⌜const-loop⌝)) (branches [ v-p ← ⌜ e ⌝ ]B⋆)    ⟶⟨ case p⌜const-loop⌝⇓true (there (λ ()) here) [] ⟩
          χ.not (apply ⟨ p [ v-p ← ⌜ e ⌝ ] ⟩ (coded-arg e∉ [ v-p ← ⌜ e ⌝ ]))  ≡⟨ ⟨by⟩ (subst-closed _ _ cl-p) ⟩⟶
          χ.not (apply p (coded-arg e∉ [ v-p ← ⌜ e ⌝ ]))                      ⟶⟨ []⇓ (case (apply→ ∙)) (coded-arg⇓⌜arg⌝ e∉ e) ⟩
          χ.not (apply p (⌜ arg e∉ ⌜ e ⌝ ⌝))                                  ⇓⟨ e∉⇓v P-const-loop ⟩■
          v

        lemma (false , p⌜const-loop⌝⇓false , ¬P-const-loop) =
          case (apply p (proj₁ ⌜const-loop⌝)) (branches [ v-p ← ⌜ e ⌝ ]B⋆)  ⟶⟨ case p⌜const-loop⌝⇓false here [] ⟩
          apply ⟨ p [ v-p ← ⌜ e ⌝ ] ⟩ (coded-arg e∈ [ v-p ← ⌜ e ⌝ ])        ≡⟨ ⟨by⟩ (subst-closed _ _ cl-p) ⟩⟶
          apply p (coded-arg e∈ [ v-p ← ⌜ e ⌝ ])                            ⟶⟨ []⇓ (apply→ ∙) (coded-arg⇓⌜arg⌝ e∈ e) ⟩
          apply p (⌜ arg e∈ ⌜ e ⌝ ⌝)                                        ⇓⟨ e∈⇓v ¬P-const-loop ⟩■
          v

      ⇓-lemma :
        ∃Bool →
        (e : Closed-exp) →
        Terminates (proj₁ e) →
        apply halts ⌜ e ⌝ ⇓ ⌜ true ⦂ Bool ⌝
      ⇓-lemma ∃bool e e⇓ = halts⇓-lemma ∃bool e

          (λ _ →
             apply p (⌜ arg e∈ ⌜ e ⌝ ⌝)  ⇓⟨ hyp (arg e∈ ⌜ e ⌝) true (arg-lemma-⇓-true e e⇓) ⟩■
             ⌜ true ⦂ Bool ⌝)

          (λ _ →
             χ.not (apply p (⌜ arg e∉ ⌜ e ⌝ ⌝))  ⟶⟨ []⇓ (case ∙) (hyp (arg e∉ ⌜ e ⌝) false (arg-lemma-⇓-false e e⇓)) ⟩
             χ.not ⌜ false ⦂ Bool ⌝              ⇓⟨ not-correct false (rep⇓rep (false ⦂ Bool)) ⟩■
             ⌜ true ⦂ Bool ⌝)

      ¬⇓-lemma :
        ∃Bool →
        (e : Closed-exp) →
        ¬ Terminates (proj₁ e) →
        apply halts ⌜ e ⌝ ⇓ ⌜ false ⦂ Bool ⌝
      ¬⇓-lemma ∃bool e ¬e⇓ = halts⇓-lemma ∃bool e

          (λ ¬P-const-loop →
             apply p (⌜ arg e∈ ⌜ e ⌝ ⌝)  ⇓⟨ hyp (arg e∈ ⌜ e ⌝) false (arg-lemma-¬⇓ e∈ e ¬e⇓ ¬P-const-loop) ⟩■
             ⌜ false ⦂ Bool ⌝)

          (λ P-const-loop →
             χ.not (apply p (⌜ arg e∉ ⌜ e ⌝ ⌝))  ⟶⟨ []⇓ (case ∙) (hyp (arg e∉ ⌜ e ⌝) true (arg-lemma-¬⇓ e∉ e ¬e⇓ P-const-loop)) ⟩
             χ.not ⌜ true ⦂ Bool ⌝               ⇓⟨ not-correct true (rep⇓rep (true ⦂ Bool)) ⟩■
             ⌜ false ⦂ Bool ⌝)

  rice's-theorem : ¬ Decidable P
  rice's-theorem (p , cl-p , hyp , _) = ¬¬¬⊥ $
    ¬¬∃ >>= λ ∃bool →
    return (intensional-halting-problem₀
              ( halts
              , cl-halts
              , λ e cl-e → ⇓-lemma  ∃bool (e , cl-e)
                         , ¬⇓-lemma ∃bool (e , cl-e)
              ))
    where
    open Helper p cl-p hyp

-- A variant of the theorem.

rice's-theorem′ :
  (P : Closed-exp → Type)
  (e∈ : Closed-exp) →
  P e∈ →
  (e∉ : Closed-exp) →
  ¬ P e∉ →
  (∀ e₁ e₂ →
   Pointwise-semantically-equivalent e₁ e₂ →
   P e₁ → P e₂) →
  ¬ Decidable (as-function-to-Bool₁ P)
rice's-theorem′ P e∈ Pe∈ e∉ ¬Pe∉ resp =
  rice's-theorem
    (as-function-to-Bool₁ P)
    e∈
    ((λ _ → refl) , ⊥-elim ∘ (_$ Pe∈))
    e∉
    (⊥-elim ∘ ¬Pe∉ , (λ _ → refl))
    (λ e₁ e₂ eq →
       Σ-map (_∘ resp e₂ e₁ (symmetric e₁ e₂ eq))
             (_∘ (_∘ resp e₁ e₂ eq)))

------------------------------------------------------------------------
-- Examples

-- The problem of deciding whether an expression implements the
-- successor function is undecidable.

Equal-to-suc : Closed-exp →Bool
Equal-to-suc =
  as-function-to-Bool₁ λ e →
    (n : ℕ) → apply (proj₁ e) ⌜ n ⌝ ⇓ ⌜ suc n ⌝

equal-to-suc-not-decidable : ¬ Decidable Equal-to-suc
equal-to-suc-not-decidable =
  rice's-theorem′
    _
    (s , from-⊎ (closed? s))
    (λ n → apply lambda (rep⇓rep n) (rep⇓rep (suc n)))
    (z , from-⊎ (closed? z))
    (λ z⌜n⌝⇓ → case z⌜n⌝⇓ 0 of λ { (apply () _ _) })
    (λ e₁ e₂ e₁∼e₂ Pe₁ n →
       apply (proj₁ e₂) ⌜ n ⌝  ⇓⟨ _⇔_.to (e₁∼e₂ ⌜ n ⌝ ⌜ suc n ⌝) (Pe₁ n) ⟩■
       ⌜ suc n ⌝)
  where
  z = const c-zero []
  s = lambda v-n (const c-suc (var v-n ∷ []))

-- The problem of deciding whether an expression always terminates
-- with the same value when applied to an arbitrary argument is
-- undecidable.

Is-constant : Closed-exp →Bool
Is-constant = as-function-to-Bool₁ λ e →
  ∃ λ v → (n : ℕ) → apply (proj₁ e) ⌜ n ⌝ ⇓ v

is-constant-not-decidable : ¬ Decidable Is-constant
is-constant-not-decidable =
  rice's-theorem′
    _
    (c , from-⊎ (closed? c))
    ((⌜ 0 ⌝ ⦂ Exp) , λ n →
       apply c ⌜ n ⌝  ⇓⟨ apply lambda (rep⇓rep n) (const []) ⟩■
       ⌜ 0 ⌝)
    (f , from-⊎ (closed? f))
    not-constant
    (λ e₁ e₂ e₁∼e₂ → Σ-map id λ {v} ⇓v n →
       let v-closed : Closed v
           v-closed = closed⇓closed (⇓v n) $
                        Closed′-closed-under-apply
                          (proj₂ e₁)
                          (rep-closed n)
       in
       apply (proj₁ e₂) ⌜ n ⌝  ⇓⟨ _⇔_.to (e₁∼e₂ ⌜ n ⌝ (v , v-closed)) (⇓v n) ⟩■
       v)
  where
  c = lambda v-underscore ⌜ 0 ⌝
  f = lambda v-n (var v-n)

  not-constant : ¬ ∃ λ v → (n : ℕ) → apply f ⌜ n ⌝ ⇓ v
  not-constant (v  , constant) = impossible
    where
    v≡0 : v ≡ ⌜ 0 ⌝
    v≡0 with constant 0
    ... | apply lambda (const []) (const []) = refl

    v≡1 : v ≡ ⌜ 1 ⌝
    v≡1 with constant 1
    ... | apply lambda (const (const [] ∷ [])) (const (const [] ∷ [])) =
      refl

    0≡1 =
      ⌜ 0 ⌝  ≡⟨ sym v≡0 ⟩
      v      ≡⟨ v≡1 ⟩∎
      ⌜ 1 ⌝  ∎

    impossible : ⊥
    impossible with 0≡1
    ... | ()


module cwf where

open import Nat
open import Base
open import univ
open import help

-- Category with Families

infix 40 _─→_
infixl 50 _,_ _,,_
infixl 70 _∘_ _∙_
infixl 60 _/_ _//_

Con : Set
Con = S

_─→_ : Con -> Con -> Set
Γ ─→ Δ = El (pi Γ (K Δ))

p─→ : {Γ Δ : Con}(σ : Γ ─→ Δ){x y : El Γ} -> x == y -> σ # x == σ # y
p─→ σ {x}{y} x=y =
  chain> σ # x
     === refS << σ # y by pFun σ x=y
     === σ # y         by ref<< (σ # y)
  where open module C13 = Chain _==_ (ref {_}) (trans {_})

id : {Γ : Con} -> Γ ─→ Γ
id = el < (\x -> x) , (\{x}{y} -> prf x y) >
  where
    prf : (x y : El _)(x=y : x == y) -> x == refS << y
    prf x y x=y =
      chain> x
         === refS << x by sym (ref<< x)
         === refS << y by p<< refS x=y
      where open module C0 = Chain _==_ (ref {_}) (trans {_})

_∘_ : {Γ Δ Θ : Con} -> (Δ ─→ Θ) -> (Γ ─→ Δ) -> Γ ─→ Θ
σ ∘ δ = el < (\x -> σ # (δ # x))
           , (\{x}{y} -> prf x y)
           >
  where
    prf : (x y : El _)(x=y : x == y) -> σ # (δ # x) == _ << σ # (δ # y)
    prf x y x=y =
      chain> σ # (δ # x)
         === σ # (δ # y)      by p─→ σ (p─→ δ x=y)
         === _ << σ # (δ # y) by sym (castref _ _)
      where open module C1 = Chain _==_ (ref {_}) (trans {_})

Type : Con -> Set
Type Γ = Fam Γ

data _=Ty_ {Γ : Con}(A B : Type Γ) : Set where
  eqTy : A =Fam B -> A =Ty B

symTy : {Γ : Con}{A B : Type Γ} -> A =Ty B -> B =Ty A
symTy {Γ}{A}{B} (eqTy A=B) = eqTy (symFam {Γ}{A}{B} A=B)

_/_ : {Γ Δ : Con} -> Type Γ -> (Δ ─→ Γ) -> Type Δ
_/_ {Γ}{Δ} A (el < σ , pσ >) = fam B pB
  where
    B : El Δ -> S
    B x = A ! σ x

    σ' : Δ ─→ Γ
    σ' = el < σ , (\{x}{y} -> pσ) >

    pB : Map _==_ _=S_ B
    pB {x}{y} x=y = pFam A (p─→ σ' x=y)

lem-/id : {Γ : Con}{A : Type Γ} -> A / id =Ty A
lem-/id {Γ}{A} = eqTy \x -> refS

data Elem (Γ : Con)(A : Type Γ) : Set where
  elem : El (pi Γ A) -> Elem Γ A

_=El'_ : {Γ : Con}{A : Type Γ} -> Elem Γ A -> Elem Γ A -> Set
elem u =El' elem v = u == v

data _=El_ {Γ : Con}{A : Type Γ}(u v : Elem Γ A) : Set where
  eqEl : u =El' v -> u =El v

castElem : {Γ : Con}{A B : Type Γ} -> B =Ty A -> Elem Γ A -> Elem Γ B
castElem {Γ}{A}{B} (eqTy B=A) (elem u) = elem (ΓB=ΓA << u)
  where
    ΓB=ΓA : pi Γ B =S pi Γ A
    ΓB=ΓA = eqS < refS , Bx=Acx >
      where
        Bx=Acx : (x : El Γ) -> B ! x =S A ! (refS << x)
        Bx=Acx x =
          chain> B ! x
             === A ! x            by B=A x
             === A ! (refS << x)  by pFam A (sym (ref<< x))
          where open module C2-5 = Chain _=S_ refS transS

_//_ : {Γ Δ : Con}{A : Type Γ} -> Elem Γ A -> (σ : Δ ─→ Γ) -> Elem Δ (A / σ)
_//_ {Γ}{Δ}{A} (elem t) (el < σ , pσ >) =
    elem (el < tσ , (\{x}{y} -> prf x y) >)
  where
    tσ : (x : El Δ) -> El (A ! σ x)
    tσ x = t # σ x

    σ' : Δ ─→ Γ
    σ' = el < σ , (\{x}{y} -> pσ) >

    prf : (x y : El Δ)(x=y : x == y) -> t # σ x == _ << t # σ y
    prf x y x=y =
      chain> t # σ x
         === _ << t # σ y by pFun t (p─→ σ' x=y)
         === _ << t # σ y by pfi _ _ _
      where open module C3 = Chain _==_ (ref {_}) (trans {_})

_,_ : (Γ : Con)(A : Type Γ) -> Con
Γ , A = sigma Γ A

wk : {Γ : Con}{A : Type Γ} -> Γ , A ─→ Γ
wk {Γ}{A} = el < f , (\{x}{y} -> pf x y) >
  where
    f : El (Γ , A) -> El Γ
    f (el < x , _ >) = x

    pf : (x y : El (Γ , A))(x=y : x == y) -> f x == _ << f y
    pf (el < x , _ >) (el < y , _ >) (eq < x=y , _ >) =
      chain> x
         === y      by x=y
         === _ << y by sym (castref _ _)
      where open module C4 = Chain _==_ (ref {_}) (trans {_})

vz : {Γ : Con}{A : Type Γ} -> Elem (Γ , A) (A / wk)
vz {Γ}{A} = elem (el < f , (\{x}{y} -> pf x y) >)
  where
    f : (x : El (Γ , A)) -> El ((A / wk) ! x)
    f (el < _ , z >) = z

    pf : (x y : El (Γ , A))(x=y : x == y) -> f x == _ << f y
    pf (el < _ , x >)(el < _ , y >)(eq < _ , x=y >) =
      chain> x
         === _ << y by x=y
         === _ << y by pfi _ _ _
      where open module C5 = Chain _==_ (ref {_}) (trans {_})

_,,_ : {Γ Δ : Con}{A : Type Γ}(σ : Δ ─→ Γ)(u : Elem Δ (A / σ)) -> Δ ─→ Γ , A
_,,_ {Γ}{Δ}{A} (el < σ , pσ >) (elem (el < u , pu >)) = build δ pδ
  where
    -- We need to generalise to be able to infer the proof of Γ, A =S Γ, A
    Ok : (f : El Δ -> El (Γ , A)) -> Set
    Ok f = (x y : El Δ)(p : Γ , A =S Γ , A)(x=y : x == y) -> f x == p << f y

    build : (f : El Δ -> El (Γ , A)) -> Ok f -> Δ ─→ Γ , A
    build f p = el < f , (\{x}{y} -> p x y _) >

    δ : El Δ -> El (Γ , A)
    δ x = el {Γ , A} < σ x , u x >

    pδ : Ok δ
    pδ x y (eqS < Γ=Γ , A=A >) x=y =
      eq < σx=cσy , ux=ccuy >
      where
        σx=cσy = trans (pσ x=y) (pfi _ _ _)
        ux=ccuy =
          chain> u x
             === _ << u y      by pu x=y
             === _ << _ << u y by sym (casttrans _ _ _ _)
          where open module C6 = Chain _==_ (ref {_}) (trans {_})

{- TODO: Prove

  wk ∘ (σ ,, u) = σ
  vz / (σ ,, u) = u

  (σ ,, u) ∘ δ  = (σ ∘ δ ,, u)
  wk ,, vz      = id

-}

[_] : {Γ : Con}{A : Type Γ} -> Elem Γ A -> Γ ─→ Γ , A
[_] {Γ}{A} u = id ,, castElem lem-/id u

Π : {Γ : Con}(A : Type Γ)(B : Type (Γ , A)) -> Type Γ
Π {Γ} A B = fam F pF
  where
    F : El Γ -> S
    F x = pi (A ! x) (curryFam B x)

    pF : Map _==_ _=S_ F
    pF {y}{z} y=z = eqS
        < pFam A (sym y=z)
        , (\x -> pFam B (eq < y=z
                            , trans (sym (castref _ _)) (trans<< _ _ _)
                            >
                        )
          )
        >

{- TODO: Prove

  (Π A B) / σ = Π (A / σ) (B / (σ / wk ,, vz))

-}

ƛ : {Γ : Con}{A : Type Γ}{B : Type (Γ , A)} -> Elem (Γ , A) B -> Elem Γ (Π A B)
ƛ {Γ}{A}{B} (elem u) = elem (mkFun f pf)
  where
    f : (x : El Γ) -> El (Π A B ! x)
    f x = el < g , (\{x}{y} -> pg) >
      where
        g : (y : El (A ! x)) -> El (B ! el < x , y >)
        g y = u # el < x , y >

        pg : {y z : El (A ! x)}(y=z : y == z) -> g y == _ << g z
        pg {y}{z} y=z =
          chain> u # el < x , y >
             === _ << u # el < x , z > by pFun u (eqSnd y=z)
             === _ << u # el < x , z > by pfi _ _ _
          where open module C7 = Chain _==_ (ref {_}) (trans {_})

    pf : IsFun {F = Π A B} f
    pf {y}{z} (eqS < Ay=Az , B'=B' >) y=z = eq prf
      where
        prf : (x : El (A ! y)) -> _ == _
        prf x =
          chain> u # el < y , x >
             === _ << u # el < z , _ << x >
              by pFun u (eq < y=z , sym (castref2 _ _ _) >)
             === _ << u # el < z , _ << x > by pfi _ _ _
          where open module C8 = Chain _==_ (ref {_}) (trans {_})

_∙_ : {Γ : Con}{A : Type Γ}{B : Type (Γ , A)}
      (w : Elem Γ (Π A B))(u : Elem Γ A) -> Elem Γ (B / [ u ])
_∙_ {Γ}{A}{B} (elem w) (elem u) = elem (el < f , (\{x}{y} -> pf) >)
  where
    f : (x : El Γ) -> El ((B / [ elem u ]) ! x)
    f x = p u << y
      where
        y : El (B ! el < x , u # x >)
        y = (w # x) # (u # x)

        p : (u : El (pi Γ A)) -> (B / [ elem u ]) ! x =S B ! el < x , u # x >
        p (el < u , pu >) = pFam B (
          chain> el < x , _ << u (refS << x) >
             === el < x , _ << _ << u x > by eqSnd (p<< _ (pu (ref<< _)))
             === el < x , u x >           by eqSnd (castref2 _ _ _)
          )
          where open module C9 = Chain _==_ (ref {_}) (trans {_})

    pf : {x y : El Γ}(x=y : x == y) -> f x == _ << f y
    pf {x}{y} x=y =
      chain> q1 << (w # x) # (u # x)
         === q1 << (q3 << w # y) ## (u # x)
          by p<< q1 (p# (pFun w x=y))
         === q1 << q4 << (w # y) # (q5 << u # x)
          by p<< q1 (distr<<# (w # y) q3)
         === q7 << (w # y) # (q5 << u # x)
          by sym (trans<< q1 q4 _)
         === q7 << q8 << (w # y) # (q5 << q9 << u # y)
          by p<< q7 (pFun (w # y) (p<< q5 (pFun u x=y)))
         === qA << (w # y) # (q5 << q9 << u # y)
          by sym (trans<< q7 q8 _)
         === qA << qB << (w # y) # (u # y)
          by p<< qA (pFun (w # y) (castref2 q5 q9 _))
         === q2 << q6 << (w # y) # (u # y)
          by pfi2 qA q2 qB q6 _
      where
        open module C10 = Chain _==_ (ref {_}) (trans {_})
        q1 = _
        q2 = _
        q3 = _
        q4 = _
        q5 = _
        q6 = _
        q7 = _
        q8 = _
        q9 = _
        qA = _
        qB = _
        infixl 150 _##_
        _##_ = _#_ {F = curryFam B x}

{- TODO: Prove

  (ƛ v) ∙ u = v // [ u ]    (β)
  w = ƛ ((w // wk) ∙ vz)    (η)

  ƛ v // σ = ƛ (v // (σ ∘ wk ,, vz))
  w ∙ u // σ = (w // σ) ∙ (u // σ)

-}


open import FRP.JS.Behaviour using ( Beh ; [_] ; hold )
open import FRP.JS.Event using ( tag )
open import FRP.JS.DOM using ( DOM ; text ; element ; listen ; click ; _++_ )
open import FRP.JS.RSet using ( ⟦_⟧ )

module FRP.JS.Demo.Button where

main : ∀ {w} → ⟦ Beh (DOM w) ⟧
main = text lab ++ but where
  but = element "button" (text ["OK"])
  lab = hold "Press me: " (tag "Pressed: " (listen click but))


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

module ConcretePermutation where

import Level using (zero)
open import Data.Nat using (ℕ; _+_; _*_)
open import Data.Fin using (Fin; zero; suc; inject+; raise)
open import Data.Sum
  using (_⊎_; inj₁; inj₂; [_,_]′)
  renaming (map to map⊎)
open import Data.Product using (_×_; proj₁; proj₂; _,′_)
open import Data.Vec
  using (Vec; _∷_; []; tabulate; _>>=_; allFin)
  renaming (_++_ to _++V_; map to mapV; concat to concatV)
open import Data.Vec.Properties
  using (lookup-allFin; tabulate∘lookup; lookup∘tabulate; lookup-++-inject+;
         tabulate-∘)
open import Function using (_∘_; id)
open import Algebra using (CommutativeSemiring)
open import Algebra.Structures using
  (IsSemigroup; IsCommutativeMonoid; IsCommutativeSemiring)
open import Relation.Binary using (IsEquivalence)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans;
         cong; cong₂; module ≡-Reasoning; proof-irrelevance)

open import Proofs using (
  -- FiniteFunctions
     finext;
  -- VectorLemmas
     lookup-++-raise; lookupassoc; tabulate-split; _!!_; unSplit;
     concat-map; map-map-map; lookup-map; map-∘;
     left!!; right!!
     )

open import FinVec -- using ()
open import FinVecProperties -- using ()

------------------------------------------------------------------------------
-- a concrete permutation has 4 components:
-- - the permutation
-- - its inverse
-- - and 2 proofs that it is indeed inverse

record CPerm (values : ℕ) (size : ℕ) : Set where
  constructor cp
  field
    π : FinVec values size
    πᵒ : FinVec size values
    αp : π ∘̂ πᵒ ≡ 1C
    βp : πᵒ ∘̂ π ≡ 1C

πᵒ≡ : ∀ {m n} → (π₁ π₂ : CPerm m n) → (CPerm.π π₁ ≡ CPerm.π π₂) →
  (CPerm.πᵒ π₁ ≡ CPerm.πᵒ π₂)
πᵒ≡ {n} (cp π πᵒ αp βp) (cp .π πᵒ₁ αp₁ βp₁) refl =
  begin (
    πᵒ                  ≡⟨ sym (∘̂-rid πᵒ) ⟩
    πᵒ ∘̂ 1C          ≡⟨  cong (_∘̂_ πᵒ) (sym αp₁)  ⟩
    πᵒ ∘̂ (π ∘̂ πᵒ₁)      ≡⟨ ∘̂-assoc πᵒ π πᵒ₁ ⟩
    (πᵒ ∘̂ π) ∘̂ πᵒ₁      ≡⟨ cong (λ x → x ∘̂ πᵒ₁) βp ⟩
    1C ∘̂ πᵒ₁            ≡⟨ ∘̂-lid πᵒ₁ ⟩
    πᵒ₁ ∎)
  where open ≡-Reasoning

p≡ : ∀ {m n} → {π₁ π₂ : CPerm m n} → (CPerm.π π₁ ≡ CPerm.π π₂) → π₁ ≡ π₂
p≡ {m} {n} {cp π πᵒ αp βp} {cp .π πᵒ₁ αp₁ βp₁} refl with
  πᵒ≡ (cp π πᵒ αp βp) (cp π πᵒ₁ αp₁ βp₁) refl
p≡ {m} {n} {cp π πᵒ αp βp} {cp .π .πᵒ αp₁ βp₁} refl | refl
  with proof-irrelevance αp αp₁ | proof-irrelevance βp βp₁
p≡ {m} {n} {cp π πᵒ αp βp} {cp .π .πᵒ .αp .βp} refl | refl | refl | refl = refl

idp : ∀ {n} → CPerm n n
idp {n} = cp 1C 1C (∘̂-rid _) (∘̂-lid _)

symp : ∀ {m n} → CPerm m n → CPerm n m
symp (cp p₁ p₂ α β) = cp p₂ p₁ β α

transp : ∀ {m₁ m₂ m₃} → CPerm m₂ m₁ → CPerm m₃ m₂ → CPerm m₃ m₁
transp {n} (cp π πᵒ αp βp) (cp π₁ πᵒ₁ αp₁ βp₁) = cp (π ∘̂ π₁) (πᵒ₁ ∘̂ πᵒ) pf₁ pf₂
  where
    open ≡-Reasoning
    pf₁ : (π ∘̂ π₁) ∘̂ (πᵒ₁ ∘̂ πᵒ) ≡ 1C
    pf₁ =
      begin (
        (π ∘̂ π₁) ∘̂ (πᵒ₁ ∘̂ πᵒ)      ≡⟨ ∘̂-assoc _ _ _ ⟩
        ((π ∘̂ π₁) ∘̂ πᵒ₁) ∘̂ πᵒ      ≡⟨ cong (λ x → x ∘̂ πᵒ) (sym (∘̂-assoc _ _ _)) ⟩
        (π ∘̂ (π₁ ∘̂ πᵒ₁)) ∘̂ πᵒ      ≡⟨ cong (λ x → (π ∘̂ x) ∘̂ πᵒ) (αp₁) ⟩
        (π ∘̂ 1C) ∘̂ πᵒ       ≡⟨ cong (λ x → x ∘̂ πᵒ) (∘̂-rid _) ⟩
        π ∘̂ πᵒ                     ≡⟨ αp ⟩
        1C ∎)
    pf₂ : (πᵒ₁ ∘̂ πᵒ) ∘̂ (π ∘̂ π₁) ≡ 1C
    pf₂ =
      begin (
        (πᵒ₁ ∘̂ πᵒ) ∘̂ (π ∘̂ π₁)     ≡⟨ ∘̂-assoc _ _ _ ⟩
        ((πᵒ₁ ∘̂ πᵒ) ∘̂ π) ∘̂ π₁     ≡⟨ cong (λ x → x ∘̂ π₁) (sym (∘̂-assoc _ _ _)) ⟩
        (πᵒ₁ ∘̂ (πᵒ ∘̂ π)) ∘̂ π₁     ≡⟨ cong (λ x → (πᵒ₁ ∘̂ x) ∘̂ π₁) βp ⟩
        (πᵒ₁ ∘̂ 1C) ∘̂ π₁     ≡⟨ cong (λ x → x ∘̂ π₁) (∘̂-rid _) ⟩
         πᵒ₁ ∘̂ π₁                 ≡⟨ βp₁ ⟩
        1C ∎)

-- zero permutation

0p : CPerm 0 0
0p = idp {0}

_⊎p_ : ∀ {m₁ m₂ n₁ n₂} → CPerm m₁ m₂ → CPerm n₁ n₂ → CPerm (m₁ + n₁) (m₂ + n₂)
_⊎p_ {m₁} {m₂} {n₁} {n₂} π₀ π₁ =
  cp ((π π₀) ⊎c (π π₁)) ((πᵒ π₀) ⊎c (πᵒ π₁)) pf₁ pf₂
  where
    open CPerm
    open ≡-Reasoning
    pf₁ : (π π₀ ⊎c π π₁) ∘̂ (πᵒ π₀ ⊎c πᵒ π₁) ≡ 1C
    pf₁ =
      begin (
        (π π₀ ⊎c π π₁) ∘̂ (πᵒ π₀ ⊎c πᵒ π₁)
          ≡⟨ ⊎c-distrib {p₁ = π π₀} ⟩
       (π π₀ ∘̂ πᵒ π₀) ⊎c (π π₁ ∘̂ πᵒ π₁)
          ≡⟨ cong₂ _⊎c_ (αp π₀) (αp π₁) ⟩
        1C {m₂} ⊎c 1C {n₂}
          ≡⟨ 1C⊎1C≡1C {m₂} ⟩
        1C ∎)
    pf₂ : (πᵒ π₀ ⊎c πᵒ π₁) ∘̂ (π π₀ ⊎c π π₁) ≡ 1C
    pf₂ =
      begin (
        (πᵒ π₀ ⊎c πᵒ π₁) ∘̂ (π π₀ ⊎c π π₁)
          ≡⟨ ⊎c-distrib {p₁ = πᵒ π₀} ⟩
        (πᵒ π₀ ∘̂ π π₀) ⊎c (πᵒ π₁ ∘̂ π π₁)
          ≡⟨ cong₂ _⊎c_ (βp π₀) (βp π₁) ⟩
        1C {m₁} ⊎c 1C {n₁}
          ≡⟨ 1C⊎1C≡1C {m₁} ⟩
        1C ∎ )

-- For the rest of the permutations, it is convenient to lift things from
-- FinVec in one go; but don't use it yet, it makes other things fall apart
{--
mkPerm : {m n : ℕ} (eq : Fin m ≃ Fin n) → CPerm m n
mkPerm {m} {n} eq = cp p q p∘̂q≡1 q∘̂p≡1
  where
    f = proj₁ eq
    g = proj₁ (sym≃ eq)
    p = tabulate g -- note the flip!
    q = tabulate f
    q∘̂p≡1 = ~⇒≡ {f = g} {g = f} (p∘!p≡id {p = eq})
    p∘̂q≡1 = ~⇒≡ {f = f} {g = g} (p∘!p≡id {p = sym≃ eq})
--}

unite+p : {m : ℕ} → CPerm m (0 + m)
unite+p {m} =
  cp (unite+ {m}) (uniti+ {m}) (unite+∘̂uniti+~id {m}) (uniti+∘̂unite+~id {m})

uniti+p : {m : ℕ} → CPerm (0 + m) m
uniti+p {m} = symp (unite+p {m})

unite+rp : {m : ℕ} → CPerm m (m + 0)
unite+rp {m} =
  cp (unite+r {m}) (uniti+r) (unite+r∘̂uniti+r~id) (uniti+r∘̂unite+r~id)

uniti+rp : {m : ℕ} → CPerm (m + 0) m
uniti+rp {m} = symp (unite+rp {m})

assocl+p : {m n o : ℕ} → CPerm ((m + n) + o) (m + (n + o))
assocl+p {m} =
  cp
    (assocl+ {m}) (assocr+ {m})
    (assocl+∘̂assocr+~id {m}) (assocr+∘̂assocl+~id {m})

assocr+p : {m n o : ℕ} → CPerm (m + (n + o)) ((m + n) + o)
assocr+p {m} = symp (assocl+p {m})

swap+p : {m n : ℕ} → CPerm (n + m) (m + n)
swap+p {m} {n} =
  cp (swap+cauchy m n) (swap+cauchy n m) (swap+-inv {m}) (swap+-inv {n})

unite*p : {m : ℕ} → CPerm m (1 * m)
unite*p {m} =
  cp (unite* {m}) (uniti* {m}) (unite*∘̂uniti*~id {m}) (uniti*∘̂unite*~id {m})

uniti*p : {m : ℕ} → CPerm (1 * m) m
uniti*p {m} = symp (unite*p {m})

unite*rp : {m : ℕ} → CPerm m (m * 1)
unite*rp {m} =
  cp
    (unite*r {m}) (uniti*r {m})
    (unite*r∘̂uniti*r~id {m}) (uniti*r∘̂unite*r~id {m})

uniti*rp : {m : ℕ} → CPerm (m * 1) m
uniti*rp {m} = symp (unite*rp {m})

swap*p : {m n : ℕ} → CPerm (n * m) (m * n)
swap*p {m} {n} =
  cp (swap⋆cauchy m n) (swap⋆cauchy n m) (swap*-inv {m}) (swap*-inv {n})

assocl*p : {m n o : ℕ} → CPerm ((m * n) * o) (m * (n * o))
assocl*p {m} =
  cp
    (assocl* {m}) (assocr* {m})
    (assocl*∘̂assocr*~id {m}) (assocr*∘̂assocl*~id {m})

assocr*p : {m n o : ℕ} → CPerm (m * (n * o)) ((m * n) * o)
assocr*p {m} = symp (assocl*p {m})

_×p_ : ∀ {m₁ m₂ n₁ n₂} → CPerm m₁ m₂ → CPerm n₁ n₂ → CPerm (m₁ * n₁) (m₂ * n₂)
_×p_ {m₁} {m₂} {n₁} {n₂} π₀ π₁ =
  cp ((π π₀) ×c (π π₁)) ((πᵒ π₀) ×c (πᵒ π₁)) pf₁ pf₂
  where
    open CPerm
    open ≡-Reasoning
    pf₁ : (π π₀ ×c π π₁) ∘̂ (πᵒ π₀ ×c πᵒ π₁) ≡ 1C
    pf₁ =
      begin (
        (π π₀ ×c π π₁) ∘̂ (πᵒ π₀ ×c πᵒ π₁) ≡⟨ ×c-distrib {p₁ = π π₀} ⟩
        (π π₀ ∘̂ πᵒ π₀) ×c (π π₁ ∘̂ πᵒ π₁)  ≡⟨ cong₂ _×c_ (αp π₀) (αp π₁) ⟩
        1C ×c 1C                          ≡⟨ 1C×1C≡1C ⟩
        1C ∎)
    pf₂ : (πᵒ π₀ ×c πᵒ π₁) ∘̂ (π π₀ ×c π π₁) ≡ 1C
    pf₂ =
      begin (
        (πᵒ π₀ ×c πᵒ π₁) ∘̂ (π π₀ ×c π π₁) ≡⟨ ×c-distrib {p₁ = πᵒ π₀} ⟩
        (πᵒ π₀ ∘̂ π π₀) ×c (πᵒ π₁ ∘̂ π π₁) ≡⟨ cong₂ _×c_ (βp π₀) (βp π₁) ⟩
        1C ×c 1C                          ≡⟨ 1C×1C≡1C ⟩
        1C ∎)

distp : {m n o : ℕ} → CPerm (m * o + n * o) ((m + n) * o)
distp {m} {n} {o} =
  cp
    (dist*+ {m}) (factor*+ {m})
    (dist*+∘̂factor*+~id {m}) (factor*+∘̂dist*+~id {m})

factorp : {m n o : ℕ} → CPerm ((m + n) * o) (m * o + n * o)
factorp {m} = symp (distp {m})

distlp : {m n o : ℕ} → CPerm (m * n + m * o) (m * (n + o))
distlp {m} {n} {o} =
  cp
    (distl*+ {m}) (factorl*+ {m})
    (distl*+∘̂factorl*+~id {m}) (factorl*+∘̂distl*+~id {m})

factorlp : {m n o : ℕ} → CPerm (m * (n + o)) (m * n + m * o)
factorlp {m} = symp (distlp {m})

-- right-zero absorbing permutation

0pr : ∀ {n} → CPerm 0 (n * 0)
0pr {n} =
  cp
    (right-zero*l {n}) (right-zero*r {n})
    (right-zero*l∘̂right-zero*r~id {n}) (right-zero*r∘̂right-zero*l~id {n})

-- and its symmetric version

0pl : ∀ {n} → CPerm (n * 0) 0
0pl {n} = symp (0pr {n})

--

ridp : ∀ {m₁ m₂} {p : CPerm m₂ m₁} → transp p idp ≡ p
ridp {p = p} = p≡ (∘̂-rid (CPerm.π p))

lidp : ∀ {m₁ m₂} {p : CPerm m₂ m₁} → transp idp p ≡ p
lidp {p = p} = p≡ (∘̂-lid (CPerm.π p))

assocp : ∀ {m₁ m₂ m₃ n₁} → {p₁ : CPerm m₁ n₁} → {p₂ : CPerm m₂ m₁} →
  {p₃ : CPerm m₃ m₂} →
  transp p₁ (transp p₂ p₃) ≡ transp (transp p₁ p₂) p₃
assocp {p₁ = p₁} {p₂} {p₃} =
  p≡ (∘̂-assoc (CPerm.π p₁) (CPerm.π p₂) (CPerm.π p₃))

linv : ∀ {m₁ m₂} (p : CPerm m₂ m₁) → transp p (symp p) ≡ idp
linv p = p≡ (CPerm.αp p)

rinv : ∀ {m₁ m₂} (p : CPerm m₂ m₁) → transp (symp p) p ≡ idp
rinv p = p≡ (CPerm.βp p)

transp-resp-≡ : ∀ {m₁ m₂ m₃} {f h : CPerm m₂ m₃} {g i : CPerm m₁ m₂} →
  f ≡ h → g ≡ i → transp f g ≡ transp h i
transp-resp-≡ refl refl = refl

1p⊎1p≡1p : ∀ {m n} → idp {m} ⊎p idp {n} ≡ idp
1p⊎1p≡1p {m} = p≡ (1C⊎1C≡1C {m})

1p×1p≡1p : ∀ {m n} → idp {m} ×p idp {n} ≡ idp
1p×1p≡1p {m} = p≡ (1C×1C≡1C {m})

⊎p-distrib :  ∀ {m₁ m₂ m₃ m₄ n₁ n₂} → {p₁ : CPerm m₁ n₁} → {p₂ : CPerm m₂ n₂}
    → {p₃ : CPerm m₃ m₁} → {p₄ : CPerm m₄ m₂} →
      transp (p₁ ⊎p p₂) (p₃ ⊎p p₄) ≡ (transp p₁ p₃) ⊎p (transp p₂ p₄)
⊎p-distrib {p₁ = p₁} = p≡ (⊎c-distrib {p₁ = CPerm.π p₁})

×p-distrib :  ∀ {m₁ m₂ m₃ m₄ n₁ n₂} → {p₁ : CPerm m₁ n₁} → {p₂ : CPerm m₂ n₂}
    → {p₃ : CPerm m₃ m₁} → {p₄ : CPerm m₄ m₂} →
      (transp p₁ p₃) ×p (transp p₂ p₄) ≡ transp (p₁ ×p p₂) (p₃ ×p p₄)
×p-distrib {p₁ = p₁} = p≡ (sym (×c-distrib {p₁ = CPerm.π p₁}))

0p⊎x≡x : ∀ {m n} {p : CPerm m n} → idp {0} ⊎p p ≡ p
0p⊎x≡x {p = p} = p≡ 1C₀⊎x≡x

-- this comes from looking at things categorically:

unite+p∘[0⊎x]≡x∘unite+p : ∀ {m n} (p : CPerm m n) →
  transp unite+p (0p ⊎p p) ≡ transp p unite+p
unite+p∘[0⊎x]≡x∘unite+p p = p≡ unite+∘[0⊎x]≡x∘unite+

uniti+p∘x≡[0⊎x]∘uniti+p : ∀ {m n} (p : CPerm m n) →
  transp uniti+p p ≡ transp (0p ⊎p p) uniti+p
uniti+p∘x≡[0⊎x]∘uniti+p p = p≡ (uniti+∘x≡[0⊎x]∘uniti+ {x = CPerm.π p})

-- and the right version
{-
unite+rp∘[x⊎0]≡x∘unite+rp : ∀ {m n} (p : CPerm m n) →
  transp unite+rp (p ⊎p 0p) ≡ transp p unite+rp
unite+rp∘[x⊎0]≡x∘unite+rp p = p≡ ?

uniti+rp∘[x⊎0]≡x∘uniti+rp : ∀ {m n} (p : CPerm m n) →
  transp uniti+rp (p ⊎p 0p) ≡ transp p uniti+rp
uniti+rp∘[x⊎0]≡x∘uniti+rp p = p≡ {!!}
-}

-- SCPerm : ℕ → ℕ → Setoid zero zero
-- SCPerm m n = setoid (CPerm m n)

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


module Highlighting.M where

postulate
  ℕ : Set
  _+_ _*_ : (x y : ℕ) → ℕ


module Prelude where

open import Agda.Primitive public
  using (_⊔_)
  renaming (lsuc to ↑_)

-- Built-in implication.

id : ∀ {ℓ} {X : Set ℓ} → X → X
id x = x

const : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} → X → Y → X
const x y = x

flip : ∀ {ℓ ℓ′ ℓ″} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} →
       (X → Y → Z) → Y → X → Z
flip P y x = P x y

ap : ∀ {ℓ ℓ′ ℓ″} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} →
     (X → Y → Z) → (X → Y) → X → Z
ap f g x = f x (g x)

infixr 9 _∘_
_∘_ : ∀ {ℓ ℓ′ ℓ″} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} →
      (Y → Z) → (X → Y) → X → Z
f ∘ g = λ x → f (g x)

refl→ : ∀ {ℓ} {X : Set ℓ} → X → X
refl→ = id

trans→ : ∀ {ℓ ℓ′ ℓ″} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} →
          (X → Y) → (Y → Z) → X → Z
trans→ = flip _∘_

-- Built-in verum.

open import Agda.Builtin.Unit public
  using (⊤)
  renaming (tt to ∙)

-- Falsum.

data ⊥ : Set where

{-# HASKELL data AgdaEmpty #-}
{-# COMPILED_DATA ⊥ MAlonzo.Code.Data.Empty.AgdaEmpty #-}

elim⊥ : ∀ {ℓ} {X : Set ℓ} → ⊥ → X
elim⊥ ()

-- Negation.

infix 3 ¬_
¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ X = X → ⊥

_↯_ : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} → X → ¬ X → Y
p ↯ ¬p = elim⊥ (¬p p)

-- Built-in equality.

open import Agda.Builtin.Equality public
  using (_≡_ ; refl)

infix 4 _≢_
_≢_ : ∀ {ℓ} {X : Set ℓ} → X → X → Set ℓ
x ≢ x′ = ¬ (x ≡ x′)

trans : ∀ {ℓ} {X : Set ℓ} {x x′ x″ : X} → x ≡ x′ → x′ ≡ x″ → x ≡ x″
trans refl refl = refl

sym : ∀ {ℓ} {X : Set ℓ} {x x′ : X} → x ≡ x′ → x′ ≡ x
sym refl = refl

subst : ∀ {ℓ ℓ′} {X : Set ℓ} → (P : X → Set ℓ′) →
        ∀ {x x′} → x ≡ x′ → P x → P x′
subst P refl p = p

cong : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} → (f : X → Y) →
       ∀ {x x′} → x ≡ x′ → f x ≡ f x′
cong f refl = refl

cong² : ∀ {ℓ ℓ′ ℓ″} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} → (f : X → Y → Z) →
        ∀ {x x′ y y′} → x ≡ x′ → y ≡ y′ → f x y ≡ f x′ y′
cong² f refl refl = refl

cong³ : ∀ {ℓ ℓ′ ℓ″ ℓ‴} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} {A : Set ℓ‴} →
        (f : X → Y → Z → A) →
        ∀ {x x′ y y′ z z′} → x ≡ x′ → y ≡ y′ → z ≡ z′ → f x y z ≡ f x′ y′ z′
cong³ f refl refl refl = refl

-- Equational reasoning with built-in equality.

module ≡-Reasoning {ℓ} {X : Set ℓ} where
  infix 1 begin_
  begin_ : ∀ {x x′ : X} → x ≡ x′ → x ≡ x′
  begin p = p

  infixr 2 _≡⟨⟩_
  _≡⟨⟩_ : ∀ (x {x′} : X) → x ≡ x′ → x ≡ x′
  x ≡⟨⟩ p = p

  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ (x {x′ x″} : X) → x ≡ x′ → x′ ≡ x″ → x ≡ x″
  x ≡⟨ p ⟩ q = trans p q

  infix 3 _∎
  _∎ : ∀ (x : X) → x ≡ x
  x ∎ = refl

open ≡-Reasoning public

-- Constructive existence.

infixl 5 _,_
record Σ {ℓ ℓ′} (X : Set ℓ) (Y : X → Set ℓ′) : Set (ℓ ⊔ ℓ′) where
  constructor _,_
  field
    π₁ : X
    π₂ : Y π₁

open Σ public

-- Conjunction.

infixr 2 _∧_
_∧_ : ∀ {ℓ ℓ′} → Set ℓ → Set ℓ′ → Set (ℓ ⊔ ℓ′)
X ∧ Y = Σ X (λ x → Y)

-- Disjunction.

infixr 1 _∨_
data _∨_ {ℓ ℓ′} (X : Set ℓ) (Y : Set ℓ′) : Set (ℓ ⊔ ℓ′) where
  ι₁ : X → X ∨ Y
  ι₂ : Y → X ∨ Y

{-# HASKELL type AgdaEither _ _ x y = Either x y #-}
{-# COMPILED_DATA _∨_ MAlonzo.Code.Data.Sum.AgdaEither Left Right #-}

elim∨ : ∀ {ℓ ℓ′ ℓ″} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} →
        X ∨ Y → (X → Z) → (Y → Z) → Z
elim∨ (ι₁ x) f g = f x
elim∨ (ι₂ y) f g = g y

-- Equivalence.

infix 3 _↔_
_↔_ : ∀ {ℓ ℓ′} → (X : Set ℓ) (Y : Set ℓ′) → Set (ℓ ⊔ ℓ′)
X ↔ Y = (X → Y) ∧ (Y → X)

infix 3 _↮_
_↮_ : ∀ {ℓ ℓ′} → (X : Set ℓ) (Y : Set ℓ′) → Set (ℓ ⊔ ℓ′)
X ↮ Y = ¬ (X ↔ Y)

refl↔ : ∀ {ℓ} {X : Set ℓ} → X ↔ X
refl↔ = refl→ , refl→

trans↔ : ∀ {ℓ ℓ′ ℓ″} {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″} →
          X ↔ Y → Y ↔ Z → X ↔ Z
trans↔ (P , Q) (P′ , Q′) = trans→ P P′ , trans→ Q′ Q

sym↔ : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} → X ↔ Y → Y ↔ X
sym↔ (P , Q) = Q , P

antisym→ : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} →
            ((X → Y) ∧ (Y → X)) ≡ (X ↔ Y)
antisym→ = refl

≡→↔ : ∀ {ℓ} {X Y : Set ℓ} → X ≡ Y → X ↔ Y
≡→↔ refl = refl↔

-- Equational reasoning with equivalence.

module ↔-Reasoning where
  infix 1 begin↔_
  begin↔_ : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} → X ↔ Y → X ↔ Y
  begin↔ P = P

  infixr 2 _↔⟨⟩_
  _↔⟨⟩_ : ∀ {ℓ ℓ′} → (X : Set ℓ) → {Y : Set ℓ′} → X ↔ Y → X ↔ Y
  X ↔⟨⟩ P = P

  infixr 2 _≡→↔⟨⟩_
  _≡→↔⟨⟩_ : ∀ {ℓ} → (X : Set ℓ) → {Y : Set ℓ} → X ≡ Y → X ↔ Y
  X ≡→↔⟨⟩ P = ≡→↔ P

  infixr 2 _↔⟨_⟩_
  _↔⟨_⟩_ : ∀ {ℓ ℓ′ ℓ″} → (X : Set ℓ) → {Y : Set ℓ′} {Z : Set ℓ″} →
            X ↔ Y → Y ↔ Z → X ↔ Z
  X ↔⟨ P ⟩ Q = trans↔ P Q

  infix 3 _∎↔
  _∎↔ : ∀ {ℓ} → (X : Set ℓ) → X ↔ X
  X ∎↔ = refl↔

open ↔-Reasoning public

-- Booleans.

open import Agda.Builtin.Bool public
  using (Bool ; false ; true)

elimBool : ∀ {ℓ} {X : Set ℓ} → Bool → X → X → X
elimBool false z s = z
elimBool true  z s = s

-- Conditionals.

data Maybe {ℓ} (X : Set ℓ) : Set ℓ where
  nothing : Maybe X
  just    : X → Maybe X

{-# HASKELL type AgdaMaybe _ x = Maybe x #-}
{-# COMPILED_DATA Maybe MAlonzo.Code.Data.Maybe.Base.AgdaMaybe Just Nothing #-}

elimMaybe : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} → Maybe X → Y → (X → Y) → Y
elimMaybe nothing  z f = z
elimMaybe (just x) z f = f x

-- Naturals.

open import Agda.Builtin.Nat public
  using (Nat ; zero ; suc)

elimNat : ∀ {ℓ} {X : Set ℓ} → Nat → X → (Nat → X → X) → X
elimNat zero    z f = z
elimNat (suc n) z f = f n (elimNat n z f)

-- Decidability.

data Dec {ℓ} (X : Set ℓ) : Set ℓ where
  yes : X → Dec X
  no  : ¬ X → Dec X

mapDec : ∀ {ℓ ℓ′} {X : Set ℓ} {Y : Set ℓ′} →
         (X → Y) → (Y → X) → Dec X → Dec Y
mapDec f g (yes x) = yes (f x)
mapDec f g (no ¬x) = no (λ y → g y ↯ ¬x)

⌊_⌋Dec : ∀ {ℓ} {X : Set ℓ} → Dec X → Bool
⌊ yes x ⌋Dec = true
⌊ no ¬x ⌋Dec = false


{-# OPTIONS --without-K #-}
module Model.Type where

open import Model.Exponential public
open import Model.Nat public
open import Model.Product public
open import Model.Terminal public
open import Model.Type.Core public
open import Model.Stream public
open import Model.Quantification public

open import Model.Size as MS using
  ( ≤-IsProp ; ⟦_⟧Δ ; ⟦_⟧n ; ⟦_⟧σ )
open import Source.Size.Substitution.Theory
open import Source.Size.Substitution.Universe as SS using (Sub⊢ᵤ ; ⟨_⟩)
open import Util.Prelude hiding (id ; _∘_ ; _×_ ; ⊤)

import Source.Size as SS
import Source.Type as ST

open MS._≤_

⟦_⟧T : ∀ {Δ} (T : ST.Type Δ) → ⟦Type⟧ ⟦ Δ ⟧Δ
⟦ ST.Nat n ⟧T = subT ⟦ n ⟧n Nat
⟦ ST.Stream n ⟧T = subT ⟦ n ⟧n Stream
⟦ T ST.⇒ U ⟧T = ⟦ T ⟧T ↝ ⟦ U ⟧T
⟦ ST.Π n , T ⟧T = ⟦∀⟧ n ⟦ T ⟧T

⟦_⟧Γ : ∀ {Δ} (Γ : ST.Ctx Δ) → ⟦Type⟧ ⟦ Δ ⟧Δ
⟦ ST.[] ⟧Γ = ⊤
⟦ Γ ST.∙ T ⟧Γ = ⟦ Γ ⟧Γ × ⟦ T ⟧T

⇒-resp-≈⟦Type⟧ : ∀ {Γ} {T T′ U U′ : ⟦Type⟧ Γ}
  → T ≈⟦Type⟧ T′
  → U ≈⟦Type⟧ U′
  → T ⇒ U
  → T′ ⇒ U′
⇒-resp-≈⟦Type⟧ T≈T′ U≈U′ f = U≈U′ .forth ∘ f ∘ T≈T′ .back

⟦subT⟧ : ∀ {Δ Ω σ} (⊢σ : σ ∶ Δ ⇒ᵤ Ω) T
  → ⟦ T [ σ ]ᵤ ⟧T ≈⟦Type⟧ subT ⟦ ⊢σ ⟧σ ⟦ T ⟧T
⟦subT⟧ ⊢σ (ST.Nat n) = record
  { forth = record
    { fobj = castℕ≤ (reflexive (MS.⟦sub⟧ ⊢σ n))
    ; feq = λ γ≈γ′ m≡m → m≡m
    }
  ; back = record
    { fobj = castℕ≤ (reflexive (sym (MS.⟦sub⟧ ⊢σ n)))
    ; feq = λ γ≈γ′ m≡m → m≡m
    }
  ; back-forth = ≈⁺ λ γ x → ℕ≤-≡⁺ _ _ refl
  ; forth-back = ≈⁺ λ γ x → ℕ≤-≡⁺ _ _ refl
  }
⟦subT⟧ ⊢σ (ST.Stream n) = record
  { forth = record
    { fobj = castColist (reflexive (sym (MS.⟦sub⟧ ⊢σ n)))
    ; feq = λ γ≈γ′ xs≈ys a a₁ a₂ → xs≈ys _ _ _
    }
  ; back = record
    { fobj = castColist (reflexive (MS.⟦sub⟧ ⊢σ n))
    ; feq = λ γ≈γ′ xs≈ys a a₁ a₂ → xs≈ys _ _ _
    }
  ; back-forth = ≈⁺ λ γ xs → Colist-≡⁺ λ m m≤n → cong (xs m) (≤-IsProp _ _)
  ; forth-back = ≈⁺ λ γ xs → Colist-≡⁺ λ m m≤n → cong (xs m) (≤-IsProp _ _)
  }
⟦subT⟧ {Δ} {Ω} {σ} ⊢σ (T ST.⇒ U)
  = ≈⟦Type⟧-trans (↝-resp-≈⟦Type⟧ _ _ _ _ (⟦subT⟧ ⊢σ T) (⟦subT⟧ ⊢σ U))
      (subT-↝ ⟦ ⊢σ ⟧σ ⟦ T ⟧T ⟦ U ⟧T)
⟦subT⟧ {Δ} {Ω} {σ} ⊢σ (ST.Π n , T)
  = ≈⟦Type⟧-trans (⟦∀⟧-resp-≈⟦Type⟧ (n [ σ ]ᵤ) (⟦subT⟧ (SS.Lift ⊢σ refl) T))
      (subT-⟦∀⟧ ⊢σ ⟦ T ⟧T)

⟦subΓ⟧ : ∀ {Δ Ω σ} (⊢σ : σ ∶ Δ ⇒ᵤ Ω) Γ
  → ⟦ Γ [ σ ]ᵤ ⟧Γ ≈⟦Type⟧ subT ⟦ ⊢σ ⟧σ ⟦ Γ ⟧Γ
⟦subΓ⟧ σ ST.[] = record
  { forth = record { fobj = λ x → x ; feq = λ γ≈γ′ x → x }
  ; back = record { fobj = λ x → x ; feq = λ γ≈γ′ x → x }
  ; back-forth = ≈⁺ λ γ x → refl
  ; forth-back = ≈⁺ λ γ x → refl
  }
⟦subΓ⟧ σ (Γ ST.∙ T) = ×-resp-≈⟦Type⟧ (⟦subΓ⟧ σ Γ) (⟦subT⟧ σ T)

subₛ
  : ∀ {Δ Ω σ Γ T}
  → (⊢σ : σ ∶ Δ ⇒ᵤ Ω)
  → ⟦ Γ ⟧Γ ⇒ ⟦ T ⟧T
  → ⟦ Γ [ σ ]ᵤ ⟧Γ ⇒ ⟦ T [ σ ]ᵤ ⟧T
subₛ {Γ = Γ} {T} ⊢σ f
  = ⟦subT⟧ ⊢σ T .back ∘ subt ⟦ ⊢σ ⟧σ f ∘ ⟦subΓ⟧ ⊢σ Γ .forth

≡→≈⟦Type⟧Γ : ∀ {Δ} {Γ Ψ : ST.Ctx Δ}
  → Γ ≡ Ψ
  → ⟦ Γ ⟧Γ ≈⟦Type⟧ ⟦ Ψ ⟧Γ
≡→≈⟦Type⟧Γ p = ≡→≈⟦Type⟧ (cong ⟦_⟧Γ p)

≡→≈⟦Type⟧T : ∀ {Δ} {T U : ST.Type Δ}
  → T ≡ U
  → ⟦ T ⟧T ≈⟦Type⟧ ⟦ U ⟧T
≡→≈⟦Type⟧T p = ≡→≈⟦Type⟧ (cong ⟦_⟧T p)


module cfg where

open import jarsec using (Parser ; run-parser ; partial-parse ; _>>=_ ; _>>_ ; _<*>_)

open import Data.Bool
open import Data.List hiding (lookup)
open import Data.Vec renaming ([_] to V[_] ; _++_ to _vv_) hiding (_>>=_)
open import Data.Fin hiding (_+_)
open import Data.Char
open import Agda.Builtin.Char renaming ( primCharEquality to charEq )
open import Data.Nat
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
open import Data.Maybe
open import Data.Sum hiding (map)
open import Data.String hiding (length ; _++_) renaming (primStringToList to 𝕊→𝕃 ; primStringFromList to 𝕃→𝕊)
open import Data.Product hiding (map)
open import Agda.Builtin.Unit

postulate
  𝕃⇄𝕊 : ∀ (cs : List Char) → (𝕊→𝕃 (𝕃→𝕊 cs)) ≡ cs

_at_ : ∀ {n} {A : Set} → Vec A n → Fin n → A
(x ∷ xs) at zero = x
(x ∷ xs) at suc i = xs at i

A : Set
A = Char

data Cfg : ℕ → Set where
  emp : ∀ {n} → Cfg n
  eps : ∀ {n} → Cfg n
  lit : ∀ {n} → A → Cfg n
  var : ∀ {n} → Fin n → Cfg n
  seq : ∀ {n} → Cfg n → Cfg n → Cfg n
  alt : ∀ {n} → Cfg n → Cfg n → Cfg n
  many : ∀ {n} → Cfg n → Cfg n
  fix : ∀ {n} → Cfg (suc n) → Cfg n

Env : ℕ → Set
Env n = Vec (Cfg n) n

_⊖_ : ∀ (n : ℕ) → Fin n → ℕ
(suc n) ⊖ zero = n
(suc n) ⊖ suc i = suc (n ⊖ i)

_⊕_ : ℕ → ℕ → ℕ
zero ⊕ n = n
suc m ⊕ n = m ⊕ suc n

introd-var : ∀ {n : ℕ} (i : Fin n) → Fin (n ⊖ i) → Fin n
introd-var zero x = suc x
introd-var (suc i) zero = zero

introd-var (suc i) (suc x) = suc (introd-var i x)

introd : ∀ {n : ℕ} (i : Fin n) → Cfg (n ⊖ i) → Cfg n
introd i emp = emp
introd i eps = eps
introd i (lit l) = lit l
introd i (var x) = var (introd-var i x)
introd i (seq e₁ e₂) = seq (introd i e₁) (introd i e₂)
introd i (alt e₁ e₂) = alt (introd i e₁) (introd i e₂)
introd i (many e) = many (introd i e)
introd i (fix e) = fix (introd (suc i) e)

-- used in subst
introd-var-N : ∀ {n : ℕ} (m : ℕ) → Fin n → Fin (m ⊕ n)
introd-var-N zero x = x
introd-var-N (suc m) x = introd-var-N m (introd-var zero x)

-- used in subst
intro : ∀ {n : ℕ} → Cfg n → Cfg (suc n)
intro = introd zero

subst-var : ∀ {n : ℕ} (m : ℕ) (x : Fin n) → Cfg (m ⊕ (n ⊖ x)) → Fin n → Cfg (m ⊕ (n ⊖ x))
subst-var m zero v zero = v
subst-var m zero v (suc y) = var (introd-var-N m y)
subst-var m (suc x) v zero = var (introd-var-N m zero)
subst-var m (suc x) v (suc y) = subst-var (suc m) x v y

subst : ∀ {n : ℕ} (x : Fin n) → Cfg (n ⊖ x) → Cfg n → Cfg (n ⊖ x)
subst y v emp = emp
subst y v eps = eps
subst y v (lit l) = lit l
subst y v (var x) = subst-var zero y v x
subst y v (seq e₁ e₂) = seq (subst y v e₁) (subst y v e₂)
subst y v (alt e₁ e₂) = alt (subst y v e₁) (subst y v e₂)
subst y v (many e) = many (subst y v e)
subst y v (fix e) = fix (subst (suc y) (intro v) e)

sub : ∀ {n : ℕ} → Cfg n → Cfg (suc n) → Cfg n
sub = subst zero

data _∈[_] : List A → Cfg 0 → Set where
  eps : [] ∈[ eps ]

  lit : ∀ (c : A) → [ c ] ∈[ lit c ]

  seq : ∀ {s₁ s₂ : List A} {cfg₁ cfg₂ : Cfg 0}
    → s₁ ∈[ cfg₁ ]
    → s₂ ∈[ cfg₂ ]
    → (s₁ ++ s₂) ∈[ seq cfg₁ cfg₂ ]

  alt₁ : {s : List A} {cfg₁ cfg₂ : Cfg 0}
    → s ∈[ cfg₁ ]
    → s ∈[ alt cfg₁ cfg₂ ]

  alt₂ : {s : List A} {cfg₁ cfg₂ : Cfg 0}
    → s ∈[ cfg₂ ]
    → s ∈[ alt cfg₁ cfg₂ ]

  many0 : {cfg : Cfg 0}
    → [] ∈[ many cfg ]

  many+ : {s₁ s₂ : List A} {cfg : Cfg 0}
    → s₁ ∈[ cfg ]
    → s₂ ∈[ many cfg ]
    → (s₁ ++ s₂) ∈[ many cfg ]

  unroll : {s : List A}
    → {cfg : Cfg 1}
    → s ∈[ sub (fix cfg) cfg ]
    → s ∈[ fix cfg ]

abstract
  instance
    block : ⊤
    block = tt
  unblock : block ≡ tt
  unblock = refl

delayed : ∀ {A : Set} → ⊤ → A  → A
delayed tt x = x

delay : ∀ {A : Set} → A → A
delay = delayed block

{-# TERMINATING #-}
interp : Cfg 0 → Parser (List A)
interp emp = Parser.mk-parser (λ _ → [])
interp eps = Parser.mk-parser (λ str → [ ([] , str) ])
interp (lit c) = do
  c′ ← jarsec.satisfy (charEq c)
  jarsec.unit [ c′ ]
interp (var ())
interp (seq cfg₁ cfg₂) = do
  x ← (interp cfg₁)
  y ← (interp cfg₂)
  jarsec.unit (x ++ y)
interp (alt cfg₁ cfg₂) = jarsec.combine (interp cfg₁) (interp cfg₂)
interp (many cfg) = interp (alt eps (seq cfg (delay (many cfg))))
interp (fix cfg) = interp (sub (fix cfg) cfg)

a : Fin 2
a = zero
b : Fin 2
b = (suc zero)

xX-or-ε : Cfg 0
xX-or-ε = fix (alt (seq (lit 'x') (var zero)) eps)

-- _ : interp xX-or-ε ≡ {!   !}
-- _ = refl

_ : (𝕊→𝕃 "xx") ∈[ fix {n = 0} (alt (seq (lit 'x') (var zero)) (eps)) ]
_ = unroll (alt₁ (seq (lit 'x') (unroll (alt₁ (seq (lit 'x') (unroll (alt₂ eps)))))))

_ : (𝕊→𝕃 "xx") ∈[ xX-or-ε ]
_ =
  unroll
  (alt₁ (seq (lit 'x') (
    unroll
    (alt₁ (seq (lit 'x') (
      unroll
      (alt₂ eps)))))))

_ : ( 'a' ∷ 'a' ∷ []) ∈[ many (lit 'a') ]
_ = many+ (lit 'a') (many+ (lit 'a') many0)


-- Andreas, 2017-01-18, issue #5 is fixed
-- reported by Ulf 2007-10-24

data Nat : Set where
  zero : Nat

data Vec : Nat -> Set where
  []   : Vec zero

f : (n : Nat) -> Vec n -> Nat
f n@._ [] = n


------------------------------------------------------------------------------
-- Example of a partial function
------------------------------------------------------------------------------

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

-- From (Bove, A. and Capretta, V. (2001)).

module FOT.FOTC.Program.Min.Min where

open import Data.Nat renaming ( suc to succ )
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------------
-- Note: Although the function is partial the problem is that it is
-- rejected by Agda's termination checker.

{-# NON_TERMINATING #-}
min : (ℕ → ℕ) → ℕ
min f with f 0
... | 0      = 0
... | succ x = succ (min (λ n → f (succ n)))

------------------------------------------------------------------------------
-- References
--
-- Bove, A. and Capretta, V. (2001). Nested General Recursion and
-- Partiality in Type Theory. In: Theorem Proving in Higher Order
-- Logics (TPHOLs 2001). Ed. by Boulton, R. J. and Jackson,
-- P. B. Vol. 2152. LNCS. Springer, pp. 121–135.


{-# OPTIONS --universe-polymorphism #-}
module Categories.DinaturalTransformation where

open import Level
open import Data.Product

open import Categories.Category
import Categories.NaturalTransformation
private module NT = Categories.NaturalTransformation
open import Categories.Functor using (Functor) renaming (_∘_ to _∘F_)
open import Categories.Bifunctor using (Bifunctor; module Functor)
open import Categories.Product
open import Categories.Square

record DinaturalTransformation {o ℓ e o′ ℓ′ e′}
                               {C : Category o ℓ e}
                               {D : Category o′ ℓ′ e′}
                               (F G : Bifunctor (Category.op C) C D) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private
    module C = Category C
    module D = Category D
  open Functor F renaming (op to Fop)
  open Functor G renaming (F₀ to G₀; F₁ to G₁; op to Gop)
  open D hiding (op)
  field
    α : (c : C.Obj) → D [ F₀ (c , c) , G₀ (c , c) ]

    .commute : ∀ {c c′} (f : C [ c , c′ ]) → G₁ (f , C.id) ∘ α c′ ∘ F₁ ( C.id , f ) ≡ G₁ ( C.id , f ) ∘ α c ∘ F₁ ( f , C.id )

  op : DinaturalTransformation {C = C.op} {D = D.op} Gop Fop
  op = record { α = α; commute = λ f → D.Equiv.trans assoc (D.Equiv.trans (D.Equiv.sym (commute f)) (D.Equiv.sym assoc)) }

_<∘_ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G H : Bifunctor (Category.op C) C D}
      → NT.NaturalTransformation G H → DinaturalTransformation {C = C} F G → DinaturalTransformation {C = C} F H
_<∘_ {C = C} {D} {F} {G} {H} eta alpha = record { α = λ c → η (c , c) ∘ α c; commute = λ {c} {c′} f →
     begin
       H.F₁ (f , C.id) ∘ ((η (c′ , c′) ∘ α c′) ∘ F.F₁ (C.id , f))
     ↓⟨ ∘-resp-≡ʳ assoc ⟩
       H.F₁ (f , C.id) ∘ (η (c′ , c′) ∘ (α c′ ∘ F.F₁ (C.id , f)))
     ↑⟨ assoc ⟩
       (H.F₁ (f , C.id) ∘ η (c′ , c′)) ∘ (α c′ ∘ F.F₁ (C.id , f))
     ↑⟨ ∘-resp-≡ˡ (eta.commute (f , C.id)) ⟩
       (η (c , c′) ∘ G.F₁ (f , C.id)) ∘ (α c′ ∘ F.F₁ (C.id , f))
     ↓⟨ pullʳ (commute f) ⟩
       η (c , c′) ∘ G.F₁ (C.id , f) ∘ (α c ∘ F.F₁ (f , C.id))
     ↓⟨ pullˡ (eta.commute (C.id , f)) ⟩
       (H.F₁ (C.id , f) ∘ η (c , c)) ∘ (α c ∘ F.F₁ (f , C.id))
     ↓⟨ assoc ⟩
       H.F₁ (C.id , f) ∘ (η (c , c) ∘ (α c ∘ F.F₁ (f , C.id)))
     ↑⟨ ∘-resp-≡ʳ assoc ⟩
       H.F₁ (C.id , f) ∘ ((η (c , c) ∘ α c) ∘ F.F₁ (f , C.id))
     ∎
{-  This uses 'associative-unital reasoning, which is now broken.  Above uses
    direct reasoning, which is heavier, but works.  JC.
     begin
       H.F₁ (f , C.id) ∙ ((η (c′ , c′) ∙ α c′) ∙ F.F₁ (C.id , f))
     ↑⟨ refl ⟩
       (H.F₁ (f , C.id) ∙ η (c′ , c′)) ∙ (α c′ ∙ F.F₁ (C.id , f))
     ↑≡⟨ ∘-resp-≡ˡ (eta.commute (f , C.id)) ⟩
       (η (c , c′) ∙ G.F₁ (f , C.id)) ∙ (α c′ ∙ F.F₁ (C.id , f))
     ↓≡⟨ pullʳ (commute f) ⟩
       η (c , c′) ∙ G.F₁ (C.id , f) ∙ α c ∙ F.F₁ (f , C.id)
     ↓≡⟨ pullˡ (eta.commute (C.id , f)) ⟩
       (H.F₁ (C.id , f) ∙ η (c , c)) ∙ α c ∙ F.F₁ (f , C.id)
     ↓⟨ refl ⟩
       H.F₁ (C.id , f) ∙ (η (c , c) ∙ α c) ∙ F.F₁ (f , C.id)
     ∎ -} }
  where
    module C = Category C
    module D = Category D
    open D
    open D.Equiv
    module F = Functor F
    module G = Functor G
    module H = Functor H
    module eta = NT.NaturalTransformation eta
    open eta using (η)
    open DinaturalTransformation alpha
    -- open AUReasoning D
    open HomReasoning
    open GlueSquares D

_∘>_ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G H : Bifunctor (Category.op C) C D}
       → DinaturalTransformation {C = C} G H → NT.NaturalTransformation F G → DinaturalTransformation {C = C} F H
alpha ∘> eta = DinaturalTransformation.op (eta.op <∘ alpha.op)
  where
    module eta = NT.NaturalTransformation eta
    module alpha = DinaturalTransformation alpha

_∘ʳ_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
     → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
     → {F G : Bifunctor (Category.op C) C D}
     → (η : DinaturalTransformation {C = C} F G) → (K : Functor E C) → DinaturalTransformation {C = E} (F ∘F ((Functor.op K) ⁂ K)) (G ∘F ((Functor.op K) ⁂ K))
_∘ʳ_ {C = C} {D = D} {E} {F} {G} η K = record
  { α = λ c → DinaturalTransformation.α η (K.F₀ c)
  ; commute = λ {c} {c′} f → begin
      G.F₁ (K.F₁ f , K.F₁ E.id) D.∘ η.α (K.F₀ c′) D.∘ F.F₁ (K.F₁ E.id , K.F₁ f)
        ↓⟨ G.F-resp-≡ (C.Equiv.refl , K.identity) ⟩∘⟨ D.Equiv.refl ⟩∘⟨ F.F-resp-≡ (K.identity , C.Equiv.refl) ⟩
      G.F₁ (K.F₁ f , C.id) D.∘ η.α (K.F₀ c′) D.∘ F.F₁ (C.id , K.F₁ f)
        ↓⟨ DinaturalTransformation.commute η (K.F₁ f) ⟩
      G.F₁ (C.id , K.F₁ f) D.∘ η.α (K.F₀ c) D.∘ F.F₁ (K.F₁ f , C.id)
        ↑⟨ G.F-resp-≡ (K.identity , C.Equiv.refl) ⟩∘⟨ D.Equiv.refl ⟩∘⟨ F.F-resp-≡ (C.Equiv.refl , K.identity) ⟩
      G.F₁ (K.F₁ E.id , K.F₁ f) D.∘ η.α (K.F₀ c) D.∘ F.F₁ (K.F₁ f , K.F₁ E.id)
        ∎
  }
  where
    module K = Functor K
    module C = Category C
    module D = Category D
    module E = Category E
    module F = Functor F
    module G = Functor G
    module η = DinaturalTransformation η
    open D.HomReasoning


module Issue644 where

postulate
  A : Set

record R : Set₁ where
  field P : A → Set

module M₁ (r : R) where

  postulate
    Foo₁ : ((x : A) → R.P r x) → Set

module M₂ (r : R) where

  open R r

  postulate
    Foo₂ : ((x : A) → P x) → Set

postulate r : R

open R  r
open M₁ r
open M₂ r

foo₂ : Set
foo₂ = Foo₂ r

-- Error message should speak about
--
--   (x : A) → P x
--
-- not mention
--
--   (x : A) → .Bug.M₂._.P r x


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

open import HoTT

{- Useful lemmas for computing the effect of transporting a function
 - across an equivalence in the domain or codomain.
 - TODO: find a better place for this. -}

module cohomology.FunctionOver where

{- transporting a function along an equivalence or path in the domain -}
module _ {i} {j} {B : Type i} {C : Type j} (g : B → C) where

  domain-over-path : {A : Type i} (p : A == B)
    → g ∘ coe p == g [ (λ D → (D → C)) ↓ p ]
  domain-over-path idp = idp

  domain-over-equiv : {A : Type i} (e : A ≃ B)
    → g ∘ –> e == g [ (λ D → (D → C)) ↓ ua e ]
  domain-over-equiv e = ↓-app→cst-in $ λ q → ap g (↓-idf-ua-out e q)

module _ {i} {j} {A : Type i} {C : Type j} (f : A → C) where

  domain!-over-path : {B : Type i} (p : A == B)
    → f == f ∘ coe! p [ (λ D → (D → C)) ↓ p ]
  domain!-over-path idp = idp

  domain!-over-equiv : {B : Type i} (e : A ≃ B)
    → f == f ∘ <– e [ (λ D → (D → C)) ↓ ua e ]
  domain!-over-equiv e = ↓-app→cst-in $
    λ q → ap f (! (<–-inv-l e _) ∙ ap (<– e) (↓-idf-ua-out e q))

{- transporting a ptd function along a equivalence or path in the domain -}
module _ {i} {j} {Y : Ptd i} {Z : Ptd j} (g : fst (Y ⊙→ Z)) where

  domain-over-⊙path : {X : Ptd i} (p : fst X == fst Y)
    (q : coe p (snd X) == snd Y)
    → g ⊙∘ (coe p , q) == g [ (λ W → fst (W ⊙→ Z)) ↓ pair= p (↓-idf-in p q) ]
  domain-over-⊙path idp idp = idp

  domain-over-⊙equiv : {X : Ptd i} (e : X ⊙≃ Y)
    → g ⊙∘ ⊙–> e == g [ (λ W → fst (W ⊙→ Z)) ↓ ⊙ua e ]
  domain-over-⊙equiv {X = X} e =
    ap (λ w → g ⊙∘ w) (! $ ⊙λ= (coe-β (⊙≃-to-≃ e)) idp)
    ◃ domain-over-⊙path (ua (⊙≃-to-≃ e))
                        (coe-β (⊙≃-to-≃ e) (snd X) ∙ snd (⊙–> e))

module _ {i} {j} {X : Ptd i} {Z : Ptd j} (f : fst (X ⊙→ Z)) where

  domain!-over-⊙path : {Y : Ptd i} (p : fst X == fst Y)
    (q : coe p (snd X) == snd Y)
    → f == f ⊙∘ (coe! p , ap (coe! p) (! q) ∙ coe!-inv-l p (snd X))
      [ (λ W → fst (W ⊙→ Z)) ↓ pair= p (↓-idf-in p q) ]
  domain!-over-⊙path idp idp = idp

  domain!-over-⊙equiv : {Y : Ptd i} (e : X ⊙≃ Y)
    → f == f ⊙∘ (⊙<– e) [ (λ W → fst (W ⊙→ Z)) ↓ ⊙ua e ]
  domain!-over-⊙equiv {Y = Y} e =
    (! (ap (λ w → f ⊙∘ w) (⊙<–-inv-l e)) ∙ ! (⊙∘-assoc f _ (⊙–> e)))
    ◃ domain-over-⊙equiv (f ⊙∘ (⊙<– e)) e

{- transporting a function along an equivalence or path in the codomain -}
module _ {i} {j} {A : Type i} {B : Type j} (f : A → B) where

  codomain-over-path : {C : Type j} (p : B == C)
    → f == coe p ∘ f [ (λ D → (A → D)) ↓ p ]
  codomain-over-path idp = idp

  codomain-over-equiv : {C : Type j} (e : B ≃ C)
    → f == –> e ∘ f [ (λ D → (A → D)) ↓ ua e ]
  codomain-over-equiv e = ↓-cst→app-in $ λ _ → ↓-idf-ua-in e idp

module _ {i} {j} {A : Type i} {C : Type j} (g : A → C) where

  codomain!-over-path : {B : Type j} (p : B == C)
    → coe! p ∘ g == g [ (λ D → (A → D)) ↓ p ]
  codomain!-over-path idp = idp

  codomain!-over-equiv : {B : Type j} (e : B ≃ C)
    → <– e ∘ g == g [ (λ D → (A → D)) ↓ ua e ]
  codomain!-over-equiv e = ↓-cst→app-in $ λ _ → ↓-idf-ua-in e (<–-inv-r e _)

{- transporting a ptd function along a equivalence or path in the codomain -}
module _ {i} {j} {X : Ptd i} {Y : Ptd j} (f : fst (X ⊙→ Y)) where

  codomain-over-⊙path : {Z : Ptd j} (p : fst Y == fst Z)
    (q : coe p (snd Y) == snd Z)
    → f == (coe p , q) ⊙∘ f [ (λ W → fst (X ⊙→ W)) ↓ pair= p (↓-idf-in p q) ]
  codomain-over-⊙path idp idp = pair= idp (! (∙-unit-r _ ∙ ap-idf (snd f)))

  codomain-over-⊙equiv : {Z : Ptd j} (e : Y ⊙≃ Z)
    → f == (⊙–> e) ⊙∘ f [ (λ W → fst (X ⊙→ W)) ↓ ⊙ua e ]
  codomain-over-⊙equiv {Z = Z} e =
    codomain-over-⊙path (ua (⊙≃-to-≃ e))
      (coe-β (⊙≃-to-≃ e) (snd Y) ∙ snd (⊙–> e))
    ▹ ap (λ w → w ⊙∘ f) (⊙λ= (coe-β (⊙≃-to-≃ e)) idp)

module _ {i} {j} {X : Ptd i} {Z : Ptd j} (g : fst (X ⊙→ Z)) where

  codomain!-over-⊙path : {Y : Ptd j} (p : fst Y == fst Z)
    (q : coe p (snd Y) == snd Z)
    → (coe! p , ap (coe! p) (! q) ∙ coe!-inv-l p (snd Y)) ⊙∘ g == g
      [ (λ W → fst (X ⊙→ W)) ↓ pair= p (↓-idf-in p q) ]
  codomain!-over-⊙path idp idp = pair= idp (∙-unit-r _ ∙ ap-idf (snd g))

  codomain!-over-⊙equiv : {Y : Ptd j} (e : Y ⊙≃ Z)
    → (⊙<– e) ⊙∘ g == g [ (λ W → fst (X ⊙→ W)) ↓ ⊙ua e ]
  codomain!-over-⊙equiv {Y = Y} e =
    codomain-over-⊙equiv (⊙<– e ⊙∘ g) e
    ▹ ! (⊙∘-assoc (⊙–> e) _ g) ∙ ap (λ w → w ⊙∘ g) (⊙<–-inv-r e) ∙ ⊙∘-unit-l g

module _ {i j} where

  function-over-paths : {A₁ B₁ : Type i} {A₂ B₂ : Type j}
    {f : A₁ → A₂} {g : B₁ → B₂} (p₁ : A₁ == B₁) (p₂ : A₂ == B₂)
    → coe p₂ ∘ f == g ∘ coe p₁
    → f == g [ (λ {(A , B) → A → B}) ↓ pair×= p₁ p₂ ]
  function-over-paths idp idp α = α

  function-over-equivs : {A₁ B₁ : Type i} {A₂ B₂ : Type j}
    {f : A₁ → A₂} {g : B₁ → B₂} (e₁ : A₁ ≃ B₁) (e₂ : A₂ ≃ B₂)
    → –> e₂ ∘ f == g ∘ –> e₁
    → f == g [ (λ {(A , B) → A → B}) ↓ pair×= (ua e₁) (ua e₂) ]
  function-over-equivs {f = f} {g = g} e₁ e₂ α =
    function-over-paths (ua e₁) (ua e₂) $
      transport (λ {(h , k) → h ∘ f == g ∘ k})
        (pair×= (! (λ= (coe-β e₂))) (! (λ= (coe-β e₁)))) α

{- transporting a group homomorphism along an isomorphism -}

domain-over-iso : ∀ {i j} {G H : Group i} {K : Group j}
  {φ : G →ᴳ H} {ie : is-equiv (GroupHom.f φ)} {ψ : G →ᴳ K} {χ : H →ᴳ K}
  → GroupHom.f ψ == GroupHom.f χ
    [ (λ A → A → Group.El K) ↓ ua (GroupHom.f φ , ie) ]
  → ψ == χ [ (λ J → J →ᴳ K) ↓ group-ua (φ , ie) ]
domain-over-iso {K = K} {φ = φ} {ie} {ψ} {χ} p =
  hom=-↓ _ _ $ ↓-ap-out _ Group.El _ $
    transport
      (λ q → GroupHom.f ψ == GroupHom.f χ [ (λ A → A → Group.El K) ↓ q ])
      (! (group-ua-el (φ , ie)))
      p

codomain-over-iso : ∀ {i j} {G : Group i} {H K : Group j}
  {φ : H →ᴳ K} {ie : is-equiv (GroupHom.f φ)} {ψ : G →ᴳ H} {χ : G →ᴳ K}
  → GroupHom.f ψ == GroupHom.f χ
    [ (λ A → Group.El G → A) ↓ ua (GroupHom.f φ , ie) ]
  → ψ == χ [ (λ J → G →ᴳ J) ↓ group-ua (φ , ie) ]
codomain-over-iso {G = G} {φ = φ} {ie} {ψ} {χ} p =
  hom=-↓ _ _ $ ↓-ap-out _ Group.El _ $
    transport
      (λ q → GroupHom.f ψ == GroupHom.f χ [ (λ A → Group.El G → A) ↓ q ])
      (! (group-ua-el (φ , ie)))
      p

hom-over-isos : ∀ {i j} {G₁ H₁ : Group i} {G₂ H₂ : Group j}
  {φ₁ : G₁ →ᴳ H₁} {ie₁ : is-equiv (GroupHom.f φ₁)}
  {φ₂ : G₂ →ᴳ H₂} {ie₂ : is-equiv (GroupHom.f φ₂)}
  {ψ : G₁ →ᴳ G₂} {χ : H₁ →ᴳ H₂}
  → GroupHom.f ψ == GroupHom.f χ
    [ (λ {(A , B) → A → B}) ↓ pair×= (ua (GroupHom.f φ₁ , ie₁))
                                     (ua (GroupHom.f φ₂ , ie₂)) ]
  → ψ == χ [ uncurry _→ᴳ_ ↓ pair×= (group-ua (φ₁ , ie₁)) (group-ua (φ₂ , ie₂)) ]
hom-over-isos {φ₁ = φ₁} {ie₁} {φ₂} {ie₂} {ψ} {χ} p = hom=-↓ _ _ $
  ↓-ap-out (λ {(A , B) → A → B}) (λ {(G , H) → (Group.El G , Group.El H)}) _ $
    transport
      (λ q → GroupHom.f ψ == GroupHom.f χ [ (λ {(A , B) → A → B}) ↓ q ])
      (ap2 (λ p q → pair×= p q) (! (group-ua-el (φ₁ , ie₁)))
                                (! (group-ua-el (φ₂ , ie₂)))
       ∙ ! (lemma Group.El Group.El
             (group-ua (φ₁ , ie₁)) (group-ua (φ₂ , ie₂))))
      p
  where
  lemma : ∀ {i j k l} {A : Type i} {B : Type j} {C : Type k} {D : Type l}
    (f : A → C) (g : B → D) {x y : A} {w z : B} (p : x == y) (q : w == z)
    → ap (λ {(a , b) → (f a , g b)}) (pair×= p q)
      == pair×= (ap f p) (ap g q)
  lemma f g idp idp = idp


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

module Definition.Typed.Decidable where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Conversion
open import Definition.Conversion.Decidable
open import Definition.Conversion.Soundness
open import Definition.Conversion.Stability
open import Definition.Conversion.Consequences.Completeness

open import Tools.Nullary

-- Decidability of conversion of well-formed types
dec : ∀ {A B Γ} → Γ ⊢ A → Γ ⊢ B → Dec (Γ ⊢ A ≡ B)
dec ⊢A ⊢B = map soundnessConv↑ completeEq
                (decConv↑ (completeEq (refl ⊢A))
                          (completeEq (refl ⊢B)))

-- Decidability of conversion of well-formed terms
decTerm : ∀ {t u A Γ} → Γ ⊢ t ∷ A → Γ ⊢ u ∷ A → Dec (Γ ⊢ t ≡ u ∷ A)
decTerm ⊢t ⊢u = map soundnessConv↑Term completeEqTerm
                    (decConv↑Term (completeEqTerm (refl ⊢t))
                                  (completeEqTerm (refl ⊢u)))