Compile fix

Compile fix

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c}
    {Carrier : Set c}
    (Change : Carrier → Set c)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v)
    (nil : (u : Carrier) → Change u) : Set (c) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u
    -- This corresponds to Lemma 2.3 from the paper.
    update-nil : ∀ v → update v (nil v) ≡ v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c}
    (Carrier : Set c) : Set (suc c) where
  field
    Change : Carrier → Set c
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    -- This generalizes Def. 2.2. from the paper.
    nil : (u : Carrier) → Change u

    isChangeAlgebra : IsChangeAlgebra Change update diff nil

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} {A : Set a} (P : A → Set p): Set (suc p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

-- XXX not clear this is ever used
instance
  change-algebra-family-inst = change-algebra₍_₎

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

RawChange : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  Set (a ⊔ b)
RawChange f = ∀ a (da : Δ a) → Δ (f a)

IsDerivative : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  (df : RawChange f) →
  Set (a ⊔ b)
IsDerivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of IsDerivative for change algebra families.
RawChange₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) → Set (p ⊔ q)
RawChange₍ x , y ₎ f = ∀ px (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)

IsDerivative₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : RawChange₍_,_₎ x y f) →
  Set (p ⊔ q)
IsDerivative₍_,_₎ {P = P} {{CP}} {{CQ}} x y f df = IsDerivative {{change-algebra₍ _ ₎}} {{change-algebra₍ _ ₎}} f df where
  CPx = change-algebra₍_₎ {{CP}} x
  CQy = change-algebra₍_₎ {{CQ}} y

-- Lemma 2.5 appears in Base.Change.Equivalence.

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

-- For non-abelian groups
module PlainGroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isGroup : IsGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsGroup isGroup
      hiding
        ( refl
        ; sym
        )
      renaming
        ( ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    _⊝_ : A → A → A
    v ⊝ u = (u ⁻¹) ⊕ v

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨⟩
               v ⊕ ((v ⁻¹) ⊕ u)
            ≡⟨  sym (assoc _ _ _) ⟩
               (v ⊕ (v ⁻¹)) ⊕ u
            ≡⟨ proj₂ inverse v ⟨⊕⟩ refl ⟩
               ε ⊕ u
            ≡⟨ proj₁ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} (A : Set a) (B : Set b) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b) where
      field
        -- Definition 2.6a
        apply : RawChange f

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    funDiff : (g f : A → B) → FunctionChange f
    funDiff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g (a ⊞ da ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }

    funUpdate : ∀ (f : A → B) (df : FunctionChange f) → A → B
    funUpdate = λ f df a → f a ⊞ apply df a (nil a)

    funNil : (f : A → B) → FunctionChange f
    funNil = λ f → funDiff f f
    private
      -- Realizer for funNil
      funNil-realizer : (f : A → B) → RawChange f
      funNil-realizer f = λ a da → f (a ⊞ da) ⊟ f a
      -- Note that it cannot use nil (f a), that would not be a correct function change!
      funNil-correct : ∀ f a da → funNil-realizer f a da ≡ apply (funNil f) a da
      funNil-correct f a da = refl

    mutual
      -- I have to write the type of funUpdateDiff without using changeAlgebra,
      -- so I just use the underlying implementations.
      funUpdateDiff : ∀ u v → funUpdate v (funDiff u v) ≡ u
      instance
        changeAlgebraFun : ChangeAlgebra (A → B)

      changeAlgebraFun = record
        { Change = FunctionChange
          -- in the paper, update and diff below are in Def. 2.7
        ; update = funUpdate
        ; diff = funDiff
        ; nil = funNil
        ; isChangeAlgebra = record
            -- the proof of update-diff is the second half of what
            -- we have to prove for Theorem 2.8.
          { update-diff = funUpdateDiff
          ; update-nil = λ v → funUpdateDiff v v
          }
        }
      -- XXX remove mutual recursion by inlining the algebra in here?
      funUpdateDiff = λ g f → ext (λ a →
        begin
          f a ⊞ (g (a ⊞ (nil a)) ⊟ f a)
        ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
          f a ⊞ (g a ⊟ f a)
        ≡⟨ update-diff (g a) (f a) ⟩
          g a
        ∎)

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper. However, the derivative of f is just
    -- the apply component of `nil f`, not the full `nil f`, which also includes
    -- a proof. This is not an issue in the paper, which is formulated in a
    -- proof-irrelevant metalanguage.
    nil-is-derivative : ∀ (f : A → B) →
      IsDerivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

    -- Show that any derivative is a valid function change.

    -- In the paper, this is never actually stated. We just prove that nil
    -- changes are derivatives; the paper keeps talking about "the derivative",
    -- suggesting derivatives are unique. If derivatives were unique, we could
    -- say that the nil change is *the* derivative, hence the derivative is the
    -- nil change (hence also a change).
    --
    -- In fact, derivatives are only unique up to change equivalence and
    -- extensional equality; this is proven in Base.Change.Equivalence.derivative-unique.
    --
    Derivative-is-valid : ∀ {f : A → B} df (IsDerivative-f-df : IsDerivative f df) a da →
      f (a ⊞ da) ⊞ (df (a ⊞ da) (nil (a ⊞ da))) ≡ f a ⊞ df a da
    Derivative-is-valid {f} df IsDerivative-f-df a da rewrite IsDerivative-f-df (a ⊞ da) (nil (a ⊞ da)) | update-nil (a ⊞ da) = sym (IsDerivative-f-df a da)

    DerivativeAsChange : ∀ {f : A → B} {df} (IsDerivative-f-df : IsDerivative f df) → Δ f
    DerivativeAsChange {df = df} IsDerivative-f-df = record { apply = df ; correct = Derivative-is-valid df IsDerivative-f-df }
    -- In Equivalence.agda, derivative-is-nil-alternative then proves that a derivative is also a nil change.

-- Reexport a few members with A and B marked as implicit parameters. This
-- matters especially for changeAlgebra, since otherwise it can't be used for
-- instance search.
module _
    {a} {b} {A : Set a} {B : Set b} {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    open FunctionChanges A B {{CA}} {{CB}} public
      using
        ( changeAlgebraFun
        ; apply
        ; correct
        ; incrementalization
        ; DerivativeAsChange
        ; FunctionChange
        ; nil-is-derivative
        )

module BinaryFunctionChanges
    {a} {b} {c} (A : Set a) (B : Set b) (C : Set c) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} {{CC : ChangeAlgebra C}} where
    incrementalization-binary : ∀ (f : A → B → C) df a da b db →
      (f ⊞ df) (a ⊞ da) (b ⊞ db) ≡ f a b ⊞ apply (apply df a da) b db
    incrementalization-binary f df x dx y dy
      rewrite cong (λ □ → □ (y ⊞ dy)) (incrementalization f df x dx)
      = incrementalization (f x) (apply df x dx) y dy

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ Δ pxs  → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ Δ pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff px′ px) (update-diff-all pxs′ pxs)

    instance
      changeAlgebraListChanges : ChangeAlgebraFamily (All P)

    changeAlgebraListChanges = record
      { change-algebra = λ xs → record
        { Change = All′ Δ
        ; update = update-all
        ; diff = diff-all
        ; nil = λ xs → diff-all xs xs
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          ; update-nil = λ xs₁ → update-diff-all xs₁ xs₁
          }
        }
      }

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c}
    {Carrier : Set c}
    (Change : Carrier → Set c)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v)
    (nil : (u : Carrier) → Change u) : Set (c) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u
    -- This corresponds to Lemma 2.3 from the paper.
    update-nil : ∀ v → update v (nil v) ≡ v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c}
    (Carrier : Set c) : Set (suc c) where
  field
    Change : Carrier → Set c
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    -- This generalizes Def. 2.2. from the paper.
    nil : (u : Carrier) → Change u

    isChangeAlgebra : IsChangeAlgebra Change update diff nil

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} {A : Set a} (P : A → Set p): Set (suc p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

-- XXX not clear this is ever used
instance
  change-algebra-family-inst = change-algebra₍_₎

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

RawChange : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  Set (a ⊔ b)
RawChange f = ∀ a (da : Δ a) → Δ (f a)

IsDerivative : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  (df : RawChange f) →
  Set (a ⊔ b)
IsDerivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of IsDerivative for change algebra families.
RawChange₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) → Set (p ⊔ q)
RawChange₍ x , y ₎ f = ∀ px (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)

IsDerivative₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : RawChange₍_,_₎ x y f) →
  Set (p ⊔ q)
IsDerivative₍_,_₎ {P = P} {{CP}} {{CQ}} x y f df = IsDerivative {{change-algebra₍ _ ₎}} {{change-algebra₍ _ ₎}} f df where
  CPx = change-algebra₍_₎ {{CP}} x
  CQy = change-algebra₍_₎ {{CQ}} y

-- Lemma 2.5 appears in Base.Change.Equivalence.

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isGroup : IsGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsGroup isGroup
      hiding
        ( refl
        ; sym
        )
      renaming
        ( ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    _⊝_ : A → A → A
    v ⊝ u = (u ⁻¹) ⊕ v

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨⟩
               v ⊕ ((v ⁻¹) ⊕ u)
            ≡⟨  sym (assoc _ _ _) ⟩
               (v ⊕ (v ⁻¹)) ⊕ u
            ≡⟨ proj₂ inverse v ⟨⊕⟩ refl ⟩
               ε ⊕ u
            ≡⟨ proj₁ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

module AbelianGroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} (A : Set a) (B : Set b) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b) where
      field
        -- Definition 2.6a
        apply : RawChange f

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    funDiff : (g f : A → B) → FunctionChange f
    funDiff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g (a ⊞ da ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }

    funUpdate : ∀ (f : A → B) (df : FunctionChange f) → A → B
    funUpdate = λ f df a → f a ⊞ apply df a (nil a)

    funNil : (f : A → B) → FunctionChange f
    funNil = λ f → funDiff f f
    private
      -- Realizer for funNil
      funNil-realizer : (f : A → B) → RawChange f
      funNil-realizer f = λ a da → f (a ⊞ da) ⊟ f a
      -- Note that it cannot use nil (f a), that would not be a correct function change!
      funNil-correct : ∀ f a da → funNil-realizer f a da ≡ apply (funNil f) a da
      funNil-correct f a da = refl

    mutual
      -- I have to write the type of funUpdateDiff without using changeAlgebra,
      -- so I just use the underlying implementations.
      funUpdateDiff : ∀ u v → funUpdate v (funDiff u v) ≡ u
      instance
        changeAlgebraFun : ChangeAlgebra (A → B)

      changeAlgebraFun = record
        { Change = FunctionChange
          -- in the paper, update and diff below are in Def. 2.7
        ; update = funUpdate
        ; diff = funDiff
        ; nil = funNil
        ; isChangeAlgebra = record
            -- the proof of update-diff is the second half of what
            -- we have to prove for Theorem 2.8.
          { update-diff = funUpdateDiff
          ; update-nil = λ v → funUpdateDiff v v
          }
        }
      -- XXX remove mutual recursion by inlining the algebra in here?
      funUpdateDiff = λ g f → ext (λ a →
        begin
          f a ⊞ (g (a ⊞ (nil a)) ⊟ f a)
        ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
          f a ⊞ (g a ⊟ f a)
        ≡⟨ update-diff (g a) (f a) ⟩
          g a
        ∎)

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper. However, the derivative of f is just
    -- the apply component of `nil f`, not the full `nil f`, which also includes
    -- a proof. This is not an issue in the paper, which is formulated in a
    -- proof-irrelevant metalanguage.
    nil-is-derivative : ∀ (f : A → B) →
      IsDerivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

    -- Show that any derivative is a valid function change.

    -- In the paper, this is never actually stated. We just prove that nil
    -- changes are derivatives; the paper keeps talking about "the derivative",
    -- suggesting derivatives are unique. If derivatives were unique, we could
    -- say that the nil change is *the* derivative, hence the derivative is the
    -- nil change (hence also a change).
    --
    -- In fact, derivatives are only unique up to change equivalence and
    -- extensional equality; this is proven in Base.Change.Equivalence.derivative-unique.
    --
    Derivative-is-valid : ∀ {f : A → B} df (IsDerivative-f-df : IsDerivative f df) a da →
      f (a ⊞ da) ⊞ (df (a ⊞ da) (nil (a ⊞ da))) ≡ f a ⊞ df a da
    Derivative-is-valid {f} df IsDerivative-f-df a da rewrite IsDerivative-f-df (a ⊞ da) (nil (a ⊞ da)) | update-nil (a ⊞ da) = sym (IsDerivative-f-df a da)

    DerivativeAsChange : ∀ {f : A → B} {df} (IsDerivative-f-df : IsDerivative f df) → Δ f
    DerivativeAsChange {df = df} IsDerivative-f-df = record { apply = df ; correct = Derivative-is-valid df IsDerivative-f-df }
    -- In Equivalence.agda, derivative-is-nil-alternative then proves that a derivative is also a nil change.

-- Reexport a few members with A and B marked as implicit parameters. This
-- matters especially for changeAlgebra, since otherwise it can't be used for
-- instance search.
module _
    {a} {b} {A : Set a} {B : Set b} {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    open FunctionChanges A B {{CA}} {{CB}} public
      using
        ( changeAlgebraFun
        ; apply
        ; correct
        ; incrementalization
        ; DerivativeAsChange
        ; FunctionChange
        ; nil-is-derivative
        )

module BinaryFunctionChanges
    {a} {b} {c} (A : Set a) (B : Set b) (C : Set c) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} {{CC : ChangeAlgebra C}} where
    incrementalization-binary : ∀ (f : A → B → C) df a da b db →
      (f ⊞ df) (a ⊞ da) (b ⊞ db) ≡ f a b ⊞ apply (apply df a da) b db
    incrementalization-binary f df x dx y dy
      rewrite cong (λ □ → □ (y ⊞ dy)) (incrementalization f df x dx)
      = incrementalization (f x) (apply df x dx) y dy

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ Δ pxs  → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ Δ pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff px′ px) (update-diff-all pxs′ pxs)

    instance
      changeAlgebraListChanges : ChangeAlgebraFamily (All P)

    changeAlgebraListChanges = record
      { change-algebra = λ xs → record
        { Change = All′ Δ
        ; update = update-all
        ; diff = diff-all
        ; nil = λ xs → diff-all xs xs
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          ; update-nil = λ xs₁ → update-diff-all xs₁ xs₁
          }
        }
      }


Tests

Tests

{-# OPTIONS -vtc.unquote.decl:20 -vtc.unquote.def:20 #-}
{-# OPTIONS --without-K #-}
open import Level hiding (zero; suc)
open import Data.Unit renaming (⊤ to 𝟙; tt to 0₁)
open import Data.Bool
  using    (not)
  renaming (Bool to 𝟚; false to 0₂; true to 1₂)
open import Data.String.Core using (String)
open import Data.Float       using (Float)
open import Function
open import Data.Fin using (Fin; zero; suc)
open import Data.Nat hiding (_≟_)
open import Data.List using (List; []; _∷_)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl) renaming (_≗_ to _~_)

open import Function.Param.Unary
open import Function.Param.Binary
open import Type.Param.Unary
open import Type.Param.Binary
open import Data.Two.Param.Binary
open import Data.Nat.Param.Binary
open import Reflection.NP
open import Reflection.Param
open import Reflection.Param.Env

module Reflection.Param.Tests where

import Reflection.Printer as Pr
open Pr using (var;con;def;lam;pi;sort;unknown;showTerm;showType;showDef;showFunDef;showClauses)

-- Local "imports" to avoid depending on nplib
private
  postulate
    opaque : ∀ {a b} {A : Set a} {B : Set b} → A → B → B
    -- opaque-rule : ∀ {x} y → opaque x y ≡ y

  ★₀ = Set₀
  ★₁ = Set₁

infixr 1 _[₀→₀]_
_[₀→₀]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₀} (Bₚ : B → Set₀)
            (f : A → B) → Set₀
_[₀→₀]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₀→₁]_
_[₀→₁]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₀→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₁]_
_[₁→₁]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₁→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₂]_
_[₁→₂]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₂} (Bₚ : B → Set₂)
            (f : A → B) → Set₂
_[₁→₂]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

[[Set₀]] : ([Set₀] [₁→₂] [Set₁]) [Set₀]
[[Set₀]] = λ A → A [₀→₁] [Set₀]

{-
EqEnv = {!!}
EqRes = {!!}

eqTerm : EqEnv → Term → Term → EqRes
eqTerm Γ (var x args) (var x₁ args₁) = {!!}
eqTerm Γ (def f₀ args₀) (def f₁ args₁) = {!!}
eqTerm Γ (con c₀ args₀) (con c₁ args₁) = {!!}
eqTerm Γ (lam v t) (lam v' t') = {!!}
eqTerm Γ (pi t₁ t₂) (pi u₁ u₂) = {!!}
eqTerm Γ (sort s₀) (sort s₁) = {!!}
eqTerm Γ (lit l₀) (lit l₁) = {!!}
eqTerm Γ unknown unknown = {!!}
eqTerm Γ (def f args) u = {!!}
--eqTerm Γ (pat-lam cs args) u = {!!}
eqTerm _ _ = ?
-}

{-
import Reflection.Simple as Si
open Si using (var;con;def;lam;pi;sort;unknown;simple;showTerm)
-}

_≡-no-hints_ : Term → Term → Set
t ≡-no-hints u = noHintsTerm t ≡ noHintsTerm u

_≡-def-no-hints_ : Definition → Definition → Set
t ≡-def-no-hints u = noHintsDefinition t ≡ noHintsDefinition u

p[Set₀]-type = param-type-by-name (ε 1) (quote [Set₀])
p[Set₀] = param-clauses-by-name (ε 1) (quote [Set₀])
q[[Set₀]] = definition (quote [[Set₀]]) -- quoteTerm [[Set₀]]
test-type-p[Set₀] : ([Set₀] [₁→₂] [Set₁]) [Set₀] ≡ unquote (unEl p[Set₀]-type)
test-type-p[Set₀] = refl
test-term-p[Set₀] : quoteTerm [[Set₀]] ≡-no-hints Get-term.from-clauses p[Set₀]
test-term-p[Set₀] = refl
u-p[Set₀] : ([Set₀] [₁→₂] [Set₁]) [Set₀]
unquoteDef u-p[Set₀] = p[Set₀]

False : Set₁
False = (A : Set) → A

param1-False-type = param-type-by-name (ε 1) (quote False)
param1-False-term = param-term-by-name (ε 1) (quote False)

param1-False-type-check : [Set₁] False ≡ unquote (unEl param1-False-type)
param1-False-type-check = refl

[False] : unquote (unEl param1-False-type)
[False] = unquote param1-False-term

[Level] : [Set₀] Level
[Level] _ = 𝟙

[String] : [Set₀] String
[String] _ = 𝟙

[Float] : [Set₀] Float
[Float] _ = 𝟙

-- Levels are parametric, hence the relation is total
⟦Level⟧ : ⟦Set₀⟧ Level Level
⟦Level⟧ _ _ = 𝟙

⟦String⟧ : ⟦Set₀⟧ String String
⟦String⟧ = _≡_

⟦Float⟧ : ⟦Set₀⟧ Float Float
⟦Float⟧ = _≡_

data [𝟚] : [Set₀] 𝟚 where
  [0₂] : [𝟚] 0₂
  [1₂] : [𝟚] 1₂

data [ℕ] : [Set₀] ℕ where
  [zero] : [ℕ] zero
  [suc]  : ([ℕ] [→] [ℕ]) suc

[pred] : ([ℕ] [→] [ℕ]) pred
[pred] [zero]     = [zero]
[pred] ([suc] xₚ) = xₚ

defDefEnv1 : Name → Name
defDefEnv1 (quote 𝟚)      = quote [𝟚]
defDefEnv1 (quote ℕ)      = quote [ℕ]
defDefEnv1 (quote String) = quote [String]
defDefEnv1 (quote Float)  = quote [Float]
defDefEnv1 (quote ★₀)     = quote [Set₀]
defDefEnv1 (quote ★₁)     = quote [Set₁]
defDefEnv1 (quote False)  = quote [False]
defDefEnv1 (quote Level)  = quote [Level]
defDefEnv1 n              = opaque "defDefEnv1" n

defConEnv1 : Name → Name
defConEnv1 (quote 0₂)         = quote [0₂]
defConEnv1 (quote 1₂)         = quote [1₂]
defConEnv1 (quote ℕ.zero)     = quote [zero]
defConEnv1 (quote ℕ.suc)      = quote [suc]
defConEnv1 (quote Level.zero) = quote 0₁
defConEnv1 (quote Level.suc)  = quote 0₁
defConEnv1 n                  = opaque "defConEnv1" n

defDefEnv2 : Name → Name
defDefEnv2 (quote 𝟚)      = quote ⟦𝟚⟧
defDefEnv2 (quote ℕ)      = quote ⟦ℕ⟧
defDefEnv2 (quote ★₀)     = quote ⟦Set₀⟧
defDefEnv2 (quote ★₁)     = quote ⟦Set₁⟧
defDefEnv2 (quote String) = quote ⟦String⟧
defDefEnv2 (quote Float)  = quote ⟦Float⟧
defDefEnv2 (quote Level)  = quote ⟦Level⟧
defDefEnv2 n              = opaque "defDefEnv" n

defConEnv2 : Name → Name
defConEnv2 (quote 0₂)         = quote ⟦0₂⟧
defConEnv2 (quote 1₂)         = quote ⟦1₂⟧
defConEnv2 (quote ℕ.zero)     = quote ⟦ℕ⟧.⟦zero⟧
defConEnv2 (quote ℕ.suc)      = quote ⟦ℕ⟧.⟦suc⟧
defConEnv2 (quote Level.zero) = quote 0₁
defConEnv2 (quote Level.suc)  = quote 0₁
defConEnv2 n                  = opaque "defConEnv2" n

defEnv0 : Env' 0
defEnv0 = record (ε 0)
                 { pConT = con
                 ; pConP = con
                 ; pDef  = id }

defEnv1 : Env' 1
defEnv1 = record (ε 1)
  { pConP = con ∘′ defConEnv1
  ; pConT = con ∘′ defConEnv1
  ; pDef = defDefEnv1 }

defEnv2 : Env' 2
defEnv2 = record (ε 2)
  { pConP = con ∘′ defConEnv2
  ; pConT = con ∘′ defConEnv2
  ; pDef = defDefEnv2 }

param1-[False]-type = param-type-by-name defEnv1 (quote [False])
param1-[False]-term = param-term-by-name defEnv1 (quote [False])

{-
module Const where
  postulate
    A  : Set₀
    Aᵣ : A → A → Set₀
  data Wrapper : Set where
    wrap : A → Wrapper

  idWrapper : Wrapper → Wrapper
  idWrapper (wrap x) = wrap x

  data ⟦Wrapper⟧ : Wrapper → Wrapper → Set₀ where
    ⟦wrap⟧ : (Aᵣ ⟦→⟧ ⟦Wrapper⟧) wrap wrap

  wrapperEnv = record (ε 2)
   { pDef = [ quote Wrapper       ≔ quote ⟦Wrapper⟧  ] id
   ; pConP = [ quote Wrapper.wrap ≔ con (quote ⟦Wrapper⟧.⟦wrap⟧) ] con
   ; pConT = [ quote Wrapper.wrap ≔ con (quote ⟦Wrapper⟧.⟦wrap⟧) ] con
   }

  unquoteDecl ⟦idWrapper⟧ = param-rec-def-by-name wrapperEnv (quote idWrapper) ⟦idWrapper⟧
-}

data Wrapper (A : Set₀) : Set₀ where
  wrap : A → Wrapper A

idWrapper : ∀ {A} → Wrapper A → Wrapper A
idWrapper (wrap x) = wrap x

data [Wrapper] {A : Set} (Aₚ : A → Set₀)
   : Wrapper A → Set₀ where
  [wrap] : (Aₚ [→] [Wrapper] Aₚ) wrap

[Wrapper]-env = record (ε 1)
  { pDef = [ quote Wrapper ≔ quote [Wrapper] ] id
  ; pConP = [ quote wrap ≔ con (quote [wrap])  ] con
  ; pConT = [ quote wrap ≔ conSkip' 2 (quote [wrap]) ] con
  }

unquoteDecl [idWrapper] =
  param-rec-def-by-name [Wrapper]-env (quote idWrapper) [idWrapper]

  {-
[idWrapper] = {!  param-rec-def-by-name [Wrapper]-env (quote idWrapper) [idWrapper]!}
-- [idWrapper] = {!  param-rec-def-by-name [Wrapper]-env (quote idWrapper) [idWrapper]!}
-}

{-
-- The generated type bigger since it is a familly for no reason.
data ⟦Wrapper⟧ : (⟦Set₀⟧ ⟦→⟧ ⟦Set₁⟧) Wrapper Wrapper

private
  ⟦Wrapper⟧-ctor = λ c → unEl (param-ctor-by-name (extDefEnv [ quote Wrapper ≔ quote ⟦Wrapper⟧ ] (ε 2)) c)

data ⟦Wrapper⟧ where
  ⟦wrap⟧ : unquote (⟦Wrapper⟧-ctor (quote Wrapper.wrap))
-}
data ⟦Wrapper⟧ {A₀ A₁ : Set} (Aᵣ : A₀ → A₁ → Set₀)
   : Wrapper A₀ → Wrapper A₁ → Set₀ where
  ⟦wrap⟧ : (Aᵣ ⟦→⟧ ⟦Wrapper⟧ Aᵣ) wrap wrap

⟦Wrapper⟧-env = record (ε 2)
  { pDef = [ quote Wrapper ≔ quote ⟦Wrapper⟧ ] id
  ; pConP = [ quote wrap ≔ con (quote ⟦wrap⟧)  ] con
  ; pConT = [ quote wrap ≔ conSkip' 3 (quote ⟦wrap⟧) ] con
  }

⟦idWrapper⟧1 : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦Wrapper⟧ A ⟦→⟧ ⟦Wrapper⟧ A) idWrapper idWrapper
⟦idWrapper⟧1 {x0} {x1} (x2) {._} {._} (⟦wrap⟧ {x3} {x4} x5)
  = ⟦wrap⟧ {_} {_} {_} {x3} {x4} x5

⟦idWrapper⟧-clauses =
  clause
  (arg (arg-info hidden  relevant) (var "A0") ∷
   arg (arg-info hidden  relevant) (var "A1") ∷
   arg (arg-info visible relevant) (var "Ar") ∷
   arg (arg-info hidden  relevant) dot ∷
   arg (arg-info hidden  relevant) dot ∷
   arg (arg-info visible relevant)
   (con (quote ⟦wrap⟧)
    (arg (arg-info hidden  relevant) (var "x0") ∷
     arg (arg-info hidden  relevant) (var "x1") ∷
     arg (arg-info visible relevant) (var "xr") ∷ []))
   ∷ [])
  (con (quote ⟦wrap⟧)
   (arg (arg-info hidden relevant) unknown ∷
    arg (arg-info hidden relevant) unknown ∷
    arg (arg-info hidden relevant) unknown ∷
    arg (arg-info hidden relevant)  (var 2 []) ∷
    arg (arg-info hidden relevant)  (var 1 []) ∷
    arg (arg-info visible relevant) (var 0 []) ∷ []))
  ∷ []

⟦idWrapper⟧2 : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦Wrapper⟧ A ⟦→⟧ ⟦Wrapper⟧ A) idWrapper idWrapper
unquoteDef ⟦idWrapper⟧2 = ⟦idWrapper⟧-clauses

unquoteDecl ⟦idWrapper⟧ =
  param-rec-def-by-name ⟦Wrapper⟧-env (quote idWrapper) ⟦idWrapper⟧

data Bot (A : Set₀) : Set₀ where
  bot : Bot A → Bot A

gobot : ∀ {A} → Bot A → A
gobot (bot x) = gobot x

data [Bot] {A : Set} (Aₚ : A → Set₀)
   : Bot A → Set₀ where
  [bot] : ([Bot] Aₚ [→] [Bot] Aₚ) bot

[Bot]-env = record (ε 1)
  { pDef = [ quote Bot ≔ quote [Bot] ] id
  ; pConP = [ quote bot ≔ con (quote [bot])  ] con
  ; pConT = [ quote bot ≔ conSkip' 2 (quote [bot]) ] con
  }

[gobot]' : (∀⟨ A ∶ [Set₀] ⟩[→] [Bot] A [→] A) gobot
[gobot]' {x0} (x1) {._} ([bot] {x2} x3)
  = [gobot]' {x0} x1 {x2} x3

-- [gobot]' = {!showClauses "[gobot]'" (param-rec-clauses-by-name [Bot]-env (quote gobot) (quote [gobot]'))!}

[gobot]2 : (∀⟨ A ∶ [Set₀] ⟩[→] [Bot] A [→] A) gobot

[gobot]2-clauses =
  clause
    (arg (arg-info hidden  relevant) (var "Aᵢ0") ∷
     arg (arg-info visible relevant) (var "Aᵣ") ∷
     arg (arg-info hidden  relevant) dot ∷
     arg (arg-info visible relevant)
     (con (quote [bot])
      (arg (arg-info hidden  relevant) (var "xᵢ0") ∷
       arg (arg-info visible relevant) (var "xᵣ") ∷ []))
     ∷ [])
    (def (quote [gobot]2)
     (arg (arg-info hidden  relevant) (var 4 []) ∷
      arg (arg-info visible relevant) (var 3 []) ∷
      arg (arg-info hidden  relevant) (var 1 []) ∷
      arg (arg-info visible relevant) (var 0 []) ∷ []))
    ∷ []

unquoteDef [gobot]2 = [gobot]2-clauses

unquoteDecl [gobot] =
  param-rec-def-by-name [Bot]-env (quote gobot) [gobot]

data ⟦Bot⟧ {A₀ A₁ : Set} (Aᵣ : A₀ → A₁ → Set₀)
   : Bot A₀ → Bot A₁ → Set₀ where
  ⟦bot⟧ : (⟦Bot⟧ Aᵣ ⟦→⟧ ⟦Bot⟧ Aᵣ) bot bot

⟦Bot⟧-env = record (ε 2)
  { pDef = [ quote Bot ≔ quote ⟦Bot⟧ ] id
  ; pConP = [ quote bot ≔ con (quote ⟦bot⟧)  ] con
  ; pConT = [ quote bot ≔ conSkip' 3 (quote ⟦bot⟧) ] con
  }

⟦gobot⟧1 : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦Bot⟧ A ⟦→⟧ A) gobot gobot
⟦gobot⟧1 {x0} {x1} x2 {._} {._} (⟦bot⟧ {x3} {x4} x5)
  = ⟦gobot⟧1 {x0} {x1} x2 {x3} {x4} x5

unquoteDecl ⟦gobot⟧ =
  param-rec-def-by-name ⟦Bot⟧-env (quote gobot) ⟦gobot⟧

id₀ : {A : Set₀} → A → A
id₀ x = x

⟦id₀⟧ : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ A ⟦→⟧ A) id₀ id₀
⟦id₀⟧ = λ {x₁} {x₂} xᵣ {x₃} {x₄} xᵣ₁ → xᵣ₁

data List₀ (A : Set) : Set where
  []  : List₀ A
  _∷_ : A → List₀ A → List₀ A

map₀ : ∀ {A B} (f : A → B) (xs : List₀ A) → List₀ B
map₀ f []       = []
map₀ f (x ∷ xs) = f x ∷ map₀ f xs

idList₀ : ∀ {A} → List₀ A → List₀ A
-- idList₀ : List₀ ℕ → List₀ ℕ
idList₀ []       = []
idList₀ {A} (x ∷ xs) = idList₀ {A} xs

data ⟦List₀⟧ {A₀ A₁ : Set} (Aᵣ : A₀ → A₁ → Set₀) : List₀ A₀ → List₀ A₁ → Set₀ where
  ⟦[]⟧  : ⟦List₀⟧ Aᵣ [] []
  _⟦∷⟧_ : (Aᵣ ⟦→⟧ ⟦List₀⟧ Aᵣ ⟦→⟧ ⟦List₀⟧ Aᵣ) _∷_ _∷_

con⟦List₀⟧ = conSkip' 3
⟦List₀⟧-env = record (ε 2)
  { pDef = [ quote List₀ ≔ quote ⟦List₀⟧ ] id
  ; pConP = [ quote List₀.[]  ≔ con (quote ⟦List₀⟧.⟦[]⟧)  ]
           ([ quote List₀._∷_ ≔ con (quote ⟦List₀⟧._⟦∷⟧_) ]
            con)
  ; pConT = [ quote List₀.[]  ≔ con⟦List₀⟧ (quote ⟦List₀⟧.⟦[]⟧)  ]
           ([ quote List₀._∷_ ≔ con⟦List₀⟧ (quote ⟦List₀⟧._⟦∷⟧_) ]
            con)
  }

⟦idList₀⟧ : unquote (unEl (param-type-by-name ⟦List₀⟧-env (quote idList₀)))
-- ⟦idList₀⟧ : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦List₀⟧ A ⟦→⟧ ⟦List₀⟧ A) idList₀ idList₀
unquoteDef ⟦idList₀⟧ = param-rec-clauses-by-name ⟦List₀⟧-env (quote idList₀) (quote ⟦idList₀⟧)

{-
⟦map₀⟧ : {x0 : Set0} → {x1 : Set0} → (x2 : (x2 : x0) → (x3 : x1) → Set0) → {x3 : Set0} → {x4 : Set0} → (x5 : (x5 : x3) → (x6 : x4) → Set0) → {x6 : (x6 : x0) → x3} → {x7 : (x7 : x1) → x4} → (x8 : {x8 : x0} → {x9 : x1} → (x10 : x2 (x8) (x9)) → x5 (x6 (x8)) (x7 (x9))) → {x9 : List₀ (x0)} → {x10 : List₀ (x1)} → (x11 : ⟦List₀⟧ {x0} {x1} (x2) (x9) (x10)) → ⟦List₀⟧ {x3} {x4} (x5) (map₀ {x0} {x3} (x6) (x9)) (map₀ {x1} {x4} (x7) (x10))
⟦map₀⟧ {x0} {x1} (x2) {x3} {x4} (x5) {x6} {x7} (x8) {._} {._} (⟦[]⟧ )  = ⟦[]⟧
⟦map₀⟧ {x0} {x1} (x2) {x3} {x4} (x5) {x6} {x7} (x8) {._} {._} (_⟦∷⟧_ {x11} {x12} (x13) {x14} {x15} (x16) )  = _⟦∷⟧_ {x6 (x11)} {x7 (x12)} (x8 {x11} {x12} (x13)) {map₀ {x0} {x3} (x6) (x14)} {map₀ {x1} {x4} (x7) (x15)} (⟦map₀⟧ {x0} {x1} (x2) {x3} {x4} (x5) {x6} {x7} (x8) {x14} {x15} (x16))
-}

unquoteDecl ⟦map₀⟧
 = param-rec-def-by-name ⟦List₀⟧-env (quote map₀) ⟦map₀⟧

{-
map-nat : ∀ (f : ∀ {X} → List₀ X → List₀ X)
            {A B : Set} (g : A → B)
          → f ∘ map₀ g ~ map₀ g ∘ f
map-nat f g x = {!⟦map₀⟧ _≡_ _≡_ {g}!}

  -- The generated type is bigger since it is a familly for no reason.
  data ⟦List₀⟧ : (⟦Set₀⟧ ⟦→⟧ ⟦Set₁⟧) List₀ List₀

  private
    ⟦List₀⟧-ctor = λ c → unEl (param-ctor-by-name (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2)) c)

  data ⟦List₀⟧ where
    ⟦[]⟧  : unquote (⟦List₀⟧-ctor (quote List₀.[]))
    _⟦∷⟧_ : unquote (⟦List₀⟧-ctor (quote List₀._∷_))

  ⟦List₀⟧-env = extConEnv ([ quote List₀.[]  ≔ quote ⟦List₀⟧.⟦[]⟧  ] ∘
                        [ quote List₀._∷_ ≔ quote ⟦List₀⟧._⟦∷⟧_ ])
             (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2))
-}

data Maybe' (A : Set) : Set₁ where
  nothing : Maybe' A
  just    : A → Maybe' A

{-
-- Set₁ is here because ⟦List₀⟧ is not using parameters, hence gets bigger.
-- This only happens without-K given the new rules for data types.
data List₀ : (A : Set) → Set₁ where
  []  : ∀ {A} → List₀ A
  _∷_ : ∀ {A} → A → List₀ A → List₀ A

map₀ : ∀ {A B} → (A → B) → List₀ A → List₀ B
map₀ f []       = []
map₀ f (x ∷ xs) = f x ∷ map₀ f xs

idList₀ : ∀ {A} → List₀ A → List₀ A
idList₀ []       = []
idList₀ (x ∷ xs) = x ∷ idList₀ xs

-- The generated type bigger since it is a familly for no reason.
data ⟦List₀⟧ : (⟦Set₀⟧ ⟦→⟧ ⟦Set₁⟧) List₀ List₀

private
  ⟦List₀⟧-ctor = λ c → unEl (param-ctor-by-name (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2)) c)

data ⟦List₀⟧ where
  ⟦[]⟧  : unquote (⟦List₀⟧-ctor (quote List₀.[]))
  _⟦∷⟧_ : unquote (⟦List₀⟧-ctor (quote List₀._∷_))

⟦List₀⟧-env = extConEnv ([ quote List₀.[]  ≔ quote ⟦List₀⟧.⟦[]⟧  ] ∘
                      [ quote List₀._∷_ ≔ quote ⟦List₀⟧._⟦∷⟧_ ])
           (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2))

-- test = ⟦[]⟧ {{!showType (type (quote List₀.[]))!}} {{!!}} {!!}
-}

{-
⟦idList₀⟧ : unquote (unEl (param-type-by-name ⟦List₀⟧-env (quote idList₀)))
unquoteDef ⟦idList₀⟧ = param-rec-clauses-by-name ⟦List₀⟧-env (quote idList₀) (quote ⟦idList₀⟧)
-}

{-
⟦map₀⟧ : unquote (unEl (param-type-by-name ⟦List₀⟧-env (quote map₀)))
⟦map₀⟧ {x} {x₁} {x₂} {x₃} {x₄} {x₅} {x₆} {x₇} x₈ {[]} {[]} ⟦[]⟧
  = ⟦[]⟧
⟦map₀⟧ {x} {x₁} {x₂} {x₃} {x₄} {x₅} {x₆} {x₇} x₈ {._ ∷ ._}
  {._ ∷ ._}
  (_⟦∷⟧_ {x₁₃} {x₁₄} x₁₅ {x₁₆} {x₁₇} x₁₈)
  = _⟦∷⟧_ {x₁₀ x₁₃} {x₁₁ x₁₄} (x₁₂ {x₁₃} {x₁₄} x₁₅)
    {map₀ {x₄} {x₇} x₁₀ x₁₆} {map₀ {x₅} {x₈} x₁₁ x₁₇}
    (⟦map₀⟧ {x₄} {x₅} {x₆} {x₇} {x₈} {x₉} {x₁₀} {x₁₁} x₁₂ {x₁₆} {x₁₇}
     x₁₈)
-}

{-
unquoteDef ⟦map₀⟧ = param-rec-clauses-by-name ⟦List₀⟧-env (quote map₀) (quote ⟦map₀⟧)
-}

{-
foo : {x0 : Set0} → {x1 : Set0} → (x2 : (x2 : x0) → (x3 : x1) → Set0) → {x3 : Set0} → {x4 : Set0} → (x5 : (x5 : x3) → (x6 : x4) → Set0) → {x6 : (x6 : x0) → x3} → {x7 : (x7 : x1) → x4} → (x8 : {x8 : x0} → {x9 : x1} → (x10 : x2 (x8) (x9)) → x5 (x6 (x8)) (x7 (x9))) → {x9 : Reflection.Param.List₀ (x0)} → {x10 : Reflection.Param.List₀ (x1)} → (x11 : Reflection.Param.⟦List₀⟧ {x0} {x1} (x2) (x9) (x10)) → Reflection.Param.⟦List₀⟧ {x3} {x4} (x5) (Reflection.Param.map₀ {x0} {x3} (x6) (x9)) (Reflection.Param.map₀ {x1} {x4} (x7) (x10))
foo {A} {A} (A) {B} {B} (B) {f} {f} (f) {._} {._} (Reflection.Param.⟦List₀⟧.⟦[]⟧ )  = Reflection.Param.⟦List₀⟧.⟦[]⟧
foo {A} {A} (A) {B} {B} (B) {f} {f} (f) {._} {._} (Reflection.Param.⟦List₀⟧._⟦∷⟧_ {x} {x} (x) {xs} {xs} (xs) )  = Reflection.Param.⟦List₀⟧._⟦∷⟧_ {x0 (x0)} {x0 (x0)} (x0 {x0} {x0} (x0)) {Reflection.Param.map₀ {x0} {x0} (x0) (x0)} {Reflection.Param.map₀ {x0} {x0} (x0) (x0)} (Reflection.Param.test' {x0} {x0} (x0) {x0} {x0} (x0) {x0} {x0} (x0) {x0} {x0} (x0))
-}

-- test' = {! showFunDef "foo" (param-rec-def-by-name ⟦List₀⟧-env (quote map₀) (quote test'))!}

open import Function.Param.Unary

revealed-[→] = Reveal-args.nåme (quote _[₀→₀]_)

revealed-[→]' : ∀ (A : Set₀) (Aₚ : A → Set₀)
                  (B : Set₀) (Bₚ : B → Set₀)
                  (f : A → B) → Set₀
unquoteDef revealed-[→]' = Get-clauses.from-def revealed-[→]

revelator-[→] : ({A : Set} (Aₚ : A → Set) {B : Set} (Bₚ : B → Set) (f : A → B) → Set)
              →  (A : Set) (Aₚ : A → Set) (B : Set) (Bₚ : B → Set) (f : A → B) → Set
unquoteDef revelator-[→] = Revelator.clauses (type (quote _[₀→₀]_))

p-[→]-type = param-type-by-name    (ε 1) (quote _[₀→₀]_)
p-[→]      = param-clauses-by-name (ε 1) (quote _[₀→₀]_)

p-[→]' = ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
           {Aₚ : A → Set₀}  (A₁ₚ : {x : A} → A₀ₚ x → Aₚ x → Set₀)
           {B : Set₀}       (B₀ₚ : B → Set₀)
           {Bₚ : B → Set₀}  (B₁ₚ : {x : B} → B₀ₚ x → Bₚ x → Set₀)
           {f : A → B}      (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
         → (Aₚ [₀→₀] Bₚ) f
         → Set

p-[→]'-test : p-[→]' ≡ unquote (unEl p-[→]-type)
p-[→]'-test = refl

[[→]] : unquote (unEl p-[→]-type)
unquoteDef [[→]] = p-[→]

data [[ℕ]] : [[Set₀]] [ℕ] [ℕ] where
  [[zero]] : [[ℕ]] [zero] [zero]
  [[suc]]  : [[→]] [ℕ] [[ℕ]] [ℕ] [[ℕ]] [suc] [suc]

_/2 : ℕ → ℕ
zero        /2 = zero
suc zero    /2 = zero
suc (suc n) /2 = suc (n /2)

_⟦/2⟧ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _/2 _/2
⟦zero⟧          ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ ⟦zero⟧    ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ (⟦suc⟧ n) ⟦/2⟧ = ⟦suc⟧ (n ⟦/2⟧)

_+ℕ_ : ℕ → ℕ → ℕ
zero  +ℕ n = n
suc m +ℕ n = suc (m +ℕ n)

pred' : ℕ → ℕ
pred' = λ { zero    → zero
          ; (suc m) → m }

⟦pred'⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) pred' pred'
unquoteDef ⟦pred'⟧ = param-clauses-by-name defEnv2 (quote pred')

_⟦+ℕ⟧_ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _+ℕ_ _+ℕ_
⟦zero⟧  ⟦+ℕ⟧ n = n
⟦suc⟧ m ⟦+ℕ⟧ n = ⟦suc⟧ (m ⟦+ℕ⟧ n)

⟦⟦Set₀⟧⟧ : (⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₁⟧) ⟦Set₀⟧ ⟦Set₀⟧
⟦⟦Set₀⟧⟧ = λ A₀ A₁ → A₀ ⟦₀→₁⟧ A₁ ⟦₀→₁⟧ ⟦Set₀⟧

⟦⟦Set₀⟧⟧' : {x₁ x₂ : Set} (xᵣ : x₁ → x₂ → Set) {x₃ : Set} {x₄ : Set}
            (xᵣ₁ : x₃ → x₄ → Set) →
            (x₁ → x₃ → Set) → (x₂ → x₄ → Set) → Set₁
⟦⟦Set₀⟧⟧' = λ A₀ A₁ f₁ f₂ →
  ∀ {x₁} {x₂} (xᵣ : A₀ x₁ x₂)
    {x₃} {x₄} (xᵣ₁ : A₁ x₃ x₄) →
    f₁ x₁ x₃ → f₂ x₂ x₄ → Set

-- Since quoteTerm normalises
test-⟦⟦Set₀⟧⟧ : quoteTerm ⟦⟦Set₀⟧⟧ ≡-no-hints quoteTerm ⟦⟦Set₀⟧⟧'
test-⟦⟦Set₀⟧⟧ = refl

⟦⟦Set₀⟧⟧-type = unquote (unEl (type (quote ⟦⟦Set₀⟧⟧)))
test-⟦⟦Set₀⟧⟧-type : ⟦⟦Set₀⟧⟧-type ≡ unquote (unEl (type (quote ⟦⟦Set₀⟧⟧')))
test-⟦⟦Set₀⟧⟧-type = refl

pSet₀ = pTerm defEnv2 `★₀
ppSet₀ = pTerm defEnv2 pSet₀
p⟦Set₀⟧ = param-clauses-by-name defEnv2 (quote ⟦Set₀⟧)
test-pSet₀ : pSet₀ ≡-no-hints quoteTerm ⟦Set₀⟧
test-pSet₀ = refl
test-ppSet₀ : ppSet₀ ≡-no-hints quoteTerm ⟦⟦Set₀⟧⟧
test-ppSet₀ = refl
test-ppSet₀'' : ppSet₀ ≡-no-hints Get-term.from-clauses p⟦Set₀⟧
test-ppSet₀'' = refl

⟦⟦Set₀⟧⟧'' : (⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₁⟧) ⟦Set₀⟧ ⟦Set₀⟧
unquoteDef ⟦⟦Set₀⟧⟧'' = p⟦Set₀⟧

test-⟦⟦Set₀⟧⟧'' : _≡_ {A = ⟦⟦Set₀⟧⟧-type} ⟦⟦Set₀⟧⟧'' ⟦⟦Set₀⟧⟧
test-⟦⟦Set₀⟧⟧'' = refl

test-p0-⟦Set₀⟧ : pTerm defEnv0 (quoteTerm ⟦Set₀⟧) ≡-no-hints quoteTerm ⟦Set₀⟧
test-p0-⟦Set₀⟧ = refl

data ⟦⟦𝟚⟧⟧ : (⟦⟦Set₀⟧⟧ ⟦𝟚⟧ ⟦𝟚⟧) ⟦𝟚⟧ ⟦𝟚⟧ where
  ⟦⟦0₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧
  ⟦⟦1₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧

p1ℕ→ℕ = pTerm defEnv1 (quoteTerm (ℕ → ℕ))
[ℕ→ℕ] = [ℕ] [→] [ℕ]
test-p1ℕ→ℕ : unquote p1ℕ→ℕ ≡ [ℕ→ℕ]
test-p1ℕ→ℕ = refl

p2ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ))
⟦ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
test-p2ℕ→ℕ : unquote p2ℕ→ℕ ≡ ⟦ℕ→ℕ⟧
test-p2ℕ→ℕ = refl

pℕ→ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ → ℕ))
⟦ℕ→ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
test-pℕ→ℕ→ℕ : pℕ→ℕ→ℕ ≡-no-hints quoteTerm ⟦ℕ→ℕ→ℕ⟧
test-pℕ→ℕ→ℕ = refl
ZERO : Set₁
ZERO = (A : Set₀) → A
⟦ZERO⟧ : ZERO → ZERO → Set₁
⟦ZERO⟧ f₀ f₁ =
  {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
  → Aᵣ (f₀ A₀) (f₁ A₁)
pZERO = pTerm (ε 2) (quoteTerm ZERO)
q⟦ZERO⟧ = quoteTerm ⟦ZERO⟧
test-pZERO : pZERO ≡-no-hints q⟦ZERO⟧
test-pZERO = refl
ID : Set₁
ID = (A : Set₀) → A → A
⟦ID⟧ : ID → ID → Set₁
⟦ID⟧ f₀ f₁ =
  {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
  {x₀ : A₀} {x₁ : A₁} (x : Aᵣ x₀ x₁)
  → Aᵣ (f₀ A₀ x₀) (f₁ A₁ x₁)
pID = pTerm (ε 2) (quoteTerm ID)
q⟦ID⟧ = quoteTerm ⟦ID⟧
test-ID : q⟦ID⟧ ≡-no-hints pID
test-ID = refl

⟦not⟧' : (⟦𝟚⟧ ⟦→⟧ ⟦𝟚⟧) not not
unquoteDef ⟦not⟧' = param-clauses-by-name defEnv2 (quote not)
test-not : ∀ {x₀ x₁ : 𝟚} (xᵣ : ⟦𝟚⟧ x₀ x₁) → ⟦not⟧ xᵣ ≡ ⟦not⟧' xᵣ
test-not ⟦0₂⟧ = refl
test-not ⟦1₂⟧ = refl

[pred]' : ([ℕ] [→] [ℕ]) pred
unquoteDef [pred]' = param-clauses-by-name defEnv1 (quote pred)

test-p1-pred : ∀ {n} (nₚ : [ℕ] n) → [pred]' nₚ ≡ [pred] nₚ
test-p1-pred [zero]     = refl
test-p1-pred ([suc] nₚ) = refl

⟦pred⟧' : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) pred pred
unquoteDef ⟦pred⟧' = param-clauses-by-name defEnv2 (quote pred)

test-p2-pred : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → ⟦pred⟧' nᵣ ≡ ⟦pred⟧ nᵣ
test-p2-pred ⟦zero⟧     = refl
test-p2-pred (⟦suc⟧ nᵣ) = refl

p/2 = param-rec-def-by-name defEnv2 (quote _/2)
q⟦/2⟧ = definition (quote _⟦/2⟧)
unquoteDecl _⟦/2⟧' = p/2 _⟦/2⟧'
test-/2 : function (p/2 (quote _⟦/2⟧)) ≡-def-no-hints q⟦/2⟧
test-/2 = refl
test-/2' : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → nᵣ ⟦/2⟧' ≡ nᵣ ⟦/2⟧
test-/2' ⟦zero⟧ = refl
test-/2' (⟦suc⟧ ⟦zero⟧) = refl
test-/2' (⟦suc⟧ (⟦suc⟧ nᵣ)) rewrite test-/2' nᵣ = refl

p+ = param-rec-def-by-name defEnv2 (quote _+ℕ_)
q⟦+⟧ = definition (quote _⟦+ℕ⟧_)
unquoteDecl _⟦+⟧'_ = p+ _⟦+⟧'_
test-+ : function (p+ (quote _⟦+ℕ⟧_)) ≡-def-no-hints q⟦+⟧
test-+ = refl
test-+' : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) {n'₀ n'₁} (n'ᵣ : ⟦ℕ⟧ n'₀ n'₁) → nᵣ ⟦+⟧' n'ᵣ ≡ nᵣ ⟦+ℕ⟧ n'ᵣ
test-+' ⟦zero⟧    n'ᵣ = refl
test-+' (⟦suc⟧ nᵣ) n'ᵣ rewrite test-+' nᵣ n'ᵣ = refl

{-
is-good : String → 𝟚
is-good "good" = 1₂
is-good _      = 0₂

⟦is-good⟧ : (⟦String⟧ ⟦₀→₀⟧ ⟦𝟚⟧) is-good is-good
⟦is-good⟧ {"good"} refl = ⟦1₂⟧
⟦is-good⟧ {_}      refl = {!!}

my-good = unquote (lit (string "good"))
my-good-test : my-good ≡ "good"
my-good-test = refl
-}

{-
⟦is-good⟧' : (⟦String⟧ ⟦₀→₀⟧ ⟦𝟚⟧) is-good is-good
unquoteDef ⟦is-good⟧' = param-clauses-by-name defEnv2 (quote is-good)
test-is-good = {!!}
-}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS -vtc.unquote.decl:20 -vtc.unquote.def:20 #-}
{-# OPTIONS --without-K #-}
open import Level hiding (zero; suc)
open import Data.Unit renaming (⊤ to 𝟙; tt to 0₁)
open import Data.Bool
  using    (not)
  renaming (Bool to 𝟚; false to 0₂; true to 1₂)
open import Data.String.Core using (String)
open import Data.Float       using (Float)
open import Function
open import Data.Fin using (Fin; zero; suc)
open import Data.Nat hiding (_≟_)
open import Data.List using (List; []; _∷_)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl) renaming (_≗_ to _~_)

open import Function.Param.Unary
open import Function.Param.Binary
open import Type.Param.Unary
open import Type.Param.Binary
open import Data.Two.Param.Binary
open import Data.Nat.Param.Binary
open import Reflection.NP
open import Reflection.Param
open import Reflection.Param.Env

module Reflection.Param.Tests where

import Reflection.Printer as Pr
open Pr using (var;con;def;lam;pi;sort;unknown;showTerm;showType;showDef;showFunDef;showClauses)

-- Local "imports" to avoid depending on nplib
private
  postulate
    opaque : ∀ {a b} {A : Set a} {B : Set b} → A → B → B
    -- opaque-rule : ∀ {x} y → opaque x y ≡ y

  ★₀ = Set₀
  ★₁ = Set₁

infixr 1 _[₀→₀]_
_[₀→₀]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₀} (Bₚ : B → Set₀)
            (f : A → B) → Set₀
_[₀→₀]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₀→₁]_
_[₀→₁]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₀→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₁]_
_[₁→₁]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₁→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₂]_
_[₁→₂]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₂} (Bₚ : B → Set₂)
            (f : A → B) → Set₂
_[₁→₂]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

[[Set₀]] : ([Set₀] [₁→₂] [Set₁]) [Set₀]
[[Set₀]] = λ A → A [₀→₁] [Set₀]

{-
EqEnv = {!!}
EqRes = {!!}

eqTerm : EqEnv → Term → Term → EqRes
eqTerm Γ (var x args) (var x₁ args₁) = {!!}
eqTerm Γ (def f₀ args₀) (def f₁ args₁) = {!!}
eqTerm Γ (con c₀ args₀) (con c₁ args₁) = {!!}
eqTerm Γ (lam v t) (lam v' t') = {!!}
eqTerm Γ (pi t₁ t₂) (pi u₁ u₂) = {!!}
eqTerm Γ (sort s₀) (sort s₁) = {!!}
eqTerm Γ (lit l₀) (lit l₁) = {!!}
eqTerm Γ unknown unknown = {!!}
eqTerm Γ (def f args) u = {!!}
--eqTerm Γ (pat-lam cs args) u = {!!}
eqTerm _ _ = ?
-}

{-
import Reflection.Simple as Si
open Si using (var;con;def;lam;pi;sort;unknown;simple;showTerm)
-}

_≡-no-hints_ : Term → Term → Set
t ≡-no-hints u = noHintsTerm t ≡ noHintsTerm u

_≡-def-no-hints_ : Definition → Definition → Set
t ≡-def-no-hints u = noHintsDefinition t ≡ noHintsDefinition u

p[Set₀]-type = param-type-by-name (ε 1) (quote [Set₀])
p[Set₀] = param-clauses-by-name (ε 1) (quote [Set₀])
q[[Set₀]] = definition (quote [[Set₀]]) -- quoteTerm [[Set₀]]
test-type-p[Set₀] : ([Set₀] [₁→₂] [Set₁]) [Set₀] ≡ unquote (unEl p[Set₀]-type)
test-type-p[Set₀] = refl
test-term-p[Set₀] : quoteTerm [[Set₀]] ≡-no-hints Get-term.from-clauses p[Set₀]
test-term-p[Set₀] = refl
u-p[Set₀] : ([Set₀] [₁→₂] [Set₁]) [Set₀]
unquoteDef u-p[Set₀] = p[Set₀]

False : Set₁
False = (A : Set) → A

param1-False-type = param-type-by-name (ε 1) (quote False)
param1-False-term = param-term-by-name (ε 1) (quote False)

param1-False-type-check : [Set₁] False ≡ unquote (unEl param1-False-type)
param1-False-type-check = refl

[False] : unquote (unEl param1-False-type)
[False] = unquote param1-False-term

[Level] : [Set₀] Level
[Level] _ = 𝟙

[String] : [Set₀] String
[String] _ = 𝟙

[Float] : [Set₀] Float
[Float] _ = 𝟙

-- Levels are parametric, hence the relation is total
⟦Level⟧ : ⟦Set₀⟧ Level Level
⟦Level⟧ _ _ = 𝟙

⟦String⟧ : ⟦Set₀⟧ String String
⟦String⟧ = _≡_

⟦Float⟧ : ⟦Set₀⟧ Float Float
⟦Float⟧ = _≡_

data [𝟚] : [Set₀] 𝟚 where
  [0₂] : [𝟚] 0₂
  [1₂] : [𝟚] 1₂

data [ℕ] : [Set₀] ℕ where
  [zero] : [ℕ] zero
  [suc]  : ([ℕ] [→] [ℕ]) suc

[pred] : ([ℕ] [→] [ℕ]) pred
[pred] [zero]     = [zero]
[pred] ([suc] xₚ) = xₚ

defDefEnv1 : Name → Name
defDefEnv1 (quote 𝟚)      = quote [𝟚]
defDefEnv1 (quote ℕ)      = quote [ℕ]
defDefEnv1 (quote String) = quote [String]
defDefEnv1 (quote Float)  = quote [Float]
defDefEnv1 (quote ★₀)     = quote [Set₀]
defDefEnv1 (quote ★₁)     = quote [Set₁]
defDefEnv1 (quote False)  = quote [False]
defDefEnv1 (quote Level)  = quote [Level]
defDefEnv1 n              = opaque "defDefEnv1" n

defConEnv1 : Name → Name
defConEnv1 (quote 0₂)         = quote [0₂]
defConEnv1 (quote 1₂)         = quote [1₂]
defConEnv1 (quote ℕ.zero)     = quote [zero]
defConEnv1 (quote ℕ.suc)      = quote [suc]
defConEnv1 (quote Level.zero) = quote 0₁
defConEnv1 (quote Level.suc)  = quote 0₁
defConEnv1 n                  = opaque "defConEnv1" n

defDefEnv2 : Name → Name
defDefEnv2 (quote 𝟚)      = quote ⟦𝟚⟧
defDefEnv2 (quote ℕ)      = quote ⟦ℕ⟧
defDefEnv2 (quote ★₀)     = quote ⟦Set₀⟧
defDefEnv2 (quote ★₁)     = quote ⟦Set₁⟧
defDefEnv2 (quote String) = quote ⟦String⟧
defDefEnv2 (quote Float)  = quote ⟦Float⟧
defDefEnv2 (quote Level)  = quote ⟦Level⟧
defDefEnv2 n              = opaque "defDefEnv" n

defConEnv2 : Name → Name
defConEnv2 (quote 0₂)         = quote ⟦0₂⟧
defConEnv2 (quote 1₂)         = quote ⟦1₂⟧
defConEnv2 (quote ℕ.zero)     = quote ⟦ℕ⟧.⟦zero⟧
defConEnv2 (quote ℕ.suc)      = quote ⟦ℕ⟧.⟦suc⟧
defConEnv2 (quote Level.zero) = quote 0₁
defConEnv2 (quote Level.suc)  = quote 0₁
defConEnv2 n                  = opaque "defConEnv2" n

defEnv0 : Env' 0
defEnv0 = record (ε 0)
                 { pConT = con
                 ; pConP = con
                 ; pDef  = id }

defEnv1 : Env' 1
defEnv1 = record (ε 1)
  { pConP = con ∘′ defConEnv1
  ; pConT = con ∘′ defConEnv1
  ; pDef = defDefEnv1 }

defEnv2 : Env' 2
defEnv2 = record (ε 2)
  { pConP = con ∘′ defConEnv2
  ; pConT = con ∘′ defConEnv2
  ; pDef = defDefEnv2 }

param1-[False]-type = param-type-by-name defEnv1 (quote [False])
param1-[False]-term = param-term-by-name defEnv1 (quote [False])

{-
module Const where
  postulate
    A  : Set₀
    Aᵣ : A → A → Set₀
  data Wrapper : Set where
    wrap : A → Wrapper

  idWrapper : Wrapper → Wrapper
  idWrapper (wrap x) = wrap x

  data ⟦Wrapper⟧ : Wrapper → Wrapper → Set₀ where
    ⟦wrap⟧ : (Aᵣ ⟦→⟧ ⟦Wrapper⟧) wrap wrap

  wrapperEnv = record (ε 2)
   { pDef = [ quote Wrapper       ≔ quote ⟦Wrapper⟧  ] id
   ; pConP = [ quote Wrapper.wrap ≔ con (quote ⟦Wrapper⟧.⟦wrap⟧) ] con
   ; pConT = [ quote Wrapper.wrap ≔ con (quote ⟦Wrapper⟧.⟦wrap⟧) ] con
   }

  unquoteDecl ⟦idWrapper⟧ = param-rec-def-by-name wrapperEnv (quote idWrapper) ⟦idWrapper⟧
-}

data Wrapper (A : Set₀) : Set₀ where
  wrap : A → Wrapper A

idWrapper : ∀ {A} → Wrapper A → Wrapper A
idWrapper (wrap x) = wrap x

data [Wrapper] {A : Set} (Aₚ : A → Set₀)
   : Wrapper A → Set₀ where
  [wrap] : (Aₚ [→] [Wrapper] Aₚ) wrap

[Wrapper]-env = record (ε 1)
  { pDef = [ quote Wrapper ≔ quote [Wrapper] ] id
  ; pConP = [ quote wrap ≔ con (quote [wrap])  ] con
  ; pConT = [ quote wrap ≔ conSkip' 2 (quote [wrap]) ] con
  }

unquoteDecl [idWrapper] =
  param-rec-def-by-name [Wrapper]-env (quote idWrapper) [idWrapper]

  {-
[idWrapper] = {!  param-rec-def-by-name [Wrapper]-env (quote idWrapper) [idWrapper]!}
-- [idWrapper] = {!  param-rec-def-by-name [Wrapper]-env (quote idWrapper) [idWrapper]!}
-}

{-
-- The generated type bigger since it is a familly for no reason.
data ⟦Wrapper⟧ : (⟦Set₀⟧ ⟦→⟧ ⟦Set₁⟧) Wrapper Wrapper

private
  ⟦Wrapper⟧-ctor = λ c → unEl (param-ctor-by-name (extDefEnv [ quote Wrapper ≔ quote ⟦Wrapper⟧ ] (ε 2)) c)

data ⟦Wrapper⟧ where
  ⟦wrap⟧ : unquote (⟦Wrapper⟧-ctor (quote Wrapper.wrap))
-}
data ⟦Wrapper⟧ {A₀ A₁ : Set} (Aᵣ : A₀ → A₁ → Set₀)
   : Wrapper A₀ → Wrapper A₁ → Set₀ where
  ⟦wrap⟧ : (Aᵣ ⟦→⟧ ⟦Wrapper⟧ Aᵣ) wrap wrap

⟦Wrapper⟧-env = record (ε 2)
  { pDef = [ quote Wrapper ≔ quote ⟦Wrapper⟧ ] id
  ; pConP = [ quote wrap ≔ con (quote ⟦wrap⟧)  ] con
  ; pConT = [ quote wrap ≔ conSkip' 3 (quote ⟦wrap⟧) ] con
  }

⟦idWrapper⟧1 : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦Wrapper⟧ A ⟦→⟧ ⟦Wrapper⟧ A) idWrapper idWrapper
⟦idWrapper⟧1 {x0} {x1} (x2) {._} {._} (⟦wrap⟧ {x3} {x4} x5)
  = ⟦wrap⟧ {_} {_} {_} {x3} {x4} x5

⟦idWrapper⟧-clauses =
  clause
  (arg (arg-info hidden  relevant) (var "A0") ∷
   arg (arg-info hidden  relevant) (var "A1") ∷
   arg (arg-info visible relevant) (var "Ar") ∷
   arg (arg-info hidden  relevant) dot ∷
   arg (arg-info hidden  relevant) dot ∷
   arg (arg-info visible relevant)
   (con (quote ⟦wrap⟧)
    (arg (arg-info hidden  relevant) (var "x0") ∷
     arg (arg-info hidden  relevant) (var "x1") ∷
     arg (arg-info visible relevant) (var "xr") ∷ []))
   ∷ [])
  (con (quote ⟦wrap⟧)
   (arg (arg-info hidden relevant) unknown ∷
    arg (arg-info hidden relevant) unknown ∷
    arg (arg-info hidden relevant) unknown ∷
    arg (arg-info hidden relevant)  (var 2 []) ∷
    arg (arg-info hidden relevant)  (var 1 []) ∷
    arg (arg-info visible relevant) (var 0 []) ∷ []))
  ∷ []

⟦idWrapper⟧2 : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦Wrapper⟧ A ⟦→⟧ ⟦Wrapper⟧ A) idWrapper idWrapper
unquoteDef ⟦idWrapper⟧2 = ⟦idWrapper⟧-clauses

unquoteDecl ⟦idWrapper⟧ =
  param-rec-def-by-name ⟦Wrapper⟧-env (quote idWrapper) ⟦idWrapper⟧

data Bot (A : Set₀) : Set₀ where
  bot : Bot A → Bot A

gobot : ∀ {A} → Bot A → A
gobot (bot x) = gobot x

data [Bot] {A : Set} (Aₚ : A → Set₀)
   : Bot A → Set₀ where
  [bot] : ([Bot] Aₚ [→] [Bot] Aₚ) bot

[Bot]-env = record (ε 1)
  { pDef = [ quote Bot ≔ quote [Bot] ] id
  ; pConP = [ quote bot ≔ con (quote [bot])  ] con
  ; pConT = [ quote bot ≔ conSkip' 2 (quote [bot]) ] con
  }

[gobot]' : (∀⟨ A ∶ [Set₀] ⟩[→] [Bot] A [→] A) gobot
[gobot]' {x0} (x1) {._} ([bot] {x2} x3)
  = [gobot]' {x0} x1 {x2} x3

-- [gobot]' = {!showClauses "[gobot]'" (param-rec-clauses-by-name [Bot]-env (quote gobot) (quote [gobot]'))!}

[gobot]2 : (∀⟨ A ∶ [Set₀] ⟩[→] [Bot] A [→] A) gobot

[gobot]2-clauses =
  clause
    (arg (arg-info hidden  relevant) (var "Aᵢ0") ∷
     arg (arg-info visible relevant) (var "Aᵣ") ∷
     arg (arg-info hidden  relevant) dot ∷
     arg (arg-info visible relevant)
     (con (quote [bot])
      (arg (arg-info hidden  relevant) (var "xᵢ0") ∷
       arg (arg-info visible relevant) (var "xᵣ") ∷ []))
     ∷ [])
    (def (quote [gobot]2)
     (arg (arg-info hidden  relevant) (var 4 []) ∷
      arg (arg-info visible relevant) (var 3 []) ∷
      arg (arg-info hidden  relevant) (var 1 []) ∷
      arg (arg-info visible relevant) (var 0 []) ∷ []))
    ∷ []

unquoteDef [gobot]2 = [gobot]2-clauses

unquoteDecl [gobot] =
  param-rec-def-by-name [Bot]-env (quote gobot) [gobot]

data ⟦Bot⟧ {A₀ A₁ : Set} (Aᵣ : A₀ → A₁ → Set₀)
   : Bot A₀ → Bot A₁ → Set₀ where
  ⟦bot⟧ : (⟦Bot⟧ Aᵣ ⟦→⟧ ⟦Bot⟧ Aᵣ) bot bot

⟦Bot⟧-env = record (ε 2)
  { pDef = [ quote Bot ≔ quote ⟦Bot⟧ ] id
  ; pConP = [ quote bot ≔ con (quote ⟦bot⟧)  ] con
  ; pConT = [ quote bot ≔ conSkip' 3 (quote ⟦bot⟧) ] con
  }

⟦gobot⟧1 : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦Bot⟧ A ⟦→⟧ A) gobot gobot
⟦gobot⟧1 {x0} {x1} x2 {._} {._} (⟦bot⟧ {x3} {x4} x5)
  = ⟦gobot⟧1 {x0} {x1} x2 {x3} {x4} x5

unquoteDecl ⟦gobot⟧ =
  param-rec-def-by-name ⟦Bot⟧-env (quote gobot) ⟦gobot⟧

id₀ : {A : Set₀} → A → A
id₀ x = x

⟦id₀⟧ : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ A ⟦→⟧ A) id₀ id₀
⟦id₀⟧ = λ {x₁} {x₂} xᵣ {x₃} {x₄} xᵣ₁ → xᵣ₁

data List₀ (A : Set) : Set where
  []  : List₀ A
  _∷_ : A → List₀ A → List₀ A

map₀ : ∀ {A B} (f : A → B) (xs : List₀ A) → List₀ B
map₀ f []       = []
map₀ f (x ∷ xs) = f x ∷ map₀ f xs

idList₀ : ∀ {A} → List₀ A → List₀ A
-- idList₀ : List₀ ℕ → List₀ ℕ
idList₀ []       = []
idList₀ {A} (x ∷ xs) = idList₀ {A} xs

data ⟦List₀⟧ {A₀ A₁ : Set} (Aᵣ : A₀ → A₁ → Set₀) : List₀ A₀ → List₀ A₁ → Set₀ where
  ⟦[]⟧  : ⟦List₀⟧ Aᵣ [] []
  _⟦∷⟧_ : (Aᵣ ⟦→⟧ ⟦List₀⟧ Aᵣ ⟦→⟧ ⟦List₀⟧ Aᵣ) _∷_ _∷_

con⟦List₀⟧ = conSkip' 3
⟦List₀⟧-env = record (ε 2)
  { pDef = [ quote List₀ ≔ quote ⟦List₀⟧ ]
          ([ quote ℕ     ≔ quote ⟦ℕ⟧ ]
          ([ quote id₀   ≔ quote ⟦id₀⟧ ] id))
  ; pConP = [ quote List₀.[]  ≔ con (quote ⟦List₀⟧.⟦[]⟧)  ]
           ([ quote List₀._∷_ ≔ con (quote ⟦List₀⟧._⟦∷⟧_) ]
            con)
  ; pConT = [ quote List₀.[]  ≔ con⟦List₀⟧ (quote ⟦List₀⟧.⟦[]⟧)  ]
           ([ quote List₀._∷_ ≔ con⟦List₀⟧ (quote ⟦List₀⟧._⟦∷⟧_) ]
            con)
  }

⟦idList₀⟧ : unquote (unEl (param-type-by-name ⟦List₀⟧-env (quote idList₀)))
-- ⟦idList₀⟧ : (∀⟨ A ∶ ⟦Set₀⟧ ⟩⟦→⟧ ⟦List₀⟧ A ⟦→⟧ ⟦List₀⟧ A) idList₀ idList₀
unquoteDef ⟦idList₀⟧ = param-rec-clauses-by-name ⟦List₀⟧-env (quote idList₀) (quote ⟦idList₀⟧)

{-
⟦map₀⟧ : {x0 : Set0} → {x1 : Set0} → (x2 : (x2 : x0) → (x3 : x1) → Set0) → {x3 : Set0} → {x4 : Set0} → (x5 : (x5 : x3) → (x6 : x4) → Set0) → {x6 : (x6 : x0) → x3} → {x7 : (x7 : x1) → x4} → (x8 : {x8 : x0} → {x9 : x1} → (x10 : x2 (x8) (x9)) → x5 (x6 (x8)) (x7 (x9))) → {x9 : List₀ (x0)} → {x10 : List₀ (x1)} → (x11 : ⟦List₀⟧ {x0} {x1} (x2) (x9) (x10)) → ⟦List₀⟧ {x3} {x4} (x5) (map₀ {x0} {x3} (x6) (x9)) (map₀ {x1} {x4} (x7) (x10))
⟦map₀⟧ {x0} {x1} (x2) {x3} {x4} (x5) {x6} {x7} (x8) {._} {._} (⟦[]⟧ )  = ⟦[]⟧
⟦map₀⟧ {x0} {x1} (x2) {x3} {x4} (x5) {x6} {x7} (x8) {._} {._} (_⟦∷⟧_ {x11} {x12} (x13) {x14} {x15} (x16) )  = _⟦∷⟧_ {x6 (x11)} {x7 (x12)} (x8 {x11} {x12} (x13)) {map₀ {x0} {x3} (x6) (x14)} {map₀ {x1} {x4} (x7) (x15)} (⟦map₀⟧ {x0} {x1} (x2) {x3} {x4} (x5) {x6} {x7} (x8) {x14} {x15} (x16))
-}

unquoteDecl ⟦map₀⟧ = param-rec-def-by-name ⟦List₀⟧-env (quote map₀) ⟦map₀⟧

{-
  -- The generated type is bigger since it is a familly for no reason.
  data ⟦List₀⟧ : (⟦Set₀⟧ ⟦→⟧ ⟦Set₁⟧) List₀ List₀

  private
    ⟦List₀⟧-ctor = λ c → unEl (param-ctor-by-name (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2)) c)

  data ⟦List₀⟧ where
    ⟦[]⟧  : unquote (⟦List₀⟧-ctor (quote List₀.[]))
    _⟦∷⟧_ : unquote (⟦List₀⟧-ctor (quote List₀._∷_))

  ⟦List₀⟧-env = extConEnv ([ quote List₀.[]  ≔ quote ⟦List₀⟧.⟦[]⟧  ] ∘
                        [ quote List₀._∷_ ≔ quote ⟦List₀⟧._⟦∷⟧_ ])
             (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2))
-}

data Maybe' (A : Set) : Set₁ where
  nothing : Maybe' A
  just    : A → Maybe' A

{-
-- Set₁ is here because ⟦List₀⟧ is not using parameters, hence gets bigger.
-- This only happens without-K given the new rules for data types.
data List₀ : (A : Set) → Set₁ where
  []  : ∀ {A} → List₀ A
  _∷_ : ∀ {A} → A → List₀ A → List₀ A

map₀ : ∀ {A B} → (A → B) → List₀ A → List₀ B
map₀ f []       = []
map₀ f (x ∷ xs) = f x ∷ map₀ f xs

idList₀ : ∀ {A} → List₀ A → List₀ A
idList₀ []       = []
idList₀ (x ∷ xs) = x ∷ idList₀ xs

-- The generated type bigger since it is a familly for no reason.
data ⟦List₀⟧ : (⟦Set₀⟧ ⟦→⟧ ⟦Set₁⟧) List₀ List₀

private
  ⟦List₀⟧-ctor = λ c → unEl (param-ctor-by-name (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2)) c)

data ⟦List₀⟧ where
  ⟦[]⟧  : unquote (⟦List₀⟧-ctor (quote List₀.[]))
  _⟦∷⟧_ : unquote (⟦List₀⟧-ctor (quote List₀._∷_))

⟦List₀⟧-env = extConEnv ([ quote List₀.[]  ≔ quote ⟦List₀⟧.⟦[]⟧  ] ∘
                      [ quote List₀._∷_ ≔ quote ⟦List₀⟧._⟦∷⟧_ ])
           (extDefEnv [ quote List₀ ≔ quote ⟦List₀⟧ ] (ε 2))

-- test = ⟦[]⟧ {{!showType (type (quote List₀.[]))!}} {{!!}} {!!}
-}

{-
⟦idList₀⟧ : unquote (unEl (param-type-by-name ⟦List₀⟧-env (quote idList₀)))
unquoteDef ⟦idList₀⟧ = param-rec-clauses-by-name ⟦List₀⟧-env (quote idList₀) (quote ⟦idList₀⟧)
-}

{-
⟦map₀⟧ : unquote (unEl (param-type-by-name ⟦List₀⟧-env (quote map₀)))
⟦map₀⟧ {x} {x₁} {x₂} {x₃} {x₄} {x₅} {x₆} {x₇} x₈ {[]} {[]} ⟦[]⟧
  = ⟦[]⟧
⟦map₀⟧ {x} {x₁} {x₂} {x₃} {x₄} {x₅} {x₆} {x₇} x₈ {._ ∷ ._}
  {._ ∷ ._}
  (_⟦∷⟧_ {x₁₃} {x₁₄} x₁₅ {x₁₆} {x₁₇} x₁₈)
  = _⟦∷⟧_ {x₁₀ x₁₃} {x₁₁ x₁₄} (x₁₂ {x₁₃} {x₁₄} x₁₅)
    {map₀ {x₄} {x₇} x₁₀ x₁₆} {map₀ {x₅} {x₈} x₁₁ x₁₇}
    (⟦map₀⟧ {x₄} {x₅} {x₆} {x₇} {x₈} {x₉} {x₁₀} {x₁₁} x₁₂ {x₁₆} {x₁₇}
     x₁₈)
-}

{-
unquoteDef ⟦map₀⟧ = param-rec-clauses-by-name ⟦List₀⟧-env (quote map₀) (quote ⟦map₀⟧)
-}

{-
foo : {x0 : Set0} → {x1 : Set0} → (x2 : (x2 : x0) → (x3 : x1) → Set0) → {x3 : Set0} → {x4 : Set0} → (x5 : (x5 : x3) → (x6 : x4) → Set0) → {x6 : (x6 : x0) → x3} → {x7 : (x7 : x1) → x4} → (x8 : {x8 : x0} → {x9 : x1} → (x10 : x2 (x8) (x9)) → x5 (x6 (x8)) (x7 (x9))) → {x9 : Reflection.Param.List₀ (x0)} → {x10 : Reflection.Param.List₀ (x1)} → (x11 : Reflection.Param.⟦List₀⟧ {x0} {x1} (x2) (x9) (x10)) → Reflection.Param.⟦List₀⟧ {x3} {x4} (x5) (Reflection.Param.map₀ {x0} {x3} (x6) (x9)) (Reflection.Param.map₀ {x1} {x4} (x7) (x10))
foo {A} {A} (A) {B} {B} (B) {f} {f} (f) {._} {._} (Reflection.Param.⟦List₀⟧.⟦[]⟧ )  = Reflection.Param.⟦List₀⟧.⟦[]⟧
foo {A} {A} (A) {B} {B} (B) {f} {f} (f) {._} {._} (Reflection.Param.⟦List₀⟧._⟦∷⟧_ {x} {x} (x) {xs} {xs} (xs) )  = Reflection.Param.⟦List₀⟧._⟦∷⟧_ {x0 (x0)} {x0 (x0)} (x0 {x0} {x0} (x0)) {Reflection.Param.map₀ {x0} {x0} (x0) (x0)} {Reflection.Param.map₀ {x0} {x0} (x0) (x0)} (Reflection.Param.test' {x0} {x0} (x0) {x0} {x0} (x0) {x0} {x0} (x0) {x0} {x0} (x0))
-}

-- test' = {! showFunDef "foo" (param-rec-def-by-name ⟦List₀⟧-env (quote map₀) (quote test'))!}

open import Function.Param.Unary

revealed-[→] = Reveal-args.nåme (quote _[₀→₀]_)

revealed-[→]' : ∀ (A : Set₀) (Aₚ : A → Set₀)
                  (B : Set₀) (Bₚ : B → Set₀)
                  (f : A → B) → Set₀
unquoteDef revealed-[→]' = Get-clauses.from-def revealed-[→]

revelator-[→] : ({A : Set} (Aₚ : A → Set) {B : Set} (Bₚ : B → Set) (f : A → B) → Set)
              →  (A : Set) (Aₚ : A → Set) (B : Set) (Bₚ : B → Set) (f : A → B) → Set
unquoteDef revelator-[→] = Revelator.clauses (type (quote _[₀→₀]_))

p-[→]-type = param-type-by-name    (ε 1) (quote _[₀→₀]_)
p-[→]      = param-clauses-by-name (ε 1) (quote _[₀→₀]_)

p-[→]' = ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
           {Aₚ : A → Set₀}  (A₁ₚ : {x : A} → A₀ₚ x → Aₚ x → Set₀)
           {B : Set₀}       (B₀ₚ : B → Set₀)
           {Bₚ : B → Set₀}  (B₁ₚ : {x : B} → B₀ₚ x → Bₚ x → Set₀)
           {f : A → B}      (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
         → (Aₚ [₀→₀] Bₚ) f
         → Set

p-[→]'-test : p-[→]' ≡ unquote (unEl p-[→]-type)
p-[→]'-test = refl

[[→]] : unquote (unEl p-[→]-type)
unquoteDef [[→]] = p-[→]

data [[ℕ]] : [[Set₀]] [ℕ] [ℕ] where
  [[zero]] : [[ℕ]] [zero] [zero]
  [[suc]]  : [[→]] [ℕ] [[ℕ]] [ℕ] [[ℕ]] [suc] [suc]

_/2 : ℕ → ℕ
zero        /2 = zero
suc zero    /2 = zero
suc (suc n) /2 = suc (n /2)

_⟦/2⟧ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _/2 _/2
⟦zero⟧          ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ ⟦zero⟧    ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ (⟦suc⟧ n) ⟦/2⟧ = ⟦suc⟧ (n ⟦/2⟧)

_+ℕ_ : ℕ → ℕ → ℕ
zero  +ℕ n = n
suc m +ℕ n = suc (m +ℕ n)

pred' : ℕ → ℕ
pred' = λ { zero    → zero
          ; (suc m) → m }

⟦pred'⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) pred' pred'
unquoteDef ⟦pred'⟧ = param-clauses-by-name defEnv2 (quote pred')

_⟦+ℕ⟧_ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _+ℕ_ _+ℕ_
⟦zero⟧  ⟦+ℕ⟧ n = n
⟦suc⟧ m ⟦+ℕ⟧ n = ⟦suc⟧ (m ⟦+ℕ⟧ n)

⟦⟦Set₀⟧⟧ : (⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₁⟧) ⟦Set₀⟧ ⟦Set₀⟧
⟦⟦Set₀⟧⟧ = λ A₀ A₁ → A₀ ⟦₀→₁⟧ A₁ ⟦₀→₁⟧ ⟦Set₀⟧

⟦⟦Set₀⟧⟧' : {x₁ x₂ : Set} (xᵣ : x₁ → x₂ → Set) {x₃ : Set} {x₄ : Set}
            (xᵣ₁ : x₃ → x₄ → Set) →
            (x₁ → x₃ → Set) → (x₂ → x₄ → Set) → Set₁
⟦⟦Set₀⟧⟧' = λ A₀ A₁ f₁ f₂ →
  ∀ {x₁} {x₂} (xᵣ : A₀ x₁ x₂)
    {x₃} {x₄} (xᵣ₁ : A₁ x₃ x₄) →
    f₁ x₁ x₃ → f₂ x₂ x₄ → Set

-- Since quoteTerm normalises
test-⟦⟦Set₀⟧⟧ : quoteTerm ⟦⟦Set₀⟧⟧ ≡-no-hints quoteTerm ⟦⟦Set₀⟧⟧'
test-⟦⟦Set₀⟧⟧ = refl

⟦⟦Set₀⟧⟧-type = unquote (unEl (type (quote ⟦⟦Set₀⟧⟧)))
test-⟦⟦Set₀⟧⟧-type : ⟦⟦Set₀⟧⟧-type ≡ unquote (unEl (type (quote ⟦⟦Set₀⟧⟧')))
test-⟦⟦Set₀⟧⟧-type = refl

pSet₀ = pTerm defEnv2 `★₀
ppSet₀ = pTerm defEnv2 pSet₀
p⟦Set₀⟧ = param-clauses-by-name defEnv2 (quote ⟦Set₀⟧)
test-pSet₀ : pSet₀ ≡-no-hints quoteTerm ⟦Set₀⟧
test-pSet₀ = refl
test-ppSet₀ : ppSet₀ ≡-no-hints quoteTerm ⟦⟦Set₀⟧⟧
test-ppSet₀ = refl
test-ppSet₀'' : ppSet₀ ≡-no-hints Get-term.from-clauses p⟦Set₀⟧
test-ppSet₀'' = refl

⟦⟦Set₀⟧⟧'' : (⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₁⟧) ⟦Set₀⟧ ⟦Set₀⟧
unquoteDef ⟦⟦Set₀⟧⟧'' = p⟦Set₀⟧

test-⟦⟦Set₀⟧⟧'' : _≡_ {A = ⟦⟦Set₀⟧⟧-type} ⟦⟦Set₀⟧⟧'' ⟦⟦Set₀⟧⟧
test-⟦⟦Set₀⟧⟧'' = refl

test-p0-⟦Set₀⟧ : pTerm defEnv0 (quoteTerm ⟦Set₀⟧) ≡-no-hints quoteTerm ⟦Set₀⟧
test-p0-⟦Set₀⟧ = refl

data ⟦⟦𝟚⟧⟧ : (⟦⟦Set₀⟧⟧ ⟦𝟚⟧ ⟦𝟚⟧) ⟦𝟚⟧ ⟦𝟚⟧ where
  ⟦⟦0₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧
  ⟦⟦1₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧

p1ℕ→ℕ = pTerm defEnv1 (quoteTerm (ℕ → ℕ))
[ℕ→ℕ] = [ℕ] [→] [ℕ]
test-p1ℕ→ℕ : unquote p1ℕ→ℕ ≡ [ℕ→ℕ]
test-p1ℕ→ℕ = refl

p2ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ))
⟦ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
test-p2ℕ→ℕ : unquote p2ℕ→ℕ ≡ ⟦ℕ→ℕ⟧
test-p2ℕ→ℕ = refl

pℕ→ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ → ℕ))
⟦ℕ→ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
test-pℕ→ℕ→ℕ : pℕ→ℕ→ℕ ≡-no-hints quoteTerm ⟦ℕ→ℕ→ℕ⟧
test-pℕ→ℕ→ℕ = refl
ZERO : Set₁
ZERO = (A : Set₀) → A
⟦ZERO⟧ : ZERO → ZERO → Set₁
⟦ZERO⟧ f₀ f₁ =
  {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
  → Aᵣ (f₀ A₀) (f₁ A₁)
pZERO = pTerm (ε 2) (quoteTerm ZERO)
q⟦ZERO⟧ = quoteTerm ⟦ZERO⟧
test-pZERO : pZERO ≡-no-hints q⟦ZERO⟧
test-pZERO = refl
ID : Set₁
ID = (A : Set₀) → A → A
⟦ID⟧ : ID → ID → Set₁
⟦ID⟧ f₀ f₁ =
  {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
  {x₀ : A₀} {x₁ : A₁} (x : Aᵣ x₀ x₁)
  → Aᵣ (f₀ A₀ x₀) (f₁ A₁ x₁)
pID = pTerm (ε 2) (quoteTerm ID)
q⟦ID⟧ = quoteTerm ⟦ID⟧
test-ID : q⟦ID⟧ ≡-no-hints pID
test-ID = refl

⟦not⟧' : (⟦𝟚⟧ ⟦→⟧ ⟦𝟚⟧) not not
unquoteDef ⟦not⟧' = param-clauses-by-name defEnv2 (quote not)
test-not : ∀ {x₀ x₁ : 𝟚} (xᵣ : ⟦𝟚⟧ x₀ x₁) → ⟦not⟧ xᵣ ≡ ⟦not⟧' xᵣ
test-not ⟦0₂⟧ = refl
test-not ⟦1₂⟧ = refl

[pred]' : ([ℕ] [→] [ℕ]) pred
unquoteDef [pred]' = param-clauses-by-name defEnv1 (quote pred)

test-p1-pred : ∀ {n} (nₚ : [ℕ] n) → [pred]' nₚ ≡ [pred] nₚ
test-p1-pred [zero]     = refl
test-p1-pred ([suc] nₚ) = refl

⟦pred⟧' : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) pred pred
unquoteDef ⟦pred⟧' = param-clauses-by-name defEnv2 (quote pred)

test-p2-pred : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → ⟦pred⟧' nᵣ ≡ ⟦pred⟧ nᵣ
test-p2-pred ⟦zero⟧     = refl
test-p2-pred (⟦suc⟧ nᵣ) = refl

p/2 = param-rec-def-by-name defEnv2 (quote _/2)
q⟦/2⟧ = definition (quote _⟦/2⟧)
unquoteDecl _⟦/2⟧' = p/2 _⟦/2⟧'
test-/2 : function (p/2 (quote _⟦/2⟧)) ≡-def-no-hints q⟦/2⟧
test-/2 = refl
test-/2' : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → nᵣ ⟦/2⟧' ≡ nᵣ ⟦/2⟧
test-/2' ⟦zero⟧ = refl
test-/2' (⟦suc⟧ ⟦zero⟧) = refl
test-/2' (⟦suc⟧ (⟦suc⟧ nᵣ)) rewrite test-/2' nᵣ = refl

p+ = param-rec-def-by-name defEnv2 (quote _+ℕ_)
q⟦+⟧ = definition (quote _⟦+ℕ⟧_)
unquoteDecl _⟦+⟧'_ = p+ _⟦+⟧'_
test-+ : function (p+ (quote _⟦+ℕ⟧_)) ≡-def-no-hints q⟦+⟧
test-+ = refl
test-+' : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) {n'₀ n'₁} (n'ᵣ : ⟦ℕ⟧ n'₀ n'₁) → nᵣ ⟦+⟧' n'ᵣ ≡ nᵣ ⟦+ℕ⟧ n'ᵣ
test-+' ⟦zero⟧    n'ᵣ = refl
test-+' (⟦suc⟧ nᵣ) n'ᵣ rewrite test-+' nᵣ n'ᵣ = refl

{-
is-good : String → 𝟚
is-good "good" = 1₂
is-good _      = 0₂

⟦is-good⟧ : (⟦String⟧ ⟦₀→₀⟧ ⟦𝟚⟧) is-good is-good
⟦is-good⟧ {"good"} refl = ⟦1₂⟧
⟦is-good⟧ {_}      refl = {!!}

my-good = unquote (lit (string "good"))
my-good-test : my-good ≡ "good"
my-good-test = refl
-}

{-
⟦is-good⟧' : (⟦String⟧ ⟦₀→₀⟧ ⟦𝟚⟧) is-good is-good
unquoteDef ⟦is-good⟧' = param-clauses-by-name defEnv2 (quote is-good)
test-is-good = {!!}
-}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


Added examples for an issue.

Added examples for an issue.

Ignore-this: d41f2b18e5032bdc71396e32315466b7

darcs-hash:20120619011758-3bd4e-b614e3f5267122084c9b6e13b2bb79830a0f802a.gz

------------------------------------------------------------------------------
-- The translation is badly erasing the universal quantification
------------------------------------------------------------------------------

-- Found on 14 March 2012.

module Issues.BadErase where

postulate
  _↔_ : Set → Set → Set
  D   : Set
  A   : Set

postulate bad₁ : ((x : D) → A) → A
{-# ATP prove bad₁ #-}

postulate bad₂ : A → ((x : D) → A)
{-# ATP prove bad₂ #-}

postulate bad₃ : ((x : D) → A) ↔ A
{-# ATP prove bad₃ #-}


composable: More abstraction madness

composable: More abstraction madness

module composable where

open import Level
open import Function
open import Data.Unit using (⊤)
open import Relation.Binary

Arrow : ∀ {i} → Set i → ∀ j → Set (suc j ⊔ i)
Arrow = Rel

Composition : ∀ {a ℓ} {A : Set a} → Arrow A ℓ → Set _
Composition = Transitive

Identity : ∀ {a ℓ} {A : Set a} → Arrow A ℓ → Set _
Identity = Reflexive

IArrow : ∀ {i j t} {I : Set i} (_↝ᵢ_ : Arrow I j) (T : I → Set t) a → Set _
IArrow _↝ᵢ_ T a = ∀ {i₀ i₁} → i₀ ↝ᵢ i₁ → T i₀ → T i₁ → Set a

IReflexivity : ∀ {a i j t} {I : Set i} {R : Rel I j} {T : I → Set t} → Reflexive R → IArrow R T a → Set _
IReflexivity R-refl Arr = ∀ {i A} → Arr (R-refl {i}) A A

IIdentity : ∀ {a i j t} {I : Set i} {_↝ᵢ_ : Arrow I j} {T : I → Set t} → Identity _↝ᵢ_ → IArrow _↝ᵢ_ T a → Set _
IIdentity = IReflexivity

ITrans : ∀ {i j t a} {I : Set i} {R₀ R₁ R₂ : Rel I j} {T : I → Set t}
           (R-trans : Trans R₀ R₁ R₂)
           (Arr₀ : IArrow R₀ T a)
           (Arr₀ : IArrow R₁ T a)
           (Arr₀ : IArrow R₂ T a)
         → Set _
ITrans R-trans Arr₀ Arr₁ Arr₂
  = ∀ {i₀ i₁ i₂ j₀ j₁} → Trans (Arr₀ j₀) (Arr₁ j₁) (Arr₂ (R-trans {i₀} {i₁} {i₂} j₀ j₁))

ITransitive : ∀ {i j t a} {I : Set i} {R : Rel I j} {T : I → Set t}
                → Transitive R → IArrow R T a → Set _
ITransitive {R = R} R-trans Arr = ITrans {R₀ = R} {R} {R} R-trans Arr Arr Arr

IComposition : ∀ {i j t a} {I : Set i} {_↝ᵢ_ : Arrow I j} {T : I → Set t}
                   (_·_ : Composition _↝ᵢ_)
                   (⟨_⟩_↝_ : IArrow _↝ᵢ_ T a) → Set _
IComposition = ITransitive

record IComposable {i j t a} {I : Set i} {_↝ᵢ_ : Arrow I j} {T : I → Set t}
                   (_·_ : Composition _↝ᵢ_)
                   (⟨_⟩_↝_ : IArrow _↝ᵢ_ T a)
                 : Set (a ⊔ t ⊔ i ⊔ j) where
  constructor mk
  infixr 1 _>>>_
  field
--    _>>>_ : ∀ {i₀ i₁ i₂} {ix₀ : i₀ ↝ᵢ i₁} {ix₁ : i₁ ↝ᵢ i₂} {A B C}
--            → (⟨ ix₀ ⟩ A ↝ B) → (⟨ ix₁ ⟩ B ↝ C) → (⟨ ix₀ · ix₁ ⟩ A ↝ C)
    _>>>_ : IComposition (λ {η} → _·_ {η}) ⟨_⟩_↝_

open import Relation.Binary.PropositionalEquality
Refl-Unit : ∀ {ℓ a} {A : Set a} {R : Rel A ℓ} → Reflexive R → Transitive R → Set _
Refl-Unit {R = R} R-refl R-trans = ∀ {x y} (p : R x y) → R-trans R-refl p ≡ p

{-
record ICat        {i j t a} {I : Set i} {_↝ᵢ_ : Arrow I j} {T : I → Set t}
                   {_·_ : Composition _↝ᵢ_}
                   {⟨_⟩_↝_ : IArrow a _↝ᵢ_ T}
                   (comp : IComposable _·_ ⟨_⟩_↝_)
                   {idᵢ : Identity _↝ᵢ_}
                   (id : IIdentity (λ {η} → idᵢ {η}) ⟨_⟩_↝_)
                   (_≈ᵢ_ : ∀ {a b} (i j : a ↝ᵢ b) → Set)
                   (_≈_ : ∀ {i j A B} → i ≈ᵢ j → ⟨ i ⟩ A ↝ B → ⟨ j ⟩ A ↝ B → Set) : Set
          where
  constructor mk
  open IComposable comp
  field
    id-unit->>> :
      ∀ f → ⟨ id >>> f ≈ f
-}
open import Data.Unit using (⊤)

ConstArr : ∀ {a} (A : Set a) → ⊤ → ⊤ → Set a
ConstArr A _ _ = A

Composable : ∀ {t a} {T : Set t} (_↝_ : T → T → Set a) → Set (t ⊔ a)
Composable _↝_ = IComposable {i = zero} {_↝ᵢ_ = ConstArr ⊤} _ (const _↝_)

{- Composable, unfolded:
record Composable {t a} {T : Set t} (_↝_ : T → T → Set a) : Set (t ⊔ a) where
  constructor mk
  infixr 1 _>>>_
  field
    _>>>_ : ∀ {A B C} → (A ↝ B) → (B ↝ C) → (A ↝ C)
-}

constComp' : ∀ {a} {A : Set a} (_·_ : A → A → A) → Composition (ConstArr A)
constComp' _·_ = _·_

constComp : ∀ {a} {A : Set a} (_·_ : A → A → A) → Composable (ConstArr A)
constComp _·_ = mk _·_

module Composable = IComposable

ixFunComp : ∀ {ix t} {Ix : Set ix} (F : Ix → Set t) → Composable (λ i o → F i → F o)
ixFunComp _ = mk (λ f g x → g (f x))

funComp : ∀ {t} → Composable (λ (A B : Set t) → A → B)
funComp = ixFunComp id

opComp : ∀ {t a} {T : Set t} {_↝_ : T → T → Set a} → Composable _↝_ → Composable (flip _↝_)
opComp (mk _>>>_) = mk (flip _>>>_)

open import Data.Vec
vecFunComp : ∀ {a} (A : Set a) → Composable (λ i o → Vec A i → Vec A o)
vecFunComp A = ixFunComp (Vec A)

open import Data.Bits
bitsFunComp : Composable (λ i o → Bits i → Bits o)
bitsFunComp = ixFunComp Bits

-- open import Data.Fin
-- funRewireComp : Composable (λ i o → Fin o → Fin i)
-- FunRewireComp = opComp (ixFunComp Fin)

{-
open import bintree

open import Data.Nat
CircuitType : Set₁
CircuitType = (i o : ℕ) → Set

RewireTbl : CircuitType
RewireTbl i o = Vec (Fin i) o

rewireTblComp : Composable RewireTbl
rewireTblComp = {!!}
-}

module composable where

open import Level
open import Function
open import Data.Unit using (⊤)

-- Monoid M ≅ Cat (ConstArr M)

Composition : ∀ {i a} {I : Set i} (_↝_ : I → I → Set a) → Set (i ⊔ a)
Composition _↝_ = ∀ {A B C} → (A ↝ B) → (B ↝ C) → (A ↝ C)

record IComposable {i j s t} {I : Set i} {_↝ᵢ_ : I → I → Set j} {S : I → Set s}
                   (_·_ : Composition _↝ᵢ_)
                   (⟨_⟩_↝_ : ∀ {i₀ i₁} → i₀ ↝ᵢ i₁ → S i₀ → S i₁ → Set t) : Set (t ⊔ s ⊔ i ⊔ j) where
  constructor mk
  infixr 1 _>>>_
  field
    _>>>_ : ∀ {i₀ i₁ i₂} {ix₀ : i₀ ↝ᵢ i₁} {ix₁ : i₁ ↝ᵢ i₂} {A B C}
            → (⟨ ix₀ ⟩ A ↝ B) → (⟨ ix₁ ⟩ B ↝ C) → (⟨ ix₀ · ix₁ ⟩ A ↝ C)

open import Data.Unit using (⊤)

ConstArr : ∀ {a} (A : Set a) → ⊤ → ⊤ → Set a
ConstArr A _ _ = A

Composable : ∀ {s t} {S : Set s} (_↝_ : S → S → Set t) → Set (s ⊔ t)
Composable _↝_ = IComposable {i = zero} {_↝ᵢ_ = ConstArr ⊤} _ (const _↝_)

{- Composable, unfolded:
record Composable {s t} {S : Set s} (_↝_ : S → S → Set t) : Set (s ⊔ t) where
  constructor mk
  infixr 1 _>>>_
  field
    _>>>_ : ∀ {A B C : S} → (A ↝ B) → (B ↝ C) → (A ↝ C)
-}

constComp' : ∀ {a} {A : Set a} (_·_ : A → A → A) → Composition (ConstArr A)
constComp' _·_ = _·_

constComp : ∀ {a} {A : Set a} (_·_ : A → A → A) → Composable (ConstArr A)
constComp _·_ = mk _·_

module Composable = IComposable

ixFunComp : ∀ {ix s} {Ix : Set ix} (F : Ix → Set s) → Composable (λ i o → F i → F o)
ixFunComp _ = mk (λ f g x → g (f x))

funComp : ∀ {s} → Composable (λ (A B : Set s) → A → B)
funComp = ixFunComp id

opComp : ∀ {s t} {S : Set s} {_↝_ : S → S → Set t} → Composable _↝_ → Composable (flip _↝_)
opComp (mk _>>>_) = mk (flip _>>>_)

open import Data.Vec
vecFunComp : ∀ {a} (A : Set a) → Composable (λ i o → Vec A i → Vec A o)
vecFunComp A = ixFunComp (Vec A)

open import Data.Bits
bitsFunComp : Composable (λ i o → Bits i → Bits o)
bitsFunComp = ixFunComp Bits

-- open import Data.Fin
-- funRewireComp : Composable (λ i o → Fin o → Fin i)
-- FunRewireComp = opComp (ixFunComp Fin)

{-
open import bintree

open import Data.Nat
CircuitType : Set₁
CircuitType = (i o : ℕ) → Set

RewireTbl : CircuitType
RewireTbl i o = Vec (Fin i) o

rewireTblComp : Composable RewireTbl
rewireTblComp = {!!}
-}


Inline ΔType.

Inline ΔType.

Old-commit-hash: 01465077ba29a751a7f67c946f2516def3753a94

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

module Structure where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  lift-diff-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))) →
    (∀ {ι Γ} → Term Γ (base (ΔBase ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} →
      Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-diff-apply diff apply {base ι} = diff , apply
  lift-diff-apply diff apply {σ ⇒ τ} =
    let
      -- for diff
      g  = var (that (that (that this)))
      f  = var (that (that this))
      x  = var (that this)
      Δx = var this
      -- for apply
      Δh = var (that (that this))
      h  = var (that this)
      y  = var this
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
      _⊝σ_ = λ s t  → app (app diffσ s) t
      _⊝τ_ = λ s t  → app (app diffτ s) t
      _⊕σ_ = λ t Δt → app (app applyσ Δt) t
      _⊕τ_ = λ t Δt → app (app applyτ Δt) t
    in
      abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
      ,
      abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

  lift-diff :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))) →
    (∀ {ι Γ} → Term Γ (base (ΔBase ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  lift-diff diff apply = λ {τ Γ} →
    proj₁ (lift-diff-apply diff apply {τ} {Γ})

  lift-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))) →
    (∀ {ι Γ} → Term Γ (base (ΔBase ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-apply diff apply = λ {τ Γ} →
    proj₂ (lift-diff-apply diff apply {τ} {Γ})

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

module Structure where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  lift-diff-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} →
      Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-diff-apply diff apply {base ι} = diff , apply
  lift-diff-apply diff apply {σ ⇒ τ} =
    let
      -- for diff
      g  = var (that (that (that this)))
      f  = var (that (that this))
      x  = var (that this)
      Δx = var this
      -- for apply
      Δh = var (that (that this))
      h  = var (that this)
      y  = var this
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
      _⊝σ_ = λ s t  → app (app diffσ s) t
      _⊝τ_ = λ s t  → app (app diffτ s) t
      _⊕σ_ = λ t Δt → app (app applyσ Δt) t
      _⊕τ_ = λ t Δt → app (app applyτ Δt) t
    in
      abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
      ,
      abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

  lift-diff :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  lift-diff diff apply = λ {τ Γ} →
    proj₁ (lift-diff-apply diff apply {τ} {Γ})

  lift-apply :
    (∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))) →
    (∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)) →
    ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-apply diff apply = λ {τ Γ} →
    proj₂ (lift-diff-apply diff apply {τ} {Γ})


Document P.C.Type.

Document P.C.Type.

Old-commit-hash: 11e38d018843f21411d014020ce42181e1f77d32

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Simply-typed changes (Fig. 3 and Fig. 4d)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type

module Parametric.Change.Type
  (Base : Type.Structure)
  where

open Type.Structure Base

-- Extension point: Simply-typed changes of base types.
Structure : Set
Structure = Base → Base

module Structure (ΔBase : Structure) where
  -- We provide: Simply-typed changes on simple types.
  ΔType : Type → Type
  ΔType (base ι) = base (ΔBase ι)
  ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ

  -- And we also provide context merging.
  open import Base.Change.Context ΔType public

import Parametric.Syntax.Type as Type

module Parametric.Change.Type
  (Base : Type.Structure)
  where

open Type.Structure Base

Structure : Set
Structure = Base → Base

module Structure (ΔBase : Structure) where
  ΔType : Type → Type
  ΔType (base ι) = base (ΔBase ι)
  ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ

  open import Base.Change.Context ΔType public