------------------------------------------------------------------------
-- Equivalence of declarative and canonical kinding of Fω with
-- interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Canonical.Equivalence where

open import Data.Fin using (zero)
open import Data.Fin.Substitution using (module VarSubst)
open import Data.Fin.Substitution.Typed
open import Data.Product as Prod using (_,_; proj₁; proj₂)
open import Data.Vec using ([])
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization
open import FOmegaInt.Syntax.WeakEquality
import FOmegaInt.Typing                            as Original
import FOmegaInt.Typing.Validity                   as OriginalValidity
import FOmegaInt.Kinding.Declarative               as Extended
import FOmegaInt.Kinding.Declarative.Validity      as ExtendedValidity
import FOmegaInt.Kinding.Declarative.Equivalence   as ExtendedEquiv
import FOmegaInt.Kinding.Declarative.Normalization as OriginalNorm
open import FOmegaInt.Kinding.Canonical            as Canonical
open import FOmegaInt.Kinding.Canonical.Validity
open import FOmegaInt.Kinding.Canonical.WeakEquality
import FOmegaInt.Kinding.Simple              as SimpKind
import FOmegaInt.Kinding.Simple.EtaExpansion as SimpEtaExp
open import FOmegaInt.Kinding.Simple.Normalization

private

  -- Original declarative rules and lemmas.
  module O where
    open Original            public
    open Typing              public
    open TermCtx             public
    open TypedSubstitution   public
    open OriginalValidity    public
    open OriginalNorm        public

  -- Extended declarative rules and lemmas.
  module E where
    open Extended           public
    open Extended.Kinding   public
    open TermCtx            public
    open KindedSubstitution public
    open ExtendedValidity   public
    open ExtendedEquiv      public

  -- Canonical rules and lemmas.
  module C where
    open Canonical public
    open Kinding   public
    open ElimCtx   public

open Syntax
open Substitution using (_Kind[_])
open ElimCtx
open SimpleCtx using (kd)
open ContextConversions
open WeakEqNormalization
open Kinding
open KindedRenaming
open ContextNarrowing
open Original.Typing  hiding (_ctx; _⊢_wf; _⊢_kd; _⊢_<∷_; _⊢_<:_∈_; _⊢_≅_)
open Extended.Kinding hiding (_ctx; _⊢_wf; _⊢_kd; _⊢_<∷_; _⊢_<:_∈_; _⊢_≅_)

------------------------------------------------------------------------
-- Soundness of canonical (sub)kinding w.r.t. declarative (sub)kinding

mutual

  sound-wf : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢ a wf → ⌞ Γ ⌟Ctx O.⊢ ⌞ a ⌟Asc wf
  sound-wf (wf-kd k-kd)  = wf-kd (sound-kd k-kd)
  sound-wf (wf-tp a⇉a⋯a) = wf-tp (O.Tp∈-⋯-* (sound-Nf⇉ a⇉a⋯a))

  sound-ctx : ∀ {n} {Γ : Ctx n} → Γ ctx → ⌞ Γ ⌟Ctx O.ctx
  sound-ctx C.[]             = O.[]
  sound-ctx (a-wf C.∷ Γ-ctx) = sound-wf a-wf O.∷ sound-ctx Γ-ctx

  sound-kd : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → ⌞ Γ ⌟Ctx O.⊢ ⌞ k ⌟Kd kd
  sound-kd (kd-⋯ a⇉a⋯a b⇉b⋯b) =
    kd-⋯ (O.Tp∈-⋯-* (sound-Nf⇉ a⇉a⋯a)) (O.Tp∈-⋯-* (sound-Nf⇉ b⇉b⋯b))
  sound-kd (kd-Π j-kd k-kd)   = kd-Π (sound-kd j-kd) (sound-kd k-kd)

  sound-Nf⇉ : ∀ {n} {Γ : Ctx n} {a k} →
              Γ ⊢Nf a ⇉ k → ⌞ Γ ⌟Ctx O.⊢Tp ⌞ a ⌟ ∈ ⌞ k ⌟Kd
  sound-Nf⇉ (⇉-⊥-f Γ-ctx)       = ∈-s-i (∈-⊥-f (sound-ctx Γ-ctx))
  sound-Nf⇉ (⇉-⊤-f Γ-ctx)       = ∈-s-i (∈-⊤-f (sound-ctx Γ-ctx))
  sound-Nf⇉ (⇉-∀-f k-kd a⇉a⋯a)  =
    ∈-s-i (∈-∀-f (sound-kd k-kd) (O.Tp∈-⋯-* (sound-Nf⇉ a⇉a⋯a)))
  sound-Nf⇉ (⇉-→-f a⇉a⋯a b⇉b⋯b) =
    ∈-s-i (∈-→-f (O.Tp∈-⋯-* (sound-Nf⇉ a⇉a⋯a)) (O.Tp∈-⋯-* (sound-Nf⇉ b⇉b⋯b)))
  sound-Nf⇉ (⇉-Π-i j-kd a⇉k)    =
    let ⌞a⌟∈⌞k⌟ = sound-Nf⇉ a⇉k
    in ∈-Π-i (sound-kd j-kd) ⌞a⌟∈⌞k⌟
  sound-Nf⇉ (⇉-s-i a⇉b⋯c)       = ∈-s-i (sound-Ne∈ a⇉b⋯c)

  sound-Ne∈ : ∀ {n} {Γ : Ctx n} {a k} →
              Γ ⊢Ne a ∈ k → ⌞ Γ ⌟Ctx O.⊢Tp ⌞ a ⌟ ∈ ⌞ k ⌟Kd
  sound-Ne∈ (∈-∙ x∈j j⇉as⇉k) = sound-Sp⇉ (sound-Var∈ x∈j) j⇉as⇉k

  sound-Sp⇉ : ∀ {n} {Γ : Ctx n} {a bs j k} →
              ⌞ Γ ⌟Ctx O.⊢Tp a ∈ ⌞ j ⌟Kd → Γ ⊢ j ⇉∙ bs ⇉ k →
              ⌞ Γ ⌟Ctx O.⊢Tp a ⌞∙⌟ ⌞ bs ⌟Sp ∈ ⌞ k ⌟Kd
  sound-Sp⇉ a∈⌞j⌟ ⇉-[] = a∈⌞j⌟
  sound-Sp⇉ a∈⌞Πjk⌟ (⇉-∷ b⇇j j-kd k[b]⇉bs⇉l) with O.Tp∈-valid a∈⌞Πjk⌟
  ... | (kd-Π ⌞j⌟-kd ⌞k⌟-kd) =
    let ⌞b⌟∈⌞j⌟ = sound-Nf⇇ b⇇j
    in sound-Sp⇉ (∈-⇑ (∈-Π-e a∈⌞Πjk⌟ ⌞b⌟∈⌞j⌟)
                      (O.≅⇒<∷ (O.kd-⌞⌟-[]-≅ ⌞k⌟-kd ⌞b⌟∈⌞j⌟)))
                 k[b]⇉bs⇉l

  sound-Nf⇇ : ∀ {n} {Γ : Ctx n} {a k} →
              Γ ⊢Nf a ⇇ k → ⌞ Γ ⌟Ctx O.⊢Tp ⌞ a ⌟ ∈ ⌞ k ⌟Kd
  sound-Nf⇇ (⇇-⇑ a⇉j j<∷k) = ∈-⇑ (sound-Nf⇉ a⇉j) (sound-<∷ j<∷k)

  sound-Var∈ : ∀ {n} {Γ : Ctx n} {x k} →
               Γ ⊢Var x ∈ k → ⌞ Γ ⌟Ctx O.⊢Tp var x ∈ ⌞ k ⌟Kd
  sound-Var∈ {_} {Γ} (⇉-var {k} x Γ-ctx Γ[x]≡kd-k) =
    ∈-var x (sound-ctx Γ-ctx) (begin
      TermCtx.lookup ⌞ Γ ⌟Ctx x  ≡⟨ ⌞⌟Asc-lookup Γ x ⟩
      ⌞ lookup Γ x ⌟Asc          ≡⟨ cong ⌞_⌟Asc Γ[x]≡kd-k ⟩
      kd ⌞ k ⌟Kd                 ∎)
    where
      open ≡-Reasoning
      open Substitution using (⌞⌟Asc-weaken)
  sound-Var∈ (⇇-⇑ x∈j j<∷k k-kd) = ∈-⇑ (sound-Var∈ x∈j) (sound-<∷ j<∷k)

  sound-<∷ : ∀ {n} {Γ : Ctx n} {j k} →
             Γ ⊢ j <∷ k → ⌞ Γ ⌟Ctx O.⊢ ⌞ j ⌟Kd <∷ ⌞ k ⌟Kd
  sound-<∷ (<∷-⋯ a₂<:a₁ b₁<:b₂)          =
    <∷-⋯ (sound-<: a₂<:a₁) (sound-<: b₁<:b₂)
  sound-<∷ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) =
    <∷-Π (sound-<∷ j₂<∷j₁) (sound-<∷ k₁<∷k₂) (sound-kd Πj₁k₁-kd)

  sound-<: : ∀ {n} {Γ : Ctx n} {a b} →
             Γ ⊢ a <: b → ⌞ Γ ⌟Ctx O.⊢ ⌞ a ⌟ <: ⌞ b ⌟ ∈ *
  sound-<: (<:-trans a<:b b<:c) =
    <:-trans (sound-<: a<:b) (sound-<: b<:c)
  sound-<: (<:-⊥ a⇉a⋯a) = <:-⊥ (O.Tp∈-⋯-* (sound-Nf⇉ a⇉a⋯a))
  sound-<: (<:-⊤ a⇉a⋯a) = <:-⊤ (O.Tp∈-⋯-* (sound-Nf⇉ a⇉a⋯a))
  sound-<: (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) =
    <:-∀ (sound-<∷ k₂<∷k₁) (sound-<: a₁<:a₂)
         (O.Tp∈-⋯-* (sound-Nf⇉ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁))
  sound-<: (<:-→ a₂<:a₁ b₁<:b₂) =
    <:-→ (sound-<: a₂<:a₁) (sound-<: b₁<:b₂)
  sound-<: (<:-∙ x∈j j⇉as⇉k) =
    O.<:-⋯-* (sound-<:-∙-≃ (<:-refl (sound-Var∈ x∈j)) j⇉as⇉k)
  sound-<: (<:-⟨| a∈b⋯c) = <:-⟨| (sound-Ne∈ a∈b⋯c)
  sound-<: (<:-|⟩ a∈b⋯c) = <:-|⟩ (sound-Ne∈ a∈b⋯c)

  sound-<:⇇ : ∀ {n} {Γ : Ctx n} {a b k} →
              Γ ⊢ a <: b ⇇ k → ⌞ Γ ⌟Ctx O.⊢ ⌞ a ⌟ <: ⌞ b ⌟ ∈ ⌞ k ⌟Kd
  sound-<:⇇ (<:-⇇ (⇇-⇑ a₁⇉c₁⋯d₁ (<∷-⋯ c₁<:c d<:d₁))
                  (⇇-⇑ a₂⇉c₂⋯d₂ (<∷-⋯ c₂<:c d<:d₂)) a<:b)
    with Nf⇉-≡ a₁⇉c₁⋯d₁ | Nf⇉-≡ a₂⇉c₂⋯d₂
  sound-<:⇇ (<:-⇇ (⇇-⇑ a₁⇉a₁⋯a₁ (<∷-⋯ c<:a₁ _))
                  (⇇-⇑ a₂⇉a₂⋯a₂ (<∷-⋯ _ a₂<:d)) a<:b)
    | refl , refl | refl , refl =
      <:-⇑ (<:-⋯-i (sound-<: a<:b)) (<∷-⋯ (sound-<: c<:a₁) (sound-<: a₂<:d))
  sound-<:⇇ (<:-λ a₁<:a₂⇇k Λj₁a₁⇇Πjk Λj₂a₂⇇Πjk) =
    <:-λ (sound-<:⇇ a₁<:a₂⇇k) (sound-Nf⇇ Λj₁a₁⇇Πjk) (sound-Nf⇇ Λj₂a₂⇇Πjk)

  sound-≅ : ∀ {n} {Γ : Ctx n} {j k} →
            Γ ⊢ j ≅ k → ⌞ Γ ⌟Ctx O.⊢ ⌞ j ⌟Kd ≅ ⌞ k ⌟Kd
  sound-≅ (<∷-antisym _ _ j<∷k k<∷j) =
    <∷-antisym (sound-<∷ j<∷k) (sound-<∷ k<∷j)

  sound-≃ : ∀ {n} {Γ : Ctx n} {a b k} →
            Γ ⊢ a ≃ b ⇇ k → ⌞ Γ ⌟Ctx O.⊢ ⌞ a ⌟ ≃ ⌞ b ⌟ ∈ ⌞ k ⌟Kd
  sound-≃ (<:-antisym k-kd a<:b⇇k b<:a⇇k) =
    <:-antisym (sound-<:⇇ a<:b⇇k) (sound-<:⇇ b<:a⇇k)

  sound-<:-∙-≃ : ∀ {n} {Γ : Ctx n} {a b as bs j k} →
                 ⌞ Γ ⌟Ctx O.⊢ a <: b ∈ ⌞ j ⌟Kd → Γ ⊢ j ⇉∙ as ≃ bs ⇉ k →
                 ⌞ Γ ⌟Ctx O.⊢ a ⌞∙⌟ ⌞ as ⌟Sp <: b ⌞∙⌟ ⌞ bs ⌟Sp ∈ ⌞ k ⌟Kd
  sound-<:-∙-≃ a<:b∈⌞j⌟ ≃-[] = a<:b∈⌞j⌟
  sound-<:-∙-≃ a<:b∈⌞Πjk⌟ (≃-∷ c≃d⇇j k[c]⇉cs≃ds⇉l) with O.<:-valid-kd a<:b∈⌞Πjk⌟
  ... | (kd-Π ⌞j⌟-kd ⌞k⌟-kd) =
    let ⌞c⌟≃⌞d⌟∈⌞j⌟ = sound-≃ c≃d⇇j
        ⌞c⌟∈⌞j⌟ , _ = O.≃-valid ⌞c⌟≃⌞d⌟∈⌞j⌟
    in sound-<:-∙-≃ (<:-⇑ (<:-· a<:b∈⌞Πjk⌟ ⌞c⌟≃⌞d⌟∈⌞j⌟)
                          (O.≅⇒<∷ (O.kd-⌞⌟-[]-≅ ⌞k⌟-kd ⌞c⌟∈⌞j⌟)))
                    k[c]⇉cs≃ds⇉l

------------------------------------------------------------------------
-- Completeness of canonical (sub)kinding w.r.t. declarative
-- (sub)kinding

open Substitution hiding (subst)

module TrackSimpleKindsCanonicalEtaExp where
  open RenamingCommutes
  open SimpHSubstLemmas
  private
    module V   = VarSubst
    module TK  = TrackSimpleKindsEtaExp
    module TKE = SimpEtaExp.TrackSimpleKindsKindedEtaExp

  -- Hereditary substitutions of a variable by its well-kinded
  -- η-expansion in well-formed kinds vanish.
  --
  -- NOTE. We will strengthen this lemma below, once we have proven
  -- that η-expansion preserves canonical kinding.
  kd-[]-η-var : ∀ {k n} {Γ : Ctx n} {j l} →
                Γ ⊢ j kd → kd j ∷ Γ ⊢ l kd →
                let j′  = weakenKind′ j in (hyp : ⌊ j′ ⌋≡ k) →
                let η-z = TK.η-exp j′ hyp (var∙ zero)
                in kd j ∷ Γ ⊢Nf η-z ⇇ j′ →
                   kd j ∷ Γ ⊢ (l Kind′/Var V.wk V.↑) Kind[ η-z ∈ ⌊ j′ ⌋ ] ≅ l
  kd-[]-η-var j-kd l-kd hyp η-z⇇j =
    let open TypedVarSubst    typedVarSubst
        open SimpKind.Kinding using (_⊢_kds)
        open SimpleCtx        using (kd)

        j-wf     = wf-kd j-kd
        j-kd′    = kd-weaken j-wf j-kd
        ⌊j⌋≡k    = trans (sym (⌊⌋-Kind′/Var _)) (⌊⌋≡⇒⌊⌋-≡ hyp)
        η-z      = TK.η-exp _ hyp (var∙ zero)
        j-kds′   = subst (λ k → kd k ∷ _ ⊢ _ kds) ⌊j⌋≡k (kd-kds j-kd′)
        l-kds    = subst (λ k → kd k ∷ _ ⊢ _ kds) ⌊j⌋≡k (kd-kds l-kd)
        l[z]≋l   = TKE.kds-[]-η-var [] hyp j-kds′ l-kds
        wk↑∈j∷Γ  = ∈-↑′ j-kd′ (∈-wk j-wf)
        l[z]-kd  = kd-[] (kd-/Var l-kd wk↑∈j∷Γ) η-z⇇j
    in ≋-≅ l[z]-kd l-kd (subst (λ l → _ Kind[ η-z ∈ l ] ≋ _)
                               (sym (⌊⌋≡⇒⌊⌋-≡ hyp)) l[z]≋l)

  -- NOTE. The definition of the function η-exp-Ne∈ below is
  -- structurally recursive in the *shape* parameter k, but *not* in
  -- the kind j because we need to weaken the domain j₁ of the
  -- dependent kind (j = Π j₁ j₂) in the arrow case.  The additional
  -- hypothesis ⌊ j ⌋≡ k ensures that k is indeed the shape of the
  -- kind j.

  -- η-expansion preserves canonical kinding of neutral types.
  η-exp-Ne∈ : ∀ {n} {Γ : Ctx n} {a j k l} (hyp : ⌊ j ⌋≡ k) →
              Γ ⊢ j kd → Γ ⊢Ne a ∈ l → Γ ⊢ l <∷ j → Γ ⊢Nf TK.η-exp j hyp a ⇇ j
  η-exp-Ne∈ is-★ b₂⋯c₂-kd a∈b₁⋯c₁ (<∷-⋯ b₂<:b₁ c₁<:c₂) =
    Nf⇇-⇑ (Nf⇇-ne a∈b₁⋯c₁) (<∷-⋯ b₂<:b₁ c₁<:c₂)
  η-exp-Ne∈ (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) (kd-Π j₁-kd j₂-kd)
            (∈-∙ {x} {_} {_} {as} x∈l l⇉as∈Πl₁l₂)
            (<∷-Π j₁<∷l₁ l₂<∷j₂ (kd-Π l₁-kd l₂-kd)) =
    Nf⇇-Π-i j₁-kd (η-exp-Ne∈ ⌊j₂⌋≡k₂ j₂-kd x∙as·z∈l₂[z] l₂[z]<∷j₂)
    where
      open TypedVarSubst    typedVarSubst

      j₁-wf     = wf-kd j₁-kd
      j₁∷Γ-ctx  = j₁-wf C.∷ Var∈-ctx x∈l
      j₁-kd′    = kd-weaken j₁-wf j₁-kd
      l₁-kd′    = kd-weaken j₁-wf l₁-kd
      ⌊j₁′⌋≡k₁  = ⌊⌋≡-weaken ⌊j₁⌋≡k₁
      η-z       = TK.η-exp _ ⌊j₁′⌋≡k₁ (var∙ zero)
      z⇇j₁      = η-exp-Ne∈ ⌊j₁′⌋≡k₁ j₁-kd′
                            (∈-∙ (⇉-var zero j₁∷Γ-ctx refl) ⇉-[])
                            (<∷-refl j₁-kd′)
      z⇇l₁      = Nf⇇-⇑ z⇇j₁ (<∷-weaken j₁-wf j₁<∷l₁)
      wk↑∈j₁∷Γ  = ∈-↑′ j₁-kd′ (∈-wk j₁-wf)
      j₂[z]<∷j₂ = ≅⇒<∷ (kd-[]-η-var j₁-kd j₂-kd ⌊j₁′⌋≡k₁ z⇇j₁)
      l₂[z]<∷j₂[z] = <∷-[≃] (<∷-/Var l₂<∷j₂ wk↑∈j₁∷Γ) (≃-reflNf⇇ z⇇j₁ j₁-kd′)
      l₂[z]<∷j₂ = subst (λ l → _ ⊢ _ Kind[ η-z ∈ l ] <∷ _)
                        (<∷-⌊⌋ (<∷-weaken j₁-wf j₁<∷l₁))
                        (<∷-trans l₂[z]<∷j₂[z] j₂[z]<∷j₂)
      x∙as·z∈l₂[z] = (∈-∙ (Var∈-weaken j₁-wf x∈l)
                          (⇉-∷ʳ (Sp⇉-weaken j₁-wf l⇉as∈Πl₁l₂) z⇇l₁ l₁-kd′))

private module TK  = TrackSimpleKindsCanonicalEtaExp

-- η-expansion preserves canonical kinding of neutral types.

η-exp-Ne∈ : ∀ {n} {Γ : Ctx n} {a k} →
            Γ ⊢ k kd → Γ ⊢Ne a ∈ k → Γ ⊢Nf η-exp k a ⇇ k
η-exp-Ne∈ k-kd a∈k = TK.η-exp-Ne∈ (⌊⌋-⌊⌋≡ _) k-kd a∈k (<∷-refl k-kd)

η-exp-Var∈ : ∀ {n} {Γ : Ctx n} {x k} → Γ ⊢ k kd → Γ ⊢Var x ∈ k →
             Γ ⊢Nf η-exp k (var∙ x) ⇇ k
η-exp-Var∈ k-kd x∈k = η-exp-Ne∈ k-kd (∈-∙ x∈k ⇉-[])

-- Hereditary substitutions in well-formed kinds of a variable by its
-- η-expansion vanish.
kd-[]-η-var : ∀ {n} {Γ : Ctx n} {j l} → Γ ⊢ j kd → kd j ∷ Γ ⊢ l kd →
              let j′  = weakenKind′ j
                  l′  = l Kind′/Var VarSubst.wk VarSubst.↑
              in kd j ∷ Γ ⊢ l′ Kind[ η-exp j′ (var∙ zero) ∈ ⌊ j′ ⌋ ] ≅ l
kd-[]-η-var j-kd l-kd =
  let j-kd′ = kd-weaken (wf-kd j-kd) j-kd
  in TK.kd-[]-η-var j-kd l-kd (⌊⌋-⌊⌋≡ _)
                    (η-exp-Var∈ j-kd′ (⇉-var zero (kd-ctx j-kd′) refl))

open RenamingCommutesNorm

-- Completeness of canonical (sub)kinding w.r.t. extended declarative
-- (sub)kinding
module CompletenessExtended where

  mutual

    complete-wf : ∀ {n} {Γ : E.Ctx n} {a} → Γ E.⊢ a wf →
                  nfCtx Γ ⊢ nfAsc (nfCtx Γ) a wf
    complete-wf (wf-kd k-kd) = wf-kd (complete-kd k-kd)
    complete-wf (wf-tp a∈*)  = wf-tp (Nf⇇-s-i (complete-Tp∈ a∈*))

    complete-ctx : ∀ {n} {Γ : E.Ctx n} → Γ E.ctx → nfCtx Γ ctx
    complete-ctx E.[]             = C.[]
    complete-ctx (a-wf E.∷ Γ-ctx) = complete-wf a-wf C.∷ complete-ctx Γ-ctx

    complete-kd : ∀ {n} {Γ : E.Ctx n} {k} → Γ E.⊢ k kd →
                  nfCtx Γ ⊢ nfKind (nfCtx Γ) k kd
    complete-kd (kd-⋯ a∈* b∈*)   =
      kd-⋯ (Nf⇇-s-i (complete-Tp∈ a∈*)) (Nf⇇-s-i (complete-Tp∈ b∈*))
    complete-kd (kd-Π j-kd k-kd) = kd-Π (complete-kd j-kd) (complete-kd k-kd)

    complete-Tp∈ : ∀ {n} {Γ : E.Ctx n} {a k} → Γ E.⊢Tp a ∈ k →
                   nfCtx Γ ⊢Nf nf (nfCtx Γ) a ⇇ nfKind (nfCtx Γ) k
    complete-Tp∈ {_} {Γ} (∈-var x Γ-ctx Γ[x]≡kd-k)
      with C.lookup (nfCtx Γ) x | nfCtx-lookup-kd x Γ Γ[x]≡kd-k
    complete-Tp∈ {_} {Γ} (∈-var x Γ-ctx Γ[x]≡kd-k) | kd ._ | refl =
      η-exp-Var∈ (WfCtxOps.lookup-kd x nf-Γ-ctx nf-Γ[x]≡kd-nf-k)
                 (⇉-var x nf-Γ-ctx nf-Γ[x]≡kd-nf-k)
      where
        nf-Γ-ctx        = complete-ctx Γ-ctx
        nf-Γ[x]≡kd-nf-k = nfCtx-lookup-kd x Γ Γ[x]≡kd-k
    complete-Tp∈ (∈-⊥-f Γ-ctx) = Nf⇉-⋯-* (⇉-⊥-f (complete-ctx Γ-ctx))
    complete-Tp∈ (∈-⊤-f Γ-ctx) = Nf⇉-⋯-* (⇉-⊤-f (complete-ctx Γ-ctx))
    complete-Tp∈ (∈-∀-f k-kd a∈*) = Nf⇇-∀-f (complete-kd k-kd) (complete-Tp∈ a∈*)
    complete-Tp∈ (∈-→-f a∈* b∈*)  = Nf⇇-→-f (complete-Tp∈ a∈*) (complete-Tp∈ b∈*)
    complete-Tp∈ (∈-Π-i j-kd a∈k k-kd) =
      Nf⇇-Π-i (complete-kd j-kd) (complete-Tp∈ a∈k)
    complete-Tp∈ (∈-Π-e {a} {b} a∈Πjk b∈j k-kd k[a]-kd) =
      Nf⇇-⇑ (Nf⇇-Π-e′ (complete-Tp∈ a∈Πjk) (complete-Tp∈ b∈j))
            (≅⇒<∷ (≅-nfKind-[] k-kd b∈j k[a]-kd))
    complete-Tp∈ (∈-s-i a∈b⋯c) =
      let nf-a⇉a⋯a = Nf⇇-s-i (complete-Tp∈ a∈b⋯c)
      in ⇇-⇑ nf-a⇉a⋯a (<∷-⋯ (<:-reflNf⇉ nf-a⇉a⋯a) (<:-reflNf⇉ nf-a⇉a⋯a))
    complete-Tp∈ (∈-⇑ a∈j j<∷k) = Nf⇇-⇑ (complete-Tp∈ a∈j) (complete-<∷ j<∷k)

    complete-<∷ : ∀ {n} {Γ : E.Ctx n} {j k} → Γ E.⊢ j <∷ k →
                  nfCtx Γ ⊢ nfKind (nfCtx Γ) j <∷ nfKind (nfCtx Γ) k
    complete-<∷ (<∷-⋯ a₂<:a₁ b₁<:b₂) =
      <∷-⋯ (complete-<:-⋯ a₂<:a₁) (complete-<:-⋯ b₁<:b₂)
    complete-<∷ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) with complete-kd Πj₁k₁-kd
    ... | kd-Π nf-j₁-kd nf-k₁-kd =
      let nf-j₂<∷j₁  = complete-<∷ j₂<∷j₁
          nf-k₁′<∷k₂ = complete-<∷ k₁<∷k₂
          ⌊nf-j₁∷Γ⌋≡⌊nf-j₂∷Γ⌋ = cong (λ k → kd k ∷ _) (sym (<∷-⌊⌋ nf-j₂<∷j₁))
          nf-k₁≋k₁′  = ≋-nfKind ⌊nf-j₁∷Γ⌋≡⌊nf-j₂∷Γ⌋ _
          nf-j₂-kd   = proj₁ (<∷-valid nf-j₂<∷j₁)
          nf-k₁′-kd  = proj₁ (<∷-valid nf-k₁′<∷k₂)
          nf-k₁<∷k₁′ = ≋-<∷ (⇓-kd nf-j₂-kd nf-j₂<∷j₁ nf-k₁-kd)
                            nf-k₁′-kd nf-k₁≋k₁′
          nf-k₁<∷k₂ = <∷-trans nf-k₁<∷k₁′ nf-k₁′<∷k₂
      in <∷-Π nf-j₂<∷j₁ nf-k₁<∷k₂ (kd-Π nf-j₁-kd nf-k₁-kd)

    complete-<:-⋯ : ∀ {n} {Γ : E.Ctx n} {a b c d} → Γ E.⊢ a <: b ∈ c ⋯ d →
                    nfCtx Γ ⊢ nf (nfCtx Γ) a <: nf (nfCtx Γ) b
    complete-<:-⋯ a<:b∈c⋯d with complete-<: a<:b∈c⋯d
    complete-<:-⋯ a<:b∈c⋯d | <:-⇇ _ _ a<:b = a<:b

    complete-<: : ∀ {n} {Γ : E.Ctx n} {a b k} → Γ E.⊢ a <: b ∈ k →
                  nfCtx Γ ⊢ nf (nfCtx Γ) a  <:
                    nf (nfCtx Γ) b ⇇ nfKind (nfCtx Γ) k
    complete-<: (<:-refl a∈k) =
      let nf-a∈k  = complete-Tp∈ a∈k
      in <:⇇-reflNf⇇ nf-a∈k (Nf⇇-valid nf-a∈k)
    complete-<: (<:-trans a<:b b<:c) =
      <:⇇-trans (complete-<: a<:b) (complete-<: b<:c)
    complete-<: (<:-β₁ a∈k b∈j a[b]∈k[b] k-kd k[b]-kd) =
      ≃⇒<: (≃-β-nf a∈k b∈j k-kd a[b]∈k[b] k[b]-kd)
    complete-<: (<:-β₂ a∈k b∈j a[b]∈k[b] k-kd k[b]-kd) =
      ≃⇒<: (≃-sym (≃-β-nf a∈k b∈j k-kd a[b]∈k[b] k[b]-kd))
    complete-<: (<:-η₁ a∈Πjk) = ≃⇒<: (≃-η-nf a∈Πjk)
    complete-<: (<:-η₂ a∈Πjk) = ≃⇒<: (≃-sym (≃-η-nf a∈Πjk))
    complete-<: (<:-⊥ a∈b⋯c) = <:-⋯-* (<:-⊥ (Nf⇇-s-i (complete-Tp∈ a∈b⋯c)))
    complete-<: (<:-⊤ a∈b⋯c) = <:-⋯-* (<:-⊤ (Nf⇇-s-i (complete-Tp∈ a∈b⋯c)))
    complete-<: (<:-∀ {a₁ = a₁} k₂<∷k₁ a₁<:a₂ Πk₁a₁∈*) with complete-Tp∈ Πk₁a₁∈*
    ... | (⇇-⇑ (⇉-∀-f nf-k₁-kd nf-a₁⇉a₁⋯a₁) _) =
      let nf-k₂<∷k₁    = complete-<∷ k₂<∷k₁
          nf-a₁′<:a₂   = complete-<:-⋯ a₁<:a₂
          ⌊nf-k₁∷Γ⌋≡⌊nf-k₂∷Γ⌋ = cong (λ k → kd k ∷ _) (sym (<∷-⌊⌋ nf-k₂<∷k₁))
          nf-a₁≈a₁′    = ≈-nf ⌊nf-k₁∷Γ⌋≡⌊nf-k₂∷Γ⌋ a₁
          nf-k₂-kd     = proj₁ (<∷-valid nf-k₂<∷k₁)
          nf-a₁⇉a₁⋯a₁′ = proj₁ (<:-valid nf-a₁′<:a₂)
          nf-a₁<:a₁′   = ≈-<: (⇓-Nf⇉ nf-k₂-kd nf-k₂<∷k₁ nf-a₁⇉a₁⋯a₁)
                              nf-a₁⇉a₁⋯a₁′ nf-a₁≈a₁′
          nf-a₁<:a₂ = <:-trans nf-a₁<:a₁′ nf-a₁′<:a₂
      in <:-⋯-* (<:-∀ nf-k₂<∷k₁ nf-a₁<:a₂ (⇉-∀-f nf-k₁-kd nf-a₁⇉a₁⋯a₁))
    ... | (⇇-⇑ (⇉-s-i ()) _)
    complete-<: (<:-→ a₂<:a₁ b₁<:b₂) =
      <:-⋯-* (<:-→ (complete-<:-⋯ a₂<:a₁) (complete-<:-⋯ b₁<:b₂))
    complete-<: (<:-λ {a₁ = a₁} {a₂} a₁<:a₂∈k Λj₁a₁∈Πjk Λj₂a₂∈Πjk)
      with complete-Tp∈ Λj₁a₁∈Πjk | complete-Tp∈ Λj₂a₂∈Πjk
    ... | ⇇-⇑ (⇉-Π-i nf-j₁-kd nf-a₁⇉k₁) (<∷-Π nf-j<∷j₁ nf-k₁<∷k Πj₁k₁-kd)
        | ⇇-⇑ (⇉-Π-i nf-j₂-kd nf-a₂⇉k₂) (<∷-Π nf-j<∷j₂ nf-k₂<∷k Πj₂k₂-kd) =
      let nf-a₁′<:a₂′⇇k = complete-<: a₁<:a₂∈k
          nf-a₁′⇇k , nf-a₂′⇇k = <:⇇-valid nf-a₁′<:a₂′⇇k
          j-kd          = proj₁ (<∷-valid nf-j<∷j₁)
          k-kd          = proj₂ (<∷-valid nf-k₁<∷k)
          ⌊nf-j₁∷Γ⌋≡⌊nf-j∷Γ⌋  = cong (λ k → kd k ∷ _) (sym (<∷-⌊⌋ nf-j<∷j₁))
          ⌊nf-j∷Γ⌋≡⌊nf-j₂∷Γ⌋  = cong (λ k → kd k ∷ _) (<∷-⌊⌋ nf-j<∷j₂)
          nf-a₁≈a₁′     = ≈-nf ⌊nf-j₁∷Γ⌋≡⌊nf-j∷Γ⌋ a₁
          nf-a₂′≈a₂     = ≈-nf ⌊nf-j∷Γ⌋≡⌊nf-j₂∷Γ⌋ a₂
          nf-a₁<:a₁′⇇k  = ≈-<:⇇ k-kd
                                (⇇-⇑ (⇓-Nf⇉ j-kd nf-j<∷j₁ nf-a₁⇉k₁) nf-k₁<∷k)
                                nf-a₁′⇇k nf-a₁≈a₁′
          nf-a₂′<:a₂⇇k  = ≈-<:⇇ k-kd nf-a₂′⇇k
                                (⇇-⇑ (⇓-Nf⇉ j-kd nf-j<∷j₂ nf-a₂⇉k₂) nf-k₂<∷k)
                                nf-a₂′≈a₂
          nf-a₁<:a₂⇇k   = <:⇇-trans (<:⇇-trans nf-a₁<:a₁′⇇k nf-a₁′<:a₂′⇇k)
                                    nf-a₂′<:a₂⇇k
      in <:-λ nf-a₁<:a₂⇇k
              (⇇-⇑ (⇉-Π-i nf-j₁-kd nf-a₁⇉k₁) (<∷-Π nf-j<∷j₁ nf-k₁<∷k Πj₁k₁-kd))
              (⇇-⇑ (⇉-Π-i nf-j₂-kd nf-a₂⇉k₂) (<∷-Π nf-j<∷j₂ nf-k₂<∷k Πj₂k₂-kd))
    ... | ⇇-⇑ (⇉-Π-i _ _) _ | ⇇-⇑ (⇉-s-i ()) _
    ... | ⇇-⇑ (⇉-s-i ()) _  | _
    complete-<: (<:-· {a₁} {a₂} {b₁} {b₂} a₁<:a₂∈Πjk b₁≃b₂∈j
                      b₁∈j k-kd k[b₁]-kd) =
      let nf-a₁<:a₂⇇Πjk         = complete-<: a₁<:a₂∈Πjk
          nf-a₁⇇Πjk , nf-a₂⇇Πjk = <:⇇-valid nf-a₁<:a₂⇇Πjk
      in <:⇇-⇑ (<:-↓⌜·⌝ nf-a₁<:a₂⇇Πjk (complete-≃ b₁≃b₂∈j))
               (≅⇒<∷ (≅-nfKind-[] k-kd b₁∈j k[b₁]-kd)) (complete-kd k[b₁]-kd)
    complete-<: (<:-⟨| a∈b⋯c) = <:-⋯-* (<:-⟨|-Nf⇇ (complete-Tp∈ a∈b⋯c))
    complete-<: (<:-|⟩ a∈b⋯c) = <:-⋯-* (<:-|⟩-Nf⇇ (complete-Tp∈ a∈b⋯c))
    complete-<: (<:-⋯-i a<:b) = <:⇇-⋯-i (complete-<: a<:b)
    complete-<: (<:-⇑ a<:b∈j j<∷k) =
      let nf-j<∷k = complete-<∷ j<∷k
      in <:⇇-⇑ (complete-<: a<:b∈j) nf-j<∷k (proj₂ (<∷-valid nf-j<∷k))

    complete-≅ : ∀ {n} {Γ : E.Ctx n} {j k} → Γ E.⊢ j ≅ k →
                 nfCtx Γ ⊢ nfKind (nfCtx Γ) j ≅ nfKind (nfCtx Γ) k
    complete-≅ (<∷-antisym j<∷k k<∷j) =
      let nf-j<∷k           = complete-<∷ j<∷k
          nf-j-kd , nf-k-kd = <∷-valid nf-j<∷k
      in <∷-antisym nf-j-kd nf-k-kd nf-j<∷k (complete-<∷ k<∷j)

    complete-≃ : ∀ {n} {Γ : E.Ctx n} {a b k} → Γ E.⊢ a ≃ b ∈ k →
                 nfCtx Γ ⊢ nf (nfCtx Γ) a ≃ nf (nfCtx Γ) b ⇇ nfKind (nfCtx Γ) k
    complete-≃ (<:-antisym a<:b∈k b<:a∈k) =
      let nf-a<:b⇇k = complete-<: a<:b∈k
      in <:-antisym (<:⇇-valid-kd nf-a<:b⇇k) nf-a<:b⇇k (complete-<: b<:a∈k)

    -- η-expansion of normal forms is admissible in canonical kinding.
    ≃-η-nf : ∀ {n} {Γ : E.Ctx n} {a j k} → Γ E.⊢Tp a ∈ Π j k →
             nfCtx Γ ⊢ nf (nfCtx Γ) (Λ j (weaken a · var zero))  ≃
               nf (nfCtx Γ) a ⇇ nfKind (nfCtx Γ) (Π j k)
    ≃-η-nf                 a∈Πjk with complete-Tp∈ a∈Πjk
    ≃-η-nf {_} {Γ} {a} {j} a∈Πjk | nf-a⇇Πjk with Nf⇇-valid nf-a⇇Πjk
    ... | (kd-Π nf-j-kd nf-k-kd) =
      let nf-Γ      = nfCtx Γ
          nf-j      = nfKind nf-Γ j
          nf-j-wf   = wf-kd nf-j-kd
          nf-j-kd′  = kd-weaken nf-j-wf nf-j-kd
          nf-a⇇Πjk′ = subst (kd nf-j ∷ nf-Γ ⊢Nf_⇇ _) (nf-weaken (kd nf-j) a)
                            (Nf⇇-weaken nf-j-wf nf-a⇇Πjk)
          η-z⇇j′    = η-exp-Var∈ nf-j-kd′ (⇉-var zero (kd-ctx nf-j-kd′) refl)
          nf-a·z⇇k[z] = Nf⇇-Π-e′ nf-a⇇Πjk′ η-z⇇j′
          nf-a·z⇇k    = Nf⇇-⇑ nf-a·z⇇k[z] (≅⇒<∷ (kd-[]-η-var nf-j-kd nf-k-kd))
      in ≈-≃ (kd-Π nf-j-kd nf-k-kd) (Nf⇇-Π-i nf-j-kd nf-a·z⇇k) nf-a⇇Πjk
             (≈-η-nf a∈Πjk)

    -- Substitution in well-formed kinds commutes with normalization.
    ≅-nfKind-[] : ∀ {n} {Γ : E.Ctx n} {a j k} →
                  kd k ∷ Γ E.⊢ j kd → Γ E.⊢Tp a ∈ k → Γ E.⊢ j Kind[ a ] kd →
                  nfCtx Γ ⊢ (nfKind (nfCtx (kd k ∷ Γ)) j) Kind[
                    nf (nfCtx Γ) a ∈ ⌊ nfKind (nfCtx Γ) k ⌋ ]  ≅
                      nfKind (nfCtx Γ) (j Kind[ a ])
    ≅-nfKind-[] {_} {Γ} {a} {j} {k} j-kd a∈k j[a]-kd =
      let nf-Γ         = nfCtx Γ
          nf-k         = nfKind nf-Γ k
          nf-a         = nf nf-Γ a
          nf-k∷Γ       = kd nf-k ∷ nf-Γ
          nf-j         = nfKind (nf-k∷Γ) j
          ⌊k⌋≡⌊nf-k⌋   = sym (⌊⌋-nf {_} {nf-Γ} k)
          nf-j-kd      = complete-kd j-kd
          nf-a⇇k       = complete-Tp∈ a∈k
          nf-j[a]-kd   = complete-kd j[a]-kd
          nf-j[a∈⌊k⌋]-kd   = kd-[] nf-j-kd nf-a⇇k
          nf-j[a∈⌊k⌋]≋j[a] = subst (λ l → nf-j Kind[ nf-a ∈ l ] ≋ _)
                                   ⌊k⌋≡⌊nf-k⌋ (≋-sym (nfKind-[] j-kd a∈k))
      in ≋-≅ nf-j[a∈⌊k⌋]-kd nf-j[a]-kd nf-j[a∈⌊k⌋]≋j[a]

    -- β-reduction of normal forms is admissible in canonical kinding.
    ≃-β-nf : ∀ {n} {Γ : E.Ctx n} {a b j k} →
             kd j ∷ Γ E.⊢Tp a ∈ k → Γ E.⊢Tp b ∈ j → kd j ∷ Γ E.⊢ k kd →
             Γ E.⊢Tp a [ b ] ∈ k Kind[ b ] → Γ E.⊢ k Kind[ b ] kd →
             nfCtx Γ ⊢ nf (nfCtx Γ) ((Λ j a) · b)  ≃
               nf (nfCtx Γ) (a [ b ]) ⇇ nfKind (nfCtx Γ) (k Kind[ b ])
    ≃-β-nf {_} {Γ} {a} {b} {j} {k} a∈k b∈j k-kd a[b]∈k[b] k[b]-kd =
      let nf-Γ         = nfCtx Γ
          nf-j         = nfKind nf-Γ j
          nf-b         = nf nf-Γ b
          nf-j∷Γ       = kd nf-j ∷ nf-Γ
          nf-a         = nf (nf-j∷Γ) a
          ⌊j⌋≡⌊nf-j⌋   = sym (⌊⌋-nf {_} {nf-Γ} j)
          nf-a⇇k       = complete-Tp∈ a∈k
          nf-b⇇j       = complete-Tp∈ b∈j
          nf-a[b]⇇k[b] = complete-Tp∈ a[b]∈k[b]
          nf-k[b]-kd   = complete-kd k[b]-kd
          nf-a[b∈⌊j⌋]⇇k[b∈⌊j⌋] = Nf⇇-[] nf-a⇇k nf-b⇇j
          nf-k[b∈⌊j⌋]<∷k[b]    = ≅⇒<∷ (≅-nfKind-[] k-kd b∈j k[b]-kd)
          nf-a[b∈⌊j⌋]⇇k[b]     = Nf⇇-⇑ nf-a[b∈⌊j⌋]⇇k[b∈⌊j⌋] nf-k[b∈⌊j⌋]<∷k[b]
          nf-a[b∈⌊j⌋]≈a[b]     = subst (λ l → nf-a [ nf-b ∈ l ] ≈ _) ⌊j⌋≡⌊nf-j⌋
                                       (≈-sym (nf-[] a∈k b∈j))
      in ≈-≃ nf-k[b]-kd nf-a[b∈⌊j⌋]⇇k[b] nf-a[b]⇇k[b] nf-a[b∈⌊j⌋]≈a[b]

-- Completeness of canonical subkinding and subtyping
-- w.r.t. declarative subkinding and subtyping

complete-<:-⋯ : ∀ {n} {Γ : E.Ctx n} {a b c d} → Γ O.⊢ a <: b ∈ c ⋯ d →
                nfCtx Γ ⊢ nf (nfCtx Γ) a <: nf (nfCtx Γ) b
complete-<:-⋯ = CompletenessExtended.complete-<:-⋯ ∘ E.complete-<:

complete-<: : ∀ {n} {Γ : E.Ctx n} {a b k} → Γ O.⊢ a <: b ∈ k →
              nfCtx Γ ⊢ nf (nfCtx Γ) a <: nf (nfCtx Γ) b ⇇ nfKind (nfCtx Γ) k
complete-<: = CompletenessExtended.complete-<: ∘ E.complete-<:

complete-<∷ : ∀ {n} {Γ : E.Ctx n} {j k} → Γ O.⊢ j <∷ k →
              nfCtx Γ ⊢ nfKind (nfCtx Γ) j <∷ nfKind (nfCtx Γ) k
complete-<∷ = CompletenessExtended.complete-<∷ ∘ E.complete-<∷


open import Relation.Binary.Core

module BBHeap.Drop.Properties {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import BBHeap _≤_
open import BBHeap.Compound _≤_
open import BBHeap.Drop _≤_ tot≤ trans≤
open import BBHeap.Equality _≤_
open import BBHeap.Equality.Properties _≤_
open import BBHeap.Push _≤_ tot≤ trans≤
open import BBHeap.Push.Properties _≤_ tot≤ trans≤
open import BBHeap.Subtyping _≤_ trans≤
open import BBHeap.Subtyping.Properties _≤_ trans≤
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.Nat
open import Data.List hiding (drop)
open import Data.Sum
open import Data.Product
open import Nat.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Concatenation A
open import List.Permutation.Base.Equivalence A
open import Order.Total _≤_ tot≤

mutual
  lemma-drop⋘# : {b : Bound}{x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x))(l⋘r : l ⋘ r) → # (drop⋘ b≤x l⋘r) ≡ # l + # r
  lemma-drop⋘# b≤x lf⋘ = refl
  lemma-drop⋘# b≤x (ll⋘ {x = y₁} {x' = y₂} {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
      with tot≤ y₁ y₂ | lemma-drop⋘ (cl x≤y₁ l₁⋘r₁) (cl x≤y₂ l₂⋘r₂) (ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
  ... | inj₁ y₁≤y₂ | inj₁ (_ , l⋙dr)
      with # (drop⋘ x≤y₂ l₂⋘r₂) | lemma-drop⋘# x≤y₂ l₂⋘r₂ | # (push⋘ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁) | lemma-push# (lexy y₁≤y₂) (left (lexy refl≤) l₁⋘r₁) | # (subtyping (lexy y₁≤y₂) (drop⋘ x≤y₂ l₂⋘r₂)) | lemma-subtyping# (lexy y₁≤y₂) (drop⋘ x≤y₂ l₂⋘r₂) | # l₁ + # r₁ + suc (# l₂ + # r₂) | +assoc (# l₁ + # r₁) (# l₂ + # r₂)
  ... | ._ | refl | ._ | refl | ._ | refl | ._ | refl = refl
  lemma-drop⋘# b≤x (ll⋘ {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂) | inj₁ y₁≤y₂ | inj₂ dl⋘r
      with # (drop⋘ x≤y₁ l₁⋘r₁) | lemma-drop⋘# x≤y₁ l₁⋘r₁
  ... | ._ | refl = refl
  lemma-drop⋘# b≤x (ll⋘ {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂) | inj₂ y₂≤y₁ | inj₁ (_ , l⋙dr)
      with # (drop⋘ x≤y₂ l₂⋘r₂) | lemma-drop⋘# x≤y₂ l₂⋘r₂ | (# l₁ + # r₁) + suc (# l₂ + # r₂) | +assoc (# l₁ + # r₁) (# l₂ + # r₂)
  ... | ._ | refl | ._ | refl = refl
  lemma-drop⋘# b≤x (ll⋘ {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂) | inj₂ y₂≤y₁ | inj₂ dl⋘r
      with # (drop⋘ x≤y₁ l₁⋘r₁) | lemma-drop⋘# x≤y₁ l₁⋘r₁ | # (push⋘ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂) | lemma-push# (lexy y₂≤y₁) (left (lexy refl≤) l₂⋘r₂) | # (subtyping (lexy y₂≤y₁) (drop⋘ x≤y₁ l₁⋘r₁)) | lemma-subtyping# (lexy y₂≤y₁) (drop⋘ x≤y₁ l₁⋘r₁)
  ... | ._ | refl | ._ | refl | ._ | refl = refl
  lemma-drop⋘# b≤x (lr⋘ {x = y₁} {x' = y₂} {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
      with tot≤ y₁ y₂ | lemma-drop⋘ (cr x≤y₁ l₁⋙r₁) (cl x≤y₂ l₂⋘r₂) (lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₁≤y₂ | inj₂ dl⋘r
      with # (drop⋙ x≤y₁ l₁⋙r₁) | lemma-drop⋙# x≤y₁ l₁⋙r₁
  ... | ._ | refl = refl
  lemma-drop⋘# b≤x (lr⋘ {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂) | inj₂ y₂≤y₁ | inj₂ dl⋘r
      with # (drop⋙ x≤y₁ l₁⋙r₁) | lemma-drop⋙# x≤y₁ l₁⋙r₁ | # (push⋘ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂) | lemma-push# (lexy y₂≤y₁) (left (lexy refl≤) l₂⋘r₂) | # (subtyping (lexy y₂≤y₁) (drop⋙ x≤y₁ l₁⋙r₁)) | lemma-subtyping# (lexy y₂≤y₁) (drop⋙ x≤y₁ l₁⋙r₁)
  ... | ._ | refl | ._ | refl | ._ | refl = refl

  lemma-drop⋙# : {b : Bound}{x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x))(l⋙r : l ⋙ r) → # (drop⋙ b≤x l⋙r) ≡ # l + # r
  lemma-drop⋙# b≤x (⋙lf x≤y) = refl
  lemma-drop⋙# b≤x (⋙rl {x = y₁} {x' = y₂} {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
      with tot≤ y₁ y₂ | lemma-drop⋙ (cl x≤y₁ l₁⋘r₁) (cl x≤y₂ l₂⋘r₂) (⋙rl x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
  ... | inj₁ y₁≤y₂ | inj₁ (_ , dl⋘r)
      with # (drop⋘ x≤y₁ l₁⋘r₁) | lemma-drop⋘# x≤y₁ l₁⋘r₁
  ... | ._ | refl = refl
  lemma-drop⋙# b≤x (⋙rl {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂) | inj₁ y₁≤y₂ | inj₂ l⋙dr
      with # (drop⋘ x≤y₂ l₂⋘r₂) | lemma-drop⋘# x≤y₂ l₂⋘r₂ | # (push⋘ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁) | lemma-push# (lexy y₁≤y₂) (left (lexy refl≤) l₁⋘r₁) | # (subtyping (lexy y₁≤y₂) (drop⋘ x≤y₂ l₂⋘r₂)) | lemma-subtyping# (lexy y₁≤y₂) (drop⋘ x≤y₂ l₂⋘r₂) | # l₁ + # r₁ + suc (# l₂ + # r₂) | +assoc (# l₁ + # r₁) (# l₂ + # r₂)
  ... | ._ | refl | ._ | refl | ._ | refl | ._ | refl = refl
  lemma-drop⋙# b≤x (⋙rl x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂) | inj₂ y₂≤y₁ | inj₁ (_ , dl⋘r)
        with # (drop⋘ x≤y₁ l₁⋘r₁) | lemma-drop⋘# x≤y₁ l₁⋘r₁ | # (push⋘ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂) | lemma-push# (lexy y₂≤y₁) (left (lexy refl≤) l₂⋘r₂) | # (subtyping (lexy y₂≤y₁) (drop⋘ x≤y₁ l₁⋘r₁)) | lemma-subtyping# (lexy y₂≤y₁) (drop⋘ x≤y₁ l₁⋘r₁)
  ... | ._ | refl | ._ | refl | ._ | refl = refl
  lemma-drop⋙# b≤x (⋙rl {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂) | inj₂ y₂≤y₁ | inj₂ l⋙dr
      with # (drop⋘ x≤y₂ l₂⋘r₂) | lemma-drop⋘# x≤y₂ l₂⋘r₂ | (# l₁ + # r₁) + suc (# l₂ + # r₂) | +assoc (# l₁ + # r₁) (# l₂ + # r₂)
  ... | ._ | refl | ._ | refl = refl
  lemma-drop⋙# b≤x (⋙rr {x = y₁} {x' = y₂} {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
      with tot≤ y₁ y₂ | lemma-drop⋙ (cl x≤y₁ l₁⋘r₁) (cr x≤y₂ l₂⋙r₂) (⋙rr x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₁≤y₂ | inj₂ l⋙dr
      with # (drop⋙ x≤y₂ l₂⋙r₂) | lemma-drop⋙# x≤y₂ l₂⋙r₂ | # (push⋘ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁) | lemma-push# (lexy y₁≤y₂) (left (lexy refl≤) l₁⋘r₁) | # (subtyping (lexy y₁≤y₂) (drop⋙ x≤y₂ l₂⋙r₂)) | lemma-subtyping# (lexy y₁≤y₂) (drop⋙ x≤y₂ l₂⋙r₂) | # l₁ + # r₁ + suc (# l₂ + # r₂) | +assoc (# l₁ + # r₁) (# l₂ + # r₂)
  ... | ._ | refl | ._ | refl | ._ | refl | ._ | refl = refl
  lemma-drop⋙# b≤x (⋙rr {l = l₁} {r = r₁} {l' = l₂} {r' = r₂} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂) | inj₂ y₂≤y₁ | inj₂ l⋙dr
      with # (drop⋙ x≤y₂ l₂⋙r₂) | lemma-drop⋙# x≤y₂ l₂⋙r₂ | (# l₁ + # r₁) + suc (# l₂ + # r₂) | +assoc (# l₁ + # r₁) (# l₂ + # r₂)
  ... | ._ | refl | ._ | refl = refl

lemma-drop# : {b : Bound}{h : BBHeap b}(cₕ : Compound h)  → suc (# (drop cₕ)) ≡ # h
lemma-drop# (cl b≤x l⋘r)
    with # (drop (cl b≤x l⋘r)) | lemma-drop⋘# b≤x l⋘r
... | ._ | refl = refl
lemma-drop# (cr b≤x l⋙r)
    with # (drop (cr b≤x l⋙r)) | lemma-drop⋙# b≤x l⋙r
... | ._ | refl = refl

lemma-drop≤′ : {b : Bound}{h : BBHeap b}(cₕ : Compound h) → suc (# (drop cₕ)) ≤′ # h
lemma-drop≤′ cₕ
    with suc (# (drop cₕ)) | lemma-drop# cₕ
... | ._ | refl = ≤′-refl

mutual
  lemma-drop⋘∼ : {b : Bound}{x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x))(l⋘r : l ⋘ r) → flatten (drop⋘ b≤x l⋘r) ∼ (flatten l ++ flatten r)
  lemma-drop⋘∼ b≤x lf⋘ = ∼[]
  lemma-drop⋘∼ b≤x (ll⋘ {x = y₁} {x' = y₂} {l = l₁} {r = r₁} x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
      with tot≤ y₁ y₂ | lemma-drop⋘ (cl x≤y₁ l₁⋘r₁) (cl x≤y₂ l₂⋘r₂) (ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂)
  ... | inj₁ y₁≤y₂ | inj₁ (_ , l⋙dr) =
                     let fdr∼fl₂fr₂ = lemma-drop⋘∼ x≤y₂ l₂⋘r₂ ;
                          fdr'∼fdr = lemma-subtyping∼ (lexy y₁≤y₂) (drop⋘ x≤y₂ l₂⋘r₂) ;
                          fdr'∼fl₂fr₂ = trans∼ fdr'∼fdr fdr∼fl₂fr₂ ;
                          fpl'∼y₂fl₁fr₁ = lemma-push⋘∼ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁ ;
                          fpl'fdr'∼y₂fl₁fr₁fl₂fr₂ = lemma++∼ fpl'∼y₂fl₁fr₁ fdr'∼fl₂fr₂ ;
                          fl₁fr₁fr/y₂⟶fl₁fr₁fl₂fr₂ = lemma++/ {xs = flatten l₁ ++ flatten r₁} ;
                          y₂fl₁fr₁fl₂fr₂∼fl₁fr₁fr = ∼x /head fl₁fr₁fr/y₂⟶fl₁fr₁fl₂fr₂ refl∼ ;
                          fpl'fdr'∼fl₁fr₁fr = trans∼ fpl'fdr'∼y₂fl₁fr₁fl₂fr₂ y₂fl₁fr₁fl₂fr₂∼fl₁fr₁fr
                     in ∼x /head /head fpl'fdr'∼fl₁fr₁fr
  ... | inj₁ y₁≤y₂ | inj₂ dl⋘r =
                     let fdl∼fl₁fr₁ = lemma-drop⋘∼ x≤y₁ l₁⋘r₁ ;
                          fdlfr∼fl₁fr₁fr = lemma++∼r fdl∼fl₁fr₁
                     in ∼x /head /head fdlfr∼fl₁fr₁fr
  ... | inj₂ y₂≤y₁ | inj₁ (_ , l⋙dr) =
                     let fdr∼fl₂fr₂ = lemma-drop⋘∼ x≤y₂ l₂⋘r₂ ;
                          fl = y₁ ∷ (flatten l₁ ++ flatten r₁) ;
                          flfdr∼flfl₂fr₂ = lemma++∼l {xs = fl} fdr∼fl₂fr₂ ;
                          flfr/y₂⟶flfl₂fr₂ =  lemma++/ {xs = fl}
                     in ∼x {x = y₂} /head flfr/y₂⟶flfl₂fr₂ flfdr∼flfl₂fr₂
  ... | inj₂ y₂≤y₁ | inj₂ dl⋘r =
                     let fdl∼fl₁fr₁ = lemma-drop⋘∼ x≤y₁ l₁⋘r₁ ;
                          fdl'∼fdl = lemma-subtyping∼ (lexy y₂≤y₁) (drop⋘ x≤y₁ l₁⋘r₁) ;
                          fdl'∼fl₁fr₁ = trans∼ fdl'∼fdl fdl∼fl₁fr₁ ;
                          fpr'∼y₁fl₂fr₂ = lemma-push⋘∼ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂ ;
                          fdl'fpr'∼fl₁fr₁y₁fl₂fr₂ = lemma++∼ fdl'∼fl₁fr₁ fpr'∼y₁fl₂fr₂ ;
                          flfr/y₂⟶flfl₂fr₂ = lemma++/ {xs = y₁ ∷ (flatten l₁ ++ flatten r₁)} ;
                          fl₁fr₁y₁fl₂fr₂/y₁⟶fl₁fr₁fl₂fr₂ =  lemma++/ {xs = flatten l₁ ++ flatten r₁} ;
                          fl₁fr₁y₁fl₂fr₂∼flfl₂fr₂ = ∼x fl₁fr₁y₁fl₂fr₂/y₁⟶fl₁fr₁fl₂fr₂ /head refl∼ ;
                          fdl'fpr'∼flfl₂fr₂ = trans∼ fdl'fpr'∼fl₁fr₁y₁fl₂fr₂ fl₁fr₁y₁fl₂fr₂∼flfl₂fr₂
                     in ∼x /head flfr/y₂⟶flfl₂fr₂ fdl'fpr'∼flfl₂fr₂
  lemma-drop⋘∼ b≤x (lr⋘ {x = y₁} {x' = y₂} {l = l₁} {r = r₁} x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
      with tot≤ y₁ y₂ | lemma-drop⋘ (cr x≤y₁ l₁⋙r₁) (cl x≤y₂ l₂⋘r₂) (lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₁≤y₂ | inj₂ dl⋘r =
                     let fdl∼fl₁fr₁ = lemma-drop⋙∼ x≤y₁ l₁⋙r₁ ;
                          fdlfr∼fl₁fr₁fr = lemma++∼r fdl∼fl₁fr₁
                     in ∼x /head /head fdlfr∼fl₁fr₁fr
  ... | inj₂ y₂≤y₁ | inj₂ dl⋘r =
                     let fdl∼fl₁fr₁ = lemma-drop⋙∼ x≤y₁ l₁⋙r₁ ;
                          fdl'∼fdl = lemma-subtyping∼ (lexy y₂≤y₁) (drop⋙ x≤y₁ l₁⋙r₁) ;
                          fdl'∼fl₁fr₁ = trans∼ fdl'∼fdl fdl∼fl₁fr₁ ;
                          fpr'∼y₁fl₂fr₂ = lemma-push⋘∼ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂ ;
                          fdl'fpr'∼fl₁fr₁y₁fl₂fr₂ = lemma++∼ fdl'∼fl₁fr₁ fpr'∼y₁fl₂fr₂ ;
                          flfr/y₂⟶flfl₂fr₂ = lemma++/ {xs = y₁ ∷ (flatten l₁ ++ flatten r₁)} ;
                          fl₁fr₁y₁fl₂fr₂/y₁⟶fl₁fr₁fl₂fr₂ =  lemma++/ {xs = flatten l₁ ++ flatten r₁} ;
                          fl₁fr₁y₁fl₂fr₂∼flfl₂fr₂ = ∼x fl₁fr₁y₁fl₂fr₂/y₁⟶fl₁fr₁fl₂fr₂ /head refl∼ ;
                          fdl'fpr'∼flfl₂fr₂ = trans∼ fdl'fpr'∼fl₁fr₁y₁fl₂fr₂ fl₁fr₁y₁fl₂fr₂∼flfl₂fr₂
                     in ∼x /head flfr/y₂⟶flfl₂fr₂ fdl'fpr'∼flfl₂fr₂

  lemma-drop⋙∼ : {b : Bound}{x : A}{l r : BBHeap (val x)}(b≤x : LeB b (val x))(l⋙r : l ⋙ r) → flatten (drop⋙ b≤x l⋙r) ∼ (flatten l ++ flatten r)
  lemma-drop⋙∼ b≤x (⋙lf x≤y) = ∼x /head /head ∼[]
  lemma-drop⋙∼ b≤x (⋙rl {x = y₁} {x' = y₂} {l = l₁} {r = r₁} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
      with tot≤ y₁ y₂ | lemma-drop⋙ (cl x≤y₁ l₁⋘r₁) (cl x≤y₂ l₂⋘r₂) (⋙rl x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋘r₂ l₁⋗r₂)
  ... | inj₁ y₁≤y₂ | inj₁ (_ , dl⋘r) =
                       let fdl∼fl₁fr₁ = lemma-drop⋘∼ x≤y₁ l₁⋘r₁ ;
                            fdlfr∼fl₁fr₁fr = lemma++∼r fdl∼fl₁fr₁
                       in ∼x /head /head fdlfr∼fl₁fr₁fr
  ... | inj₁ y₁≤y₂ | inj₂ l⋙dr =
                       let fdr∼fl₂fr₂ = lemma-drop⋘∼ (lexy refl≤) l₂⋘r₂ ;
                            fdr'∼fdr = lemma-subtyping∼ (lexy y₁≤y₂) (drop⋘ x≤y₂ l₂⋘r₂) ;
                            fdr'∼fl₂fr₂ = trans∼ fdr'∼fdr fdr∼fl₂fr₂ ;
                            fpl'∼y₂fl₁fr₁ = lemma-push⋘∼ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁ ;
                            fpl'fdr'∼y₂fl₁fr₁fl₂fr₂ = lemma++∼ fpl'∼y₂fl₁fr₁ fdr'∼fl₂fr₂ ;
                            fl₁fr₁fr/y₂⟶fl₁fr₁fl₂fr₂ = lemma++/ {xs = flatten l₁ ++ flatten r₁} ;
                            y₂fl₁fr₁fl₂fr₂∼fl₁fr₁fr = ∼x /head fl₁fr₁fr/y₂⟶fl₁fr₁fl₂fr₂ refl∼ ;
                            fpl'fdr'∼fl₁fr₁fr = trans∼ fpl'fdr'∼y₂fl₁fr₁fl₂fr₂ y₂fl₁fr₁fl₂fr₂∼fl₁fr₁fr
                       in ∼x /head /head fpl'fdr'∼fl₁fr₁fr
  ... | inj₂ y₂≤y₁ | inj₁ (_ , dl⋘r) =
                       let fdl∼fl₁fr₁ = lemma-drop⋘∼ x≤y₁ l₁⋘r₁ ;
                            fdl'∼fdl = lemma-subtyping∼ (lexy y₂≤y₁) (drop⋘ x≤y₁ l₁⋘r₁) ;
                            fdl'∼fl₁fr₁ = trans∼ fdl'∼fdl fdl∼fl₁fr₁ ;
                            fpr'∼y₁fl₂fr₂ = lemma-push⋘∼ (lexy y₂≤y₁) (lexy refl≤) l₂⋘r₂ ;
                            fdl'fpr'∼fl₁fr₁y₁fl₂fr₂ = lemma++∼ fdl'∼fl₁fr₁ fpr'∼y₁fl₂fr₂ ;
                            flfr/y₂⟶flfl₂fr₂ = lemma++/ {xs = y₁ ∷ (flatten l₁ ++ flatten r₁)} ;
                            fl₁fr₁y₁fl₂fr₂/y₁⟶fl₁fr₁fl₂fr₂ =  lemma++/ {xs = flatten l₁ ++ flatten r₁} ;
                            fl₁fr₁y₁fl₂fr₂∼flfl₂fr₂ = ∼x fl₁fr₁y₁fl₂fr₂/y₁⟶fl₁fr₁fl₂fr₂ /head refl∼ ;
                            fdl'fpr'∼flfl₂fr₂ = trans∼ fdl'fpr'∼fl₁fr₁y₁fl₂fr₂ fl₁fr₁y₁fl₂fr₂∼flfl₂fr₂
                       in ∼x /head flfr/y₂⟶flfl₂fr₂ fdl'fpr'∼flfl₂fr₂
  ... | inj₂ y₂≤y₁ | inj₂ l⋙dr =
                       let fdr∼fl₂fr₂ = lemma-drop⋘∼ x≤y₂ l₂⋘r₂ ;
                            fl = y₁ ∷ (flatten l₁ ++ flatten r₁) ;
                            flfdr∼flfl₂fr₂ = lemma++∼l {xs = fl} fdr∼fl₂fr₂ ;
                            flfr/y₂⟶flfl₂fr₂ =  lemma++/ {xs = fl}
                       in ∼x {x = y₂} /head flfr/y₂⟶flfl₂fr₂ flfdr∼flfl₂fr₂
  lemma-drop⋙∼ b≤x (⋙rr {x = y₁} {x' = y₂} {l = l₁} {r = r₁} x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
      with tot≤ y₁ y₂ | lemma-drop⋙ (cl x≤y₁ l₁⋘r₁) (cr x≤y₂ l₂⋙r₂) (⋙rr x≤y₁ x≤y₂ l₁⋘r₁ l₁≃r₁ l₂⋙r₂ l₁≃l₂)
  ... | _ | inj₁ (() , _)
  ... | inj₁ y₁≤y₂ | inj₂ l⋙dr =
                       let fdr∼fl₂fr₂ = lemma-drop⋙∼ (lexy refl≤) l₂⋙r₂ ;
                            fdr'∼fdr = lemma-subtyping∼ (lexy y₁≤y₂) (drop⋙ x≤y₂ l₂⋙r₂) ;
                            fdr'∼fl₂fr₂ = trans∼ fdr'∼fdr fdr∼fl₂fr₂ ;
                            fpl'∼y₂fl₁fr₁ = lemma-push⋘∼ (lexy y₁≤y₂) (lexy refl≤) l₁⋘r₁ ;
                            fpl'fdr'∼y₂fl₁fr₁fl₂fr₂ = lemma++∼ fpl'∼y₂fl₁fr₁ fdr'∼fl₂fr₂ ;
                            fl₁fr₁fr/y₂⟶fl₁fr₁fl₂fr₂ = lemma++/ {xs = flatten l₁ ++ flatten r₁} ;
                            y₂fl₁fr₁fl₂fr₂∼fl₁fr₁fr = ∼x /head fl₁fr₁fr/y₂⟶fl₁fr₁fl₂fr₂ refl∼ ;
                            fpl'fdr'∼fl₁fr₁fr = trans∼ fpl'fdr'∼y₂fl₁fr₁fl₂fr₂ y₂fl₁fr₁fl₂fr₂∼fl₁fr₁fr
                       in ∼x /head /head fpl'fdr'∼fl₁fr₁fr
  ... | inj₂ y₂≤y₁ | inj₂ l⋙dr =
                       let fdr∼fl₂fr₂ = lemma-drop⋙∼ x≤y₂ l₂⋙r₂ ;
                            fl = y₁ ∷ (flatten l₁ ++ flatten r₁) ;
                            flfdr∼flfl₂fr₂ = lemma++∼l {xs = fl} fdr∼fl₂fr₂ ;
                            flfr/y₂⟶flfl₂fr₂ =  lemma++/ {xs = fl}
                       in ∼x {x = y₂} /head flfr/y₂⟶flfl₂fr₂ flfdr∼flfl₂fr₂


open import System.IO using ( _>>_ ; putStr ; commit )
open import Data.Natural using ( show )
open import System.IO.Examples.Four using ( four )

module System.IO.Examples.HelloFour where

main = putStr "Hello, " >> putStr (show four) >> putStr ".\n" >> commit


module Luau.RuntimeError where

open import Agda.Builtin.Equality using (_≡_)
open import Luau.Heap using (Heap; _[_])
open import FFI.Data.Maybe using (just; nothing)
open import FFI.Data.String using (String)
open import Luau.Syntax using (Block; Expr; nil; var; addr; block_is_end; _$_; local_←_; return; done; _∙_; number; binexp)
open import Luau.RuntimeType using (RuntimeType; valueType)
open import Luau.Value using (val)
open import Properties.Equality using (_≢_)

data RuntimeErrorᴮ {a} (H : Heap a) : Block a → Set
data RuntimeErrorᴱ {a} (H : Heap a) : Expr a → Set

data RuntimeErrorᴱ H where
  TypeMismatch : ∀ t v → (t ≢ valueType v) → RuntimeErrorᴱ H (val v)
  UnboundVariable : ∀ x → RuntimeErrorᴱ H (var x)
  SEGV : ∀ a → (H [ a ] ≡ nothing) → RuntimeErrorᴱ H (addr a)
  app₁ : ∀ {M N} → RuntimeErrorᴱ H M → RuntimeErrorᴱ H (M $ N)
  app₂ : ∀ {M N} → RuntimeErrorᴱ H N → RuntimeErrorᴱ H (M $ N)
  block : ∀ b {B} → RuntimeErrorᴮ H B → RuntimeErrorᴱ H (block b is B end)
  bin₁ : ∀ {M N op} → RuntimeErrorᴱ H M → RuntimeErrorᴱ H (binexp M op N)
  bin₂ : ∀ {M N op} → RuntimeErrorᴱ H N → RuntimeErrorᴱ H (binexp M op N)

data RuntimeErrorᴮ H where
  local : ∀ x {M B} → RuntimeErrorᴱ H M → RuntimeErrorᴮ H (local x ← M ∙ B)
  return : ∀ {M B} → RuntimeErrorᴱ H M → RuntimeErrorᴮ H (return M ∙ B)


{-

  Functions building UARels and DUARels on function types

-}
{-# OPTIONS --no-exact-split --safe #-}
module Cubical.Displayed.Function where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Path

open import Cubical.Functions.FunExtEquiv
open import Cubical.Functions.Implicit

open import Cubical.Displayed.Base
open import Cubical.Displayed.Constant
open import Cubical.Displayed.Morphism
open import Cubical.Displayed.Subst
open import Cubical.Displayed.Sigma

private
  variable
    ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C : Level

-- UARel on dependent function type
-- from UARel on domain and DUARel on codomain

module _ {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) where

  open UARel 𝒮-A
  open DUARel 𝒮ᴰ-B

  𝒮-Π : UARel ((a : A) → B a) (ℓ-max ℓA ℓ≅B)
  UARel._≅_ 𝒮-Π f f' = ∀ a → f a ≅ᴰ⟨ ρ a ⟩ f' a
  UARel.ua 𝒮-Π f f' =
    compEquiv
      (equivΠCod λ a → uaᴰρ (f a) (f' a))
      funExtEquiv

-- Parameterize UARel by type

_→𝒮_ : (A : Type ℓA) {B : Type ℓB} (𝒮-B : UARel B ℓ≅B) → UARel (A → B) (ℓ-max ℓA ℓ≅B)
(A →𝒮 𝒮-B) .UARel._≅_ f f' = ∀ a → 𝒮-B .UARel._≅_ (f a) (f' a)
(A →𝒮 𝒮-B) .UARel.ua f f' =
  compEquiv
    (equivΠCod λ a → 𝒮-B .UARel.ua (f a) (f' a))
    funExtEquiv

𝒮-app : {A : Type ℓA} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B}
  → A → UARelHom (A →𝒮 𝒮-B) 𝒮-B
𝒮-app a .UARelHom.fun f = f a
𝒮-app a .UARelHom.rel h = h a
𝒮-app a .UARelHom.ua h = refl

-- DUARel on dependent function type
-- from DUARels on domain and codomain

module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
  {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B)
  {C : (a : A) → B a → Type ℓC} (𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) (uncurry C) ℓ≅C)
  where

  open UARel 𝒮-A
  private
    module B = DUARel 𝒮ᴰ-B
    module C = DUARel 𝒮ᴰ-C

  𝒮ᴰ-Π : DUARel 𝒮-A (λ a → (b : B a) → C a b) (ℓ-max (ℓ-max ℓB ℓ≅B) ℓ≅C)
  DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Π f p f' =
    ∀ {b b'} (q : b B.≅ᴰ⟨ p ⟩ b') → f b C.≅ᴰ⟨ p , q ⟩ f' b'
  DUARel.uaᴰ 𝒮ᴰ-Π f p f' =
    compEquiv
      (equivImplicitΠCod λ {b} →
        (equivImplicitΠCod λ {b'} →
          (equivΠ (B.uaᴰ b p b') (λ q → C.uaᴰ (f b) (p , q) (f' b')))))
      funExtDepEquiv

_→𝒮ᴰ_ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
  {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B)
  {C : A → Type ℓC} (𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C)
  → DUARel 𝒮-A (λ a → B a → C a) (ℓ-max (ℓ-max ℓB ℓ≅B) ℓ≅C)
𝒮ᴰ-B →𝒮ᴰ 𝒮ᴰ-C =
  𝒮ᴰ-Π 𝒮ᴰ-B (𝒮ᴰ-Lift _ 𝒮ᴰ-C 𝒮ᴰ-B)

-- DUARel on dependent function type
-- from a SubstRel on the domain and DUARel on the codomain

module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
  {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B)
  {C : (a : A) → B a → Type ℓC} (𝒮ᴰ-C : DUARel (∫ˢ 𝒮ˢ-B) (uncurry C) ℓ≅C)
  where

  open UARel 𝒮-A
  open SubstRel 𝒮ˢ-B
  open DUARel 𝒮ᴰ-C

  𝒮ᴰ-Πˢ : DUARel 𝒮-A (λ a → (b : B a) → C a b) (ℓ-max ℓB ℓ≅C)
  DUARel._≅ᴰ⟨_⟩_ 𝒮ᴰ-Πˢ f p f' =
    (b : B _) → f b ≅ᴰ⟨ p , refl ⟩ f' (act p .fst b)
  DUARel.uaᴰ 𝒮ᴰ-Πˢ f p f' =
    compEquiv
      (compEquiv
        (equivΠCod λ b → Jequiv (λ b' q → f b ≅ᴰ⟨ p , q ⟩ f' b'))
        (invEquiv implicit≃Explicit))
      (DUARel.uaᴰ (𝒮ᴰ-Π (Subst→DUA 𝒮ˢ-B) 𝒮ᴰ-C) f p f')

-- SubstRel on a dependent function type
-- from a SubstRel on the domain and SubstRel on the codomain

equivΠ' : ∀ {ℓA ℓA' ℓB ℓB'} {A : Type ℓA} {A' : Type ℓA'}
  {B : A → Type ℓB} {B' : A' → Type ℓB'}
  (eA : A ≃ A')
  (eB : {a : A} {a' : A'} → eA .fst a ≡ a' → B a ≃ B' a')
  → ((a : A) → B a) ≃ ((a' : A') → B' a')
equivΠ' {B' = B'} eA eB = isoToEquiv isom
  where
  open Iso

  isom : Iso _ _
  isom .fun f a' =
    eB (retEq eA a') .fst (f (invEq eA a'))
  isom .inv f' a =
    invEq (eB refl) (f' (eA .fst a))
  isom .rightInv f' =
    funExt λ a' →
    J (λ a'' p → eB p .fst (invEq (eB refl) (f' (p i0))) ≡ f' a'')
      (retEq (eB refl) (f' (eA .fst (invEq eA a'))))
      (retEq eA a')
  isom .leftInv f =
    funExt λ a →
    subst
      (λ p → invEq (eB refl) (eB p .fst (f (invEq eA (eA .fst a)))) ≡ f a)
      (sym (commPathIsEq (eA .snd) a))
      (J (λ a'' p → invEq (eB refl) (eB (cong (eA .fst) p) .fst (f (invEq eA (eA .fst a)))) ≡ f a'')
        (secEq (eB refl) (f (invEq eA (eA .fst a))))
        (secEq eA a))

module _ {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
  {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B)
  {C : Σ A B → Type ℓC} (𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C)
  where

  open UARel 𝒮-A
  open SubstRel
  private
    module B = SubstRel 𝒮ˢ-B
    module C = SubstRel 𝒮ˢ-C

  𝒮ˢ-Π : SubstRel 𝒮-A (λ a → (b : B a) → C (a , b))
  𝒮ˢ-Π .act p = equivΠ' (B.act p) (λ q → C.act (p , q))
  𝒮ˢ-Π .uaˢ p f =
    fromPathP
      (DUARel.uaᴰ (𝒮ᴰ-Π (Subst→DUA 𝒮ˢ-B) (Subst→DUA 𝒮ˢ-C)) f p (equivFun (𝒮ˢ-Π .act p) f) .fst
        (λ {b} →
          J (λ b' q →
                equivFun (C.act (p , q)) (f b)
                ≡ equivFun (equivΠ' (𝒮ˢ-B .act p) (λ q → C.act (p , q))) f b')
            (λ i →
              C.act (p , λ j → commSqIsEq (𝒮ˢ-B .act p .snd) b (~ i) j) .fst
                (f (secEq (𝒮ˢ-B .act p) b (~ i))))))


open import Prelude hiding (id; Bool; _∷_; [])

module Examples.PartialResolution where

data TC : Set where
  tc-int : TC
  tc-bool : TC

_tc≟_ : (a b : TC) → Dec (a ≡ b)
tc-int tc≟ tc-int = yes refl
tc-int tc≟ tc-bool = no (λ ())
tc-bool tc≟ tc-int = no (λ ())
tc-bool tc≟ tc-bool = yes refl

open import Implicits.Syntax
open import Implicits.WellTyped
open import Implicits.Substitutions
open import Implicits.Syntax.Type.Unification
open import Implicits.Resolution.Infinite.Algorithm
open import Data.Maybe
open import Data.List
open import Category.Monad.Partiality

Bool : ∀ {n} → Type n
Bool = simpl (tc tc-bool)

Int : ∀ {n} → Type n
Int = simpl (tc tc-int)

module Ex₁ where

  Δ : ICtx zero
  Δ = Bool ∷ Int ∷ []

  -- resolves directly using a value from the implicit context
  r = run_for_steps (resolve Δ Int) 10

  p : isNow r ≡ true
  p = refl

module Ex₂ where

  Δ : ICtx zero
  Δ = Bool ∷ (Bool ⇒ Int) ∷ []

  -- resolves using implicit application
  r = run_for_steps (resolve Δ Int) 10

  p : r resolved? ≡ true
  p = refl

module Ex₃ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' (Bool ⇒ (simpl (tvar zero)))) ∷ []

  -- resolves using polymorphic appliation + implicit application
  r = run_for_steps (resolve Δ Int) 10

  p : r resolved? ≡ true
  p = refl

module Ex₄ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' ((simpl (tvar zero)) ⇒ Int)) ∷ []

  r = run_for_steps (resolve Δ Int) 10

  -- Maybe surprisingly this fails.
  -- But we should note that unification on the codomain of the rule does not fix the domain to a
  -- concrete type, such that it's instantiation is left ambiguous.
  -- Like Oliveira we reject those rules, because they lead to ambiguous terms.
  p : r failed? ≡ true
  p = refl

module Ex₅ where

  -- The following context would not resolved Int in Oliveira's deterministic calculus.
  -- Demonstratint that partial resolution is more powerful for terminating contexts.
  Δ : ICtx zero
  Δ = (Bool ⇒ Int) ∷ Int ∷ []

  r = run_for_steps (resolve Δ Int) 10

  p : r resolved? ≡ true
  p = refl

module Ex₆ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' (Bool ⇒ (simpl (tvar zero)))) ∷ []

  -- resolves rule types
  r = run_for_steps (resolve Δ (Bool ⇒ Int)) 10

  p : r resolved? ≡ true
  p = refl

module Ex₇ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' (Bool ⇒ (simpl (tvar zero)))) ∷ []

  q : Type zero
  q = (∀' (Bool ⇒ (simpl (tvar zero))))

  -- Resolves polymorphic types.
  -- Note that it doesn't resolve to the rule in the context directly.
  -- Instead, it will apply r-tabs and r-iabs, to obtain resolve Δ' ⊢ᵣ (∀' (tvar zero))
  r = run_for_steps (resolve Δ q) 10

  p : r resolved? ≡ true
  p = refl

module Ex₈ where

  Δ : ICtx zero
  Δ = Bool ∷ (∀' ((simpl (tvar zero)) ⇒ (simpl (tvar zero)))) ∷ []

  -- infinite derivation exists: not decidable
  r = run_for_steps (resolve Δ Int) 10

  p : r resolved? ≡ false
  p = refl

  ¬p : r failed? ≡ false
  ¬p = refl

module Ex₉ where

  Δ : ICtx zero
  Δ = (∀' ((Int ⇒ simpl (tvar zero)) ⇒ ((simpl (tvar zero)) ⇒ Int))) ∷ (Int ⇒ Bool) ∷ []

  r = run_for_steps (resolve Δ (Bool ⇒ Int)) 10

  p : r resolved? ≡ false
  p = refl

  ¬p : r failed? ≡ true
  ¬p = refl

  -- Below p' demonstrates however that a derivation exists!
  -- The algorithm doesn't find it because we left the ⊢unamb predicate from oliveira implicit.
  -- at some point the algorithm has to match ((simpl (mvar zero) ⇒ Int)) with Int.
  -- However, when we match the codomain Int with the goal Int (note the open mvar):
  test : mgu {m = suc zero} {ν = zero} (to-meta Int) (tc tc-int) ≡ nothing
  test = refl
  -- Because mgu requires that all meta variables are instantiated by unification
  -- and in this example (mvar zero) does not occur and thus can't be unified.

  open import Implicits.Resolution.Infinite.Resolution
  open import Coinduction

  p' : Δ ⊢ᵣ (Bool ⇒ Int)
  p' = r-iabs
    (r-simp
      (there (here refl))
      (i-tabs
        (simpl (tc tc-bool))
        (i-iabs
          (♯ (r-iabs (r-simp (there (here refl)) (i-simp (tc tc-bool)))))
          (i-iabs (♯ (r-simp (here refl) (i-simp (tc tc-bool)))) (i-simp (tc tc-int)))
        )
      )
    )


{-# OPTIONS  --safe #-}

module Definition.Typed.Reduction where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties

-- Weak head expansion of type equality
reduction : ∀ {A A′ B B′ r Γ}
          → Γ ⊢ A ⇒* A′ ^ r
          → Γ ⊢ B ⇒* B′ ^ r
          → Whnf A′
          → Whnf B′
          → Γ ⊢ A′ ≡ B′ ^ r
          → Γ ⊢ A ≡ B ^ r
reduction D D′ whnfA′ whnfB′ A′≡B′ =
  trans (subset* D) (trans A′≡B′ (sym (subset* D′)))

reduction′ : ∀ {A A′ B B′ r Γ}
          → Γ ⊢ A ⇒* A′ ^ r
          → Γ ⊢ B ⇒* B′ ^ r
          → Whnf A′
          → Whnf B′
          → Γ ⊢ A ≡ B ^ r
          → Γ ⊢ A′ ≡ B′ ^ r
reduction′ D D′ whnfA′ whnfB′ A≡B =
  trans (sym (subset* D)) (trans A≡B (subset* D′))

-- Weak head expansion of term equality
reductionₜ : ∀ {a a′ b b′ A B l Γ}
           → Γ ⊢ A ⇒* B ^ [ ! , l ]
           → Γ ⊢ a ⇒* a′ ∷ B ^ l
           → Γ ⊢ b ⇒* b′ ∷ B ^ l
           → Whnf B
           → Whnf a′
           → Whnf b′
           → Γ ⊢ a′ ≡ b′ ∷ B ^ [ ! , l ]
           → Γ ⊢ a ≡ b ∷ A ^ [ ! , l ]
reductionₜ D d d′ whnfB whnfA′ whnfB′ a′≡b′ =
  conv (trans (subset*Term d)
              (trans a′≡b′ (sym (subset*Term d′))))
       (sym (subset* D))

reductionₜ′ : ∀ {a a′ b b′ A B l Γ}
           → Γ ⊢ A ⇒* B ^ [ ! , l ]
           → Γ ⊢ a ⇒* a′ ∷ B ^ l
           → Γ ⊢ b ⇒* b′ ∷ B ^ l
           → Whnf B
           → Whnf a′
           → Whnf b′
           → Γ ⊢ a ≡ b ∷ A ^ [ ! , l ]
           → Γ ⊢ a′ ≡ b′ ∷ B ^ [ ! , l ]
reductionₜ′ D d d′ whnfB whnfA′ whnfB′ a≡b =
  trans (sym (subset*Term d))
        (trans (conv a≡b (subset* D)) (subset*Term d′))


{-# OPTIONS --prop #-}

open import Agda.Builtin.Equality

postulate
  A : Set
  P : Prop
  p : P
  f : P → A

mutual
  X : A
  X = _

  test₁ : (x : P) → X ≡ f x
  test₁ x = refl

  test₂ : X ≡ f p
  test₂ = refl


postulate
  I : Set
  D : I → Set
  T : Set

record R : Set where
  field
    t0   : T
    {i0} : I
    t1   : T
    d0   : D i0
    {i1} : I
    d1   : D i1
    t2   : T

module M0 where
  postulate
    t0 t1 : T

module MI where
  postulate
    i1 : I
    d1 : D i1

module MD {i0 : I} where
  postulate
    d0 : D i0
    t0 : T

r : R
r = record { M0; t2 = M0.t0; MD; MI; i0 = i0 }
  module My where postulate i0 : I

r' : R
r' = record { R r; t0 = R.t1 r }
  where module Rr = R r


{-# OPTIONS --safe #-}

module Generics.Constructions.DecEq where

open import Generics.Prelude hiding (lookup; _≟_)
open import Generics.Telescope
open import Generics.Desc
open import Generics.All
open import Generics.HasDesc

import Generics.Helpers as Helpers

import Data.Fin.Properties as Fin
import Data.Product.Properties as Product

open import Relation.Nullary.Decidable as Decidable
open import Data.Empty
open import Relation.Nullary
open import Relation.Binary using (DecidableEquality)
open import Relation.Nullary.Product

record DecEq {l} (A : Set l) : Set l where
  field _≟_ : DecidableEquality A

open DecEq ⦃...⦄ public

module _ {P I ℓ}
         {A : Indexed P I ℓ}
         (H : HasDesc {P} {I} {ℓ} A) where

  data HigherOrderArgumentsNotSupported : Set where

  -- Predicate preventing the use of Higher-order inductive arguments
  OnlyFO : ∀ {V} → ConDesc P V I → Setω
  OnlyFO (var _) = Liftω ⊤
  OnlyFO (π _ _ _) = Liftω HigherOrderArgumentsNotSupported
  OnlyFO (A ⊗ B) = OnlyFO A ×ω OnlyFO B

  open HasDesc H
  open Helpers P I DecEq (const ⊤) OnlyFO

  DecEqHelpers : ∀ p → Setω
  DecEqHelpers p = Helpers p D

  private irr≡ : ∀ {l} (A : Set l) (x y : Irr A) → x ≡ y
          irr≡ A (irrv _) (irrv _) = refl

  private module _ {p} (DH : DecEqHelpers p) where

    variable
      V : ExTele P
      v : ⟦ V ⟧tel p
      i : ⟦ I ⟧tel p

    mutual
      decEqIndArg-wf : ∀ (C : ConDesc P V I) → OnlyFO C
                     → (x y : ⟦ C ⟧IndArg A′ (p , v))
                     → AllIndArgω Acc C x
                     → AllIndArgω Acc C y
                     → Dec (x ≡ y)

      decEqIndArg-wf (var i) H x y ax ay = decEq-wf x y ax ay
      decEqIndArg-wf (A ⊗ B) (HA , HB) (xa , xb) (ya , yb) (axa , axb) (aya , ayb)
        = map′ (λ (p , q) → cong₂ _,_ p q)
            (λ p → cong proj₁ p , cong proj₂ p)
            (decEqIndArg-wf _ HA xa ya axa aya ×-dec decEqIndArg-wf _ HB xb yb axb ayb)
      decEqIndArg-wf (π i S C) ()

      decEqCon-wf : (C   : ConDesc P V I)
                    ⦃ H  : ConHelper p C ⦄
                    (x y : ⟦ C ⟧Con A′ (p , v , i))
                  → AllConω Acc C x
                  → AllConω Acc C y
                  → Dec (x ≡ y)
      decEqCon-wf ._ ⦃ var ⦄ refl refl _ _ = yes refl
      decEqCon-wf ._ ⦃ pi-irr ⦃ _ ⦄ ⦃ H ⦄ ⦄ (irrv _ , x) (irrv _ , y) ax ay
        with decEqCon-wf _ ⦃ H ⦄ x y ax ay
      ... | yes refl = yes refl
      ... | no p     = no (p ∘ λ {refl → refl})
      decEqCon-wf ._ ⦃ pi-rel ⦃ dec ⦄ ⦃ H ⦄ ⦄ (s₁ , x) (s₂ , y) ax ay
        with dec .DecEq._≟_ s₁ s₂
      ... | no p     = no (p ∘ (λ { refl → refl }))
      ... | yes refl with decEqCon-wf _ ⦃ H ⦄ x y ax ay
      ... | yes refl = yes refl
      ... | no  p    = no (p ∘ (λ { refl → refl }))
      decEqCon-wf ._ ⦃ prod ⦃ HA ⦄ ⦄ (xa , xb) (ya , yb) (axa , axb) (aya , ayb) =
        map′ (λ (p , q) → cong₂ _,_ p q)
             (λ p → cong proj₁ p , cong proj₂ p)
             (decEqIndArg-wf _ HA xa ya axa aya ×-dec decEqCon-wf _ xb yb axb ayb)

      decEqData-wf : (x y : ⟦ D ⟧Data A′ (p , i))
                   → AllDataω Acc D x
                   → AllDataω Acc D y
                   → Decω (x ≡ω y)
      decEqData-wf (k₁ , x) (k₂ , y) ax ay with k₁ Fin.≟ k₂
      decEqData-wf (k  , x) (k  , y) ax ay | yes refl with decEqCon-wf _ ⦃ lookupHelper DH k ⦄ x y ax ay
      decEqData-wf (k  , x) (k  , y) ax ay | yes refl | yes refl = yesω refl
      decEqData-wf (k  , x) (k  , y) ax ay | yes refl | no x≢y   = noω λ { refl → x≢y refl }
      decEqData-wf (k₁ , x) (k₂ , y) ax ay | no k₁≢k₂ =
        noω λ { refl → k₁≢k₂ refl }

      decEq-wf : (x y : A′ (p , i)) → Acc x → Acc y → Dec (x ≡ y)
      decEq-wf x y (acc ax) (acc ay) with decEqData-wf (split x) (split y) ax ay
      ... | yesω p = yes (split-injective p)
      ... | noω  p = no  (λ e → p (cong≡ω split e))

  deriveDecEq : ∀ {p} ⦃ DH : DecEqHelpers p ⦄ {i} → DecEq (A′ (p , i))
  deriveDecEq ⦃ DH ⦄ .DecEq._≟_ x y
    = decEq-wf DH x y (wf x) (wf y)


-- Andreas, 2011-04-11
-- taken from test/succeed/HereditarilySingletonRecord.agda

module FrozenMVar where

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

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

one : ℕ
one = _

force : one ≡ suc zero
force = refl
-- this tries to instantiate the frozen metavar for one


module Pi-.Invariants where
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Nat.Properties
open import Function using (_∘_)
open import Pi-.Syntax
open import Pi-.Opsem
open import Pi-.NoRepeat
open import Pi-.Dir

-- Direction of values
dir𝕍 : ∀ {t} → ⟦ t ⟧ → Dir
dir𝕍 {𝟘} ()
dir𝕍 {𝟙} v = ▷
dir𝕍 {_ +ᵤ _} (inj₁ x) = dir𝕍 x
dir𝕍 {_ +ᵤ _} (inj₂ y) = dir𝕍 y
dir𝕍 {_ ×ᵤ _} (x , y) = dir𝕍 x ×ᵈⁱʳ dir𝕍 y
dir𝕍 { - _} (- v) = -ᵈⁱʳ (dir𝕍 v)

-- Execution direction of states
dirState : State → Dir
dirState ⟨ _ ∣ _ ∣ _ ⟩▷ = ▷
dirState ［ _ ∣ _ ∣ _ ］▷ = ▷
dirState ⟨ _ ∣ _ ∣ _ ⟩◁ = ◁
dirState ［ _ ∣ _ ∣ _ ］◁ = ◁

dirCtx : ∀ {A B} → Context {A} {B} → Dir
dirCtx ☐ = ▷
dirCtx (☐⨾ c₂ • κ) = dirCtx κ
dirCtx (c₁ ⨾☐• κ) = dirCtx κ
dirCtx (☐⊕ c₂ • κ) = dirCtx κ
dirCtx (c₁ ⊕☐• κ) = dirCtx κ
dirCtx (☐⊗[ c₂ , x ]• κ) = dir𝕍 x ×ᵈⁱʳ dirCtx κ
dirCtx ([ c₁ , x ]⊗☐• κ) = dir𝕍 x ×ᵈⁱʳ dirCtx κ

dirState𝕍 : State → Dir
dirState𝕍 ⟨ _ ∣ v ∣ κ ⟩▷ = dir𝕍 v  ×ᵈⁱʳ dirCtx κ
dirState𝕍 ［ _ ∣ v ∣ κ ］▷ = dir𝕍 v  ×ᵈⁱʳ dirCtx κ
dirState𝕍 ⟨ _ ∣ v ∣ κ ⟩◁ = dir𝕍 v  ×ᵈⁱʳ dirCtx κ
dirState𝕍 ［ _ ∣ v ∣ κ ］◁ = dir𝕍 v  ×ᵈⁱʳ dirCtx κ

δdir : ∀ {A B} (c : A ↔ B) {b : base c} → (v : ⟦ A ⟧) → dir𝕍 v ≡ dir𝕍 (δ c {b} v)
δdir unite₊l (inj₂ v) = refl
δdir uniti₊l v = refl
δdir swap₊ (inj₁ x) = refl
δdir swap₊ (inj₂ y) = refl
δdir assocl₊ (inj₁ v) = refl
δdir assocl₊ (inj₂ (inj₁ v)) = refl
δdir assocl₊ (inj₂ (inj₂ v)) = refl
δdir assocr₊ (inj₁ (inj₁ v)) = refl
δdir assocr₊ (inj₁ (inj₂ v)) = refl
δdir assocr₊ (inj₂ v) = refl
δdir unite⋆l (tt , v) = identˡᵈⁱʳ (dir𝕍 v)
δdir uniti⋆l v = sym (identˡᵈⁱʳ (dir𝕍 v))
δdir swap⋆ (x , y) = commᵈⁱʳ _ _
δdir assocl⋆ (v₁ , (v₂ , v₃)) = assoclᵈⁱʳ _ _ _
δdir assocr⋆ ((v₁ , v₂) , v₃) = sym (assoclᵈⁱʳ _ _ _)
δdir dist (inj₁ v₁ , v₃) = refl
δdir dist (inj₂ v₂ , v₃) = refl
δdir factor (inj₁ (v₁ , v₃)) = refl
δdir factor (inj₂ (v₂ , v₃)) = refl

-- Invariant of directions
dirInvariant : ∀ {st st'} → st ↦ st' → dirState st ×ᵈⁱʳ dirState𝕍 st ≡ dirState st' ×ᵈⁱʳ dirState𝕍 st'
dirInvariant {⟨ c ∣ v ∣ κ ⟩▷} (↦⃗₁ {b = b}) rewrite δdir c {b} v = refl
dirInvariant ↦⃗₂ = refl
dirInvariant ↦⃗₃ = refl
dirInvariant ↦⃗₄ = refl
dirInvariant ↦⃗₅ = refl
dirInvariant {⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ κ ⟩▷} ↦⃗₆ rewrite assoclᵈⁱʳ (dir𝕍 x) (dir𝕍 y) (dirCtx κ) = refl
dirInvariant ↦⃗₇ = refl
dirInvariant {［ c₁ ∣ x ∣ ☐⊗[ c₂ , y ]• κ ］▷} ↦⃗₈ rewrite assoc-commᵈⁱʳ (dir𝕍 x) (dir𝕍 y) (dirCtx κ) = refl
dirInvariant {［ c₂ ∣ y ∣ [ c₁ , x ]⊗☐• κ ］▷} ↦⃗₉ rewrite assocl-commᵈⁱʳ (dir𝕍 y) (dir𝕍 x) (dirCtx κ) = refl
dirInvariant ↦⃗₁₀ = refl
dirInvariant ↦⃗₁₁ = refl
dirInvariant ↦⃗₁₂ = refl
dirInvariant {_} {⟨ c ∣ v ∣ κ ⟩◁} (↦⃖₁ {b = b}) rewrite δdir c {b} v = refl
dirInvariant ↦⃖₂ = refl
dirInvariant ↦⃖₃ = refl
dirInvariant ↦⃖₄ = refl
dirInvariant ↦⃖₅ = refl
dirInvariant {⟨ c₁ ∣ x ∣ ☐⊗[ c₂ , y ]• κ ⟩◁} ↦⃖₆ rewrite assoclᵈⁱʳ (dir𝕍 x) (dir𝕍 y) (dirCtx κ) = refl
dirInvariant ↦⃖₇ = refl
dirInvariant {⟨ c₂ ∣ y ∣ [ c₁ , x ]⊗☐• κ ⟩◁} ↦⃖₈ rewrite assoc-commᵈⁱʳ (dir𝕍 y) (dir𝕍 x) (dirCtx κ) = refl
dirInvariant {［ c₁ ⊗ c₂ ∣ (x , y) ∣ κ ］◁ } ↦⃖₉ rewrite assoclᵈⁱʳ (dir𝕍 y) (dir𝕍 x) (dirCtx κ) | commᵈⁱʳ (dir𝕍 y) (dir𝕍 x) = refl
dirInvariant ↦⃖₁₀ = refl
dirInvariant ↦⃖₁₁ = refl
dirInvariant ↦⃖₁₂ = refl
dirInvariant {［ η₊ ∣ inj₁ v ∣ κ ］◁} ↦η₁ with dir𝕍 v
... | ◁ with dirCtx κ
... | ◁ = refl
... | ▷ = refl
dirInvariant {［ η₊ ∣ inj₁ v ∣ κ ］◁} ↦η₁ | ▷ with dirCtx κ
... | ◁ = refl
... | ▷ = refl
dirInvariant {［ η₊ ∣ inj₂ (- v) ∣ κ ］◁} ↦η₂ with dir𝕍 v
... | ◁ with dirCtx κ
... | ◁ = refl
... | ▷ = refl
dirInvariant {［ η₊ ∣ inj₂ (- v) ∣ κ ］◁} ↦η₂ | ▷ with dirCtx κ
... | ◁ = refl
... | ▷ = refl
dirInvariant {⟨ ε₊ ∣ inj₁ v ∣ κ ⟩▷} ↦ε₁ with dir𝕍 v
... | ◁ with dirCtx κ
... | ◁ = refl
... | ▷ = refl
dirInvariant {⟨ ε₊ ∣ inj₁ v ∣ κ ⟩▷} ↦ε₁ | ▷ with dirCtx κ
... | ◁ = refl
... | ▷ = refl
dirInvariant {⟨ ε₊ ∣ inj₂ (- v) ∣ κ ⟩▷} ↦ε₂ with dir𝕍 v
... | ◁ with dirCtx κ
... | ◁ = refl
... | ▷ = refl
dirInvariant {⟨ ε₊ ∣ inj₂ (- v) ∣ κ ⟩▷} ↦ε₂ | ▷ with dirCtx κ
... | ◁ = refl
... | ▷ = refl

-- Reconstruct the whole combinator from context
getℂκ : ∀ {A B} → A ↔ B → Context {A} {B} → ∃[ C ] ∃[ D ] (C ↔ D)
getℂκ c ☐ = _ , _ , c
getℂκ c (☐⨾ c₂ • κ) = getℂκ (c ⨾ c₂) κ
getℂκ c (c₁ ⨾☐• κ) = getℂκ (c₁ ⨾ c) κ
getℂκ c (☐⊕ c₂ • κ) = getℂκ (c ⊕ c₂) κ
getℂκ c (c₁ ⊕☐• κ) = getℂκ (c₁ ⊕ c) κ
getℂκ c (☐⊗[ c₂ , x ]• κ) = getℂκ (c ⊗ c₂) κ
getℂκ c ([ c₁ , x ]⊗☐• κ) = getℂκ (c₁ ⊗ c) κ

getℂ : State → ∃[ A ] ∃[ B ] (A ↔ B)
getℂ ⟨ c ∣ _ ∣ κ ⟩▷ = getℂκ c κ
getℂ ［ c ∣ _ ∣ κ ］▷ = getℂκ c κ
getℂ ⟨ c ∣ _ ∣ κ ⟩◁ = getℂκ c κ
getℂ ［ c ∣ _ ∣ κ ］◁ = getℂκ c κ

-- The reconstructed combinator stays the same
ℂInvariant : ∀ {st st'} → st ↦ st' → getℂ st ≡  getℂ st'
ℂInvariant ↦⃗₁ = refl
ℂInvariant ↦⃗₂ = refl
ℂInvariant ↦⃗₃ = refl
ℂInvariant ↦⃗₄ = refl
ℂInvariant ↦⃗₅ = refl
ℂInvariant ↦⃗₆ = refl
ℂInvariant ↦⃗₇ = refl
ℂInvariant ↦⃗₈ = refl
ℂInvariant ↦⃗₉ = refl
ℂInvariant ↦⃗₁₀ = refl
ℂInvariant ↦⃗₁₁ = refl
ℂInvariant ↦⃗₁₂ = refl
ℂInvariant ↦⃖₁ = refl
ℂInvariant ↦⃖₂ = refl
ℂInvariant ↦⃖₃ = refl
ℂInvariant ↦⃖₄ = refl
ℂInvariant ↦⃖₅ = refl
ℂInvariant ↦⃖₆ = refl
ℂInvariant ↦⃖₇ = refl
ℂInvariant ↦⃖₈ = refl
ℂInvariant ↦⃖₉ = refl
ℂInvariant ↦⃖₁₀ = refl
ℂInvariant ↦⃖₁₁ = refl
ℂInvariant ↦⃖₁₂ = refl
ℂInvariant ↦η₁ = refl
ℂInvariant ↦η₂ = refl
ℂInvariant ↦ε₁ = refl
ℂInvariant ↦ε₂ = refl

ℂInvariant* : ∀ {st st'} → st ↦* st' → getℂ st ≡  getℂ st'
ℂInvariant* ◾ = refl
ℂInvariant* (r ∷ rs) = trans (ℂInvariant r) (ℂInvariant* rs)

-- Get the type of the deepest context
get𝕌 : ∀ {A B} → Context {A} {B} → 𝕌 × 𝕌
get𝕌 {A} {B} ☐ = A , B
get𝕌 (☐⨾ c₂ • κ) = get𝕌 κ
get𝕌 (c₁ ⨾☐• κ) = get𝕌 κ
get𝕌 (☐⊕ c₂ • κ) = get𝕌 κ
get𝕌 (c₁ ⊕☐• κ) = get𝕌 κ
get𝕌 (☐⊗[ c₂ , x ]• κ) = get𝕌 κ
get𝕌 ([ c₁ , x ]⊗☐• κ) = get𝕌 κ

get𝕌State : State → 𝕌 × 𝕌
get𝕌State ⟨ c ∣ v ∣ κ ⟩▷ = get𝕌 κ
get𝕌State ［ c ∣ v ∣ κ ］▷ = get𝕌 κ
get𝕌State ⟨ c ∣ v ∣ κ ⟩◁ = get𝕌 κ
get𝕌State ［ c ∣ v ∣ κ ］◁ = get𝕌 κ

-- Append a context to another context
appendκ : ∀ {A B} → (ctx : Context {A} {B}) → let (C , D) = get𝕌  ctx
                                              in  Context {C} {D} → Context {A} {B}
appendκ ☐ ctx = ctx
appendκ (☐⨾ c₂ • κ) ctx = ☐⨾ c₂ • appendκ κ ctx
appendκ (c₁ ⨾☐• κ) ctx = c₁ ⨾☐• appendκ κ ctx
appendκ (☐⊕ c₂ • κ) ctx = ☐⊕ c₂ • appendκ κ ctx
appendκ (c₁ ⊕☐• κ) ctx = c₁ ⊕☐• appendκ κ ctx
appendκ (☐⊗[ c₂ , x ]• κ) ctx = ☐⊗[ c₂ , x ]• appendκ κ ctx
appendκ ([ c₁ , x ]⊗☐• κ) ctx = [ c₁ , x ]⊗☐• appendκ κ ctx

appendκState : ∀ st → let (A , B) = get𝕌State st
                      in  Context {A} {B} → State
appendκState ⟨ c ∣ v ∣ κ ⟩▷ ctx = ⟨ c ∣ v ∣ appendκ κ ctx ⟩▷
appendκState ［ c ∣ v ∣ κ ］▷ ctx = ［ c ∣ v ∣ appendκ κ ctx ］▷
appendκState ⟨ c ∣ v ∣ κ ⟩◁ ctx = ⟨ c ∣ v ∣ appendκ κ ctx ⟩◁
appendκState ［ c ∣ v ∣ κ ］◁ ctx = ［ c ∣ v ∣ appendκ κ ctx ］◁

-- The type of context does not change during execution
𝕌Invariant : ∀ {st st'} → st ↦ st' → get𝕌State st ≡ get𝕌State st'
𝕌Invariant ↦⃗₁ = refl
𝕌Invariant ↦⃗₂ = refl
𝕌Invariant ↦⃗₃ = refl
𝕌Invariant ↦⃗₄ = refl
𝕌Invariant ↦⃗₅ = refl
𝕌Invariant ↦⃗₆ = refl
𝕌Invariant ↦⃗₇ = refl
𝕌Invariant ↦⃗₈ = refl
𝕌Invariant ↦⃗₉ = refl
𝕌Invariant ↦⃗₁₀ = refl
𝕌Invariant ↦⃗₁₁ = refl
𝕌Invariant ↦⃗₁₂ = refl
𝕌Invariant ↦⃖₁ = refl
𝕌Invariant ↦⃖₂ = refl
𝕌Invariant ↦⃖₃ = refl
𝕌Invariant ↦⃖₄ = refl
𝕌Invariant ↦⃖₅ = refl
𝕌Invariant ↦⃖₆ = refl
𝕌Invariant ↦⃖₇ = refl
𝕌Invariant ↦⃖₈ = refl
𝕌Invariant ↦⃖₉ = refl
𝕌Invariant ↦⃖₁₀ = refl
𝕌Invariant ↦⃖₁₁ = refl
𝕌Invariant ↦⃖₁₂ = refl
𝕌Invariant ↦η₁ = refl
𝕌Invariant ↦η₂ = refl
𝕌Invariant ↦ε₁ = refl
𝕌Invariant ↦ε₂ = refl

𝕌Invariant* : ∀ {st st'} → st ↦* st' → get𝕌State st ≡  get𝕌State st'
𝕌Invariant* ◾ = refl
𝕌Invariant* (r ∷ rs) = trans (𝕌Invariant r) (𝕌Invariant* rs)

-- Appending context does not affect reductions
appendκ↦ : ∀ {st st'} → (r : st ↦ st') (eq : get𝕌State st ≡  get𝕌State st')
         → (κ : Context {proj₁ (get𝕌State st)} {proj₂ (get𝕌State st)})
         → appendκState st κ ↦ appendκState st' (subst (λ {(A , B) → Context {A} {B}}) eq κ)
appendκ↦ ↦⃗₁ refl ctx = ↦⃗₁
appendκ↦ ↦⃗₂ refl ctx = ↦⃗₂
appendκ↦ ↦⃗₃ refl ctx = ↦⃗₃
appendκ↦ ↦⃗₄ refl ctx = ↦⃗₄
appendκ↦ ↦⃗₅ refl ctx = ↦⃗₅
appendκ↦ ↦⃗₆ refl ctx = ↦⃗₆
appendκ↦ ↦⃗₇ refl ctx = ↦⃗₇
appendκ↦ ↦⃗₈ refl ctx = ↦⃗₈
appendκ↦ ↦⃗₉ refl ctx = ↦⃗₉
appendκ↦ ↦⃗₁₀ refl ctx = ↦⃗₁₀
appendκ↦ ↦⃗₁₁ refl ctx = ↦⃗₁₁
appendκ↦ ↦⃗₁₂ refl ctx = ↦⃗₁₂
appendκ↦ ↦⃖₁ refl ctx = ↦⃖₁
appendκ↦ ↦⃖₂ refl ctx = ↦⃖₂
appendκ↦ ↦⃖₃ refl ctx = ↦⃖₃
appendκ↦ ↦⃖₄ refl ctx = ↦⃖₄
appendκ↦ ↦⃖₅ refl ctx = ↦⃖₅
appendκ↦ ↦⃖₆ refl ctx = ↦⃖₆
appendκ↦ ↦⃖₇ refl ctx = ↦⃖₇
appendκ↦ ↦⃖₈ refl ctx = ↦⃖₈
appendκ↦ ↦⃖₉ refl ctx = ↦⃖₉
appendκ↦ ↦⃖₁₀ refl ctx = ↦⃖₁₀
appendκ↦ ↦⃖₁₁ refl ctx = ↦⃖₁₁
appendκ↦ ↦⃖₁₂ refl ctx = ↦⃖₁₂
appendκ↦ ↦η₁ refl ctx = ↦η₁
appendκ↦ ↦η₂ refl ctx = ↦η₂
appendκ↦ ↦ε₁ refl ctx = ↦ε₁
appendκ↦ ↦ε₂ refl ctx = ↦ε₂

appendκ↦* : ∀ {st st'} → (r : st ↦* st') (eq : get𝕌State st ≡  get𝕌State st')
          → (κ : Context {proj₁ (get𝕌State st)} {proj₂ (get𝕌State st)})
          → appendκState st κ ↦* appendκState st' (subst (λ {(A , B) → Context {A} {B}}) eq κ)
appendκ↦* ◾ refl ctx = ◾
appendκ↦* (↦⃗₁ {b = b} {v} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₁ {b = b} {v} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₂ {v = v} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₂ {v = v} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₃ {v = v} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₃ {v = v} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₄ {x = x} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₄ {x = x} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₅ {y = y} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₅ {y = y} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₆ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₆ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₇ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₇ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₈ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₈ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₉ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₉ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₁₀ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₁₀ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₁₁ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₁₁ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃗₁₂ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃗₁₂ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₁ {b = b} {v} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₁ {b = b} {v} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₂ {v = v} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₂ {v = v} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₃ {v = v} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₃ {v = v} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₄ {x = x} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₄ {x = x} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₅ {y = y} {κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₅ {y = y} {κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₆ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₆ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₇ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₇ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₈ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₈ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₉ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₉ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₁₀ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₁₀ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₁₁ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₁₁ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦⃖₁₂ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦⃖₁₂ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦η₁ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦η₁ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦η₂ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦η₂ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦ε₁ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦ε₁ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx
appendκ↦* (↦ε₂ {κ = κ} ∷ rs) eq ctx = appendκ↦ (↦ε₂ {κ = κ}) refl ctx ∷ appendκ↦* rs eq ctx


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

module PiLevel1 where

open import Data.Unit using (⊤; tt)
open import Relation.Binary.Core using (IsEquivalence)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst; sym; [_])

open import PiU using (U; ZERO; ONE; PLUS; TIMES)
open import PiLevel0
  -- hiding triv≡ certainly; we are replacing it with _⇔_
  using (_⟷_; !;
         unite₊l; uniti₊l; unite₊r; uniti₊r; swap₊; assocl₊; assocr₊;
         unite⋆l; uniti⋆l; unite⋆r; uniti⋆r; swap⋆; assocl⋆; assocr⋆;
         absorbr; absorbl; factorzr; factorzl;
         dist; factor; distl; factorl;
         id⟷; _◎_; _⊕_; _⊗_)

------------------------------------------------------------------------------
-- Level 1: instead of using triv≡ to reason about equivalence of
-- combinators, we use the following 2-combinators

infix  30 _⇔_

data _⇔_ : {t₁ t₂ : U} → (t₁ ⟷ t₂) → (t₁ ⟷ t₂) → Set where
  assoc◎l : {t₁ t₂ t₃ t₄ : U} {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} {c₃ : t₃ ⟷ t₄} →
          (c₁ ◎ (c₂ ◎ c₃)) ⇔ ((c₁ ◎ c₂) ◎ c₃)
  assoc◎r : {t₁ t₂ t₃ t₄ : U} {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} {c₃ : t₃ ⟷ t₄} →
          ((c₁ ◎ c₂) ◎ c₃) ⇔ (c₁ ◎ (c₂ ◎ c₃))
  assocl⊕l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
          ((c₁ ⊕ (c₂ ⊕ c₃)) ◎ assocl₊) ⇔ (assocl₊ ◎ ((c₁ ⊕ c₂) ⊕ c₃))
  assocl⊕r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
          (assocl₊ ◎ ((c₁ ⊕ c₂) ⊕ c₃)) ⇔ ((c₁ ⊕ (c₂ ⊕ c₃)) ◎ assocl₊)
  assocl⊗l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
          ((c₁ ⊗ (c₂ ⊗ c₃)) ◎ assocl⋆) ⇔ (assocl⋆ ◎ ((c₁ ⊗ c₂) ⊗ c₃))
  assocl⊗r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
          (assocl⋆ ◎ ((c₁ ⊗ c₂) ⊗ c₃)) ⇔ ((c₁ ⊗ (c₂ ⊗ c₃)) ◎ assocl⋆)
  assocr⊕r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
          (((c₁ ⊕ c₂) ⊕ c₃) ◎ assocr₊) ⇔ (assocr₊ ◎ (c₁ ⊕ (c₂ ⊕ c₃)))
  assocr⊗l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
           (assocr⋆ ◎ (c₁ ⊗ (c₂ ⊗ c₃))) ⇔ (((c₁ ⊗ c₂) ⊗ c₃) ◎ assocr⋆)
  assocr⊗r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
          (((c₁ ⊗ c₂) ⊗ c₃) ◎ assocr⋆) ⇔ (assocr⋆ ◎ (c₁ ⊗ (c₂ ⊗ c₃)))
  assocr⊕l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₅ ⟷ t₆} →
           (assocr₊ ◎ (c₁ ⊕ (c₂ ⊕ c₃))) ⇔ (((c₁ ⊕ c₂) ⊕ c₃) ◎ assocr₊)
  dist⇔l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
      ((a ⊕ b) ⊗ c) ◎ dist ⇔ dist ◎ ((a ⊗ c) ⊕ (b ⊗ c))
  dist⇔r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
      dist ◎ ((a ⊗ c) ⊕ (b ⊗ c)) ⇔ ((a ⊕ b) ⊗ c) ◎ dist
  distl⇔l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
      (a ⊗ (b ⊕ c)) ◎ distl ⇔ distl ◎ ((a ⊗ b) ⊕ (a ⊗ c))
  distl⇔r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
      distl ◎ ((a ⊗ b) ⊕ (a ⊗ c)) ⇔ (a ⊗ (b ⊕ c)) ◎ distl
  factor⇔l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
       ((a ⊗ c) ⊕ (b ⊗ c)) ◎ factor ⇔ factor ◎ ((a ⊕ b) ⊗ c)
  factor⇔r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
       factor ◎ ((a ⊕ b) ⊗ c) ⇔ ((a ⊗ c) ⊕ (b ⊗ c)) ◎ factor
  factorl⇔l : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
       ((a ⊗ b) ⊕ (a ⊗ c)) ◎ factorl ⇔ factorl ◎ (a ⊗ (b ⊕ c))
  factorl⇔r : {t₁ t₂ t₃ t₄ t₅ t₆ : U}
          {a : t₁ ⟷ t₂} {b : t₃ ⟷ t₄} {c : t₅ ⟷ t₆} →
       factorl ◎ (a ⊗ (b ⊕ c)) ⇔ ((a ⊗ b) ⊕ (a ⊗ c)) ◎ factorl
  idl◎l   : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → (id⟷ ◎ c) ⇔ c
  idl◎r   : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → c ⇔ id⟷ ◎ c
  idr◎l   : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → (c ◎ id⟷) ⇔ c
  idr◎r   : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → c ⇔ (c ◎ id⟷)
  linv◎l  : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → (c ◎ ! c) ⇔ id⟷
  linv◎r  : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → id⟷ ⇔ (c ◎ ! c)
  rinv◎l  : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → (! c ◎ c) ⇔ id⟷
  rinv◎r  : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → id⟷ ⇔ (! c ◎ c)
  unite₊l⇔l : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          (unite₊l ◎ c₂) ⇔ ((c₁ ⊕ c₂) ◎ unite₊l)
  unite₊l⇔r : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          ((c₁ ⊕ c₂) ◎ unite₊l) ⇔ (unite₊l ◎ c₂)
  uniti₊l⇔l : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          (uniti₊l ◎ (c₁ ⊕ c₂)) ⇔ (c₂ ◎ uniti₊l)
  uniti₊l⇔r : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          (c₂ ◎ uniti₊l) ⇔ (uniti₊l ◎ (c₁ ⊕ c₂))
  unite₊r⇔l : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          (unite₊r ◎ c₂) ⇔ ((c₂ ⊕ c₁) ◎ unite₊r)
  unite₊r⇔r : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          ((c₂ ⊕ c₁) ◎ unite₊r) ⇔ (unite₊r ◎ c₂)
  uniti₊r⇔l : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          (uniti₊r ◎ (c₂ ⊕ c₁)) ⇔ (c₂ ◎ uniti₊r)
  uniti₊r⇔r : {t₁ t₂ : U} {c₁ : ZERO ⟷ ZERO} {c₂ : t₁ ⟷ t₂} →
          (c₂ ◎ uniti₊r) ⇔ (uniti₊r ◎ (c₂ ⊕ c₁))
  swapl₊⇔ : {t₁ t₂ t₃ t₄ : U} {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} →
          (swap₊ ◎ (c₁ ⊕ c₂)) ⇔ ((c₂ ⊕ c₁) ◎ swap₊)
  swapr₊⇔ : {t₁ t₂ t₃ t₄ : U} {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} →
          ((c₂ ⊕ c₁) ◎ swap₊) ⇔ (swap₊ ◎ (c₁ ⊕ c₂))
  unitel⋆⇔l : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          (unite⋆l ◎ c₂) ⇔ ((c₁ ⊗ c₂) ◎ unite⋆l)
  uniter⋆⇔l : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          ((c₁ ⊗ c₂) ◎ unite⋆l) ⇔ (unite⋆l ◎ c₂)
  unitil⋆⇔l : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          (uniti⋆l ◎ (c₁ ⊗ c₂)) ⇔ (c₂ ◎ uniti⋆l)
  unitir⋆⇔l : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          (c₂ ◎ uniti⋆l) ⇔ (uniti⋆l ◎ (c₁ ⊗ c₂))
  unitel⋆⇔r : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          (unite⋆r ◎ c₂) ⇔ ((c₂ ⊗ c₁) ◎ unite⋆r)
  uniter⋆⇔r : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          ((c₂ ⊗ c₁) ◎ unite⋆r) ⇔ (unite⋆r ◎ c₂)
  unitil⋆⇔r : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          (uniti⋆r ◎ (c₂ ⊗ c₁)) ⇔ (c₂ ◎ uniti⋆r)
  unitir⋆⇔r : {t₁ t₂ : U} {c₁ : ONE ⟷ ONE} {c₂ : t₁ ⟷ t₂} →
          (c₂ ◎ uniti⋆r) ⇔ (uniti⋆r ◎ (c₂ ⊗ c₁))
  swapl⋆⇔ : {t₁ t₂ t₃ t₄ : U} {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} →
          (swap⋆ ◎ (c₁ ⊗ c₂)) ⇔ ((c₂ ⊗ c₁) ◎ swap⋆)
  swapr⋆⇔ : {t₁ t₂ t₃ t₄ : U} {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} →
          ((c₂ ⊗ c₁) ◎ swap⋆) ⇔ (swap⋆ ◎ (c₁ ⊗ c₂))
  id⇔     : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → c ⇔ c
  trans⇔  : {t₁ t₂ : U} {c₁ c₂ c₃ : t₁ ⟷ t₂} →
         (c₁ ⇔ c₂) → (c₂ ⇔ c₃) → (c₁ ⇔ c₃)
  _⊡_  : {t₁ t₂ t₃ : U}
         {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} {c₃ : t₁ ⟷ t₂} {c₄ : t₂ ⟷ t₃} →
         (c₁ ⇔ c₃) → (c₂ ⇔ c₄) → (c₁ ◎ c₂) ⇔ (c₃ ◎ c₄)
  resp⊕⇔  : {t₁ t₂ t₃ t₄ : U}
         {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₁ ⟷ t₂} {c₄ : t₃ ⟷ t₄} →
         (c₁ ⇔ c₃) → (c₂ ⇔ c₄) → (c₁ ⊕ c₂) ⇔ (c₃ ⊕ c₄)
  resp⊗⇔  : {t₁ t₂ t₃ t₄ : U}
         {c₁ : t₁ ⟷ t₂} {c₂ : t₃ ⟷ t₄} {c₃ : t₁ ⟷ t₂} {c₄ : t₃ ⟷ t₄} →
         (c₁ ⇔ c₃) → (c₂ ⇔ c₄) → (c₁ ⊗ c₂) ⇔ (c₃ ⊗ c₄)
  -- below are the combinators added for the RigCategory structure
  id⟷⊕id⟷⇔ : {t₁ t₂ : U} → (id⟷ {t₁} ⊕ id⟷ {t₂}) ⇔ id⟷
  split⊕-id⟷ : {t₁ t₂ : U} → (id⟷ {PLUS t₁ t₂}) ⇔ (id⟷ ⊕ id⟷)
  hom⊕◎⇔ : {t₁ t₂ t₃ t₄ t₅ t₆ : U} {c₁ : t₅ ⟷ t₁} {c₂ : t₆ ⟷ t₂}
        {c₃ : t₁ ⟷ t₃} {c₄ : t₂ ⟷ t₄} →
        ((c₁ ◎ c₃) ⊕ (c₂ ◎ c₄)) ⇔ ((c₁ ⊕ c₂) ◎ (c₃ ⊕ c₄))
  hom◎⊕⇔ : {t₁ t₂ t₃ t₄ t₅ t₆ : U} {c₁ : t₅ ⟷ t₁} {c₂ : t₆ ⟷ t₂}
        {c₃ : t₁ ⟷ t₃} {c₄ : t₂ ⟷ t₄} →
         ((c₁ ⊕ c₂) ◎ (c₃ ⊕ c₄)) ⇔ ((c₁ ◎ c₃) ⊕ (c₂ ◎ c₄))
  id⟷⊗id⟷⇔ : {t₁ t₂ : U} → (id⟷ {t₁} ⊗ id⟷ {t₂}) ⇔ id⟷
  split⊗-id⟷ : {t₁ t₂ : U} → (id⟷ {TIMES t₁ t₂}) ⇔ (id⟷ ⊗ id⟷)
  hom⊗◎⇔ : {t₁ t₂ t₃ t₄ t₅ t₆ : U} {c₁ : t₅ ⟷ t₁} {c₂ : t₆ ⟷ t₂}
        {c₃ : t₁ ⟷ t₃} {c₄ : t₂ ⟷ t₄} →
        ((c₁ ◎ c₃) ⊗ (c₂ ◎ c₄)) ⇔ ((c₁ ⊗ c₂) ◎ (c₃ ⊗ c₄))
  hom◎⊗⇔ : {t₁ t₂ t₃ t₄ t₅ t₆ : U} {c₁ : t₅ ⟷ t₁} {c₂ : t₆ ⟷ t₂}
        {c₃ : t₁ ⟷ t₃} {c₄ : t₂ ⟷ t₄} →
         ((c₁ ⊗ c₂) ◎ (c₃ ⊗ c₄)) ⇔ ((c₁ ◎ c₃) ⊗ (c₂ ◎ c₄))
  -- associativity triangle
  triangle⊕l : {t₁ t₂ : U} →
    (unite₊r {t₁} ⊕ id⟷ {t₂}) ⇔ assocr₊ ◎ (id⟷ ⊕ unite₊l)
  triangle⊕r : {t₁ t₂ : U} →
    assocr₊ ◎ (id⟷ {t₁} ⊕ unite₊l {t₂}) ⇔ (unite₊r ⊕ id⟷)
  triangle⊗l : {t₁ t₂ : U} →
    ((unite⋆r {t₁}) ⊗ id⟷ {t₂}) ⇔ assocr⋆ ◎ (id⟷ ⊗ unite⋆l)
  triangle⊗r : {t₁ t₂ : U} →
    (assocr⋆ ◎ (id⟷ {t₁} ⊗ unite⋆l {t₂})) ⇔ (unite⋆r ⊗ id⟷)
  pentagon⊕l : {t₁ t₂ t₃ t₄ : U} →
    assocr₊ ◎ (assocr₊ {t₁} {t₂} {PLUS t₃ t₄}) ⇔
    ((assocr₊ ⊕ id⟷) ◎ assocr₊) ◎ (id⟷ ⊕ assocr₊)
  pentagon⊕r : {t₁ t₂ t₃ t₄ : U} →
    ((assocr₊ {t₁} {t₂} {t₃} ⊕ id⟷ {t₄}) ◎ assocr₊) ◎ (id⟷ ⊕ assocr₊) ⇔
    assocr₊ ◎ assocr₊
  pentagon⊗l : {t₁ t₂ t₃ t₄ : U} →
    assocr⋆ ◎ (assocr⋆ {t₁} {t₂} {TIMES t₃ t₄}) ⇔
    ((assocr⋆ ⊗ id⟷) ◎ assocr⋆) ◎ (id⟷ ⊗ assocr⋆)
  pentagon⊗r : {t₁ t₂ t₃ t₄ : U} →
    ((assocr⋆ {t₁} {t₂} {t₃} ⊗ id⟷ {t₄}) ◎ assocr⋆) ◎ (id⟷ ⊗ assocr⋆) ⇔
    assocr⋆ ◎ assocr⋆
  -- from the braiding
  -- unit coherence
  unite₊l-coh-l : {t₁ : U} → unite₊l {t₁} ⇔ swap₊ ◎ unite₊r
  unite₊l-coh-r : {t₁ : U} → swap₊ ◎ unite₊r ⇔ unite₊l {t₁}
  unite⋆l-coh-l : {t₁ : U} → unite⋆l {t₁} ⇔ swap⋆ ◎ unite⋆r
  unite⋆l-coh-r : {t₁ : U} → swap⋆ ◎ unite⋆r ⇔ unite⋆l {t₁}
  hexagonr⊕l : {t₁ t₂ t₃ : U} →
    (assocr₊ ◎ swap₊) ◎ assocr₊ {t₁} {t₂} {t₃} ⇔
    ((swap₊ ⊕ id⟷) ◎ assocr₊) ◎ (id⟷ ⊕ swap₊)
  hexagonr⊕r : {t₁ t₂ t₃ : U} →
    ((swap₊ ⊕ id⟷) ◎ assocr₊) ◎ (id⟷ ⊕ swap₊) ⇔
    (assocr₊ ◎ swap₊) ◎ assocr₊ {t₁} {t₂} {t₃}
  hexagonl⊕l : {t₁ t₂ t₃ : U} →
    (assocl₊ ◎ swap₊) ◎ assocl₊ {t₁} {t₂} {t₃} ⇔
    ((id⟷ ⊕ swap₊) ◎ assocl₊) ◎ (swap₊ ⊕ id⟷)
  hexagonl⊕r : {t₁ t₂ t₃ : U} →
    ((id⟷ ⊕ swap₊) ◎ assocl₊) ◎ (swap₊ ⊕ id⟷) ⇔
    (assocl₊ ◎ swap₊) ◎ assocl₊ {t₁} {t₂} {t₃}
  hexagonr⊗l : {t₁ t₂ t₃ : U} →
    (assocr⋆ ◎ swap⋆) ◎ assocr⋆ {t₁} {t₂} {t₃} ⇔
    ((swap⋆ ⊗ id⟷) ◎ assocr⋆) ◎ (id⟷ ⊗ swap⋆)
  hexagonr⊗r : {t₁ t₂ t₃ : U} →
    ((swap⋆ ⊗ id⟷) ◎ assocr⋆) ◎ (id⟷ ⊗ swap⋆) ⇔
    (assocr⋆ ◎ swap⋆) ◎ assocr⋆ {t₁} {t₂} {t₃}
  hexagonl⊗l : {t₁ t₂ t₃ : U} →
    (assocl⋆ ◎ swap⋆) ◎ assocl⋆ {t₁} {t₂} {t₃} ⇔
    ((id⟷ ⊗ swap⋆) ◎ assocl⋆) ◎ (swap⋆ ⊗ id⟷)
  hexagonl⊗r : {t₁ t₂ t₃ : U} →
    ((id⟷ ⊗ swap⋆) ◎ assocl⋆) ◎ (swap⋆ ⊗ id⟷) ⇔
    (assocl⋆ ◎ swap⋆) ◎ assocl⋆ {t₁} {t₂} {t₃}
  absorbl⇔l : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    (c₁ ⊗ id⟷ {ZERO}) ◎ absorbl ⇔ absorbl ◎ id⟷ {ZERO}
  absorbl⇔r : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    absorbl ◎ id⟷ {ZERO} ⇔ (c₁ ⊗ id⟷ {ZERO}) ◎ absorbl
  absorbr⇔l : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    (id⟷ {ZERO} ⊗ c₁) ◎ absorbr ⇔ absorbr ◎ id⟷ {ZERO}
  absorbr⇔r : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    absorbr ◎ id⟷ {ZERO} ⇔ (id⟷ {ZERO} ⊗ c₁) ◎ absorbr
  factorzl⇔l : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    id⟷ ◎ factorzl ⇔ factorzl ◎ (id⟷ ⊗ c₁)
  factorzl⇔r : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    factorzl ◎ (id⟷ {ZERO} ⊗ c₁) ⇔ id⟷ {ZERO} ◎ factorzl
  factorzr⇔l : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    id⟷ ◎ factorzr ⇔ factorzr ◎ (c₁ ⊗ id⟷)
  factorzr⇔r : {t₁ t₂ : U} {c₁ : t₁ ⟷ t₂} →
    factorzr ◎ (c₁ ⊗ id⟷) ⇔ id⟷ ◎ factorzr
  -- from the coherence conditions of RigCategory
  swap₊distl⇔l : {t₁ t₂ t₃ : U} →
    (id⟷ {t₁} ⊗ swap₊ {t₂} {t₃}) ◎ distl ⇔ distl ◎ swap₊
  swap₊distl⇔r : {t₁ t₂ t₃ : U} →
    distl ◎ swap₊ ⇔ (id⟷ {t₁} ⊗ swap₊ {t₂} {t₃}) ◎ distl
  dist-swap⋆⇔l : {t₁ t₂ t₃ : U} →
    dist {t₁} {t₂} {t₃} ◎ (swap⋆ ⊕ swap⋆) ⇔ swap⋆ ◎ distl
  dist-swap⋆⇔r : {t₁ t₂ t₃ : U} →
    swap⋆ ◎ distl {t₁} {t₂} {t₃} ⇔ dist ◎ (swap⋆ ⊕ swap⋆)
  assocl₊-dist-dist⇔l : {t₁ t₂ t₃ t₄ : U} →
    ((assocl₊ {t₁} {t₂} {t₃} ⊗ id⟷ {t₄}) ◎ dist) ◎ (dist ⊕ id⟷) ⇔
    (dist ◎ (id⟷ ⊕ dist)) ◎ assocl₊
  assocl₊-dist-dist⇔r : {t₁ t₂ t₃ t₄ : U} →
    (dist {t₁} ◎ (id⟷ ⊕ dist {t₂} {t₃} {t₄})) ◎ assocl₊ ⇔
    ((assocl₊ ⊗ id⟷) ◎ dist) ◎ (dist ⊕ id⟷)
  assocl⋆-distl⇔l : {t₁ t₂ t₃ t₄ : U} →
    assocl⋆ {t₁} {t₂} ◎ distl {TIMES t₁ t₂} {t₃} {t₄} ⇔
    ((id⟷ ⊗ distl) ◎ distl) ◎ (assocl⋆ ⊕ assocl⋆)
  assocl⋆-distl⇔r : {t₁ t₂ t₃ t₄ : U} →
    ((id⟷ ⊗ distl) ◎ distl) ◎ (assocl⋆ ⊕ assocl⋆) ⇔
    assocl⋆ {t₁} {t₂} ◎ distl {TIMES t₁ t₂} {t₃} {t₄}
  absorbr0-absorbl0⇔ : absorbr {ZERO} ⇔ absorbl {ZERO}
  absorbl0-absorbr0⇔ : absorbl {ZERO} ⇔ absorbr {ZERO}
  absorbr⇔distl-absorb-unite : {t₁ t₂ : U} →
    absorbr ⇔ (distl {t₂ = t₁} {t₂} ◎ (absorbr ⊕ absorbr)) ◎ unite₊l
  distl-absorb-unite⇔absorbr : {t₁ t₂ : U} →
    (distl {t₂ = t₁} {t₂} ◎ (absorbr ⊕ absorbr)) ◎ unite₊l ⇔ absorbr
  unite⋆r0-absorbr1⇔ : unite⋆r ⇔ absorbr
  absorbr1-unite⋆r-⇔ : absorbr ⇔ unite⋆r
  absorbl≡swap⋆◎absorbr : {t₁ : U} → absorbl {t₁} ⇔ swap⋆ ◎ absorbr
  swap⋆◎absorbr≡absorbl : {t₁ : U} → swap⋆ ◎ absorbr ⇔ absorbl {t₁}
  absorbr⇔[assocl⋆◎[absorbr⊗id⟷]]◎absorbr : {t₁ t₂ : U} →
    absorbr ⇔ (assocl⋆ {ZERO} {t₁} {t₂} ◎ (absorbr ⊗ id⟷)) ◎ absorbr
  [assocl⋆◎[absorbr⊗id⟷]]◎absorbr⇔absorbr : {t₁ t₂ : U} →
    (assocl⋆ {ZERO} {t₁} {t₂} ◎ (absorbr ⊗ id⟷)) ◎ absorbr ⇔ absorbr
  [id⟷⊗absorbr]◎absorbl⇔assocl⋆◎[absorbl⊗id⟷]◎absorbr : {t₁ t₂ : U} →
    (id⟷ ⊗ absorbr {t₂}) ◎ absorbl {t₁} ⇔
    (assocl⋆ ◎ (absorbl ⊗ id⟷)) ◎ absorbr
  assocl⋆◎[absorbl⊗id⟷]◎absorbr⇔[id⟷⊗absorbr]◎absorbl : {t₁ t₂ : U} →
    (assocl⋆ ◎ (absorbl ⊗ id⟷)) ◎ absorbr ⇔
    (id⟷ ⊗ absorbr {t₂}) ◎ absorbl {t₁}
  elim⊥-A[0⊕B]⇔l : {t₁ t₂ : U} →
     (id⟷ {t₁} ⊗ unite₊l {t₂}) ⇔
     (distl ◎ (absorbl ⊕ id⟷)) ◎ unite₊l
  elim⊥-A[0⊕B]⇔r : {t₁ t₂ : U} →
     (distl ◎ (absorbl ⊕ id⟷)) ◎ unite₊l ⇔ (id⟷ {t₁} ⊗ unite₊l {t₂})
  elim⊥-1[A⊕B]⇔l : {t₁ t₂ : U} →
    unite⋆l ⇔
    distl ◎ (unite⋆l {t₁} ⊕ unite⋆l {t₂})
  elim⊥-1[A⊕B]⇔r : {t₁ t₂ : U} →
    distl ◎ (unite⋆l {t₁} ⊕ unite⋆l {t₂}) ⇔ unite⋆l
  fully-distribute⇔l : {t₁ t₂ t₃ t₄ : U} →
    (distl ◎ (dist {t₁} {t₂} {t₃} ⊕ dist {t₁} {t₂} {t₄})) ◎ assocl₊ ⇔
      ((((dist ◎ (distl ⊕ distl)) ◎ assocl₊) ◎ (assocr₊ ⊕ id⟷)) ◎
         ((id⟷ ⊕ swap₊) ⊕ id⟷)) ◎ (assocl₊ ⊕ id⟷)
  fully-distribute⇔r : {t₁ t₂ t₃ t₄ : U} →
    ((((dist ◎ (distl ⊕ distl)) ◎ assocl₊) ◎ (assocr₊ ⊕ id⟷)) ◎
       ((id⟷ ⊕ swap₊) ⊕ id⟷)) ◎ (assocl₊ ⊕ id⟷) ⇔
    (distl ◎ (dist {t₁} {t₂} {t₃} ⊕ dist {t₁} {t₂} {t₄})) ◎ assocl₊

-- At the next level we have a trivial equivalence that equates all
-- 2-morphisms of the same type.

triv≡ : {t₁ t₂ : U} {f g : t₁ ⟷ t₂} → (α β : f ⇔ g) → Set
triv≡ _ _ = ⊤

triv≡Equiv : {t₁ t₂ : U} {f₁ f₂ : t₁ ⟷ t₂} →
             IsEquivalence (triv≡ {t₁} {t₂} {f₁} {f₂})
triv≡Equiv = record
  { refl = tt
  ; sym = λ _ → tt
  ; trans = λ _ _ → tt
  }

------------------------------------------------------------------------------
-- Inverses for 2paths

2! : {t₁ t₂ : U} {c₁ c₂ : t₁ ⟷ t₂} → (c₁ ⇔ c₂) → (c₂ ⇔ c₁)
2! assoc◎l = assoc◎r
2! assoc◎r = assoc◎l
2! assocl⊕l = assocl⊕r
2! assocl⊕r = assocl⊕l
2! assocl⊗l = assocl⊗r
2! assocl⊗r = assocl⊗l
2! assocr⊕r = assocr⊕l
2! assocr⊕l = assocr⊕r
2! assocr⊗r = assocr⊗l
2! assocr⊗l = assocr⊗r
2! dist⇔l = dist⇔r
2! dist⇔r = dist⇔l
2! distl⇔l = distl⇔r
2! distl⇔r = distl⇔l
2! factor⇔l = factor⇔r
2! factor⇔r = factor⇔l
2! factorl⇔l = factorl⇔r
2! factorl⇔r = factorl⇔l
2! idl◎l = idl◎r
2! idl◎r = idl◎l
2! idr◎l = idr◎r
2! idr◎r = idr◎l
2! linv◎l = linv◎r
2! linv◎r = linv◎l
2! rinv◎l = rinv◎r
2! rinv◎r = rinv◎l
2! unite₊l⇔l = unite₊l⇔r
2! unite₊l⇔r = unite₊l⇔l
2! uniti₊l⇔l = uniti₊l⇔r
2! uniti₊l⇔r = uniti₊l⇔l
2! unite₊r⇔l = unite₊r⇔r
2! unite₊r⇔r = unite₊r⇔l
2! uniti₊r⇔l = uniti₊r⇔r
2! uniti₊r⇔r = uniti₊r⇔l
2! swapl₊⇔ = swapr₊⇔
2! swapr₊⇔ = swapl₊⇔
2! unitel⋆⇔l = uniter⋆⇔l
2! uniter⋆⇔l = unitel⋆⇔l
2! unitil⋆⇔l = unitir⋆⇔l
2! unitir⋆⇔l = unitil⋆⇔l
2! unitel⋆⇔r = uniter⋆⇔r
2! uniter⋆⇔r = unitel⋆⇔r
2! unitil⋆⇔r = unitir⋆⇔r
2! unitir⋆⇔r = unitil⋆⇔r
2! swapl⋆⇔ = swapr⋆⇔
2! swapr⋆⇔ = swapl⋆⇔
2! id⇔ = id⇔
2! (α ⊡ β) = (2! α) ⊡ (2! β)
2! (trans⇔ α β) = trans⇔ (2! β) (2! α)
2! (resp⊕⇔ α β) = resp⊕⇔ (2! α) (2! β)
2! (resp⊗⇔ α β) = resp⊗⇔ (2! α) (2! β)
2! id⟷⊕id⟷⇔ = split⊕-id⟷
2! split⊕-id⟷ = id⟷⊕id⟷⇔
2! hom⊕◎⇔ = hom◎⊕⇔
2! hom◎⊕⇔ = hom⊕◎⇔
2! id⟷⊗id⟷⇔ = split⊗-id⟷
2! split⊗-id⟷ = id⟷⊗id⟷⇔
2! hom⊗◎⇔ = hom◎⊗⇔
2! hom◎⊗⇔ = hom⊗◎⇔
2! triangle⊕l = triangle⊕r
2! triangle⊕r = triangle⊕l
2! triangle⊗l = triangle⊗r
2! triangle⊗r = triangle⊗l
2! pentagon⊕l = pentagon⊕r
2! pentagon⊕r = pentagon⊕l
2! pentagon⊗l = pentagon⊗r
2! pentagon⊗r = pentagon⊗l
2! unite₊l-coh-l = unite₊l-coh-r
2! unite₊l-coh-r = unite₊l-coh-l
2! unite⋆l-coh-l = unite⋆l-coh-r
2! unite⋆l-coh-r = unite⋆l-coh-l
2! hexagonr⊕l = hexagonr⊕r
2! hexagonr⊕r = hexagonr⊕l
2! hexagonl⊕l = hexagonl⊕r
2! hexagonl⊕r = hexagonl⊕l
2! hexagonr⊗l = hexagonr⊗r
2! hexagonr⊗r = hexagonr⊗l
2! hexagonl⊗l = hexagonl⊗r
2! hexagonl⊗r = hexagonl⊗l
2! absorbl⇔l = absorbl⇔r
2! absorbl⇔r = absorbl⇔l
2! absorbr⇔l = absorbr⇔r
2! absorbr⇔r = absorbr⇔l
2! factorzl⇔l = factorzl⇔r
2! factorzl⇔r = factorzl⇔l
2! factorzr⇔l = factorzr⇔r
2! factorzr⇔r = factorzr⇔l
2! swap₊distl⇔l = swap₊distl⇔r
2! swap₊distl⇔r = swap₊distl⇔l
2! dist-swap⋆⇔l = dist-swap⋆⇔r
2! dist-swap⋆⇔r = dist-swap⋆⇔l
2! assocl₊-dist-dist⇔l = assocl₊-dist-dist⇔r
2! assocl₊-dist-dist⇔r = assocl₊-dist-dist⇔l
2! assocl⋆-distl⇔l = assocl⋆-distl⇔r
2! assocl⋆-distl⇔r = assocl⋆-distl⇔l
2! absorbr0-absorbl0⇔ = absorbl0-absorbr0⇔
2! absorbl0-absorbr0⇔ = absorbr0-absorbl0⇔
2! absorbr⇔distl-absorb-unite = distl-absorb-unite⇔absorbr
2! distl-absorb-unite⇔absorbr = absorbr⇔distl-absorb-unite
2! unite⋆r0-absorbr1⇔ = absorbr1-unite⋆r-⇔
2! absorbr1-unite⋆r-⇔ = unite⋆r0-absorbr1⇔
2! absorbl≡swap⋆◎absorbr = swap⋆◎absorbr≡absorbl
2! swap⋆◎absorbr≡absorbl = absorbl≡swap⋆◎absorbr
2! absorbr⇔[assocl⋆◎[absorbr⊗id⟷]]◎absorbr =
    [assocl⋆◎[absorbr⊗id⟷]]◎absorbr⇔absorbr
2!  [assocl⋆◎[absorbr⊗id⟷]]◎absorbr⇔absorbr =
    absorbr⇔[assocl⋆◎[absorbr⊗id⟷]]◎absorbr
2! [id⟷⊗absorbr]◎absorbl⇔assocl⋆◎[absorbl⊗id⟷]◎absorbr =
    assocl⋆◎[absorbl⊗id⟷]◎absorbr⇔[id⟷⊗absorbr]◎absorbl
2! assocl⋆◎[absorbl⊗id⟷]◎absorbr⇔[id⟷⊗absorbr]◎absorbl =
    [id⟷⊗absorbr]◎absorbl⇔assocl⋆◎[absorbl⊗id⟷]◎absorbr
2! elim⊥-A[0⊕B]⇔l = elim⊥-A[0⊕B]⇔r
2! elim⊥-A[0⊕B]⇔r = elim⊥-A[0⊕B]⇔l
2! elim⊥-1[A⊕B]⇔l = elim⊥-1[A⊕B]⇔r
2! elim⊥-1[A⊕B]⇔r = elim⊥-1[A⊕B]⇔l
2! fully-distribute⇔l = fully-distribute⇔r
2! fully-distribute⇔r = fully-distribute⇔l

2!! : {t₁ t₂ : U} {f g : t₁ ⟷ t₂} {α : f ⇔ g} → triv≡ (2! (2! α)) α
2!! = tt

-- This makes _⇔_ an equivalence relation...

⇔Equiv : {t₁ t₂ : U} → IsEquivalence (_⇔_ {t₁} {t₂})
⇔Equiv = record
  { refl = id⇔
  ; sym = 2!
  ; trans = trans⇔
  }

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

-- Unit coherence has two versions, but one is derivable
-- from the other.  As it turns out, one of our examples
-- needs the 'flipped' version.

unite₊r-coh-r : {t₁ : U} → swap₊ ◎ unite₊l ⇔ unite₊r {t₁}
unite₊r-coh-r =
  trans⇔ (id⇔ ⊡ unite₊l-coh-l) (
  trans⇔ assoc◎l ((
  trans⇔ (linv◎l ⊡ id⇔) idl◎l ) ) )

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

-- It is often useful to have that reversing c twice is ⇔ c rather than ≡
-- Unfortunately, it needs a 'proof', which is quite dull, though
-- it does have 3 non-trivial cases.
!!⇔id : {t₁ t₂ : U} {c : t₁ ⟷ t₂} → (! (! c)) ⇔ c
!!⇔id {c = unite₊l} = id⇔
!!⇔id {c = uniti₊l} = id⇔
!!⇔id {c = unite₊r} = id⇔
!!⇔id {c = uniti₊r} = id⇔
!!⇔id {c = swap₊} = id⇔
!!⇔id {c = assocl₊} = id⇔
!!⇔id {c = assocr₊} = id⇔
!!⇔id {c = unite⋆l} = id⇔
!!⇔id {c = uniti⋆l} = id⇔
!!⇔id {c = unite⋆r} = id⇔
!!⇔id {c = uniti⋆r} = id⇔
!!⇔id {c = swap⋆} = id⇔
!!⇔id {c = assocl⋆} = id⇔
!!⇔id {c = assocr⋆} = id⇔
!!⇔id {c = absorbr} = id⇔
!!⇔id {c = absorbl} = id⇔
!!⇔id {c = factorzr} = id⇔
!!⇔id {c = factorzl} = id⇔
!!⇔id {c = dist} = id⇔
!!⇔id {c = factor} = id⇔
!!⇔id {c = distl} = id⇔
!!⇔id {c = factorl} = id⇔
!!⇔id {c = id⟷} = id⇔
!!⇔id {c = c ◎ c₁} = !!⇔id ⊡ !!⇔id
!!⇔id {c = c ⊕ c₁} = resp⊕⇔ !!⇔id !!⇔id
!!⇔id {c = c ⊗ c₁} = resp⊗⇔ !!⇔id !!⇔id

-------------
mutual
  eval₁ : {t₁ t₂ : U} {c₁ c₂ : t₁ ⟷ t₂} (ce : c₁ ⇔ c₂) → (t₁ ⟷ t₂)
  eval₁ (assoc◎l {c₁ = c₁} {c₂} {c₃}) = (c₁ ◎ c₂) ◎ c₃
  eval₁ (assoc◎r {c₁ = c₁} {c₂} {c₃}) = c₁ ◎ (c₂ ◎ c₃)
  eval₁ (assocl⊕l {c₁ = c₁} {c₂} {c₃}) = assocl₊ ◎ ((c₁ ⊕ c₂) ⊕ c₃)
  eval₁ (assocl⊕r {c₁ = c₁} {c₂} {c₃}) = (c₁ ⊕ (c₂ ⊕ c₃)) ◎ assocl₊
  eval₁ (assocl⊗l {c₁ = c₁} {c₂} {c₃}) = assocl⋆ ◎ ((c₁ ⊗ c₂) ⊗ c₃)
  eval₁ (assocl⊗r {c₁ = c₁} {c₂} {c₃}) = (c₁ ⊗ (c₂ ⊗ c₃)) ◎ assocl⋆
  eval₁ (assocr⊕r {c₁ = c₁} {c₂} {c₃}) = assocr₊ ◎ (c₁ ⊕ (c₂ ⊕ c₃))
  eval₁ (assocr⊗l {c₁ = c₁} {c₂} {c₃}) = ((c₁ ⊗ c₂) ⊗ c₃) ◎ assocr⋆
  eval₁ (assocr⊗r {c₁ = c₁} {c₂} {c₃}) = assocr⋆ ◎(c₁ ⊗ (c₂ ⊗ c₃))
  eval₁ (assocr⊕l {c₁ = c₁} {c₂} {c₃}) = ((c₁ ⊕ c₂) ⊕ c₃) ◎ assocr₊
  eval₁ (dist⇔l {a = c₁} {c₂} {c₃}) = dist ◎ ((c₁ ⊗ c₃) ⊕ (c₂ ⊗ c₃))
  eval₁ (dist⇔r {a = c₁} {c₂} {c₃}) = ((c₁ ⊕ c₂) ⊗ c₃) ◎ dist
  eval₁ (distl⇔l {a = c₁} {c₂} {c₃}) = distl ◎ ((c₁ ⊗ c₂) ⊕ (c₁ ⊗ c₃))
  eval₁ (distl⇔r {a = c₁} {c₂} {c₃}) = (c₁ ⊗ (c₂ ⊕ c₃)) ◎ distl
  eval₁ (factor⇔l {a = c₁} {c₂} {c₃}) = factor ◎ ((c₁ ⊕ c₂) ⊗ c₃)
  eval₁ (factor⇔r {a = c₁} {c₂} {c₃}) = ((c₁ ⊗ c₃) ⊕ (c₂ ⊗ c₃)) ◎ factor
  eval₁ (factorl⇔l {a = c₁} {c₂} {c₃}) = factorl ◎ (c₁ ⊗ (c₂ ⊕ c₃))
  eval₁ (factorl⇔r {a = c₁} {c₂} {c₃}) = ((c₁ ⊗ c₂) ⊕ (c₁ ⊗ c₃)) ◎ factorl
  eval₁ (idl◎l {c = c}) = c
  eval₁ (idl◎r {c = c}) = id⟷ ◎ c
  eval₁ (idr◎l {c = c}) = c
  eval₁ (idr◎r {c = c}) = c ◎ id⟷
  eval₁ (linv◎l {c = c}) = id⟷
  eval₁ (linv◎r {c = c}) = c ◎ ! c
  eval₁ (rinv◎l {c = c}) = id⟷
  eval₁ (rinv◎r {c = c}) = ! c ◎ c
  eval₁ (unite₊l⇔l {c₁ = c₁} {c₂}) = (c₁ ⊕ c₂) ◎ unite₊l
  eval₁ (unite₊l⇔r {c₁ = c₁} {c₂}) = unite₊l ◎ c₂
  eval₁ (uniti₊l⇔l {c₁ = c₁} {c₂}) = c₂ ◎ uniti₊l
  eval₁ (uniti₊l⇔r {c₁ = c₁} {c₂}) = uniti₊l ◎ (c₁ ⊕ c₂)
  eval₁ (unite₊r⇔l {c₁ = c₁} {c₂}) = (c₂ ⊕ c₁) ◎ unite₊r
  eval₁ (unite₊r⇔r {c₁ = c₁} {c₂}) = unite₊r ◎ c₂
  eval₁ (uniti₊r⇔l {c₁ = c₁} {c₂}) = c₂ ◎ uniti₊r
  eval₁ (uniti₊r⇔r {c₁ = c₁} {c₂}) = uniti₊r ◎ (c₂ ⊕ c₁)
  eval₁ (swapl₊⇔  {c₁ = c₁} {c₂}) = (c₂ ⊕ c₁) ◎ swap₊
  eval₁ (swapr₊⇔  {c₁ = c₁} {c₂}) = swap₊ ◎ (c₁ ⊕ c₂)
  eval₁ (unitel⋆⇔l {c₁ = c₁} {c₂}) = (c₁ ⊗ c₂) ◎ unite⋆l
  eval₁ (uniter⋆⇔l {c₁ = c₁} {c₂}) = unite⋆l ◎ c₂
  eval₁ (unitil⋆⇔l {c₁ = c₁} {c₂}) = c₂ ◎ uniti⋆l
  eval₁ (unitir⋆⇔l {c₁ = c₁} {c₂}) = uniti⋆l ◎ (c₁ ⊗ c₂)
  eval₁ (unitel⋆⇔r {c₁ = c₁} {c₂}) = (c₂ ⊗ c₁) ◎ unite⋆r
  eval₁ (uniter⋆⇔r {c₁ = c₁} {c₂}) = unite⋆r ◎ c₂
  eval₁ (unitil⋆⇔r {c₁ = c₁} {c₂}) = c₂ ◎ uniti⋆r
  eval₁ (unitir⋆⇔r {c₁ = c₁} {c₂}) = uniti⋆r ◎ (c₂ ⊗ c₁)
  eval₁ (swapl⋆⇔ {c₁ = c₁} {c₂}) = (c₂ ⊗ c₁) ◎ swap⋆
  eval₁ (swapr⋆⇔ {c₁ = c₁} {c₂}) = swap⋆ ◎ (c₁ ⊗ c₂)
  eval₁ (id⇔ {c = c}) = c
  eval₁ (trans⇔ {t₁} {t₂} {c₁} {c₂} {c₃} ce ce₁) with eval₁ ce | exact ce
  ... | cc | refl =  eval₁ {c₁ = cc} {c₃} ce₁
  eval₁ (_⊡_ {c₁ = c₁} {c₂} {c₃} {c₄} ce₀ ce₁) =
    let r₀ = eval₁ ce₀ in
    let r₁ = eval₁ ce₁ in
    r₀ ◎ r₁
  eval₁ (resp⊕⇔ ce₀ ce₁) =
    let r₀ = eval₁ ce₀ in
    let r₁ = eval₁ ce₁ in
    r₀ ⊕ r₁
  eval₁ (resp⊗⇔ ce₀ ce₁) =
    let r₀ = eval₁ ce₀ in
    let r₁ = eval₁ ce₁ in
    r₀ ⊗ r₁
  eval₁ id⟷⊕id⟷⇔ = id⟷
  eval₁ split⊕-id⟷ = id⟷ ⊕ id⟷
  eval₁ (hom⊕◎⇔ {c₁ = c₁} {c₂} {c₃} {c₄}) = (c₁ ⊕ c₂) ◎ (c₃ ⊕ c₄)
  eval₁ (hom◎⊕⇔ {c₁ = c₁} {c₂} {c₃} {c₄}) = (c₁ ◎ c₃) ⊕ (c₂ ◎ c₄)
  eval₁ id⟷⊗id⟷⇔ = id⟷
  eval₁ split⊗-id⟷ = id⟷ ⊗ id⟷
  eval₁ (hom⊗◎⇔ {c₁ = c₁} {c₂} {c₃} {c₄}) = (c₁ ⊗ c₂) ◎ (c₃ ⊗ c₄)
  eval₁ (hom◎⊗⇔ {c₁ = c₁} {c₂} {c₃} {c₄}) = (c₁ ◎ c₃) ⊗ (c₂ ◎ c₄)
  eval₁ triangle⊕l = assocr₊ ◎ (id⟷ ⊕ unite₊l)
  eval₁ triangle⊕r = unite₊r ⊕ id⟷
  eval₁ triangle⊗l = assocr⋆ ◎ (id⟷ ⊗ unite⋆l)
  eval₁ triangle⊗r = unite⋆r ⊗ id⟷
  eval₁ pentagon⊕l = ((assocr₊ ⊕ id⟷) ◎ assocr₊) ◎ (id⟷ ⊕ assocr₊)
  eval₁ pentagon⊕r = assocr₊ ◎ assocr₊
  eval₁ pentagon⊗l = ((assocr⋆ ⊗ id⟷) ◎ assocr⋆) ◎ (id⟷ ⊗ assocr⋆)
  eval₁ pentagon⊗r = assocr⋆ ◎ assocr⋆
  eval₁ unite₊l-coh-l = swap₊ ◎ unite₊r
  eval₁ unite₊l-coh-r = unite₊l
  eval₁ unite⋆l-coh-l = swap⋆ ◎ unite⋆r
  eval₁ unite⋆l-coh-r = unite⋆l
  eval₁ hexagonr⊕l = ((swap₊ ⊕ id⟷) ◎ assocr₊) ◎ (id⟷ ⊕ swap₊)
  eval₁ hexagonr⊕r = (assocr₊ ◎ swap₊) ◎ assocr₊
  eval₁ hexagonl⊕l = ((id⟷ ⊕ swap₊) ◎ assocl₊) ◎ (swap₊ ⊕ id⟷)
  eval₁ hexagonl⊕r = (assocl₊ ◎ swap₊) ◎ assocl₊
  eval₁ hexagonr⊗l = ((swap⋆ ⊗ id⟷) ◎ assocr⋆) ◎ (id⟷ ⊗ swap⋆)
  eval₁ hexagonr⊗r = (assocr⋆ ◎ swap⋆) ◎ assocr⋆
  eval₁ hexagonl⊗l = ((id⟷ ⊗ swap⋆) ◎ assocl⋆) ◎ (swap⋆ ⊗ id⟷)
  eval₁ hexagonl⊗r = (assocl⋆ ◎ swap⋆) ◎ assocl⋆
  eval₁ absorbl⇔l = absorbl ◎ id⟷
  eval₁ (absorbl⇔r {c₁ = c₁}) = (c₁ ⊗ id⟷) ◎ absorbl
  eval₁ absorbr⇔l = absorbr ◎ id⟷
  eval₁ (absorbr⇔r {c₁ = c₁}) = (id⟷ ⊗ c₁) ◎ absorbr
  eval₁ (factorzl⇔l {c₁ = c₁}) = factorzl ◎ (id⟷ ⊗ c₁)
  eval₁ (factorzl⇔r {c₁ = c₁}) = id⟷ ◎ factorzl
  eval₁ (factorzr⇔l {c₁ = c₁}) = factorzr ◎ (c₁ ⊗ id⟷)
  eval₁ (factorzr⇔r {c₁ = c₁}) = id⟷ ◎ factorzr
  eval₁ swap₊distl⇔l = distl ◎ swap₊
  eval₁ swap₊distl⇔r = (id⟷ ⊗ swap₊) ◎ distl
  eval₁ dist-swap⋆⇔l = swap⋆ ◎ distl
  eval₁ dist-swap⋆⇔r = dist ◎ (swap⋆ ⊕ swap⋆)
  eval₁ assocl₊-dist-dist⇔l = (dist ◎ (id⟷ ⊕ dist)) ◎ assocl₊
  eval₁ assocl₊-dist-dist⇔r = ((assocl₊ ⊗ id⟷) ◎ dist) ◎ (dist ⊕ id⟷)
  eval₁ assocl⋆-distl⇔l = ((id⟷ ⊗ distl) ◎ distl) ◎ (assocl⋆ ⊕ assocl⋆)
  eval₁ assocl⋆-distl⇔r = assocl⋆ ◎ distl
  eval₁ absorbr0-absorbl0⇔ = absorbl
  eval₁ absorbl0-absorbr0⇔ = absorbr
  eval₁ absorbr⇔distl-absorb-unite = (distl ◎ (absorbr ⊕ absorbr)) ◎ unite₊l
  eval₁ distl-absorb-unite⇔absorbr = absorbr
  eval₁ unite⋆r0-absorbr1⇔ = absorbr
  eval₁ absorbr1-unite⋆r-⇔ = unite⋆r
  eval₁ absorbl≡swap⋆◎absorbr = swap⋆ ◎ absorbr
  eval₁ swap⋆◎absorbr≡absorbl = absorbl
  eval₁ absorbr⇔[assocl⋆◎[absorbr⊗id⟷]]◎absorbr = (assocl⋆ ◎ (absorbr ⊗ id⟷)) ◎ absorbr
  eval₁ [assocl⋆◎[absorbr⊗id⟷]]◎absorbr⇔absorbr = absorbr
  eval₁ [id⟷⊗absorbr]◎absorbl⇔assocl⋆◎[absorbl⊗id⟷]◎absorbr = (assocl⋆ ◎ (absorbl ⊗ id⟷)) ◎ absorbr
  eval₁ assocl⋆◎[absorbl⊗id⟷]◎absorbr⇔[id⟷⊗absorbr]◎absorbl = (id⟷ ⊗ absorbr) ◎ absorbl
  eval₁ elim⊥-A[0⊕B]⇔l = (distl ◎ (absorbl ⊕ id⟷)) ◎ unite₊l
  eval₁ elim⊥-A[0⊕B]⇔r = id⟷ ⊗ unite₊l
  eval₁ elim⊥-1[A⊕B]⇔l = distl ◎ (unite⋆l ⊕ unite⋆l)
  eval₁ elim⊥-1[A⊕B]⇔r = unite⋆l
  eval₁ fully-distribute⇔l = ((((dist ◎ (distl ⊕ distl)) ◎ assocl₊) ◎ (assocr₊ ⊕ id⟷)) ◎
                                ((id⟷ ⊕ swap₊) ⊕ id⟷))
                               ◎ (assocl₊ ⊕ id⟷)
  eval₁ fully-distribute⇔r = (distl ◎ (dist ⊕ dist)) ◎ assocl₊

  exact : {t₁ t₂ : U} {c₁ c₂ : t₁ ⟷ t₂} (ce : c₁ ⇔ c₂) → eval₁ ce ≡ c₂
  exact assoc◎l = refl
  exact assoc◎r = refl
  exact assocl⊕l = refl
  exact assocl⊕r = refl
  exact assocl⊗l = refl
  exact assocl⊗r = refl
  exact assocr⊕r = refl
  exact assocr⊗l = refl
  exact assocr⊗r = refl
  exact assocr⊕l = refl
  exact dist⇔l = refl
  exact dist⇔r = refl
  exact distl⇔l = refl
  exact distl⇔r = refl
  exact factor⇔l = refl
  exact factor⇔r = refl
  exact factorl⇔l = refl
  exact factorl⇔r = refl
  exact idl◎l = refl
  exact idl◎r = refl
  exact idr◎l = refl
  exact idr◎r = refl
  exact linv◎l = refl
  exact linv◎r = refl
  exact rinv◎l = refl
  exact rinv◎r = refl
  exact unite₊l⇔l = refl
  exact unite₊l⇔r = refl
  exact uniti₊l⇔l = refl
  exact uniti₊l⇔r = refl
  exact unite₊r⇔l = refl
  exact unite₊r⇔r = refl
  exact uniti₊r⇔l = refl
  exact uniti₊r⇔r = refl
  exact swapl₊⇔ = refl
  exact swapr₊⇔ = refl
  exact unitel⋆⇔l = refl
  exact uniter⋆⇔l = refl
  exact unitil⋆⇔l = refl
  exact unitir⋆⇔l = refl
  exact unitel⋆⇔r = refl
  exact uniter⋆⇔r = refl
  exact unitil⋆⇔r = refl
  exact unitir⋆⇔r = refl
  exact swapl⋆⇔ = refl
  exact swapr⋆⇔ = refl
  exact id⇔ = refl
  exact (trans⇔ ce ce₁) rewrite exact ce | exact ce₁ = refl
  exact (ce ⊡ ce₁) rewrite exact ce | exact ce₁ = refl
  exact (resp⊕⇔ ce ce₁) rewrite exact ce | exact ce₁ = refl
  exact (resp⊗⇔ ce ce₁) rewrite exact ce | exact ce₁ = refl
  exact id⟷⊕id⟷⇔ = refl
  exact split⊕-id⟷ = refl
  exact hom⊕◎⇔ = refl
  exact hom◎⊕⇔ = refl
  exact id⟷⊗id⟷⇔ = refl
  exact split⊗-id⟷ = refl
  exact hom⊗◎⇔ = refl
  exact hom◎⊗⇔ = refl
  exact triangle⊕l = refl
  exact triangle⊕r = refl
  exact triangle⊗l = refl
  exact triangle⊗r = refl
  exact pentagon⊕l = refl
  exact pentagon⊕r = refl
  exact pentagon⊗l = refl
  exact pentagon⊗r = refl
  exact unite₊l-coh-l = refl
  exact unite₊l-coh-r = refl
  exact unite⋆l-coh-l = refl
  exact unite⋆l-coh-r = refl
  exact hexagonr⊕l = refl
  exact hexagonr⊕r = refl
  exact hexagonl⊕l = refl
  exact hexagonl⊕r = refl
  exact hexagonr⊗l = refl
  exact hexagonr⊗r = refl
  exact hexagonl⊗l = refl
  exact hexagonl⊗r = refl
  exact absorbl⇔l = refl
  exact absorbl⇔r = refl
  exact absorbr⇔l = refl
  exact absorbr⇔r = refl
  exact factorzl⇔l = refl
  exact factorzl⇔r = refl
  exact factorzr⇔l = refl
  exact factorzr⇔r = refl
  exact swap₊distl⇔l = refl
  exact swap₊distl⇔r = refl
  exact dist-swap⋆⇔l = refl
  exact dist-swap⋆⇔r = refl
  exact assocl₊-dist-dist⇔l = refl
  exact assocl₊-dist-dist⇔r = refl
  exact assocl⋆-distl⇔l = refl
  exact assocl⋆-distl⇔r = refl
  exact absorbr0-absorbl0⇔ = refl
  exact absorbl0-absorbr0⇔ = refl
  exact absorbr⇔distl-absorb-unite = refl
  exact distl-absorb-unite⇔absorbr = refl
  exact unite⋆r0-absorbr1⇔ = refl
  exact absorbr1-unite⋆r-⇔ = refl
  exact absorbl≡swap⋆◎absorbr = refl
  exact swap⋆◎absorbr≡absorbl = refl
  exact absorbr⇔[assocl⋆◎[absorbr⊗id⟷]]◎absorbr = refl
  exact [assocl⋆◎[absorbr⊗id⟷]]◎absorbr⇔absorbr = refl
  exact [id⟷⊗absorbr]◎absorbl⇔assocl⋆◎[absorbl⊗id⟷]◎absorbr = refl
  exact assocl⋆◎[absorbl⊗id⟷]◎absorbr⇔[id⟷⊗absorbr]◎absorbl = refl
  exact elim⊥-A[0⊕B]⇔l = refl
  exact elim⊥-A[0⊕B]⇔r = refl
  exact elim⊥-1[A⊕B]⇔l = refl
  exact elim⊥-1[A⊕B]⇔r = refl
  exact fully-distribute⇔l = refl
  exact fully-distribute⇔r = refl