module Lambda where

  -- The typed λ-calculus

  -- The type of types
  data ty : Set where
     ι : ty                   -- the base type
     _⇒_ : ty → ty → ty      -- function type
     _×_ : ty → ty → ty      -- product type

  infixr 7 _⇒_
  infixl 8 _×_

  -- A typing context, there are no variable names because we use de Bruijn indices.
  data ctx : Set where
     • : ctx                  -- empty context
     _,_ : ctx → ty → ctx     -- context extension

  infixr 5 _,_

  -- A variable is a natural number (de Bruijn index, position in the context),
  -- but at the same time a proof that a type appears in the context.
  -- We write Γ ∋ A for the type of variables in Γ of type A.
  data _∋_ : (Γ : ctx) (B : ty) → Set where
     Z : {Γ : ctx} {B : ty} → (Γ , B) ∋ B              -- zero index
     S : {Γ : ctx} {A B : ty} → Γ ∋ B → (Γ , A) ∋ B    -- successor index

  infix 4 _∋_

  -- The type of terms in context Γ of type A
  data tm (Γ : ctx) : (A : ty) → Set where
     tm-var : {A : ty} → Γ ∋ A → tm Γ A
     tm-λ : {B : ty} {A : ty} → tm (Γ , A) B → tm Γ (A ⇒ B)
     tm-app : {A B : ty} → tm Γ (A ⇒ B) → tm Γ A → tm Γ B
     tm-pair : {A B : ty} → tm Γ A → tm Γ B → tm Γ (A × B)
     tm-fst : {A B : ty} → tm Γ (A × B) → tm Γ A
     tm-snd : {A B : ty} → tm Γ (A × B) → tm Γ B

  -- We need serveral boring auxiliary functions whose
  -- purpose is to define substitution

  -- A variable renaming is a type-preserving map from variables in Γ to variables in Δ
  -- (In Agda "renaming" is a reserved word.)
  variable-renaming = λ Γ Δ → ∀ {A} → Γ ∋ A → Δ ∋ A

  -- we may extend a renaming by one more variable (which does not get renamed)
  extend-renaming : ∀ {Γ Δ A} → variable-renaming Γ Δ → variable-renaming (Γ , A) (Δ , A)
  extend-renaming ρ Z = Z
  extend-renaming ρ (S x) = S (ρ x)

  -- the action of a renaming on a term
  term-rename : ∀ {Γ Δ} → variable-renaming Γ Δ → (∀ {A} → tm Γ A → tm Δ A)
  term-rename ρ (tm-var x) = tm-var (ρ x)
  term-rename ρ (tm-λ t) = tm-λ (term-rename (extend-renaming ρ) t)
  term-rename ρ (tm-app s t) = tm-app (term-rename ρ s) (term-rename ρ t)
  term-rename ρ (tm-pair s t) = tm-pair (term-rename ρ s) (term-rename ρ t)
  term-rename ρ (tm-fst t) = tm-fst (term-rename ρ t)
  term-rename ρ (tm-snd t) = tm-snd (term-rename ρ t)

  -- a special kind of renaming is weakening by a variable, which we write as ↑
  ↑ : ∀ {Γ A B} → tm Γ A → tm (Γ , B) A
  ↑ = term-rename S

  -- a substitution from Γ to Δ takes variables in Γ to terms in Δ
  substitution = λ Γ Δ → (∀ {A} → Γ ∋ A → tm Δ A)

  extend-substutition : ∀ {Γ Δ A} → substitution Γ Δ → substitution (Γ , A) (Δ , A)
  extend-substutition σ Z = tm-var Z
  extend-substutition σ (S x) = ↑ (σ x)

  -- The action of a substitution on a term
  term-substitute : ∀ {Γ Δ} → substitution Γ Δ → ∀ {A} → tm Γ A → tm Δ A
  term-substitute σ (tm-var x) = σ x
  term-substitute σ (tm-λ t) = tm-λ (term-substitute (extend-substutition σ) t)
  term-substitute σ (tm-app s t) = tm-app (term-substitute σ s) (term-substitute σ t)
  term-substitute σ (tm-pair s t) = tm-pair (term-substitute σ s) (term-substitute σ t)
  term-substitute σ (tm-fst t) = tm-fst (term-substitute σ t)
  term-substitute σ (tm-snd t) = tm-snd (term-substitute σ t)

  -- Auxiliary substitution that replaces just the 0-th variable
  subst-Z : ∀ {Γ A} → tm Γ A → substitution (Γ , A) Γ
  subst-Z t Z = t
  subst-Z T (S x) = tm-var x

  -- A common kind of substitution only replaces the 0-th variable with a term
  -- and leaves all the others intact, so we define its action as a shorthand
  _[_] : ∀ {Γ A B} → tm (Γ , A) B → tm Γ A → tm Γ B
  _[_] {Γ} {A} {B} s t = term-substitute (subst-Z t) s where

  infix 5 _[_]

  -- Judgemental equality
  data _≡_ {Γ : ctx} : {A : ty} (t s : tm Γ A) → Set where
    -- general rules
    eq-refl : {A : ty} {t : tm Γ A} → t ≡ t
    eq-tran : {A : ty} {t s u : tm Γ A} → t ≡ s → s ≡ u → t ≡ u
    eq-sym :  {A : ty} {t s : tm Γ A} → t ≡ s → s ≡ t
    -- congruence rules
    eq-congr-app : ∀ {A B} {t₁ t₂ : tm Γ (A ⇒ B)} {s₁ s₂ : tm Γ A} →
                   t₁ ≡ t₂ → s₁ ≡ s₂ → tm-app t₁ s₁ ≡ tm-app t₂ s₂
    eq-congr-λ : ∀ {A B} {t₁ t₂ : tm (Γ , A) B} → t₁ ≡ t₂ → tm-λ t₁ ≡ tm-λ t₂
    eq-congr-pair : ∀ {A B} {t₁ t₂ : tm Γ (A ⇒ B)} {s₁ s₂ : tm Γ A} →
                   t₁ ≡ t₂ → s₁ ≡ s₂ → tm-pair t₁ s₁ ≡ tm-pair t₂ s₂
    eq-congr-fst : ∀ {A B} {s t : tm Γ (A × B)} → s ≡ t → tm-fst s ≡ tm-fst t
    eq-congr-snd : ∀ {A B} {s t : tm Γ (A × B)} → s ≡ t → tm-snd s ≡ tm-snd t
    -- function type rules
    eq-β : ∀ {A B} {t : tm (Γ , A) B} {s : tm Γ A} → tm-app (tm-λ t) s ≡ t [ s ]
    eq-⇒ : ∀ {A B} {s t : tm Γ (A ⇒ B)} →
             tm-app (↑ s) (tm-var Z) ≡ tm-app (↑ t) (tm-var Z)
             → s ≡ t
    -- product rules
    eq-fst : ∀ {A B} {u : tm Γ A} {v : tm Γ B} → tm-fst (tm-pair u v) ≡ u
    eq-snd : ∀ {A B} {u : tm Γ A} {v : tm Γ B} → tm-snd (tm-pair u v) ≡ v
    eq-× : ∀{A B} {s t : tm Γ (A × B)} → tm-fst s ≡ tm-fst t → tm-snd s ≡ tm-snd t → s ≡ t

  infix 4 _≡_

  -- "η-equivalence" for products
  eq-pair-η : ∀ {Γ A B} {s : tm Γ (A × B)} → tm-pair (tm-fst s) (tm-snd s) ≡ s
  eq-pair-η = eq-× eq-fst eq-snd

  -- subst-↑ : ∀ {Γ A B} (t : tm Γ A) (s : tm Γ B) → (( (↑ t) [ s ] ) ≡ t)
  -- subst-↑ (tm-var x) s = eq-refl
  -- subst-↑ (tm-λ t) s = eq-congr-λ {!!}
  -- subst-↑ (tm-app t₁ t₂) s = eq-congr-app (subst-↑ t₁ s) (subst-↑ t₂ s)
  -- I commented this lemma that we tried to prove this morning because we did not achieve to do it yet, and Agda doesn't like the fact that I did not detail the other case of terms yet

  -- Example: the identity function
  -- Note that we actually define a family of terms, indexed by a context
  -- and a type, but the family is constant, i.e., it is always the same term.
  tm-id : ∀ {Γ A} → tm Γ (A ⇒ A)
  tm-id = tm-λ (tm-var Z)

  -- Appying the identity function twice does nothing
  app-id-id : ∀ {Γ A} {t : tm Γ A} → tm-app tm-id (tm-app tm-id t) ≡ t
  -- app-id-id = eq-tran (eq-congr-app eq-refl eq-β) eq-β
  app-id-id = eq-tran eq-β eq-β

  -- Eta-rule

  eq-η : ∀ {Γ A B} {t : tm Γ (A ⇒ B)} → tm-λ (tm-app (↑ t) (tm-var Z)) ≡ t
  eq-η = eq-⇒(eq-tran eq-β (eq-congr-app {!!} eq-refl))

  -- natural numbers
  data N : Set where
    zero : N
    succ : N → N

  -- church numerals

  tm-numeral : ∀ {Γ} → N → tm Γ ((ι ⇒ ι) ⇒ (ι ⇒ ι))
  tm-numeral zero = tm-id
  tm-numeral (succ n) = tm-λ (tm-λ (tm-app (tm-app (tm-numeral n) (tm-var (S Z))) (tm-app (tm-var (S Z)) (tm-var Z))))


module NF.Nat where

open import NF
open import Relation.Binary.PropositionalEquality
open import Data.Nat

instance
  nf0 : NF 0
  Sing.unpack (NF.!! nf0) = 0
  Sing.eq (NF.!! nf0) = refl

  {-# INLINE nf0 #-}

  nfSuc : {n : ℕ}{{nfn : NF n}} -> NF (suc n)
  Sing.unpack (NF.!! (nfSuc {n})) = suc (nf n)
  Sing.eq (NF.!! (nfSuc {{nfn}})) = cong suc nf≡

  {-# INLINE nfSuc #-}


------------------------------------------------------------------------
-- A large(r) class of algebraic structures satisfies the property
-- that isomorphic instances of a structure are equal (assuming
-- univalence)
------------------------------------------------------------------------

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

-- Note that this module uses ordinary propositional equality, with a
-- computing J rule.

-- This module has been developed in collaboration with Thierry
-- Coquand.

module Univalence-axiom.Isomorphism-is-equality.More where

open import Equality.Propositional
  hiding (refl) renaming (equality-with-J to eq)
open import Equality
open Derived-definitions-and-properties eq using (refl)

open import Bijection eq hiding (id; _∘_; inverse; step-↔; finally-↔)
open import Equivalence eq as Eq hiding (id; _∘_; inverse)
open import Function-universe eq hiding (id; _∘_)
open import H-level eq as H-level hiding (Proposition)
open import H-level.Closure eq
open import Logical-equivalence using (_⇔_)
open import Preimage eq
open import Prelude as P hiding (Type)
open import Univalence-axiom eq

------------------------------------------------------------------------
-- A record packing up certain assumptions

-- Use of these or similar assumptions is usually not documented in
-- comments below (with remarks like "assuming univalence").

record Assumptions : P.Type₂ where
  field
    ext₁  : Extensionality (# 1) (# 1)
    univ  : Univalence (# 0)
    univ₁ : Univalence (# 1)

  abstract

    ext : Extensionality (# 0) (# 0)
    ext = lower-extensionality (# 1) (# 1) ext₁

------------------------------------------------------------------------
-- A class of algebraic structures

-- An algebraic structure universe.

mutual

  -- Codes for structures.

  infixl 5 _▻_

  data Code : P.Type₂ where
    ε   : Code
    _▻_ : (c : Code) → Extension c → Code

  -- Structures can contain arbitrary "extensions".

  record Extension (c : Code) : P.Type₂ where
    field

      -- An instance-indexed type.

      Ext : ⟦ c ⟧ → P.Type₁

      -- A predicate specifying when two elements are isomorphic with
      -- respect to an isomorphism.

      Iso : (ass : Assumptions) →
            {I J : ⟦ c ⟧} → Isomorphic ass c I J →
            Ext I → Ext J → P.Type₁

    -- An alternative definition of Iso.

    Iso′ : (ass : Assumptions) →
           ∀ {I J} → Isomorphic ass c I J →
           Ext I → Ext J → P.Type₁
    Iso′ ass I≅J x y =
      subst Ext (_≃_.to (isomorphism≃equality ass c) I≅J) x ≡ y

    field

      -- Iso and Iso′ are equivalent.

      Iso≃Iso′ :
        (ass : Assumptions) →
        ∀ {I J} (I≅J : Isomorphic ass c I J) {x y} →
        Iso ass I≅J x y ≃ Iso′ ass I≅J x y

  -- Interpretation of the codes. The elements of ⟦ c ⟧ are instances
  -- of the structure encoded by c.

  ⟦_⟧ : Code → P.Type₁
  ⟦ ε     ⟧ = ↑ _ ⊤
  ⟦ c ▻ e ⟧ = Σ ⟦ c ⟧ (Extension.Ext e)

  -- Isomorphisms.

  Isomorphic : Assumptions → (c : Code) → ⟦ c ⟧ → ⟦ c ⟧ → P.Type₁
  Isomorphic _   ε       _       _       = ↑ _ ⊤
  Isomorphic ass (c ▻ e) (I , x) (J , y) =
    Σ (Isomorphic ass c I J) λ I≅J → Extension.Iso e ass I≅J x y

  -- Isomorphism is equivalent to equality.

  isomorphism≃equality : (ass : Assumptions) →
                         (c : Code) {I J : ⟦ c ⟧} →
                         Isomorphic ass c I J ≃ (I ≡ J)

  isomorphism≃equality _ ε =

      ↑ _ ⊤              ↔⟨ contractible-isomorphic (↑-closure 0 ⊤-contractible)
                                                    (⇒≡ 0 $ ↑-closure 0 ⊤-contractible) ⟩□
      lift tt ≡ lift tt  □

  isomorphism≃equality ass (c ▻ e) {I , x} {J , y} =

    (Σ (Isomorphic ass c I J) λ I≅J → Iso e ass I≅J x y)  ↝⟨ Σ-cong (isomorphism≃equality ass c)
                                                                    (λ I≅J → Iso≃Iso′ e ass I≅J) ⟩
    (Σ (I ≡ J) λ I≡J → subst (Ext e) I≡J x ≡ y)           ↔⟨ Σ-≡,≡↔≡ ⟩□

    ((I , x) ≡ (J , y))                                   □

    where open Extension

-- Isomorphism is equal to equality (assuming /only/ univalence).

isomorphism≡equality :
  (univ  : Univalence (# 0))
  (univ₁ : Univalence (# 1))
  (univ₂ : Univalence (# 2)) →

  let ass = record
        { ext₁  = dependent-extensionality univ₂ univ₁
        ; univ  = univ
        ; univ₁ = univ₁
        } in

  (c : Code) {I J : ⟦ c ⟧} →
  Isomorphic ass c I J ≡ (I ≡ J)
isomorphism≡equality univ univ₁ univ₂ c =
  ≃⇒≡ univ₁ $ isomorphism≃equality _ c

------------------------------------------------------------------------
-- Reflexivity

-- The isomorphism relation is reflexive.

reflexivity : (ass : Assumptions) → ∀ c I → Isomorphic ass c I I
reflexivity ass c I =
  _≃_.from (isomorphism≃equality ass c) (refl I)

-- Reflexivity relates an element to itself.

reflexivityE :
  (ass : Assumptions) →
  ∀ c e I x →
  Extension.Iso e ass (reflexivity ass c I) x x
reflexivityE ass c e I x =
  _≃_.from (Iso≃Iso′ ass (reflexivity ass c I)) (
    subst Ext (to (from (refl I))) x  ≡⟨ subst (λ eq → subst Ext eq x ≡ x)
                                               (sym $ right-inverse-of (refl I))
                                               (refl x) ⟩∎
    x                                 ∎)
  where
  open Extension e
  open _≃_ (isomorphism≃equality ass c)

-- Unfolding lemma (definitional) for reflexivity.

reflexivity-▻ :
  ∀ {ass c e I x} →
  reflexivity ass (c ▻ e) (I , x) ≡
  (reflexivity ass c I , reflexivityE ass c e I x)
reflexivity-▻ = refl _

------------------------------------------------------------------------
-- Recipe for defining extensions

-- Another kind of extension.

record Extension-with-resp (c : Code) : P.Type₂ where
  field

    -- An instance-indexed type.

    Ext : ⟦ c ⟧ → P.Type₁

    -- A predicate specifying when two elements are isomorphic with
    -- respect to an isomorphism.

    Iso : (ass : Assumptions) →
          {I J : ⟦ c ⟧} → Isomorphic ass c I J →
          Ext I → Ext J → P.Type₁

    -- Ext, seen as a predicate, respects isomorphisms.

    resp : (ass : Assumptions) →
           ∀ {I J} → Isomorphic ass c I J →
           Ext I → Ext J

    -- The resp function respects reflexivity.

    resp-refl : (ass : Assumptions) →
                ∀ {I} (x : Ext I) →
                resp ass (reflexivity ass c I) x ≡ x

  -- An alternative definition of Iso.

  Iso″ : (ass : Assumptions) →
         {I J : ⟦ c ⟧} → Isomorphic ass c I J →
         Ext I → Ext J → P.Type₁
  Iso″ ass I≅J x y = resp ass I≅J x ≡ y

  field

    -- Iso and Iso″ are equivalent.

    Iso≃Iso″ :
      (ass : Assumptions) →
      ∀ {I J} (I≅J : Isomorphic ass c I J) {x y} →
      Iso ass I≅J x y ≃ Iso″ ass I≅J x y

  -- Another alternative definition of Iso.

  Iso′ : (ass : Assumptions) →
         ∀ {I J} → Isomorphic ass c I J →
         Ext I → Ext J → P.Type₁
  Iso′ ass I≅J x y =
    subst Ext (_≃_.to (isomorphism≃equality ass c) I≅J) x ≡ y

  abstract

    -- Every element is isomorphic to itself, transported along the
    -- "outer" isomorphism.

    isomorphic-to-itself″ :
      (ass : Assumptions) →
      ∀ {I J} (I≅J : Isomorphic ass c I J) {x} →
      Iso″ ass I≅J x
           (subst Ext (_≃_.to (isomorphism≃equality ass c) I≅J) x)
    isomorphic-to-itself″ ass I≅J {x} = transport-theorem′
      Ext
      (Isomorphic ass c)
      (_≃_.surjection $ inverse $ isomorphism≃equality ass c)
      (resp ass)
      (λ _ → resp-refl ass)
      I≅J
      x

  -- Iso and Iso′ are equivalent.

  Iso≃Iso′ :
    (ass : Assumptions) →
    ∀ {I J} (I≅J : Isomorphic ass c I J) {x y} →
    Iso ass I≅J x y ≃ Iso′ ass I≅J x y
  Iso≃Iso′ ass I≅J {x} {y} = record
    { to             = to
    ; is-equivalence =
        _⇔_.from (Is-equivalence≃Is-equivalence-CP _) λ y →
          (from y , right-inverse-of y) , irrelevance y
    }
    where
    -- This is the core of the definition. I could have defined
    -- Iso≃Iso′ ... = I≃I′. The rest is only included in order to
    -- control how much Agda unfolds the code.
    I≃I′ =
      Iso  ass I≅J x y  ↝⟨ Iso≃Iso″ ass I≅J ⟩
      Iso″ ass I≅J x y  ↝⟨ ≡⇒≃ $ cong (λ z → z ≡ y) $ isomorphic-to-itself″ ass I≅J ⟩□
      Iso′ ass I≅J x y  □

    to   = _≃_.to   I≃I′
    from = _≃_.from I≃I′

    abstract
      right-inverse-of : ∀ x → to (from x) ≡ x
      right-inverse-of = _≃_.right-inverse-of I≃I′

      irrelevance : ∀ y (p : to ⁻¹ y) → (from y , right-inverse-of y) ≡ p
      irrelevance = _≃_.irrelevance I≃I′

  -- An extension constructed from the fields above.

  extension : Extension c
  extension = record { Ext = Ext; Iso = Iso; Iso≃Iso′ = Iso≃Iso′ }

  -- Every element is isomorphic to itself, transported (in another
  -- way) along the "outer" isomorphism.

  isomorphic-to-itself :
    (ass : Assumptions) →
    ∀ {I J} (I≅J : Isomorphic ass c I J) x →
    Iso ass I≅J x (resp ass I≅J x)
  isomorphic-to-itself ass I≅J x =
    _≃_.from (Iso≃Iso″ ass I≅J) (refl (resp ass I≅J x))

  abstract

    -- Simplification lemmas.

    resp-refl-lemma :
      (ass : Assumptions) →
      ∀ I x →
      resp-refl ass x ≡
      _≃_.from (≡⇒≃ $ cong (λ z → z ≡ x) $
                      isomorphic-to-itself″ ass (reflexivity ass c I))
               (subst (λ eq → subst Ext eq x ≡ x)
                      (sym $ _≃_.right-inverse-of
                               (isomorphism≃equality ass c)
                               (refl I))
                      (refl x))
    resp-refl-lemma ass I x =
      let rfl    = reflexivity ass c I
          iso≃eq = λ {I J} → isomorphism≃equality ass c {I = I} {J = J}
          rio    = right-inverse-of iso≃eq (refl I)
          lio    = left-inverse-of (inverse iso≃eq) (refl I)
          sx≡x   = subst (λ eq → subst Ext eq x ≡ x) (sym rio) (refl x)

          sx≡x-lemma =
            cong (λ eq → subst Ext eq x) rio                      ≡⟨ sym $ trans-reflʳ _ ⟩

            trans (cong (λ eq → subst Ext eq x) rio)
                  (refl x)                                        ≡⟨ sym $ subst-trans (cong (λ eq → subst Ext eq x) rio) ⟩

            subst (λ z → z ≡ x)
                  (sym $ cong (λ eq → subst Ext eq x) rio)
                  (refl x)                                        ≡⟨ cong (λ eq → subst (λ z → z ≡ x) eq (refl x)) $ sym $
                                                                          cong-sym (λ eq → subst Ext eq x) rio ⟩
            subst (λ z → z ≡ x)
                  (cong (λ eq → subst Ext eq x) $ sym rio)
                  (refl x)                                        ≡⟨ sym $ subst-∘ (λ z → z ≡ x) (λ eq → subst Ext eq x) (sym rio) ⟩∎

            subst (λ eq → subst Ext eq x ≡ x) (sym rio) (refl x)  ∎

          lemma₁ =
            trans (sym lio) rio  ≡⟨ cong (λ eq → trans (sym eq) rio) $ left-inverse-of∘inverse iso≃eq ⟩

            trans (sym rio) rio  ≡⟨ trans-symˡ rio ⟩∎

            refl (refl I)        ∎

          lemma₂ =
            elim-refl (λ {I J} _ → Ext I → Ext J) (λ _ e → e)  ≡⟨⟩

            cong (subst Ext) (refl (refl I))                   ≡⟨ cong (cong (subst Ext)) $ sym lemma₁ ⟩∎

            cong (subst Ext) (trans (sym lio) rio)             ∎

          lemma₃ =
            cong (λ r → r x)
                 (elim-refl (λ {I J} _ → Ext I → Ext J) (λ _ e → e))   ≡⟨ cong (cong (λ r → r x)) lemma₂ ⟩

            cong (λ r → r x) (cong (subst Ext) (trans (sym lio) rio))  ≡⟨ cong-∘ (λ r → r x) (subst Ext) (trans (sym lio) rio) ⟩

            cong (λ eq → subst Ext eq x) (trans (sym lio) rio)         ≡⟨ cong-trans (λ eq → subst Ext eq x) (sym lio) rio ⟩

            trans (cong (λ eq → subst Ext eq x) (sym lio))
                  (cong (λ eq → subst Ext eq x) rio)                   ≡⟨ cong (λ eq → trans eq (cong (λ eq → subst Ext eq x) rio)) $
                                                                               cong-sym (λ eq → subst Ext eq x) lio ⟩∎
            trans (sym (cong (λ eq → subst Ext eq x) lio))
                  (cong (λ eq → subst Ext eq x) rio)                   ∎
      in

      resp-refl ass x                                                  ≡⟨ sym $ trans-reflʳ _ ⟩

      trans (resp-refl ass x) (refl x)                                 ≡⟨ cong (trans (resp-refl ass x)) $ trans-symˡ (subst-refl Ext x) ⟩

      trans (resp-refl ass x)
            (trans (sym $ subst-refl Ext x) (subst-refl Ext x))        ≡⟨ sym $ trans-assoc _ (sym $ subst-refl Ext x) (subst-refl Ext x) ⟩

      trans (trans (resp-refl ass x) (sym $ subst-refl Ext x))
            (subst-refl Ext x)                                         ≡⟨ cong (trans (trans (resp-refl ass x) (sym $ subst-refl Ext x)))
                                                                               lemma₃ ⟩
      trans (trans (resp-refl ass x) (sym $ subst-refl Ext x))
            (trans (sym (cong (λ eq → subst Ext eq x) lio))
                   (cong (λ eq → subst Ext eq x) rio))                 ≡⟨ sym $ trans-assoc _ _ (cong (λ eq → subst Ext eq x) rio) ⟩

      trans (trans (trans (resp-refl ass x) (sym $ subst-refl Ext x))
                   (sym (cong (λ eq → subst Ext eq x) lio)))
            (cong (λ eq → subst Ext eq x) rio)                         ≡⟨ cong₂ trans
                                                                            (sym $ transport-theorem′-refl Ext (Isomorphic ass c) (inverse iso≃eq)
                                                                                (resp ass) (λ _ → resp-refl ass) x)
                                                                            sx≡x-lemma ⟩
      trans (isomorphic-to-itself″ ass rfl) sx≡x                       ≡⟨ sym $ subst-trans (isomorphic-to-itself″ ass rfl) ⟩

      subst (λ z → z ≡ x) (sym $ isomorphic-to-itself″ ass rfl) sx≡x   ≡⟨ subst-in-terms-of-inverse∘≡⇒↝ equivalence
                                                                            (isomorphic-to-itself″ ass rfl) (λ z → z ≡ x) _ ⟩∎
      from (≡⇒≃ $ cong (λ z → z ≡ x) $ isomorphic-to-itself″ ass rfl)
           sx≡x                                                        ∎

      where open _≃_

    isomorphic-to-itself-reflexivity :
      (ass : Assumptions) →
      ∀ I x →
      isomorphic-to-itself ass (reflexivity ass c I) x ≡
      subst (Iso ass (reflexivity ass c I) x)
            (sym $ resp-refl ass x)
            (reflexivityE ass c extension I x)
    isomorphic-to-itself-reflexivity ass I x =
      let rfl = reflexivity ass c I
          r-r = resp-refl ass x in

      from (Iso≃Iso″ ass rfl) (refl (resp ass rfl x))                  ≡⟨ elim¹ (λ {y} resp-x≡y → from (Iso≃Iso″ ass rfl) (refl (resp ass rfl x)) ≡
                                                                                subst (Iso ass rfl x) (sym resp-x≡y)
                                                                                (from (Iso≃Iso″ ass rfl) resp-x≡y))
                                                                                (refl _) r-r ⟩
      subst (Iso ass rfl x) (sym r-r) (from (Iso≃Iso″ ass rfl) r-r)    ≡⟨ cong (subst (Iso ass rfl x) (sym r-r) ∘ from (Iso≃Iso″ ass rfl))
                                                                               (resp-refl-lemma ass I x) ⟩∎
      subst (Iso ass rfl x) (sym r-r)
        (from (Iso≃Iso″ ass rfl)
           (from
              (≡⇒≃ $ cong (λ z → z ≡ x)
                          (isomorphic-to-itself″ ass rfl))
              (subst (λ eq → subst Ext eq x ≡ x)
                 (sym $ right-inverse-of (isomorphism≃equality ass c)
                                         (refl I)) (refl x))))         ∎

      where open _≃_

------------------------------------------------------------------------
-- Type extractors

record Extractor (c : Code) : P.Type₂ where
  field

    -- Extracts a type from an instance.

    Type : ⟦ c ⟧ → P.Type₁

    -- Extracts an equivalence relating types extracted from
    -- isomorphic instances.
    --
    -- Perhaps one could have a variant of Type-cong that is not based
    -- on any "Assumptions", and produces logical equivalences (_⇔_)
    -- instead of equivalences (_≃_). Then one could (hopefully)
    -- define isomorphism without using any assumptions.

    Type-cong : (ass : Assumptions) →
                ∀ {I J} → Isomorphic ass c I J → Type I ≃ Type J

    -- Reflexivity is mapped to the identity equivalence.

    Type-cong-reflexivity :
      (ass : Assumptions) →
      ∀ I → Type-cong ass (reflexivity ass c I) ≡ Eq.id

-- Constant type extractor.

[_] : ∀ {c} → P.Type₁ → Extractor c
[_] {c} A = record
  { Type                  = λ _ → A
  ; Type-cong             = λ _ _ → Eq.id
  ; Type-cong-reflexivity = λ _ _ → refl _
  }

-- Successor type extractor.

infix 6 1+_

1+_ : ∀ {c e} → Extractor c → Extractor (c ▻ e)
1+_ {c} {e} extractor = record
  { Type                  = Type ∘ proj₁
  ; Type-cong             = λ ass → Type-cong ass ∘ proj₁
  ; Type-cong-reflexivity = λ { ass (I , x) →
      Type-cong ass (reflexivity ass c I)  ≡⟨ Type-cong-reflexivity ass I ⟩∎
      Eq.id                                ∎ }
  }
  where
  open Extractor extractor

------------------------------------------------------------------------
-- An extension: types

-- Extends a structure with a type.

A-type : ∀ {c} → Extension c
A-type {c} = record
  { Ext      = λ _ → P.Type
  ; Iso      = λ _ _ A B → ↑ _ (A ≃ B)
  ; Iso≃Iso′ = λ ass I≅J {A B} →
                 let I≡J = _≃_.to (isomorphism≃equality ass c) I≅J in

                 ↑ _ (A ≃ B)                       ↔⟨ ↑↔ ⟩
                 (A ≃ B)                           ↝⟨ inverse $ ≡≃≃ (Assumptions.univ ass) ⟩
                 (A ≡ B)                           ↝⟨ ≡⇒≃ $ cong (λ C → C ≡ B) $ sym (subst-const I≡J) ⟩
                 (subst (λ _ → P.Type) I≡J A ≡ B)  □
  }

-- A corresponding type extractor.

[0] : ∀ {c} → Extractor (c ▻ A-type)
[0] {c} = record
  { Type                  = λ { (_ , A) → ↑ _ A }
  ; Type-cong             = λ { _ (_ , lift A≃B) → ↑-cong A≃B }
  ; Type-cong-reflexivity = λ { ass (I , A) → elim₁
      (λ {p} q →
         ↑-cong (≡⇒≃
           (from (≡⇒≃ (cong (λ C → C ≡ A) (sym (subst-const p))))
                 (subst (λ eq → subst Ext eq A ≡ A)
                        (sym q) (refl A)))) ≡
         Eq.id)
      (lift-equality (Assumptions.ext₁ ass) (refl _))
      (right-inverse-of (isomorphism≃equality ass c) (refl I)) }
  }
  where
  open Extension A-type
  open _≃_

------------------------------------------------------------------------
-- An extension: propositions

-- Extends a structure with a proposition.

Proposition : ∀ {c} →

              -- The proposition.
              (P : ⟦ c ⟧ → P.Type₁) →

              -- The proposition must be propositional (given some
              -- assumptions).
              (Assumptions → ∀ I → Is-proposition (P I)) →

              Extension c
Proposition {c} P prop = record
  { Ext      = P
  ; Iso      = λ _ _ _ _ → ↑ _ ⊤
  ; Iso≃Iso′ = λ ass I≅J {_ p} →
                 ↑ _ ⊤    ↔⟨ contractible-isomorphic
                               (↑-closure 0 ⊤-contractible)
                               (⇒≡ 0 $ propositional⇒inhabited⇒contractible (prop ass _) p) ⟩□
                 (_ ≡ _)  □
  }

-- The proposition stating that a given type is a set.

Is-a-set : ∀ {c} → Extractor c → Extension c
Is-a-set extractor =
  Proposition (Is-set ∘ Type)
              (λ ass _ → H-level-propositional (Assumptions.ext₁ ass) 2)
  where open Extractor extractor

------------------------------------------------------------------------
-- An extension: n-ary functions

-- N-ary functions.

_^_⟶_ : P.Type₁ → ℕ → P.Type₁ → P.Type₁
A ^ zero  ⟶ B = B
A ^ suc n ⟶ B = A → A ^ n ⟶ B

-- N-ary function morphisms.

Is-_-ary-morphism :
  ∀ (n : ℕ) {A B} → (A ^ n ⟶ A) → (B ^ n ⟶ B) → (A → B) → P.Type₁
Is- zero  -ary-morphism x y m = m x ≡ y
Is- suc n -ary-morphism f g m =
  ∀ x → Is- n -ary-morphism (f x) (g (m x)) m

-- An n-ary function extension.

N-ary : ∀ {c} →

        -- Extracts the underlying type.
        Extractor c →

        -- The function's arity.
        ℕ →

        Extension c
N-ary {c} extractor n = Extension-with-resp.extension record
  { Ext       = λ I → Type I ^ n ⟶ Type I
  ; Iso       = λ ass I≅J f g →
                    Is- n -ary-morphism f g (_≃_.to (Type-cong ass I≅J))
  ; resp      = λ ass I≅J → cast n (Type-cong ass I≅J)
  ; resp-refl = λ ass f →
                    cast n (Type-cong ass (reflexivity ass c _)) f  ≡⟨ cong (λ eq → cast n eq f) $ Type-cong-reflexivity ass _ ⟩
                    cast n Eq.id f                                  ≡⟨ cast-id (Assumptions.ext₁ ass) n f ⟩∎
                    f                                               ∎
  ; Iso≃Iso″  = λ ass I≅J {f g} →
      Iso≃Iso″ (Assumptions.ext₁ ass) (Type-cong ass I≅J) n f g
  }
  where
  open Extractor extractor

  -- Changes the type of an n-ary function.

  cast : ∀ n {A B} → A ≃ B → A ^ n ⟶ A → B ^ n ⟶ B
  cast zero    A≃B = _≃_.to A≃B
  cast (suc n) A≃B = λ f x → cast n A≃B (f (_≃_.from A≃B x))

  -- Cast simplification lemma.

  cast-id : Extensionality (# 1) (# 1) →
            ∀ {A} n (f : A ^ n ⟶ A) → cast n Eq.id f ≡ f
  cast-id ext zero    x = refl x
  cast-id ext (suc n) f = apply-ext ext λ x → cast-id ext n (f x)

  -- Two definitions of isomorphism are equivalent.

  Iso≃Iso″ :
    Extensionality (# 1) (# 1) →
    ∀ {A B} (A≃B : A ≃ B)
    (n : ℕ) (f : A ^ n ⟶ A) (g : B ^ n ⟶ B) →
    Is- n -ary-morphism f g (_≃_.to A≃B) ≃ (cast n A≃B f ≡ g)

  Iso≃Iso″ ext A≃B zero x y =

    (_≃_.to A≃B x ≡ y)  □

  Iso≃Iso″ ext A≃B (suc n) f g =

    (∀ x → Is- n -ary-morphism (f x) (g (_≃_.to A≃B x)) (_≃_.to A≃B))  ↝⟨ ∀-cong ext (λ x →
                                                                            Iso≃Iso″ ext A≃B n (f x) (g (_≃_.to A≃B x))) ⟩
    (∀ x → cast n A≃B (f x) ≡ g (_≃_.to A≃B x))                        ↝⟨ Eq.extensionality-isomorphism ext ⟩

    (cast n A≃B ∘ f ≡ g ∘ _≃_.to A≃B)                                  ↔⟨ inverse $ ∘from≡↔≡∘to ext A≃B ⟩□

    (cast n A≃B ∘ f ∘ _≃_.from A≃B ≡ g)                                □

------------------------------------------------------------------------
-- An extension: simply typed functions

-- This section contains a generalisation of the development for n-ary
-- functions above.

-- Simple types.

data Simple-type (c : Code) : P.Type₂ where
  base : Extractor c → Simple-type c
  _⟶_  : Simple-type c → Simple-type c → Simple-type c

-- Interpretation of a simple type.

⟦_⟧⟶ : ∀ {c} → Simple-type c → ⟦ c ⟧ → P.Type₁
⟦ base A ⟧⟶ I = Extractor.Type A I
⟦ σ ⟶ τ  ⟧⟶ I = ⟦ σ ⟧⟶ I → ⟦ τ ⟧⟶ I

-- A simply typed function extension.

Simple : ∀ {c} → Simple-type c → Extension c
Simple {c} σ = Extension-with-resp.extension record
  { Ext       = ⟦ σ ⟧⟶
  ; Iso       = λ ass → Iso ass σ
  ; resp      = λ ass I≅J → _≃_.to (cast ass σ I≅J)
  ; resp-refl = λ ass f → cong (λ eq → _≃_.to eq f) $ cast-refl ass σ
  ; Iso≃Iso″  = λ ass → Iso≃Iso″ ass σ
  }
  where
  open Extractor

  -- Isomorphisms between simply typed values.

  Iso : (ass : Assumptions) →
        (σ : Simple-type c) →
        ∀ {I J} → Isomorphic ass c I J → ⟦ σ ⟧⟶ I → ⟦ σ ⟧⟶ J → P.Type₁
  Iso ass (base A) I≅J x y = _≃_.to (Type-cong A ass I≅J) x ≡ y
  Iso ass (σ ⟶ τ)  I≅J f g =
    ∀ x y → Iso ass σ I≅J x y → Iso ass τ I≅J (f x) (g y)

  -- Cast.

  cast : (ass : Assumptions) →
         (σ : Simple-type c) →
         ∀ {I J} → Isomorphic ass c I J → ⟦ σ ⟧⟶ I ≃ ⟦ σ ⟧⟶ J
  cast ass (base A) I≅J = Type-cong A ass I≅J
  cast ass (σ ⟶ τ)  I≅J = →-cong ext₁ (cast ass σ I≅J) (cast ass τ I≅J)
    where open Assumptions ass

  -- Cast simplification lemma.

  cast-refl : (ass : Assumptions) →
              ∀ σ {I} → cast ass σ (reflexivity ass c I) ≡ Eq.id
  cast-refl ass (base A) {I} =
    Type-cong A ass (reflexivity ass c I)  ≡⟨ Type-cong-reflexivity A ass I ⟩∎
    Eq.id                                  ∎

  cast-refl ass (σ ⟶ τ) {I} =
    cast ass (σ ⟶ τ) (reflexivity ass c I)  ≡⟨ lift-equality ext₁ $ cong _≃_.to $
                                                 cong₂ (→-cong ext₁) (cast-refl ass σ) (cast-refl ass τ) ⟩∎
    Eq.id                                   ∎
    where open Assumptions ass

  -- Two definitions of isomorphism are equivalent.

  Iso≃Iso″ :
    (ass : Assumptions) →
    (σ : Simple-type c) →
    ∀ {I J} (I≅J : Isomorphic ass c I J) {f g} →
    Iso ass σ I≅J f g ≃ (_≃_.to (cast ass σ I≅J) f ≡ g)
  Iso≃Iso″ ass (base A) I≅J {x} {y} =

    (_≃_.to (Type-cong A ass I≅J) x ≡ y)  □

  Iso≃Iso″ ass (σ ⟶ τ) I≅J {f} {g} =

    (∀ x y → Iso ass σ I≅J x y → Iso ass τ I≅J (f x) (g y))        ↝⟨ ∀-cong ext₁ (λ _ → ∀-cong ext₁ λ _ →
                                                                        →-cong ext₁ (Iso≃Iso″ ass σ I≅J) (Iso≃Iso″ ass τ I≅J)) ⟩
    (∀ x y → to (cast ass σ I≅J) x ≡ y →
             to (cast ass τ I≅J) (f x) ≡ g y)                      ↝⟨ inverse $ ∀-cong ext₁ (λ x →
                                                                        ∀-intro (λ y _ → to (cast ass τ I≅J) (f x) ≡ g y) ext₁) ⟩
    (∀ x → to (cast ass τ I≅J) (f x) ≡ g (to (cast ass σ I≅J) x))  ↝⟨ extensionality-isomorphism ext₁ ⟩

    (to (cast ass τ I≅J) ∘ f ≡ g ∘ to (cast ass σ I≅J))            ↔⟨ inverse $ ∘from≡↔≡∘to ext₁ (cast ass σ I≅J) ⟩□

    (to (cast ass τ I≅J) ∘ f ∘ from (cast ass σ I≅J) ≡ g)          □

    where
    open _≃_
    open Assumptions ass

------------------------------------------------------------------------
-- An unfinished extension: dependent types

-- The extension currently supports polymorphic types.

module Dependent where

  open Extractor

  ----------------------------------------------------------------------
  -- The extension

  -- Dependent types.

  data Ty (c : Code) : P.Type₂

  -- Extension: Dependently-typed functions.

  ext-with-resp : ∀ {c} → Ty c → Extension-with-resp c

  private
    open module E {c} (σ : Ty c) =
      Extension-with-resp (ext-with-resp σ)
      hiding (Iso; Iso≃Iso″; extension)
  open E public using () renaming (extension to Dep)

  data Ty c where
    set  : Ty c
    base : Extractor c → Ty c
    Π    : (σ : Ty c) → Ty (c ▻ Dep σ) → Ty c

  -- Interpretation of a dependent type.

  ⟦_⟧Π : ∀ {c} → Ty c → ⟦ c ⟧ → P.Type₁

  -- Isomorphisms between dependently typed functions.

  Iso :
    (ass : Assumptions) →
    ∀ {c} (σ : Ty c) →
    ∀ {I J} → Isomorphic ass c I J → ⟦ σ ⟧Π I → ⟦ σ ⟧Π J → P.Type₁

  -- A cast function.

  cast : (ass : Assumptions) →
         ∀ {c} (σ : Ty c) {I J} →
         Isomorphic ass c I J → ⟦ σ ⟧Π I ≃ ⟦ σ ⟧Π J

  -- Reflexivity is mapped to identity.

  cast-refl : (ass : Assumptions) →
              ∀ {c} (σ : Ty c) {I} →
              cast ass σ (reflexivity ass c I) ≡ Eq.id

  -- Two definitions of isomorphism are equivalent.

  Iso≃Iso″ : (ass : Assumptions) →
             ∀ {c} (σ : Ty c) {I J} (I≅J : Isomorphic ass c I J) {f g} →
             Iso ass σ I≅J f g ≃ (_≃_.to (cast ass σ I≅J) f ≡ g)

  -- Extension: Dependently-typed functions.

  ext-with-resp {c} σ = record
    { Ext       = ⟦ σ ⟧Π
    ; Iso       = λ ass → Iso ass σ
    ; resp      = λ ass I≅J → _≃_.to (cast ass σ I≅J)
    ; resp-refl = λ ass f → cong (λ eq → _≃_.to eq f) $ cast-refl ass σ
    ; Iso≃Iso″  = λ ass → Iso≃Iso″ ass σ
    }

  -- Interpretation of a dependent type.

  ⟦ set    ⟧Π _ = P.Type
  ⟦ base A ⟧Π I = Type A I
  ⟦ Π σ τ  ⟧Π I = (x : ⟦ σ ⟧Π I) → ⟦ τ ⟧Π (I , x)

  -- Isomorphisms between dependently typed functions.

  Iso _   set      _   A B = ↑ _ (A ≃ B)
  Iso ass (base A) I≅J x y = x ≡ _≃_.from (Type-cong A ass I≅J) y
  Iso ass (Π σ τ)  I≅J f g = ∀ x y →
    (x≅y : Iso ass σ I≅J x y) → Iso ass τ (I≅J , x≅y) (f x) (g y)

  -- A cast function.

  cast ass set      I≅J = Eq.id
  cast ass (base A) I≅J = Type-cong A ass I≅J
  cast ass (Π σ τ)  I≅J = Π-cong ext₁
    (cast ass σ I≅J)
    (λ x → cast ass τ (I≅J , isomorphic-to-itself σ ass I≅J x))
    where open Assumptions ass

  abstract

    -- Reflexivity is mapped to identity.

    cast-refl ass     set          = refl Eq.id
    cast-refl ass {c} (base A) {I} =

      Type-cong A ass (reflexivity ass c I)  ≡⟨ Type-cong-reflexivity A ass I ⟩∎

      Eq.id                                  ∎

    cast-refl ass {c} (Π σ τ) {I} =
      let rfl   = reflexivity ass c I
          rflE  = reflexivityE ass c (Dep σ) I in

      lift-equality-inverse ext₁ $
      apply-ext ext₁ λ f →
      apply-ext ext₁ λ x →

        from (cast ass τ (rfl , isomorphic-to-itself σ ass rfl x))
             (f (resp σ ass rfl x))                                 ≡⟨ cong (λ iso → from (cast ass τ (rfl , iso)) (f (resp σ ass rfl x))) $
                                                                            isomorphic-to-itself-reflexivity σ ass I x ⟩
        from (cast ass τ (rfl , subst (Iso ass σ rfl x)
                                      (sym $ resp-refl σ ass x)
                                      (rflE x)))
             (f (resp σ ass rfl x))                                 ≡⟨ elim¹ (λ {y} x≡y →
                                                                                from (cast ass τ (rfl , subst (Iso ass σ rfl x)
                                                                                x≡y (rflE x)))
                                                                                (f y) ≡
                                                                                f x)
                                                                             (cong (λ h → _≃_.from h (f x)) $ cast-refl ass τ)
                                                                             (sym $ resp-refl σ ass x) ⟩∎
        f x                                                         ∎

      where
      open _≃_
      open Assumptions ass

  -- Two definitions of isomorphism are equivalent.

  Iso≃Iso‴ :
    (ass : Assumptions) →
    ∀ {c} (σ : Ty c) {I J} (I≅J : Isomorphic ass c I J) {f g} →
    Iso ass σ I≅J f g ≃ (f ≡ _≃_.from (cast ass σ I≅J) g)

  Iso≃Iso‴ ass set I≅J {A} {B} =

    ↑ _ (A ≃ B)  ↔⟨ ↑↔ ⟩

    (A ≃ B)      ↝⟨ inverse $ ≡≃≃ (Assumptions.univ ass) ⟩□

    (A ≡ B)      □

  Iso≃Iso‴ ass (base A) I≅J {x} {y} =

    (x ≡ _≃_.from (Type-cong A ass I≅J) y)  □

  Iso≃Iso‴ ass (Π σ τ) I≅J {f} {g} =
    let iso-to-itself = isomorphic-to-itself σ ass I≅J in

    (∀ x y (x≅y : Iso ass σ I≅J x y) →
           Iso ass τ (I≅J , x≅y) (f x) (g y))                        ↝⟨ ∀-cong ext₁ (λ x → ∀-cong ext₁ λ y →
                                                                          Π-cong ext₁ (Iso≃Iso″ ass σ I≅J) (λ x≅y →
           Iso ass τ (I≅J , x≅y) (f x) (g y)                                ↝⟨ Iso≃Iso″ ass τ (I≅J , x≅y) ⟩
           (resp τ ass (I≅J , x≅y) (f x) ≡ g y)                             ↝⟨ ≡⇒≃ $ cong (λ x≅y → resp τ ass (I≅J , x≅y) (f x) ≡ g y) $
                                                                                sym $ left-inverse-of (Iso≃Iso″ ass σ I≅J) _ ⟩□
           (resp τ ass (I≅J , from (Iso≃Iso″ ass σ I≅J)
                                   (to (Iso≃Iso″ ass σ I≅J) x≅y))
               (f x) ≡ g y)                                                 □)) ⟩

    (∀ x y (x≡y : to (cast ass σ I≅J) x ≡ y) →
           resp τ ass (I≅J , from (Iso≃Iso″ ass σ I≅J) x≡y) (f x) ≡
           g y)                                                      ↝⟨ ∀-cong ext₁ (λ x → inverse $
                                                                          ∀-intro (λ y x≡y → _ ≡ _) ext₁) ⟩
    (∀ x → resp τ ass (I≅J , iso-to-itself x) (f x) ≡
           g (resp σ ass I≅J x))                                     ↔⟨ extensionality-isomorphism ext₁ ⟩

    (resp τ ass (I≅J , iso-to-itself _) ∘ f ≡ g ∘ resp σ ass I≅J)    ↔⟨ to∘≡↔≡from∘ ext₁ (cast ass τ (I≅J , iso-to-itself _)) ⟩

    (f ≡ from (cast ass τ (I≅J , iso-to-itself _)) ∘
         g ∘ resp σ ass I≅J)                                         □

    where
    open _≃_
    open Assumptions ass

  abstract

    -- Two definitions of isomorphism are equivalent.

    Iso≃Iso″ ass σ I≅J {f} {g} =
      Iso ass σ I≅J f g                  ↝⟨ Iso≃Iso‴ ass σ I≅J ⟩

      (f ≡ _≃_.from (cast ass σ I≅J) g)  ↔⟨ inverse $ from≡↔≡to (inverse $ cast ass σ I≅J) ⟩□

      (_≃_.to (cast ass σ I≅J) f ≡ g)    □

  ----------------------------------------------------------------------
  -- An instantiation of the type extractor mechanism that gives us
  -- support for polymorphic types

  abstract

    reflexivityE-set :
      (ass : Assumptions) →
      ∀ {c} {I : ⟦ c ⟧} {A} →
      reflexivityE ass c (Dep set) I A ≡ lift Eq.id
    reflexivityE-set ass {c} {I} {A} =
      let ≡⇒→′ = _↔_.to ∘ ≡⇒↝ _ in

      reflexivityE ass c (Dep set) I A                                ≡⟨⟩

      lift (≡⇒≃ (to (from≡↔≡to (inverse Eq.id))
              (from (≡⇒≃ $ cong (λ B → B ≡ A) $
                       isomorphic-to-itself″ set ass
                         (reflexivity ass c I))
                    (subst (λ eq → subst (λ _ → P.Type) eq A ≡ A)
                           (sym $ right-inverse-of
                                    (isomorphism≃equality ass c)
                                    (refl I))
                           (refl A)))))                               ≡⟨ cong (λ eq → lift (≡⇒≃ (to (from≡↔≡to (inverse Eq.id)) eq))) $ sym $
                                                                           resp-refl-lemma set ass I A ⟩
      lift (≡⇒≃ (to (from≡↔≡to (inverse Eq.id))
                    (resp-refl set ass {I = I} A)))                   ≡⟨⟩

      lift (≡⇒≃ (to (from≡↔≡to (inverse Eq.id)) (refl A)))            ≡⟨⟩

      lift (≡⇒≃ (≡⇒→′ (cong (λ B → B ≡ A)
                            (right-inverse-of (inverse Eq.id) A))
                      (cong id (refl A))))                            ≡⟨⟩

      lift (≡⇒≃ (≡⇒→′ (cong (λ B → B ≡ A) (left-inverse-of Eq.id A))
                      (cong id (refl A))))                            ≡⟨ cong (λ eq → lift (≡⇒≃ (≡⇒→′ (cong (λ B → B ≡ A) eq) (refl A))))
                                                                         left-inverse-of-id  ⟩
      lift (≡⇒≃ (≡⇒→′ (cong (λ B → B ≡ A) (refl A)) (refl A)))        ≡⟨⟩

      lift (≡⇒≃ (≡⇒→′ (refl (A ≡ A)) (refl A)))                       ≡⟨⟩

      lift (≡⇒≃ (refl A))                                             ≡⟨ refl _ ⟩∎

      lift Eq.id                                                      ∎

      where
      open _↔_ using  (to)
      open _≃_ hiding (to)

  ⟨0⟩ : ∀ {c} → Extractor (c ▻ Dep set)
  ⟨0⟩ {c} = record
    { Type                  = λ { (_ , A) → ↑ _ A }
    ; Type-cong             = λ { _ (_ , lift A≃B) → ↑-cong A≃B }
    ; Type-cong-reflexivity = λ { ass (I , A) →
        let open Assumptions ass; open _≃_ in

        lift-equality ext₁ (apply-ext ext₁ λ { (lift x) → cong lift (

          to (lower (reflexivityE ass c (Dep set) I A)) x  ≡⟨ cong (λ eq → to (lower eq) x) $ reflexivityE-set ass ⟩∎

          x                                                ∎ )})}
    }

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

-- For examples, see
-- Univalence-axiom.Isomorphism-is-equality.More.Examples.


{-# OPTIONS --allow-unsolved-metas #-}

-- {-# OPTIONS -v tc.rewrite:25 -v tc.with:40 --show-implicit #-}
-- {-# OPTIONS -v tc:100 #-}

-- Andreas, 2014-05-17, reported by Fabien Renaud.
-- Error in reification of interaction metas
-- leading to strange error messages for rewrite.

module _ where

open import Common.Prelude
open import Common.Equality

postulate comm : ∀{n m} → n + m ≡ m + n

-- module With where

--   foo : ∀{x y} → x + (x + y) ≡ x + (y + x)
--   foo {x} {y} with x + y | comm {x} {y}
--   foo | ._ | refl = refl

test0 : ∀{x y} → x + (x + y) ≡ x + (y + x)
test0 rewrite comm {n = {!!}} {m = {!!}} = {!!}

test : ∀{x y} → x + (x + y) ≡ x + (y + x)
test {x}{y} rewrite comm {n = {!!}} {m = {!!}} = {!!}

-- Error WAS:
-- .Agda.Primitive.Level !=< Nat of type Set
-- when checking that the expression ?0 has type Nat

-- Now this type checks.


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRingSolver.EvalHom where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.Int.Base hiding (_+_ ; _·_ ; -_)
open import Cubical.Data.FinData
open import Cubical.Data.Vec
open import Cubical.Data.Bool
open import Cubical.Relation.Nullary.Base

open import Cubical.Algebra.CommRingSolver.Utility
open import Cubical.Algebra.CommRingSolver.RawAlgebra
open import Cubical.Algebra.CommRingSolver.IntAsRawRing
open import Cubical.Algebra.CommRingSolver.HornerForms
open import Cubical.Algebra.CommRingSolver.HornerEval
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring

private
  variable
    ℓ : Level

module HomomorphismProperties (R : CommRing ℓ) where
  private
    νR = CommRing→RawℤAlgebra R
  open CommRingStr (snd R)
  open RingTheory (CommRing→Ring R)
  open IteratedHornerOperations νR

  EvalHom+0 : {n : ℕ} (P : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
      → eval (0ₕ +ₕ P) xs ≡ eval P xs
  EvalHom+0 {n = ℕ.zero} (const x) [] = cong (scalar R) (+Ridℤ x)
  EvalHom+0 {n = ℕ.suc _} P xs = refl

  Eval0H : {n : ℕ} (xs : Vec ⟨ νR ⟩ n)
         → eval {A = νR} 0ₕ xs ≡ 0r
  Eval0H  [] = refl
  Eval0H (x ∷ xs) = refl

  Eval1ₕ : {n : ℕ} (xs : Vec ⟨ νR ⟩ n)
         → eval {A = νR} 1ₕ xs ≡ 1r
  Eval1ₕ [] = refl
  Eval1ₕ (x ∷ xs) =
    eval 1ₕ (x ∷ xs)                             ≡⟨ refl ⟩
    eval (0H ·X+ 1ₕ) (x ∷ xs)                    ≡⟨ combineCasesEval R 0H 1ₕ x xs ⟩
    eval {A = νR} 0H (x ∷ xs) · x + eval 1ₕ xs   ≡⟨ cong (λ u → u · x + eval 1ₕ xs)
                                                                   (Eval0H (x ∷ xs)) ⟩
    0r · x + eval 1ₕ xs                          ≡⟨ cong (λ u → 0r · x + u)
                                                        (Eval1ₕ xs) ⟩
    0r · x + 1r                                  ≡⟨ cong (λ u → u + 1r)
                                                         (0LeftAnnihilates _) ⟩
    0r + 1r                                      ≡⟨ +IdL _ ⟩
    1r ∎

  -EvalDist :
    {n : ℕ} (P : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
    → eval (-ₕ P) xs ≡ - eval P xs
  -EvalDist (const x) []   = -DistScalar R x
  -EvalDist 0H  xs =
    eval (-ₕ 0H) xs  ≡⟨ Eval0H xs ⟩
    0r               ≡⟨ sym 0Selfinverse ⟩
    - 0r             ≡⟨ cong -_ (sym (Eval0H xs)) ⟩
    - eval 0H xs     ∎
  -EvalDist (P ·X+ Q) (x ∷ xs) =
      eval (-ₕ (P ·X+ Q)) (x ∷ xs)
    ≡⟨ refl ⟩
      eval ((-ₕ P) ·X+ (-ₕ Q)) (x ∷ xs)
    ≡⟨ combineCasesEval R (-ₕ P) (-ₕ Q) x xs ⟩
      (eval (-ₕ P) (x ∷ xs)) · x + eval (-ₕ Q) xs
    ≡⟨ cong (λ u → u · x + eval (-ₕ Q) xs) (-EvalDist P _) ⟩
      (- eval P (x ∷ xs)) · x + eval (-ₕ Q) xs
    ≡⟨ cong (λ u → (- eval P (x ∷ xs)) · x + u) (-EvalDist Q _) ⟩
      (- eval P (x ∷ xs)) · x + - eval Q xs
    ≡[ i ]⟨ -DistL· (eval P (x ∷ xs)) x i +  - eval Q xs ⟩
      - ((eval P (x ∷ xs)) · x) + (- eval Q xs)
    ≡⟨ -Dist _ _ ⟩
      - ((eval P (x ∷ xs)) · x + eval Q xs)
    ≡[ i ]⟨ - combineCasesEval R P Q x xs (~ i) ⟩
      - eval (P ·X+ Q) (x ∷ xs) ∎

  combineCases+ : {n : ℕ} (P Q : IteratedHornerForms νR (ℕ.suc n))
                  (r s : IteratedHornerForms νR n)
                  (x : fst R) (xs : Vec (fst R) n)
                  → eval ((P ·X+ r) +ₕ (Q ·X+ s)) (x ∷ xs)
                  ≡ eval ((P +ₕ Q) ·X+ (r +ₕ s)) (x ∷ xs)
  combineCases+ {n = n} P Q r s x xs with (isZero νR (P +ₕ Q) and isZero νR (r +ₕ s)) ≟ true
  ... | yes p = compute+ₕEvalBothZero R n P Q r s x xs p
  ... | no p = compute+ₕEvalNotBothZero R n P Q r s x xs (¬true→false _ p)

  +Homeval :
    {n : ℕ} (P Q : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
    → eval (P +ₕ Q) xs ≡ (eval P xs) + (eval Q xs)
  +Homeval (const x) (const y) [] = +HomScalar R x y
  +Homeval 0H Q xs =
    eval (0H +ₕ Q) xs            ≡⟨ refl ⟩
    eval Q xs                    ≡⟨ sym (+IdL _) ⟩
    0r + eval Q xs               ≡⟨ cong (λ u → u + eval Q xs) (sym (Eval0H xs)) ⟩
    eval 0H xs + eval Q xs ∎
  +Homeval (P ·X+ Q) 0H xs =
    eval ((P ·X+ Q) +ₕ 0H) xs                    ≡⟨ refl ⟩
    eval (P ·X+ Q) xs                            ≡⟨ sym (+IdR _) ⟩
    eval (P ·X+ Q) xs + 0r
   ≡⟨ cong (λ u → eval (P ·X+ Q) xs + u) (sym (Eval0H xs)) ⟩
    eval (P ·X+ Q) xs + eval 0H xs ∎
  +Homeval (P ·X+ Q) (S ·X+ T) (x ∷ xs) =
    eval ((P ·X+ Q) +ₕ (S ·X+ T)) (x ∷ xs)
   ≡⟨ combineCases+ P S Q T x xs ⟩
    eval ((P +ₕ S) ·X+ (Q +ₕ T)) (x ∷ xs)
   ≡⟨ combineCasesEval R (P +ₕ S) (Q +ₕ T) x xs ⟩
    (eval (P +ₕ S) (x ∷ xs)) · x + eval (Q +ₕ T) xs
   ≡⟨ cong (λ u → (eval (P +ₕ S) (x ∷ xs)) · x + u) (+Homeval Q T xs) ⟩
    (eval (P +ₕ S) (x ∷ xs)) · x + (eval Q xs + eval T xs)
   ≡⟨ cong (λ u → u · x + (eval Q xs + eval T xs)) (+Homeval P S (x ∷ xs)) ⟩
    (eval P (x ∷ xs) + eval S (x ∷ xs)) · x
    + (eval Q xs + eval T xs)
   ≡⟨ cong (λ u → u + (eval Q xs + eval T xs)) (·DistL+ _ _ _) ⟩
    (eval P (x ∷ xs)) · x + (eval S (x ∷ xs)) · x
    + (eval Q xs + eval T xs)
   ≡⟨ +ShufflePairs _ _ _ _ ⟩
    ((eval P (x ∷ xs)) · x + eval Q xs)
    + ((eval S (x ∷ xs)) · x + eval T xs)
   ≡[ i ]⟨ combineCasesEval R P Q x xs (~ i) + combineCasesEval R S T x xs (~ i) ⟩
    eval (P ·X+ Q) (x ∷ xs)
    + eval (S ·X+ T) (x ∷ xs) ∎

  ⋆Homeval : {n : ℕ}
             (r : IteratedHornerForms νR n)
             (P : IteratedHornerForms νR (ℕ.suc n)) (x : ⟨ νR ⟩) (xs : Vec ⟨ νR ⟩ n)
           → eval (r ⋆ P) (x ∷ xs) ≡ eval r xs · eval P (x ∷ xs)

  ⋆0LeftAnnihilates :
    {n : ℕ} (P : IteratedHornerForms νR (ℕ.suc n)) (xs : Vec ⟨ νR ⟩ (ℕ.suc n))
    → eval (0ₕ ⋆ P) xs ≡ 0r
  ⋆0LeftAnnihilates 0H xs = Eval0H xs
  ⋆0LeftAnnihilates {n = ℕ.zero} (P ·X+ Q) (x ∷ xs) = refl
  ⋆0LeftAnnihilates {n = ℕ.suc _} (P ·X+ Q) (x ∷ xs) = refl

  ⋆isZeroLeftAnnihilates :
    {n : ℕ} (r : IteratedHornerForms νR n)
            (P : IteratedHornerForms νR (ℕ.suc n))
    (xs : Vec ⟨ νR ⟩ (ℕ.suc n))
    → isZero νR r ≡ true
    → eval (r ⋆ P) xs ≡ 0r
  ⋆isZeroLeftAnnihilates r P xs isZero-r = evalIsZero R (r ⋆ P) xs (isZeroPresLeft⋆ r P isZero-r)

  ·0LeftAnnihilates :
    {n : ℕ} (P : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
    → eval (0ₕ ·ₕ P) xs ≡ 0r
  ·0LeftAnnihilates (const x) xs =
    eval (const _) xs ≡⟨ Eval0H xs ⟩ 0r ∎
  ·0LeftAnnihilates 0H xs = Eval0H xs
  ·0LeftAnnihilates (P ·X+ P₁) xs = Eval0H xs

  ·isZeroLeftAnnihilates :
    {n : ℕ} (P Q : IteratedHornerForms νR n)
    (xs : Vec (fst R) n)
    → isZero νR P ≡ true
    → eval (P ·ₕ Q) xs ≡ 0r
  ·isZeroLeftAnnihilates P Q xs isZeroP = evalIsZero R (P ·ₕ Q) xs (isZeroPresLeft·ₕ P Q isZeroP)

  ·Homeval : {n : ℕ} (P Q : IteratedHornerForms νR n) (xs : Vec ⟨ νR ⟩ n)
    → eval (P ·ₕ Q) xs ≡ (eval P xs) · (eval Q xs)

  combineCases⋆ : {n : ℕ} (x : fst R) (xs : Vec (fst R) n)
                → (r : IteratedHornerForms νR n)
                → (P : IteratedHornerForms νR (ℕ.suc n))
                → (Q : IteratedHornerForms νR n)
                → eval (r ⋆ (P ·X+ Q)) (x ∷ xs) ≡ eval ((r ⋆ P) ·X+ (r ·ₕ Q)) (x ∷ xs)
  combineCases⋆ x xs r P Q with isZero νR r ≟ true
  ... | yes p =
    eval (r ⋆ (P ·X+ Q)) (x ∷ xs)                ≡⟨ ⋆isZeroLeftAnnihilates r (P ·X+ Q) (x ∷ xs) p ⟩
    0r                                           ≡⟨ someCalculation R ⟩
    0r · x + 0r                                  ≡⟨ step1 ⟩
    eval (r ⋆ P) (x ∷ xs) · x + eval (r ·ₕ Q) xs  ≡⟨ sym (combineCasesEval R (r ⋆ P) (r ·ₕ Q) x xs) ⟩
    eval ((r ⋆ P) ·X+ (r ·ₕ Q)) (x ∷ xs) ∎
    where
      step1 : 0r · x + 0r ≡ eval (r ⋆ P) (x ∷ xs) · x + eval (r ·ₕ Q) xs
      step1 i = ⋆isZeroLeftAnnihilates r P (x ∷ xs) p (~ i) · x + ·isZeroLeftAnnihilates r Q xs p (~ i)
  ... | no p with isZero νR r
  ...           | true = byAbsurdity (p refl)
  ...           | false = refl

  ⋆Homeval r 0H x xs =
    eval (r ⋆ 0H) (x ∷ xs)                ≡⟨ refl ⟩
    0r                                    ≡⟨ sym (0RightAnnihilates _) ⟩
    eval r xs · 0r                        ≡⟨ refl ⟩
    eval r xs · eval {A = νR} 0H (x ∷ xs) ∎
  ⋆Homeval r (P ·X+ Q) x xs =
      eval (r ⋆ (P ·X+ Q)) (x ∷ xs)                ≡⟨ combineCases⋆ x xs r P Q ⟩
      eval ((r ⋆ P) ·X+ (r ·ₕ Q)) (x ∷ xs)
    ≡⟨ combineCasesEval R (r ⋆ P) (r ·ₕ Q) x xs ⟩
      (eval (r ⋆ P) (x ∷ xs)) · x + eval (r ·ₕ Q) xs
    ≡⟨ cong (λ u → u · x + eval (r ·ₕ Q) xs) (⋆Homeval r P x xs) ⟩
      (eval r xs · eval P (x ∷ xs)) · x + eval (r ·ₕ Q) xs
    ≡⟨ cong (λ u → (eval r xs · eval P (x ∷ xs)) · x + u) (·Homeval r Q xs) ⟩
      (eval r xs · eval P (x ∷ xs)) · x + eval r xs · eval Q xs
    ≡⟨ cong (λ u → u  + eval r xs · eval Q xs) (sym (·Assoc _ _ _)) ⟩
      eval r xs · (eval P (x ∷ xs) · x) + eval r xs · eval Q xs
    ≡⟨ sym (·DistR+ _ _ _) ⟩
      eval r xs · ((eval P (x ∷ xs) · x) + eval Q xs)
    ≡[ i ]⟨ eval r xs · combineCasesEval R P Q x xs (~ i) ⟩
      eval r xs · eval (P ·X+ Q) (x ∷ xs) ∎

  lemmaForCombineCases· :
    {n : ℕ} (Q : IteratedHornerForms νR n) (P S : IteratedHornerForms νR (ℕ.suc n))
    (xs : Vec (fst R) (ℕ.suc n))
    →  isZero νR (P ·ₕ S) ≡ true
    → eval ((P ·X+ Q) ·ₕ S) xs ≡ eval (Q ⋆ S) xs
  lemmaForCombineCases· Q P S xs isZeroProd with isZero νR (P ·ₕ S)
  ... | true = refl
  ... | false = byBoolAbsurdity isZeroProd

  combineCases· :
    {n : ℕ} (Q : IteratedHornerForms νR n) (P S : IteratedHornerForms νR (ℕ.suc n))
    (xs : Vec (fst R) (ℕ.suc n))
    → eval ((P ·X+ Q) ·ₕ S) xs ≡ eval (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) xs
  combineCases· Q P S (x ∷ xs) with isZero νR (P ·ₕ S) ≟ true
  ... | yes p =
        eval ((P ·X+ Q) ·ₕ S) (x ∷ xs)                          ≡⟨ lemmaForCombineCases· Q P S (x ∷ xs) p ⟩
        eval (Q ⋆ S) (x ∷ xs)                                   ≡⟨ sym (+IdL _) ⟩
        0r + eval (Q ⋆ S) (x ∷ xs)                              ≡⟨ step1 ⟩
        eval ((P ·ₕ S) ·X+ 0ₕ) (x ∷ xs) + eval (Q ⋆ S) (x ∷ xs)  ≡⟨ step2 ⟩
        eval (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs)             ∎
        where
          lemma =
            eval ((P ·ₕ S) ·X+ 0ₕ) (x ∷ xs)          ≡⟨ combineCasesEval R (P ·ₕ S) 0ₕ x xs ⟩
            eval (P ·ₕ S) (x ∷ xs) · x + eval 0ₕ xs  ≡[ i ]⟨ evalIsZero R (P ·ₕ S) (x ∷ xs) p i · x + Eval0H xs i ⟩
            0r · x + 0r                             ≡⟨ sym (someCalculation R) ⟩
            0r                                      ∎
          step1 : _ ≡ _
          step1 i = lemma (~ i) + eval (Q ⋆ S) (x ∷ xs)
          step2 = sym (+Homeval ((P ·ₕ S) ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs))
  ... | no p with isZero νR (P ·ₕ S)
  ...           | true = byAbsurdity (p refl)
  ...           | false = refl

  ·Homeval (const x) (const y) [] = ·HomScalar R x y
  ·Homeval 0H Q xs =
    eval (0H ·ₕ Q) xs       ≡⟨ Eval0H xs ⟩
    0r                     ≡⟨ sym (0LeftAnnihilates _) ⟩
    0r · eval Q xs         ≡⟨ cong (λ u → u · eval Q xs) (sym (Eval0H xs)) ⟩
    eval 0H xs · eval Q xs ∎
  ·Homeval (P ·X+ Q) S (x ∷ xs) =
      eval ((P ·X+ Q) ·ₕ S) (x ∷ xs)
    ≡⟨ combineCases· Q P S (x ∷ xs) ⟩
      eval (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs)
    ≡⟨ +Homeval ((P ·ₕ S) ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs) ⟩
      eval ((P ·ₕ S) ·X+ 0ₕ) (x ∷ xs) + eval (Q ⋆ S) (x ∷ xs)
    ≡⟨ cong (λ u → u + eval (Q ⋆ S) (x ∷ xs)) (combineCasesEval R (P ·ₕ S) 0ₕ x xs) ⟩
      (eval (P ·ₕ S) (x ∷ xs) · x + eval 0ₕ xs) + eval (Q ⋆ S) (x ∷ xs)
    ≡⟨ cong (λ u → u + eval (Q ⋆ S) (x ∷ xs))
          ((eval (P ·ₕ S) (x ∷ xs) · x + eval 0ₕ xs)
         ≡⟨ cong (λ u → eval (P ·ₕ S) (x ∷ xs) · x + u) (Eval0H xs) ⟩
           (eval (P ·ₕ S) (x ∷ xs) · x + 0r)
         ≡⟨ +IdR _ ⟩
           (eval (P ·ₕ S) (x ∷ xs) · x)
         ≡⟨ cong (λ u → u · x) (·Homeval P S (x ∷ xs)) ⟩
           ((eval P (x ∷ xs) · eval S (x ∷ xs)) · x)
         ≡⟨ sym (·Assoc _ _ _) ⟩
           (eval P (x ∷ xs) · (eval S (x ∷ xs) · x))
         ≡⟨ cong (λ u → eval P (x ∷ xs) · u) (·Comm _ _) ⟩
           (eval P (x ∷ xs) · (x · eval S (x ∷ xs)))
         ≡⟨ ·Assoc _ _ _ ⟩
           (eval P (x ∷ xs) · x) · eval S (x ∷ xs)
          ∎) ⟩
      (eval P (x ∷ xs) · x) · eval S (x ∷ xs) + eval (Q ⋆ S) (x ∷ xs)
    ≡⟨ cong (λ u → (eval P (x ∷ xs) · x) · eval S (x ∷ xs) + u)
            (⋆Homeval Q S x xs) ⟩
      (eval P (x ∷ xs) · x) · eval S (x ∷ xs) + eval Q xs · eval S (x ∷ xs)
    ≡⟨ sym (·DistL+ _ _ _) ⟩
      ((eval P (x ∷ xs) · x) + eval Q xs) · eval S (x ∷ xs)
    ≡⟨ cong (λ u → u · eval S (x ∷ xs)) (sym (combineCasesEval R P Q x xs)) ⟩
      eval (P ·X+ Q) (x ∷ xs) · eval S (x ∷ xs) ∎


{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness
            --no-subtyping #-}

module Agda.Builtin.Cubical.Id where

  open import Agda.Primitive.Cubical
  open import Agda.Builtin.Cubical.Path
  open import Agda.Builtin.Cubical.Sub renaming (primSubOut to ouc; Sub to _[_↦_])

  {-# BUILTIN ID           Id       #-}
  {-# BUILTIN REFLID       reflId   #-}

  private
    module ConId where
      primitive
        primConId : ∀ {ℓ} {A : Set ℓ} {x y : A} → I → x ≡ y → Id x y

  open ConId public renaming (primConId to conid)

  -- Id x y is treated as a pair of I and x ≡ y, using "i" for the
  -- first component and "p" for the second.
  {-# COMPILE JS conid =
      _ => _ => _ => _ => i => p => { return { "i" : i, "p" : p } }
    #-}

  primitive
    primDepIMin : _
    primIdFace : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → I
    primIdPath : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → x ≡ y

  primitive
    primIdJ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') →
                P x (conid i1 (λ i → x)) → ∀ {y} (p : Id x y) → P y p

  primitive
    primIdElim : ∀ {a c} {A : Set a} {x : A}
                   (C : (y : A) → Id x y → Set c) →
                   ((φ : I) (y : A [ φ ↦ (λ _ → x) ])
                    (w : (x ≡ ouc y) [ φ ↦ (λ { (φ = i1) → \ _ → x}) ]) →
                    C (ouc y) (conid φ (ouc w))) →
                   {y : A} (p : Id x y) → C y p


module Tactic.Nat.Coprime.Reflect where

import Agda.Builtin.Nat as Builtin

open import Prelude
open import Control.Monad.State
open import Control.Monad.Zero
open import Control.Monad.Transformer
open import Container.Traversable
open import Numeric.Nat.GCD

open import Tactic.Reflection
open import Tactic.Reflection.Parse
open import Tactic.Reflection.Quote
open import Tactic.Deriving.Quotable
open import Tactic.Nat.Coprime.Problem

-- Reflection --

instance
  unquoteDecl QuoteExp     = deriveQuotable QuoteExp (quote Exp)
  unquoteDecl QuoteFormula = deriveQuotable QuoteFormula (quote Formula)
  unquoteDecl QuoteProblem = deriveQuotable QuoteProblem (quote Problem)

data ExpF (A : Set) : Set where
  atom : (x : Atom) → ExpF A
  _⊗_ : (a b : A) → ExpF A

instance
  FunExpF : Functor ExpF
  fmap ⦃ FunExpF ⦄ f (atom x) = atom x
  fmap ⦃ FunExpF ⦄ f (a ⊗ b) = f a ⊗ f b

  TravExpF : Traversable ExpF
  traverse ⦃ TravExpF ⦄ f (atom x) = pure (atom x)
  traverse ⦃ TravExpF ⦄ f (a ⊗ b) = ⦇ f a ⊗ f b ⦈

foldExp : ExpF Exp → Exp
foldExp (atom x) = atom x
foldExp (a ⊗ b) = a ⊗ b

-- Requires normalisation!
matchExp : Term → Maybe (ExpF Term)
matchExp (def₂ (quote Builtin._*_) a b) = just (a ⊗ b)
matchExp _ = nothing

parseExp : Term → ParseTerm TC Exp
parseExp = parseTerm atom matchExp foldExp

parseEq : Term → ParseTerm TC (Term × Term)
parseEq (def (quote _≡_) (_ ∷ _ ∷ vArg x ∷ vArg y ∷ [])) = pure (x , y)
parseEq (meta x _) = lift (blockOnMeta! x)
parseEq _ = empty

parseGCD : Term → ParseTerm TC (Term × Term)
parseGCD (def (quote get-gcd) (_ ∷ _ ∷ vArg (def₂ (quote gcd) a b) ∷ [])) = pure (a , b)
parseGCD (meta x _) = lift (blockOnMeta x)
parseGCD t = empty

parseFormula : Term → ParseTerm TC Formula
parseFormula t = do
  lhs , lit (nat 1) ← parseEq t where _ → empty
  a , b ← parseGCD lhs
  ⦇ parseExp a ⋈ parseExp b ⦈

underBinder : ParseTerm TC ⊤
underBinder = _ <$ modify (second $ map $ first $ weaken 1)

-- Parse a Problem from the context and goal type.
parseProblem : List Term → Term → ParseTerm TC (Nat × List Term × Problem)
parseProblem [] t = do
  φ ← parseFormula t
  pure (0 , [] , ([] ⊨ φ))
parseProblem (h ∷ Δ) t =
  caseM just <$> parseFormula h <|> pure nothing of λ where
    (just ψ) → do
      underBinder
      fv , Hs , (Γ ⊨ φ) ← parseProblem Δ t
      pure (suc fv , var fv [] ∷ Hs , (ψ ∷ Γ ⊨ φ))
    nothing  → do
      underBinder
      fv , Hs , Q ← parseProblem Δ t
      pure (suc fv , Hs , Q)

buildEnv : List Nat → Env
buildEnv []        i      = 0
buildEnv (x ∷ xs)  zero   = x
buildEnv (x ∷ xs) (suc i) = buildEnv xs i

quotedEnv : List Term → Term
quotedEnv ts = def₁ (quote buildEnv) (quoteList ts)


-- Andreas, 2016-12-15, issue #2341
-- `with` needs to abstract also in sort of target type.

-- {-# OPTIONS -v tc.with:100 #-}

open import Agda.Primitive

test : ∀ a → Set (lsuc a)
test a with a
... | w = Set w


module With where

open import Reflection
open import Function using (_∘_ ; _$_ ; _∋_ ; id ; const)
open import Data.List
open import Data.Nat hiding (_+_)
open import Relation.Binary using (Setoid ; Decidable)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality hiding ( [_] ; subst )

open import Helper.CodeGeneration

{-# TERMINATING #-}
mutual

  s_arg : (n : ℕ) -> (ℕ -> Term -> Term) -> Arg Term -> Arg Term
  s_arg n f (arg i x) = arg i (s_term' n f x)

  s_type : (n : ℕ) -> (ℕ -> Term -> Term) -> Type -> Type
  s_type n f (el s t) = el s (s_term' n f t)

  s_term : (n : ℕ) -> (ℕ -> Term -> Term) -> Term -> Term
  s_term n f (var x args) = var x (map (s_arg n f) args)
  s_term n f (con c args) = con c (map (s_arg n f) args)
  s_term n f (def f₁ args) = def f₁ (map (s_arg n f) args)
  s_term n f (lam v (abs s x)) = lam v (abs s (s_term' n f x))
  s_term n f (pat-lam cs args) = pat-lam cs (map (s n arg f) args)
  s_term n f (pi (arg i x) (abs s x₁)) = pi (arg i (s_type n f x)) (abs s (s_type n f x₁))
  s_term n f t = t

  s_term' : (n : ℕ) -> (ℕ -> Term -> Term) -> Term -> Term
  s_term' n f t = f n (s_term n f t)

inc_debruijn_indices : Term -> Term
inc_debruijn_indices t = s_term' zero alg t
  where
    alg : ℕ -> Term -> Term
    alg n (var x args) = var (suc x) args
    alg n t2 = t2

subst : Term -> Term -> Term -> Term
subst t ti to = s_term' zero alg t
  where
    alg : ℕ -> Term -> Term
    alg n ti1 with ti Reflection.≟ ti1
    alg n ti1 | yes p = to
    alg n ti1 | no ¬p = ti1

getType : {T : Set} -> (t : T) -> Term
getType {T} t = quoteTerm T

with' : Term -> Term -> Term
with' w l = quote-goal (abs "g" lam_body)
  where
    sub_term = def (quote subst) ( (a $ var 1 []) ∷ (a $ w) ∷ (a $ quote-term $ var 0 []) ∷ [] )
    lam_type_q = unquote-term sub_term []
    lam_type = pi (a $ t0 unknown) (abs "i" $ t0 $ lam_type_q)
    lam_body = def (quote _$_) ((a $ lam_type ∋-t l) ∷ (a $ inc_debruijn_indices $ unquote-term w []) ∷ [])

postulate
   A     : Set
   _+_   : A → A → A
   T     : A → Set
   mkT   : ∀ x → T x
   P     : ∀ x → T x → Set

-- the type A of the with argument has no free variables, so the with
-- argument will come first
f₁ : (x y : A) (t : T (x + y)) → T (x + y)
f₁ x y t with x + y
f₁ x y t    | w = mkT w

f₂ : (x y : A) → T (x + y)
f₂ x y = unquote (with' (quoteTerm (quoteTerm (x + y))) (quoteTerm (\w -> mkT w)))

  -- def (quote inc_var_indices) [ a $ var 1 [] ] --
    -- sub_term = def (quote subst) ( (a $ var 1 []) ∷ (a $ w) ∷ (a $ (quote-term (var 0 []))) ∷ [] )
    -- lam_type = pi (a $ t0 $ (def (quote _≡_) ((a $ var 3 []) ∷ (a $ var 2 []) ∷ []))) (abs "i" $ t0 $ lam_type_q)


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

open import lib.Base
open import lib.PathGroupoid
open import lib.PathFunctor
open import lib.NType

module lib.Equivalences where

{-
We use the half-adjoint definition of equivalences (but this fact should be
invisible to the user of the library). The constructor of the type of
equivalences is [equiv], it takes two maps and the two proofs that the composites
are equal: [equiv to from to-from from-to]

The type of equivalences between two types [A] and [B] can be written either
[A ≃ B] or [Equiv A B].

Given an equivalence [e] : [A ≃ B], you can extract the two maps as follows:
[–> e] : [A → B] and [<– e] : [B → A] (the dash is an en dash)
The proofs that the composites are the identities are [<–-inv-l] and [<–-inv-r].

The identity equivalence on [A] is [ide A], the composition of two equivalences
is [_∘e_] (function composition order) and the inverse of an equivalence is [_⁻¹]
-}

module _ {i} {j} {A : Type i} {B : Type j} where

  record is-equiv (f : A → B) : Type (lmax i j)
    where
    field
      g : B → A
      f-g : (b : B) → f (g b) == b
      g-f : (a : A) → g (f a) == a
      adj : (a : A) → ap f (g-f a) == f-g (f a)

    abstract
      adj' : (b : B) → ap g (f-g b) == g-f (g b)
      adj' b = anti-whisker-left (ap g (f-g (f (g b)))) $ ! $
        ap g (f-g (f (g b))) ∙ g-f (g b)
          =⟨ ! $ htpy-natural-app=idf f-g b |in-ctx (λ p → ap g p ∙ g-f (g b)) ⟩
        ap g (ap (f ∘ g) (f-g b)) ∙ g-f (g b)
          =⟨ ! $ ap-∘ g (f ∘ g) (f-g b) |in-ctx (λ p → p ∙ g-f (g b)) ⟩
        ap (g ∘ f ∘ g) (f-g b) ∙ g-f (g b)
          =⟨ htpy-natural (g-f ∘ g) (f-g b) ⟩
        g-f (g (f (g b))) ∙ ap g (f-g b)
          =⟨ ! $ htpy-natural-app=idf g-f (g b) |in-ctx (λ p → p ∙ ap g (f-g b)) ⟩
        ap (g ∘ f) (g-f (g b)) ∙ ap g (f-g b)
          =⟨ ap-∘ g f (g-f (g b)) |in-ctx (λ p → p ∙ ap g (f-g b)) ⟩
        ap g (ap f (g-f (g b))) ∙ ap g (f-g b)
          =⟨ adj (g b) |in-ctx (λ p → ap g p ∙ ap g (f-g b)) ⟩
        ap g (f-g (f (g b))) ∙ ap g (f-g b)
          ∎

  {-
  In order to prove that something is an equivalence, you have to give an inverse
  and a proof that it’s an inverse (you don’t need the adj part).
  [is-eq] is a very, very bad name.
  -}
  is-eq : (f : A → B)
    (g : B → A) (f-g : (b : B) → f (g b) == b)
    (g-f : (a : A) → g (f a) == a) → is-equiv f
  is-eq f g f-g g-f =
   record {g = g; f-g = f-g'; g-f = g-f; adj = adj} where
    f-g' : (b : B) → f (g b) == b
    f-g' b = ! (ap (f ∘ g) (f-g b)) ∙ ap f (g-f (g b)) ∙ f-g b

    adj : (a : A) → ap f (g-f a) == f-g' (f a)
    adj a =
      ap f (g-f a)
        =⟨ ! (!-inv-l (ap (f ∘ g) (f-g (f a)))) |in-ctx (λ q → q ∙ ap f (g-f a)) ⟩
      (! (ap (f ∘ g) (f-g (f a))) ∙ ap (f ∘ g) (f-g (f a))) ∙ ap f (g-f a)
        =⟨ ∙-assoc (! (ap (f ∘ g) (f-g (f a)))) (ap (f ∘ g) (f-g (f a))) _ ⟩
      ! (ap (f ∘ g) (f-g (f a))) ∙ ap (f ∘ g) (f-g (f a)) ∙ ap f (g-f a)
        =⟨ lemma |in-ctx (λ q → ! (ap (f ∘ g) (f-g (f a))) ∙ q) ⟩
      ! (ap (f ∘ g) (f-g (f a))) ∙ ap f (g-f (g (f a))) ∙ f-g (f a) ∎
      where
      lemma : ap (f ∘ g) (f-g (f a)) ∙ ap f (g-f a)
           == ap f (g-f (g (f a))) ∙ f-g (f a)
      lemma =
        ap (f ∘ g) (f-g (f a)) ∙ ap f (g-f a)
          =⟨ htpy-natural-app=idf f-g (f a) |in-ctx (λ q → q ∙ ap f (g-f a)) ⟩
        f-g (f (g (f a))) ∙ ap f (g-f a)
          =⟨ ! (ap-idf (ap f (g-f a))) |in-ctx (λ q → f-g (f (g (f a))) ∙ q) ⟩
        f-g (f (g (f a))) ∙ ap (idf B) (ap f (g-f a))
          =⟨ ! (htpy-natural f-g (ap f (g-f a))) ⟩
        ap (f ∘ g) (ap f (g-f a)) ∙ f-g (f a)
          =⟨ ap-∘ f g (ap f (g-f a)) |in-ctx (λ q → q ∙ f-g (f a)) ⟩
        ap f (ap g (ap f (g-f a))) ∙ f-g (f a)
          =⟨ ∘-ap g f (g-f a) ∙ htpy-natural-app=idf g-f a
             |in-ctx (λ q → ap f q ∙ f-g (f a)) ⟩
        ap f (g-f (g (f a))) ∙ f-g (f a) ∎

infix 30 _≃_

_≃_ : ∀ {i j} (A : Type i) (B : Type j) → Type (lmax i j)
A ≃ B = Σ (A → B) is-equiv

Equiv = _≃_

module _ {i} {j} {A : Type i} {B : Type j} where

  equiv : (f : A → B) (g : B → A) (f-g : (b : B) → f (g b) == b)
          (g-f : (a : A) → g (f a) == a) → A ≃ B
  equiv f g f-g g-f = (f , is-eq f g f-g g-f)

  –> : (e : A ≃ B) → (A → B)
  –> e = fst e

  <– : (e : A ≃ B) → (B → A)
  <– e = is-equiv.g (snd e)

  <–-inv-l : (e : A ≃ B) (a : A)
    → (<– e (–> e a) == a)
  <–-inv-l e a = is-equiv.g-f (snd e) a

  <–-inv-r : (e : A ≃ B) (b : B)
    → (–> e (<– e b) == b)
  <–-inv-r e b = is-equiv.f-g (snd e) b

  <–-inv-adj : (e : A ≃ B) (a : A)
    → ap (–> e) (<–-inv-l e a) == <–-inv-r e (–> e a)
  <–-inv-adj e a = is-equiv.adj (snd e) a

  <–-inv-adj' : (e : A ≃ B) (b : B)
    → ap (<– e) (<–-inv-r e b) == <–-inv-l e (<– e b)
  <–-inv-adj' e b = is-equiv.adj' (snd e) b

  -- Equivalences are "injective"
  equiv-inj : (e : A ≃ B) {x y : A}
    → (–> e x == –> e y → x == y)
  equiv-inj e {x} {y} p = ! (<–-inv-l e x) ∙ ap (<– e) p ∙ <–-inv-l e y

idf-is-equiv : ∀ {i} (A : Type i) → is-equiv (idf A)
idf-is-equiv A = is-eq _ (idf A) (λ _ → idp) (λ _ → idp)

ide : ∀ {i} (A : Type i) → A ≃ A
ide A = equiv (idf A) (idf A) (λ _ → idp) (λ _ → idp)

infixr 80 _∘e_
infixr 80 _∘ise_

_∘e_ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  → B ≃ C → A ≃ B → A ≃ C
e1 ∘e e2 = ((–> e1 ∘ –> e2) , record {g = (<– e2 ∘ <– e1);
  f-g = (λ c → ap (–> e1) (<–-inv-r e2 (<– e1 c)) ∙ <–-inv-r e1 c);
  g-f = (λ a → ap (<– e2) (<–-inv-l e1 (–> e2 a)) ∙ <–-inv-l e2 a);
  adj = λ a →
      ap (–> e1 ∘ –> e2) (ap (<– e2) (<–-inv-l e1 (–> e2 a)) ∙ <–-inv-l e2 a)
          =⟨ ap-∘ (–> e1) (–> e2) (ap (<– e2) (<–-inv-l e1 (–> e2 a)) ∙ <–-inv-l e2 a) ⟩
      ap (–> e1) (ap (–> e2) (ap (<– e2) (<–-inv-l e1 (–> e2 a)) ∙ <–-inv-l e2 a))
          =⟨ ap-∙ (–> e2) (ap (<– e2) (<–-inv-l e1 (–> e2 a))) (<–-inv-l e2 a)  |in-ctx ap (–> e1) ⟩
      ap (–> e1) (ap (–> e2) (ap (<– e2) (<–-inv-l e1 (–> e2 a))) ∙ ap (–> e2) (<–-inv-l e2 a))
          =⟨ ! (ap-∘ (–> e2) (<– e2) (<–-inv-l e1 (–> e2 a))) ∙2 <–-inv-adj e2 a |in-ctx ap (–> e1) ⟩
      ap (–> e1) (ap (–> e2 ∘ <– e2) (<–-inv-l e1 (–> e2 a)) ∙ <–-inv-r e2 (–> e2 a))
          =⟨ htpy-natural (<–-inv-r e2) (<–-inv-l e1 (–> e2 a))    |in-ctx ap (–> e1) ⟩
      ap (–> e1) (<–-inv-r e2 (<– e1 ((–> e1 ∘ –> e2) a)) ∙ ap (λ z → z) (<–-inv-l e1 (–> e2 a)))
          =⟨ <–-inv-r e2 (<– e1 ((–> e1 ∘ –> e2) a)) ∙ₗ ap-idf (<–-inv-l e1 (–> e2 a)) |in-ctx ap (–> e1) ⟩
      ap (–> e1) (<–-inv-r e2 (<– e1 ((–> e1 ∘ –> e2) a)) ∙ <–-inv-l e1 (–> e2 a))
          =⟨ ap-∙ (–> e1) (<–-inv-r e2 (<– e1 ((–> e1 ∘ –> e2) a))) (<–-inv-l e1 (–> e2 a)) ⟩
      ap (–> e1) (<–-inv-r e2 (<– e1 ((–> e1 ∘ –> e2) a))) ∙ ap (–> e1) (<–-inv-l e1 (–> e2 a))
          =⟨  ap (–> e1) (<–-inv-r e2 (<– e1 ((–> e1 ∘ –> e2) a))) ∙ₗ (<–-inv-adj e1 (–> e2 a)) ⟩
      ap (–> e1) (<–-inv-r e2 (<– e1 ((–> e1 ∘ –> e2) a))) ∙ <–-inv-r e1 ((–> e1 ∘ –> e2) a)
      ∎})

_∘ise_ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  {f : A → B} {g : B → C}
  → is-equiv g → is-equiv f → is-equiv (g ∘ f)
i1 ∘ise i2 = snd ((_ , i1) ∘e (_ , i2))

infix 120 _⁻¹
_⁻¹ : ∀ {i j} {A : Type i} {B : Type j} → (A ≃ B) → (B ≃ A)
e ⁻¹ = equiv (<– e) (–> e) (<–-inv-l e) (<–-inv-r e)

{- Equational reasoning for equivalences -}
infix 15 _≃∎
infixr 10 _≃⟨_⟩_

_≃⟨_⟩_ : ∀ {i j k} (A : Type i) {B : Type j} {C : Type k} → A ≃ B → B ≃ C → A ≃ C
A ≃⟨ u ⟩ v = v ∘e u

_≃∎ : ∀ {i} (A : Type i) → A ≃ A
_≃∎ = ide

{- lifting is an equivalence -}
lower-equiv : ∀ {i j} {A : Type i} → Lift {j = j} A ≃ A
lower-equiv = equiv lower lift (λ _ → idp) (λ _ → idp)

{- Any contractible type is equivalent to (all liftings of) the unit type -}
module _ {i} {A : Type i} (h : is-contr A) where
  contr-equiv-Unit : A ≃ Unit
  contr-equiv-Unit = equiv (λ _ → unit) (λ _ → fst h) (λ _ → idp) (snd h)

  contr-equiv-LiftUnit : ∀ {j} → A ≃ Lift {j = j} Unit
  contr-equiv-LiftUnit = lower-equiv ⁻¹ ∘e contr-equiv-Unit

{- An equivalence induces an equivalence on the path spaces -}
module _ {i j} {A : Type i} {B : Type j} (e : A ≃ B) where

  private
    abstract
      left-inverse : {x y : A} (p : x == y) → equiv-inj e (ap (–> e) p) == p
      left-inverse idp = !-inv-l (<–-inv-l e _)

      right-inverse : {x y : A} (p : –> e x == –> e y)
        → ap (–> e) (equiv-inj e p) == p
      right-inverse {x} {y} p =
        ap f (! (g-f x) ∙ ap g p ∙ (g-f y))
          =⟨ ap-∙ f (! (g-f x)) (ap g p ∙ (g-f y)) ⟩
        ap f (! (g-f x)) ∙ ap f (ap g p ∙ (g-f y))
          =⟨ ap-∙ f (ap g p) (g-f y) |in-ctx (λ q →  ap f (! (g-f x)) ∙ q) ⟩
        ap f (! (g-f x)) ∙ ap f (ap g p) ∙ ap f (g-f y)
          =⟨ ∘-ap f g p |in-ctx (λ q → ap f (! (g-f x)) ∙ q ∙ ap f (g-f y)) ⟩
        ap f (! (g-f x)) ∙ ap (f ∘ g) p ∙ ap f (g-f y)
          =⟨ adj y |in-ctx (λ q →  ap f (! (g-f x)) ∙ ap (f ∘ g) p ∙ q) ⟩
        ap f (! (g-f x)) ∙ ap (f ∘ g) p ∙ (f-g (f y))
          =⟨ ap-! f (g-f x) |in-ctx (λ q → q ∙ ap (f ∘ g) p ∙ (f-g (f y))) ⟩
        ! (ap f (g-f x)) ∙ ap (f ∘ g) p ∙ (f-g (f y))
          =⟨ adj x |in-ctx (λ q →  ! q ∙ ap (f ∘ g) p ∙ (f-g (f y))) ⟩
        ! (f-g (f x)) ∙ ap (f ∘ g) p ∙ (f-g (f y))
          =⟨ htpy-natural f-g p |in-ctx (λ q →  ! (f-g (f x)) ∙ q) ⟩
        ! (f-g (f x)) ∙ (f-g (f x)) ∙ ap (idf B) p
          =⟨ ! (∙-assoc (! (f-g (f x))) (f-g (f x)) (ap (idf B) p))
             ∙ ap (λ q → q ∙ ap (idf B) p) (!-inv-l (f-g (f x))) ∙ ap-idf p ⟩
        p ∎
        where f : A → B
              f = fst e

              open is-equiv (snd e)

  equiv-ap : (x y : A) → (x == y) ≃ (–> e x == –> e y)
  equiv-ap x y = equiv (ap (–> e)) (equiv-inj e) right-inverse left-inverse

{- Equivalent types have the same truncation level -}
equiv-preserves-level : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂} (e : A ≃ B)
  → (has-level n A → has-level n B)
equiv-preserves-level {n = ⟨-2⟩} e (x , p) =
  (–> e x , (λ y → ap (–> e) (p _) ∙ <–-inv-r e y))
equiv-preserves-level {n = S n} e c = λ x y →
   equiv-preserves-level (equiv-ap (e ⁻¹) x y ⁻¹) (c (<– e x) (<– e y))

{- This is a collection of type equivalences involving basic type formers.
   We exclude Empty since Π₁-Empty requires λ=.
-}
module _ {j} {B : Unit → Type j} where
  Σ₁-Unit : Σ Unit B ≃ B unit
  Σ₁-Unit = equiv (λ {(unit , b) → b}) (λ b → (unit , b)) (λ _ → idp) (λ _ → idp)

  Π₁-Unit : Π Unit B ≃ B unit
  Π₁-Unit = equiv (λ f → f unit) (λ b _ → b) (λ _ → idp) (λ _ → idp)

module _ {i} {A : Type i} where
  Σ₂-Unit : Σ A (λ _ → Unit) ≃ A
  Σ₂-Unit = equiv fst (λ a → (a , unit)) (λ _ → idp) (λ _ → idp)

  Π₂-Unit : Π A (λ _ → Unit) ≃ Unit
  Π₂-Unit = equiv (λ _ → unit) (λ _ _ → unit) (λ _ → idp) (λ _ → idp)

module _ {i j k} {A : Type i} {B : A → Type j} {C : (a : A) → B a → Type k} where
  Σ-assoc : Σ (Σ A B) (uncurry C) ≃ Σ A (λ a → Σ (B a) (C a))
  Σ-assoc = equiv (λ {((a , b) , c) → (a , (b , c))})
                  (λ {(a , (b , c)) → ((a , b) , c)}) (λ _ → idp) (λ _ → idp)

  curry-equiv : Π (Σ A B) (uncurry C) ≃ Π A (λ a → Π (B a) (C a))
  curry-equiv = equiv curry uncurry (λ _ → idp) (λ _ → idp)

  {- The type-theoretic axiom of choice -}
  choice : Π A (λ a → Σ (B a) (λ b → C a b)) ≃ Σ (Π A B) (λ g → Π A (λ a → C a (g a)))
  choice = equiv f g (λ _ → idp) (λ _ → idp)
    where f = λ c → ((λ a → fst (c a)) , (λ a → snd (c a)))
          g = λ d → (λ a → (fst d a , snd d a))

{- Homotopy fibers -}
hfiber : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) (y : B) → Type (lmax i j)
hfiber {A = A} f y = Σ A (λ x → f x == y)


open import Agda.Builtin.Unit
open import Agda.Builtin.List
open import Agda.Builtin.Reflection

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

macro
  tac : Term → TC ⊤
  tac hole =
    unify hole
      (def (quote id)
         (arg (arg-info visible (modality relevant quantity-ω))
              (var 0 []) ∷
          []))

test : {A : Set} → A → A
test x = {!tac!}


module Basic.Compiler.CorrectTo where

open import Data.List
open import Relation.Binary.PropositionalEquality

open import Basic.Compiler.Code
open import Basic.AST
open import Basic.BigStep
open import Utils.Decidable

{-
Lemma 3.21

One half of the correctness proof for the compiler.

The proof here is a bit neater than the one in the book. The book uses exercises 3.19 and 3.4
to concatenate instruction lists, while I use my _▷*<>_, which does the same in one step.
Otherwise the proofs are the same, and there's not much space for variations.
-}

𝓒-correct-to :
  ∀ {n}{S : St n}{s s'}
  → ⟨ S , s ⟩⟱ s' → ⟨ 𝓒⟦ S ⟧ˢ , [] , s ⟩▷*⟨ [] , [] , s' ⟩

𝓒-correct-to (ass {_}{x}{a}) = 𝓒-Exp-nat a ▷*<> STORE x ∷ done
𝓒-correct-to skip = NOOP ∷ done
𝓒-correct-to (a , b) = 𝓒-correct-to a ▷*<> 𝓒-correct-to b

𝓒-correct-to (if-true {s = s}{b = b} x p) with 𝓒-Exp-bool {e = []}{s = s} b
... | condition rewrite T→≡true x =
  condition ▷*<> BRANCH-[] ∷ 𝓒-correct-to p

𝓒-correct-to (if-false {s = s}{b = b} x p) with 𝓒-Exp-bool {e = []}{s = s} b
... | condition rewrite F→≡false x =
  condition ▷*<> BRANCH-[] ∷ 𝓒-correct-to p

𝓒-correct-to (while-true {s}{b = b} x p k) with 𝓒-Exp-bool {e = []}{s = s} b
... | condition rewrite T→≡true x =
  LOOP ∷ condition ▷*<> BRANCH-[] ∷ 𝓒-correct-to p ▷*<> 𝓒-correct-to k

𝓒-correct-to (while-false {s}{S}{b} x) with 𝓒-Exp-bool {e = []}{s = s} b
... | condition rewrite F→≡false x =
  LOOP ∷ condition ▷*<> BRANCH-[] ∷ NOOP ∷ done


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Semigroup where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto

open Iso

private
  variable
    ℓ : Level

-- Semigroups as a record, inspired by the Agda standard library:
--
--  https://github.com/agda/agda-stdlib/blob/master/src/Algebra/Bundles.agda#L48
--  https://github.com/agda/agda-stdlib/blob/master/src/Algebra/Structures.agda#L50
--
-- Note that as we are using Path for all equations the IsMagma record
-- would only contain isSet A if we had it.
record IsSemigroup {A : Type ℓ} (_·_ : A → A → A) : Type ℓ where

  -- TODO: add no-eta-equality for efficiency? This breaks some proofs later

  constructor issemigroup
  field
    is-set : isSet A
    assoc  : (x y z : A) → x · (y · z) ≡ (x · y) · z

record Semigroup : Type (ℓ-suc ℓ) where

  constructor semigroup

  field
    Carrier     : Type ℓ
    _·_         : Carrier → Carrier → Carrier
    isSemigroup : IsSemigroup _·_

  infixl 7 _·_

  open IsSemigroup isSemigroup public

-- Extractor for the carrier type
⟨_⟩ : Semigroup → Type ℓ
⟨_⟩ = Semigroup.Carrier

record SemigroupEquiv (M N : Semigroup {ℓ}) : Type ℓ where

  constructor semigroupequiv

  -- Shorter qualified names
  private
    module M = Semigroup M
    module N = Semigroup N

  field
    e     : ⟨ M ⟩ ≃ ⟨ N ⟩
    isHom : (x y : ⟨ M ⟩) → equivFun e (x M.· y) ≡ equivFun e x N.· equivFun e y

-- Develop some theory about Semigroups using various general results
-- that are stated using Σ-types. For this we define Semigroup as a
-- nested Σ-type, prove that it's equivalent to the above record
-- definition and then transport results along this equivalence.
module SemigroupΣTheory {ℓ} where

  RawSemigroupStructure : Type ℓ → Type ℓ
  RawSemigroupStructure X = X → X → X

  RawSemigroupEquivStr = AutoEquivStr RawSemigroupStructure

  rawSemigroupUnivalentStr : UnivalentStr _ RawSemigroupEquivStr
  rawSemigroupUnivalentStr = autoUnivalentStr RawSemigroupStructure

  SemigroupAxioms : (A : Type ℓ) → RawSemigroupStructure A → Type ℓ
  SemigroupAxioms A _·_ = isSet A
                        × ((x y z : A) → x · (y · z) ≡ (x · y) · z)

  SemigroupStructure : Type ℓ → Type ℓ
  SemigroupStructure = AxiomsStructure RawSemigroupStructure SemigroupAxioms

  SemigroupΣ : Type (ℓ-suc ℓ)
  SemigroupΣ = TypeWithStr ℓ SemigroupStructure

  isPropSemigroupAxioms : (A : Type ℓ) (_·_ : RawSemigroupStructure A)
                        → isProp (SemigroupAxioms A _·_)
  isPropSemigroupAxioms _ _ = isPropΣ isPropIsSet λ isSetA → isPropΠ3 λ _ _ _ → isSetA _ _

  SemigroupEquivStr : StrEquiv SemigroupStructure ℓ
  SemigroupEquivStr = AxiomsEquivStr RawSemigroupEquivStr SemigroupAxioms

  SemigroupAxiomsIsoIsSemigroup : {A : Type ℓ} (_·_ : RawSemigroupStructure A)
                                → Iso (SemigroupAxioms A _·_) (IsSemigroup _·_)
  fun (SemigroupAxiomsIsoIsSemigroup s) (x , y)           = issemigroup x y
  inv (SemigroupAxiomsIsoIsSemigroup s) (issemigroup x y) = (x , y)
  rightInv (SemigroupAxiomsIsoIsSemigroup s) _            = refl
  leftInv (SemigroupAxiomsIsoIsSemigroup s) _             = refl

  SemigroupAxioms≡IsSemigroup : {A : Type ℓ} (_·_ : RawSemigroupStructure A)
                              → SemigroupAxioms _ _·_ ≡ IsSemigroup _·_
  SemigroupAxioms≡IsSemigroup s = isoToPath (SemigroupAxiomsIsoIsSemigroup s)

  Semigroup→SemigroupΣ : Semigroup → SemigroupΣ
  Semigroup→SemigroupΣ (semigroup A _·_ isSemigroup) =
    A , _·_ , SemigroupAxiomsIsoIsSemigroup _ .inv isSemigroup

  SemigroupΣ→Semigroup : SemigroupΣ → Semigroup
  SemigroupΣ→Semigroup (A , _·_ , isSemigroupΣ) =
    semigroup A _·_ (SemigroupAxiomsIsoIsSemigroup _ .fun isSemigroupΣ)

  SemigroupIsoSemigroupΣ : Iso Semigroup SemigroupΣ
  SemigroupIsoSemigroupΣ =
    iso Semigroup→SemigroupΣ SemigroupΣ→Semigroup (λ _ → refl) (λ _ → refl)

  semigroupUnivalentStr : UnivalentStr SemigroupStructure SemigroupEquivStr
  semigroupUnivalentStr = axiomsUnivalentStr _ isPropSemigroupAxioms rawSemigroupUnivalentStr

  SemigroupΣPath : (M N : SemigroupΣ) → (M ≃[ SemigroupEquivStr ] N) ≃ (M ≡ N)
  SemigroupΣPath = SIP semigroupUnivalentStr

  SemigroupEquivΣ : (M N : Semigroup) → Type ℓ
  SemigroupEquivΣ M N = Semigroup→SemigroupΣ M ≃[ SemigroupEquivStr ] Semigroup→SemigroupΣ N

  SemigroupIsoΣPath : {M N : Semigroup} → Iso (SemigroupEquiv M N) (SemigroupEquivΣ M N)
  fun SemigroupIsoΣPath (semigroupequiv e h) = (e , h)
  inv SemigroupIsoΣPath (e , h)            = semigroupequiv e h
  rightInv SemigroupIsoΣPath _             = refl
  leftInv SemigroupIsoΣPath _              = refl

  SemigroupPath : (M N : Semigroup) → (SemigroupEquiv M N) ≃ (M ≡ N)
  SemigroupPath M N =
    SemigroupEquiv M N                                ≃⟨ isoToEquiv SemigroupIsoΣPath ⟩
    SemigroupEquivΣ M N                               ≃⟨ SemigroupΣPath _ _ ⟩
    Semigroup→SemigroupΣ M ≡ Semigroup→SemigroupΣ N ≃⟨ isoToEquiv (invIso (congIso SemigroupIsoSemigroupΣ)) ⟩
    M ≡ N ■

-- We now extract the important results from the above module

isPropIsSemigroup : {A : Type ℓ} (_·_ : A → A → A) → isProp (IsSemigroup _·_)
isPropIsSemigroup _·_ =
  subst isProp (SemigroupΣTheory.SemigroupAxioms≡IsSemigroup _·_)
        (SemigroupΣTheory.isPropSemigroupAxioms _ _·_)

SemigroupPath : (M N : Semigroup {ℓ}) → (SemigroupEquiv M N) ≃ (M ≡ N)
SemigroupPath = SemigroupΣTheory.SemigroupPath

-- To rename the fields when using a Semigroup use for example the following:
--
-- open Semigroup M renaming ( Carrier to M ; _·_ to _·M_ )


record Unit : Set where
  constructor unit

module S {A : Set} where
  id : {A : Set} → A → A
  id a = a

module T {A : Set} = S

Sid : (A : Set) → A → A
Sid A = S.id {A = Unit} {A = A}

Tid : (A : Set) → A → A
Tid A = T.id {A = Unit} {A = Unit} {A = A}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Floats: basic types and operations
------------------------------------------------------------------------

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

module Data.Float.Base where

open import Relation.Binary.Core using (Rel)
import Data.Word.Base as Word
open import Function using (_on_)
open import Agda.Builtin.Equality

------------------------------------------------------------------------
-- Re-export built-ins publically

open import Agda.Builtin.Float public
  using (Float)
  renaming
  -- Relations
  ( primFloatEquality          to _≡ᵇ_
  ; primFloatLess              to _≤ᵇ_
  ; primFloatNumericalEquality to _≈ᵇ_
  ; primFloatNumericalLess     to _≲ᵇ_
  -- Conversions
  ; primShowFloat     to show
  ; primFloatToWord64 to toWord
  ; primNatToFloat    to fromℕ
  -- Operations
  ; primFloatPlus   to _+_
  ; primFloatMinus  to _-_
  ; primFloatTimes  to _*_
  ; primFloatNegate to -_
  ; primFloatDiv    to _÷_
  ; primFloatSqrt   to sqrt
  ; primRound       to round
  ; primFloor       to ⌊_⌋
  ; primCeiling     to ⌈_⌉
  ; primExp         to e^_
  ; primLog         to log
  ; primSin         to sin
  ; primCos         to cos
  ; primTan         to tan
  ; primASin        to asin
  ; primACos        to acos
  ; primATan        to atan
  )

_≈_ : Rel Float _
_≈_ = Word._≈_ on toWord

_<_ : Rel Float _
_<_ = Word._<_ on toWord


module _ {T : Type{ℓₒ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  instance
    PredSet-setLike : SetLike{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)
    SetLike._⊆_ PredSet-setLike = _⊆_
    SetLike._≡_ PredSet-setLike = _≡_
    SetLike.[⊆]-membership PredSet-setLike = [↔]-intro intro _⊆_.proof
    SetLike.[≡]-membership PredSet-setLike = [↔]-intro intro _≡_.proof

  instance
    PredSet-emptySet : SetLike.EmptySet{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)
    SetLike.EmptySet.∅          PredSet-emptySet = ∅
    SetLike.EmptySet.membership PredSet-emptySet ()

  instance
    PredSet-universalSet : SetLike.UniversalSet{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)
    SetLike.UniversalSet.𝐔          PredSet-universalSet = 𝐔
    SetLike.UniversalSet.membership PredSet-universalSet = record {}

  instance
    PredSet-unionOperator : SetLike.UnionOperator{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)
    SetLike.UnionOperator._∪_        PredSet-unionOperator = _∪_
    SetLike.UnionOperator.membership PredSet-unionOperator = [↔]-intro id id

  instance
    PredSet-intersectionOperator : SetLike.IntersectionOperator{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)
    SetLike.IntersectionOperator._∩_        PredSet-intersectionOperator = _∩_
    SetLike.IntersectionOperator.membership PredSet-intersectionOperator = [↔]-intro id id

  instance
    PredSet-complementOperator : SetLike.ComplementOperator{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)
    SetLike.ComplementOperator.∁          PredSet-complementOperator = ∁_
    SetLike.ComplementOperator.membership PredSet-complementOperator = [↔]-intro id id

module _ {T : Type{ℓ}} ⦃ equiv : Equiv{ℓ}(T) ⦄ where -- TODO: Levels in SetLike
  instance
    PredSet-mapFunction : SetLike.MapFunction{C₁ = PredSet{ℓ}(T) ⦃ equiv ⦄}{C₂ = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)(_∈_)
    SetLike.MapFunction.map        PredSet-mapFunction f = map f
    SetLike.MapFunction.membership PredSet-mapFunction   = [↔]-intro id id

  instance
    PredSet-unmapFunction : SetLike.UnmapFunction{C₁ = PredSet{ℓ}(T) ⦃ equiv ⦄}{C₂ = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_)(_∈_)
    SetLike.UnmapFunction.unmap      PredSet-unmapFunction = unmap
    SetLike.UnmapFunction.membership PredSet-unmapFunction = [↔]-intro id id

  instance
    PredSet-unapplyFunction : SetLike.UnapplyFunction{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_) {O = T}
    SetLike.UnapplyFunction.unapply    PredSet-unapplyFunction = unapply
    SetLike.UnapplyFunction.membership PredSet-unapplyFunction = [↔]-intro id id

  instance
    PredSet-filterFunction : SetLike.FilterFunction{C = PredSet{ℓ}(T) ⦃ equiv ⦄} (_∈_) {ℓ}{ℓ}
    SetLike.FilterFunction.filter     PredSet-filterFunction = filter
    SetLike.FilterFunction.membership PredSet-filterFunction = [↔]-intro id id

{- TODO: SetLike is not general enough
module _ {T : Type{ℓ}} ⦃ equiv : Equiv{ℓ}(T) ⦄ where
  instance
    -- PredSet-bigUnionOperator : SetLike.BigUnionOperator{Cₒ = PredSet(PredSet(T) ⦃ {!!} ⦄) ⦃ {!!} ⦄} {Cᵢ = PredSet(T) ⦃ {!!} ⦄} (_∈_)(_∈_)
    SetLike.BigUnionOperator.⋃          PredSet-bigUnionOperator = {!⋃!}
    SetLike.BigUnionOperator.membership PredSet-bigUnionOperator = {!!}
-}


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

open import Categories.Category

module Categories.Diagram.Pullback.Properties {o ℓ e} (C : Category o ℓ e) where

open import Function using (_$_)

open import Categories.Category.Cartesian C
open import Categories.Diagram.Pullback C
open import Categories.Diagram.Equalizer C
open import Categories.Object.Product C
open import Categories.Object.Terminal C
open import Categories.Morphism.Reasoning C

private
  open Category C
  variable
    X Y Z : Obj
    f g h i : X ⇒ Y
open HomReasoning

-- pullback from a terminal object is the same as a product
module _ (t : Terminal) where
  open Terminal t

  pullback-⊤⇒product : Pullback (! {X}) (! {Y}) → Product X Y
  pullback-⊤⇒product p = record
    { A×B      = P
    ; π₁       = p₁
    ; π₂       = p₂
    ; ⟨_,_⟩    = λ f g → universal (!-unique₂ {f = ! ∘ f} {g = ! ∘ g})
    ; project₁ = p₁∘universal≈h₁
    ; project₂ = p₂∘universal≈h₂
    ; unique   = λ eq eq′ → ⟺ (unique eq eq′)
    }
    where open Pullback p

  product⇒pullback-⊤ : Product X Y → Pullback (! {X}) (! {Y})
  product⇒pullback-⊤ p = record
    { p₁              = π₁
    ; p₂              = π₂
    ; isPullback = record
      { commute         = !-unique₂
      ; universal       = λ {_ f g} _ → ⟨ f , g ⟩
      ; unique          = λ eq eq′ → ⟺ (unique eq eq′)
      ; p₁∘universal≈h₁ = project₁
      ; p₂∘universal≈h₂ = project₂
      }
    }
    where open Product p

-- pullbacks respect _≈_
module _ (p : Pullback f g) where
  open Pullback p

  pullback-resp-≈ : f ≈ h → g ≈ i → Pullback h i
  pullback-resp-≈ eq eq′ = record
    { p₁              = p₁
    ; p₂              = p₂
    ; isPullback = record
      { commute         = ∘-resp-≈ˡ (⟺ eq) ○ commute ○ ∘-resp-≈ˡ eq′
      ; universal       = λ eq″ → universal (∘-resp-≈ˡ eq ○ eq″ ○ ∘-resp-≈ˡ (⟺ eq′))
      ; unique          = unique
      ; p₁∘universal≈h₁ = p₁∘universal≈h₁
      ; p₂∘universal≈h₂ = p₂∘universal≈h₂
      }
    }

-- Some facts about pulling back along identity
module _ (p : Pullback id f) where
  open Pullback p

  -- This is a more subtle way of saying that 'p₂ ≈ id', without involving heterogenous equality.
  pullback-identity : universal id-comm-sym ∘ p₂ ≈ id
  pullback-identity = begin
    universal Basic.id-comm-sym ∘ p₂ ≈⟨ unique ( pullˡ p₁∘universal≈h₁ ) (pullˡ p₂∘universal≈h₂)  ⟩
    universal eq                     ≈⟨ universal-resp-≈ (⟺ commute ○ identityˡ) identityˡ ⟩
    universal commute                ≈˘⟨ Pullback.id-unique p ⟩
    id ∎
    where
      eq : id ∘ f ∘ p₂ ≈ f ∘ id ∘ p₂
      eq = begin
        (id ∘ f ∘ p₂) ≈⟨ elimˡ Equiv.refl ⟩
        (f ∘ p₂)      ≈˘⟨ refl⟩∘⟨ identityˡ ⟩
        (f ∘ id ∘ p₂) ∎

module _ (pullbacks : ∀ {X Y Z} (f : X ⇒ Z) (g : Y ⇒ Z) → Pullback f g)
         (cartesian : Cartesian) where
  open Cartesian cartesian

  pullback×cartesian⇒equalizer : Equalizer f g
  pullback×cartesian⇒equalizer {f = f} {g = g} = record
    { arr       = p.p₁
    ; equality  = equality
    ; equalize  = λ {_ h} eq → p.universal $ begin
      ⟨ f , g ⟩ ∘ h               ≈⟨ ⟨⟩∘ ⟩
      ⟨ f ∘ h , g ∘ h ⟩           ≈˘⟨ ⟨⟩-cong₂ identityˡ (identityˡ ○ eq) ⟩
      ⟨ id ∘ f ∘ h , id ∘ f ∘ h ⟩ ≈˘⟨ ⟨⟩∘ ⟩
      ⟨ id , id ⟩ ∘ f ∘ h         ∎
    ; universal = ⟺ p.p₁∘universal≈h₁
    ; unique    = λ eq → p.unique (⟺ eq)
                                  (⟺ (pullˡ eq′) ○ ⟺ (∘-resp-≈ʳ eq))
    }
    where p : Pullback ⟨ f , g ⟩ ⟨ id , id ⟩
          p = pullbacks _ _
          module p = Pullback p
          eq : ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩ ≈ ⟨ p.p₂ , p.p₂ ⟩
          eq = begin
            ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩      ≈˘⟨ ⟨⟩∘ ⟩
            ⟨ f , g ⟩ ∘ p.p₁             ≈⟨ p.commute ⟩
            ⟨ id , id ⟩ ∘ p.p₂           ≈⟨ ⟨⟩∘ ⟩
            ⟨ id ∘ p.p₂ , id ∘ p.p₂ ⟩    ≈⟨ ⟨⟩-cong₂ identityˡ identityˡ ⟩
            ⟨ p.p₂ , p.p₂ ⟩              ∎
          eq′ : f ∘ p.p₁ ≈  p.p₂
          eq′ = begin
            f ∘ p.p₁                     ≈˘⟨ project₁ ⟩
            π₁ ∘ ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩ ≈⟨ refl⟩∘⟨ eq ⟩
            π₁ ∘ ⟨ p.p₂ , p.p₂ ⟩         ≈⟨ project₁ ⟩
            p.p₂                         ∎
          equality : f ∘ p.p₁ ≈ g ∘ p.p₁
          equality = begin
            f ∘ p.p₁                     ≈⟨ eq′ ⟩
            p.p₂                         ≈˘⟨ project₂ ⟩
            π₂ ∘ ⟨ p.p₂ , p.p₂ ⟩         ≈˘⟨ refl⟩∘⟨ eq ⟩
            π₂ ∘ ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩ ≈⟨ project₂ ⟩
            g ∘ p.p₁                     ∎


open import FRP.JS.Nat using ( ℕ ; zero ; suc ; _≤_ ; _<_ ; _≟_ ; _+_ )
open import FRP.JS.Nat.Properties using ( ≤-impl-≯ ; <-impl-s≤ ; ≤≠-impl-< ; ≤-bot )
open import FRP.JS.Bool using ( Bool ; true ; false ; _∧_ )
open import FRP.JS.Maybe using ( Maybe ; just ; nothing )
open import FRP.JS.True using ( True ; contradiction ; dec ; yes ; no )

module FRP.JS.Array where

infixr 5 _∷_
infixr 4 _++i_

-- IArray A m n is offset m of a length n array with contents of type A

data IArray {α} (A : Set α) : ℕ → ℕ → Set α where
  [] : ∀ {n} → IArray A n n
  _∷_ : ∀ {m n} → (a : A) → (as : IArray A (suc m) n) → IArray A m n

data Array {α} (A : Set α) : Set α where
  array : ∀ {n} → (as : IArray A 0 n) → Array A

{-# COMPILED_JS IArray function(xs,v) {
  if ((xs.array.length) <= (xs.offset)) { return v["[]"](xs.offset); }
  else { return v["_∷_"](xs.offset,xs.array.length,xs.head(),xs.tail()); }
} #-}
{-# COMPILED_JS [] require("agda.array").iempty #-}
{-# COMPILED_JS _∷_ function(m) { return function(n) {
  return function(x) { return function(xs) { return xs.cons(x); }; };
}; } #-}
{-# COMPILED_JS Array function(as,v) {
  return v.array(as.length,require("agda.array").iarray(as));
} #-}
{-# COMPILED_JS array function(n) { return function(as) { return as.array; }; } #-}

length : ∀ {α A} → Array {α} A → ℕ
length (array {n} as) = n

{-# COMPILED_JS length function() { return function() { return function(as) { return as.length; }; }; } #-}

iarray : ∀ {α A} → (as : Array {α} A) → IArray A 0 (length as)
iarray (array as) = as

{-# COMPILED_JS iarray function() { return function() { return require("agda.array").iarray; }; } #-}

⟨⟩ : ∀ {α A} → Array {α} A
⟨⟩ = array []

{-# COMPILED_JS ⟨⟩ function() { return function() { return require("agda.array").empty; }; } #-}

ilookup : ∀ {α A m n} → IArray {α} A m n → ∀ i → {m≤i : True (m ≤ i)} → {i<n : True (i < n)} → A
ilookup {m = m} []       i {m≤i} {i<m} = contradiction (≤-impl-≯ {m} {i} m≤i i<m)
ilookup {m = m} (a ∷ as) i {m≤i} {i<n}
  with dec (m ≟ i)
... | yes m=i = a
... | no  m≠i = ilookup as i {<-impl-s≤ {m} {i} (≤≠-impl-< {m} {i} m≤i m≠i)} {i<n}

lookup : ∀ {α A} (as : Array {α} A) i → {i<#as : True (i < length as)} → A
lookup (array as) i {i<#as} = ilookup as i {≤-bot {i}} {i<#as}

{-# COMPILED_JS lookup function() { return function() { return function(as) { return function(i) { return function() {
  return require("agda.array").lookup(as,i);
}; }; }; }; } #-}

ilookup? : ∀ {α A m n} → IArray {α} A m n → ℕ → Maybe A
ilookup? []       i       = nothing
ilookup? (a ∷ as) zero    = just a
ilookup? (a ∷ as) (suc i) = ilookup? as i

lookup? : ∀ {α A} → Array {α} A → ℕ → Maybe A
lookup? (array as) i = ilookup? as i

{-# COMPILED_JS lookup? function() { return function() { return function(as) { return function(i) {
  return require("agda.box").box(require("agda.array").lookup(as,i));
}; }; }; } #-}

imap : ∀ {α β A B m n} → (A → B) → IArray {α} A m n → IArray {β} B m n
imap f [] = []
imap f (a ∷ as) = f a ∷ imap f as

map : ∀ {α β A B} → (A → B) → Array {α} A → Array {β} B
map f (array as) = array (imap f as)

{-# COMPILED_JS map function() { return function() { return function() { return function() {
  return function(f) { return function(as) { return as.map(f); }; };
}; }; }; } #-}

#filter : ∀ {α A m n} → (A → Bool) → IArray {α} A m n → ℕ → ℕ
#filter p []       l = l
#filter p (a ∷ as) l
 with p a
... | true  = #filter p as (1 + l)
... | false = #filter p as l

ifilter : ∀ {α A l m n} p as → IArray A l (#filter {α} {A} {m} {n} p as l)
ifilter p []       = []
ifilter p (a ∷ as)
 with p a
... | true  = a ∷ ifilter p as
... | false = ifilter p as

filter : ∀ {α A} → (A → Bool) → Array {α} A → Array A
filter p (array as) = array (ifilter p as)

{-# COMPILED_JS filter function() { return function() {
  return function(p) { return function(as) { return as.filter(p); }; };
}; } #-}

iall : ∀ {α A m n} → (A → Bool) → IArray {α} A m n → Bool
iall f []       = true
iall f (a ∷ as) = f a ∧ iall f as

all : ∀ {α A} → (A → Bool) → Array {α} A → Bool
all f (array as) = iall f as

{-# COMPILED_JS all function() { return function() {
  return function(f) { return function(as) { return as.every(f); }; };
}; } #-}

_≟i[_]_ : ∀ {α β A B l m n} → IArray {α} A l m → (A → B → Bool) → IArray {β} B l n → Bool
[]       ≟i[ p ] []       = true
(a ∷ as) ≟i[ p ] (b ∷ bs) = (p a b) ∧ (as ≟i[ p ] bs)
as       ≟i[ p ] bs       = false

_≟[_]_ : ∀ {α β A B} → Array {α} A → (A → B → Bool) → Array {β} B → Bool
array as ≟[ p ] array bs = as ≟i[ p ] bs

{-# COMPILED_JS _≟[_]_ function() { return function() { return function() { return function() {
  return function(as) { return function(p) { return function(bs) {
    return require("agda.array").equals(as,bs,function(a,b) { return p(a)(b); });
  }; }; };
}; }; }; } #-}

_⊆i[_]_ : ∀ {α β A B l m n} → IArray {α} A l m → (A → B → Bool) → IArray {β} B l n → Bool
[]       ⊆i[ p ] bs       = true
(a ∷ as) ⊆i[ p ] []       = false
(a ∷ as) ⊆i[ p ] (b ∷ bs) = (p a b) ∧ (as ⊆i[ p ] bs)

_⊆[_]_ : ∀ {α β A B} → Array {α} A → (A → B → Bool) → Array {β} B → Bool
array as ⊆[ p ] array bs = as ⊆i[ p ] bs

{-# COMPILED_JS _⊆[_]_ function() { return function() { return function() { return function() {
  return function(as) { return function(p) { return function(bs) {
    return require("agda.array").subseteq(as,bs,function(a,b) { return p(a)(b); });
  }; }; };
}; }; }; } #-}

igrow : ∀ {α A l m n} → IArray {α} A l n → IArray A (l + m) (n + m)
igrow []       = []
igrow (a ∷ as) = a ∷ igrow as

_++i_ : ∀ {α A l m n} → IArray {α} A l m → IArray A 0 n → IArray A l (n + m)
[]       ++i bs = igrow bs
(a ∷ as) ++i bs = a ∷ (as ++i bs)

_++_ :  ∀ {α A} → Array {α} A → Array {α} A → Array {α} A
array as ++ array bs = array (as ++i bs)

{-# COMPILED_JS _++_ function() { return function() {
  return function(as) { return function(bs) { return as.concat(bs); }; };
}; } #-}

-- Surface syntax, e.g. ⟨ 1 , 2 , 3 ⟩ : Array ℕ

infix 3 ⟨_
infixr 4 _,_
infixr 5 _⟩

data Sugar {α} (A : Set α) : Set α where
  ε : Sugar A
  _,_ : A → Sugar A → Sugar A

_⟩ : ∀ {α A} → A → Sugar {α} A
a ⟩ = (a , ε)

slength : ∀ {α A} → Sugar {α} A → ℕ → ℕ
slength ε        m = m
slength (a , as) m = slength as (1 + m)

desugar : ∀ {α A m} as → IArray A m (slength {α} {A} as m)
desugar ε        = []
desugar (a , as) = a ∷ desugar as

⟨_ : ∀ {α A} → Sugar {α} A → Array A
⟨ as = array (desugar as)


------------------------------------------------------------------------
-- Finite maps with indexed keys and values, based on AVL trees
------------------------------------------------------------------------

open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Data.Product as Prod hiding (map)

module Data.AVL.IndexedMap
         {Index : Set} {Key : Index → Set} {_≈_ _<_ : Rel (∃ Key)}
         (isOrderedKeySet : IsStrictTotalOrder _≈_ _<_)
         -- Equal keys must have equal indices.
         (indicesEqual : _≈_ =[ proj₁ ]⇒ _≡_)
         (Value : Index → Set)
         where

import Data.AVL
open import Data.Function
open import Data.Maybe as Maybe
open import Data.Bool
open import Data.List
open import Category.Functor
open RawFunctor Maybe.functor

-- Key/value pairs.

KV : Set
KV = ∃ λ i → Key i × Value i

-- Conversions.

private

  fromKV : KV → Σ (∃ Key) λ ik → Value (proj₁ ik)
  fromKV (i , k , v) = ((i , k) , v)

  toKV : Σ (∃ Key) (λ ik → Value (proj₁ ik)) → KV
  toKV ((i , k) , v) = (i , k , v)

private

  Order : StrictTotalOrder
  Order = record { isStrictTotalOrder = isOrderedKeySet }

-- The map type.

private
  open module AVL = Data.AVL Order (λ ik → Value (proj₁ ik))
    public using () renaming (Tree to Map)

-- Repackaged functions.

empty : Map
empty = AVL.empty

singleton : ∀ {i} → Key i → Value i → Map
singleton k v = AVL.singleton (, k) v

insert : ∀ {i} → Key i → Value i → Map → Map
insert k v = AVL.insert (, k) v

delete : ∀ {i} → Key i → Map → Map
delete k = AVL.delete (, k)

lookup : ∀ {i} → Key i → Map → Maybe (Value i)
lookup k m with AVL.lookup (_ , k) m
... | nothing                    = nothing
... | just ((i′ , k′) , v′ , eq) with indicesEqual eq
...   | refl = just v′

_∈?_ : ∀ {i} → Key i → Map → Bool
_∈?_ k = AVL._∈?_ (, k)

headTail : Map → Maybe (KV × Map)
headTail m = Prod.map toKV id <$> AVL.headTail m

initLast : Map → Maybe (Map × KV)
initLast m = Prod.map id toKV <$> AVL.initLast m

fromList : List KV → Map
fromList = AVL.fromList ∘ map fromKV

toList : Map → List KV
toList = map toKV ∘ AVL.toList