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

-- This module defines an intermediate calculus that is set up in the D<: universe
-- which bridges F<:- and D<:. The goal here is purely technical - to simply reduce
-- duplication.
module DsubReduced where

open import Data.List as List
open import Data.List.All as All
open import Data.Nat as ℕ
open import Data.Maybe as Maybe
open import Data.Product
open import Function

open import Data.Maybe.Properties as Maybeₚ
open import Data.Nat.Properties as ℕₚ
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality as ≡

open import DsubDef
open import FsubMinus
open import FsubMinus2
open import Utils

-- D<: Reduced
--
-- This judgment for contexts and types in D<: defines a corresponding calculus after
-- interpreting F<:⁻ into D<:. That is, D<: reduced is the image derivation of
-- interpreting F<:⁻ in D<:.
infix 4 _⊢ᵣ_<:_
data _⊢ᵣ_<:_ : Env → Typ → Typ → Set where
  drtop   : ∀ {Γ T} → Covar T → Γ ⊢ᵣ T <: ⊤
  drrefl  : ∀ {Γ T} → Covar T → Γ ⊢ᵣ T <: T
  drall   : ∀ {Γ S U S′ U′} →
              Covar S → Covar U → Covar S′ → Covar U′ →
              (S′<:S : Γ ⊢ᵣ S′ <: S) →
              (U<:U′ : ⟨A: ⊥ ⋯ S′ ⟩ ∷ Γ ⊢ᵣ U <: U′) →
              Γ ⊢ᵣ Π ⟨A: ⊥ ⋯ S ⟩ ∙ U <: Π ⟨A: ⊥ ⋯ S′ ⟩ ∙ U′
  drsel   : ∀ {Γ n U U′} →
              (T∈Γ : env-lookup Γ n ≡ just ⟨A: ⊥ ⋯ U ⟩) →
              Covar U →
              Γ ⊢ᵣ U <: U′ →
              Γ ⊢ᵣ n ∙A <: U′

module FsubMinusToDsubR where
  open FsubMinus.FsubMinus renaming (Env to Env′ ; _↑_ to _⇑_) hiding (env-lookup)

  infix 5 ⟦_⟧ ⟪_⟫
  ⟦_⟧ : Ftyp → Typ
  ⟦ ⊤ ⟧         = ⊤
  ⟦ var x ⟧     = x ∙A
  ⟦ Π<: S ∙ U ⟧ = Π ⟨A: ⊥ ⋯ ⟦ S ⟧ ⟩ ∙ ⟦ U ⟧

  ⟪_⟫ : Env′ → Env
  ⟪ [] ⟫    = []
  ⟪ T ∷ Γ ⟫ = ⟨A: ⊥ ⋯ ⟦ T ⟧ ⟩ ∷ ⟪ Γ ⟫

  module ⟦⟧-Bijective where
    open import Function.Bijection
    open import Function.Surjection
    open import Function.Equality

    CovTyp : Set
    CovTyp = ∃ λ T → Covar T

    ⟦⟧-covar : ∀ T → Covar ⟦ T ⟧
    ⟦⟧-covar ⊤           = cv⊤
    ⟦⟧-covar (var x)     = cv∙A _
    ⟦⟧-covar (Π<: S ∙ U) = cvΠ (⟦⟧-covar S) (⟦⟧-covar U)

    ⟦⟧-func : ≡.setoid Ftyp ⟶ ≡.setoid CovTyp
    ⟦⟧-func   = record
      { _⟨$⟩_ = < ⟦_⟧ , ⟦⟧-covar >
      ; cong  = ≡.cong < ⟦_⟧ , ⟦⟧-covar >
      }

    ⟦⟧-injective : ∀ {S U} → ⟦ S ⟧ ≡ ⟦ U ⟧ → S ≡ U
    ⟦⟧-injective {⊤} {⊤} eq            = refl
    ⟦⟧-injective {⊤} {var x} ()
    ⟦⟧-injective {⊤} {Π<: _ ∙ _} ()
    ⟦⟧-injective {var x} {⊤} ()
    ⟦⟧-injective {var x} {var .x} refl = refl
    ⟦⟧-injective {var x} {Π<: _ ∙ _} ()
    ⟦⟧-injective {Π<: _ ∙ _} {⊤} ()
    ⟦⟧-injective {Π<: _ ∙ _} {var x} ()
    ⟦⟧-injective {Π<: S₁ ∙ U₁} {Π<: S₂ ∙ U₂} eq
      with ⟦ S₁ ⟧ | ⟦ S₂ ⟧ | ⟦ U₁ ⟧ | ⟦ U₂ ⟧
         | ⟦⟧-injective {S₁} {S₂} | ⟦⟧-injective {U₁} {U₂}
    ⟦⟧-injective {Π<: S₁ ∙ U₁} {Π<: S₂ ∙ U₂} refl
         | _ | _ | _ | _ | rec₁ | rec₂ = ≡.cong₂ Π<:_∙_ (rec₁ refl) (rec₂ refl)

    ⟦⟧-func-injective : ∀ {S U} → (CovTyp ∋ (⟦ S ⟧ , ⟦⟧-covar S)) ≡ (⟦ U ⟧ , ⟦⟧-covar U) → S ≡ U
    ⟦⟧-func-injective {S} {U} eq
      with ⟦ S ⟧ | ⟦⟧-covar S | ⟦ U ⟧ | ⟦⟧-covar U
         | ⟦⟧-injective {S} {U}
    ⟦⟧-func-injective {S} {U} refl
         | _ | _ | _ | _ | inj = inj refl

    infix 5 ⟦_⟧⁻¹
    ⟦_⟧⁻¹ : CovTyp → Ftyp
    ⟦ _ , cv⊤ ⟧⁻¹     = ⊤
    ⟦ _ , cv∙A x ⟧⁻¹  = var x
    ⟦ _ , cvΠ S U ⟧⁻¹ = Π<: ⟦ -, S ⟧⁻¹ ∙ ⟦ -, U ⟧⁻¹

    ⟦⟧-func-inv : ≡.setoid CovTyp ⟶ ≡.setoid Ftyp
    ⟦⟧-func-inv = record
      { _⟨$⟩_   = ⟦_⟧⁻¹
      ; cong    = ≡.cong ⟦_⟧⁻¹
      }

    ⟦⟧-left-inverse-⟦⟧⁻¹ : ∀ {T} (cT : Covar T) → (⟦ ⟦ -, cT ⟧⁻¹ ⟧ , ⟦⟧-covar ⟦ -, cT ⟧⁻¹) ≡ (CovTyp ∋ (-, cT))
    ⟦⟧-left-inverse-⟦⟧⁻¹ cv⊤           = refl
    ⟦⟧-left-inverse-⟦⟧⁻¹ (cv∙A n)      = refl
    ⟦⟧-left-inverse-⟦⟧⁻¹ (cvΠ S U)
      with ⟦ ⟦ -, S ⟧⁻¹ ⟧         | ⟦ ⟦ -, U ⟧⁻¹ ⟧
         | ⟦⟧-covar ⟦ -, S ⟧⁻¹    | ⟦⟧-covar ⟦ -, U ⟧⁻¹
         | ⟦⟧-left-inverse-⟦⟧⁻¹ S | ⟦⟧-left-inverse-⟦⟧⁻¹ U
    ...  | _ | _ | _ | _ | refl | refl = refl

    ⟦⟧-bijective : Bijective ⟦⟧-func
    ⟦⟧-bijective   = record
      { injective  = ⟦⟧-func-injective
      ; surjective = record
        { from             = ⟦⟧-func-inv
        ; right-inverse-of = λ { (_ , T) → ⟦⟧-left-inverse-⟦⟧⁻¹ T }
        }
      }

  open ⟦⟧-Bijective using (⟦⟧-covar ; ⟦⟧-injective) public

  ⟪⟫-contraEnv : ∀ Γ → ContraEnv ⟪ Γ ⟫
  ⟪⟫-contraEnv []      = []
  ⟪⟫-contraEnv (T ∷ Γ) = ctt (⟦⟧-covar T) ∷ ⟪⟫-contraEnv Γ

  ⟦⟧-↑-comm : ∀ T n → ⟦ T ⟧ ↑ n ≡ ⟦ T ⇑ n ⟧
  ⟦⟧-↑-comm ⊤ n = refl
  ⟦⟧-↑-comm (var x) n with n ≤? x
  ... | yes n≤x = refl
  ... | no n>x  = refl
  ⟦⟧-↑-comm (Π<: S ∙ U) n
    rewrite ⟦⟧-↑-comm S n | ⟦⟧-↑-comm U (suc n)
                = refl

  <:∈⇒env-lookup : ∀ {n T Γ} → n <: T ∈ Γ → env-lookup ⟪ Γ ⟫ n ≡ just ⟨A: ⊥ ⋯ ⟦ T ⟧ ⟩
  <:∈⇒env-lookup {_} {_} {T ∷ ._} hd
    rewrite ⟦⟧-↑-comm T 0       = refl
  <:∈⇒env-lookup {suc n} {_} {._ ∷ Γ} (tl {_} {T} T∈Γ)
    with lookupOpt ⟪ Γ ⟫ n | <:∈⇒env-lookup T∈Γ
  ...  | nothing           | ()
  ...  | just _            | eq
    rewrite sym $ ⟦⟧-↑-comm T 0 = cong (just ∘ (_↑ 0)) (just-injective eq)

  F<:⇒D<:ᵣ : ∀ {Γ S U} → Γ ⊢F S <: U → ⟪ Γ ⟫ ⊢ᵣ ⟦ S ⟧ <: ⟦ U ⟧
  F<:⇒D<:ᵣ ftop               = drtop (⟦⟧-covar _)
  F<:⇒D<:ᵣ fvrefl             = drrefl (cv∙A _)
  F<:⇒D<:ᵣ (fbinds T∈Γ T<:U)  = drsel (<:∈⇒env-lookup T∈Γ) (⟦⟧-covar _) (F<:⇒D<:ᵣ T<:U)
  F<:⇒D<:ᵣ (fall S′<:S U<:U′) = drall (⟦⟧-covar _) (⟦⟧-covar _) (⟦⟧-covar _) (⟦⟧-covar _)
                                      (F<:⇒D<:ᵣ S′<:S) (F<:⇒D<:ᵣ U<:U′)

  env-lookup⇒<:∈ : ∀ {n T Γ} → env-lookup Γ n ≡ just ⟨A: ⊥ ⋯ T ⟩ →
                   ∀ {Γ′} → Γ ≡ ⟪ Γ′ ⟫ →
                   ∃ λ T′ → T ≡ ⟦ T′ ⟧ × n <: T′ ∈ Γ′
  env-lookup⇒<:∈ T∈Γ eqΓ = aux (lookup⇒↦∈ T∈Γ) refl eqΓ
    where aux : ∀ {n T Γ} → n ↦ T ∈ Γ →
                   ∀ {U Γ′} → T ≡ ⟨A: ⊥ ⋯ U ⟩ → Γ ≡ ⟪ Γ′ ⟫ →
                   ∃ λ U′ → U ≡ ⟦ U′ ⟧ × n <: U′ ∈ Γ′
          aux hd {_} {[]} eqT ()
          aux hd {_} {T ∷ Γ′} refl refl
            rewrite ⟦⟧-↑-comm T 0 = T ⇑ zero , refl , hd
          aux (tl T∈Γ) {_} {[]} eqT ()
          aux (tl {T = ⊤} T∈Γ) {_} {_ ∷ Γ′} () refl
          aux (tl {T = ⊥} T∈Γ) {_} {_ ∷ Γ′} () refl
          aux (tl {T = n ∙A} T∈Γ) {_} {_ ∷ Γ′} () refl
          aux (tl {T = Π S ∙ U} T∈Γ) {_} {_ ∷ Γ′} () refl
          aux (tl {T = ⟨A: ⊤ ⋯ U ⟩} T∈Γ) {_} {_ ∷ Γ′} () refl
          aux (tl {T = ⟨A: ⊥ ⋯ U ⟩} T∈Γ) {_} {_ ∷ Γ′} refl refl
            with aux T∈Γ refl refl
          ...  | U′ , refl , U′∈Γ′
            rewrite ⟦⟧-↑-comm U′ 0 = U′ ⇑ zero , refl , tl U′∈Γ′
          aux (tl {T = ⟨A: _ ∙A ⋯ U ⟩} T∈Γ) {_} {_ ∷ Γ′} () refl
          aux (tl {T = ⟨A: Π _ ∙ _ ⋯ U ⟩} T∈Γ) {_} {_ ∷ Γ′} () refl
          aux (tl {T = ⟨A: ⟨A: _ ⋯ _ ⟩ ⋯ U ⟩} T∈Γ) {_} {_ ∷ Γ′} () refl

  D<:ᵣ⇒F<: : ∀ {Γ′ S′ U′} → Γ′ ⊢ᵣ S′ <: U′ →
            ∀ {Γ S U} →
              Γ′ ≡ ⟪ Γ ⟫ → S′ ≡ ⟦ S ⟧ → U′ ≡ ⟦ U ⟧ →
              Γ ⊢F S <: U
  D<:ᵣ⇒F<: (drtop S′) {Γ} {S} {⊤} eqΓ eqS refl   = ftop
  D<:ᵣ⇒F<: (drtop S′) {Γ} {S} {var x} eqΓ eqS ()
  D<:ᵣ⇒F<: (drtop S′) {Γ} {S} {Π<: U ∙ U₁} eqΓ eqS ()
  D<:ᵣ⇒F<: (drrefl S′) {Γ} {S} {U} eqΓ eqS eqU
    rewrite ⟦⟧-injective (≡.trans (sym eqS) eqU) = <:-refl Γ U
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {⊤} {⊤} eqΓ () eqU
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {⊤} {var x} eqΓ () eqU
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {⊤} {Π<: U ∙ U₁} eqΓ () eqU
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {var _} {⊤} eqΓ () eqU
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {var _} {var _} eqΓ () eqU
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {var _} {Π<: _ ∙ _} eqΓ () eqU
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {Π<: _ ∙ _} {⊤} eqΓ refl ()
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {Π<: _ ∙ _} {var _} eqΓ refl ()
  D<:ᵣ⇒F<: (drall cS cU cS′ cU′ S′<:S U<:U′) {Γ} {Π<: S ∙ U} {Π<: S′ ∙ U′} eqΓ refl refl
    = fall (D<:ᵣ⇒F<: S′<:S eqΓ refl refl)
           (D<:ᵣ⇒F<: U<:U′ (cong (⟨A: ⊥ ⋯ ⟦ S′ ⟧ ⟩ ∷_) eqΓ) refl refl)
  D<:ᵣ⇒F<: (drsel T∈Γ cT S<:U) {Γ} {⊤} {U} eqΓ () eqU
  D<:ᵣ⇒F<: (drsel T∈Γ cT S<:U) {Γ} {var x} {U} eqΓ refl eqU
    with env-lookup⇒<:∈ T∈Γ eqΓ
  ...  | U′ , eqU′ , T′∈Γ = fbinds T′∈Γ (D<:ᵣ⇒F<: S<:U eqΓ eqU′ eqU)
  D<:ᵣ⇒F<: (drsel T∈Γ cT S<:U) {Γ} {Π<: _ ∙ _} {U} eqΓ () eqU


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use Data.List.Relation.Unary.Any
-- directly.
------------------------------------------------------------------------

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

module Data.List.Any where

open import Data.List.Relation.Unary.Any public

{-# WARNING_ON_IMPORT
"Data.List.Any was deprecated in v1.0.
Use Data.List.Relation.Unary.Any instead."
#-}


module CTL.Proof.EG where

open import CTL.Modalities.EG
open import FStream.Bisimulation
open import FStream.Core
open import FStream.FVec
open import Library

infixr 5 _▻EG_
infix 6 ⟨_▻EG
infix 7 _⟩EG

infixr 5 _▻EGᵢ_
infix 7 _⟩EGᵢ

data proofEG {ℓ₁ ℓ₂} {C : Container ℓ₁} : {n : ℕ} →
     (props : FVec C (Set ℓ₂) n) → Set (ℓ₁ ⊔ ℓ₂) where
  []EG : proofEG FNil
  ConsEG : ∀ {n} {props : ⟦ C ⟧ (Set ℓ₂ × FVec C (Set ℓ₂) n)} →
    E (fmap (λ x → (proj₁ x) × (proofEG (proj₂ x))) props) →
      proofEG (FCons props)

_pre⟨_▻EG : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁} {m n}
              {props : FVec C (Set ℓ₂) m} {props' : FVec C (Set ℓ₂) (suc n)}
          → proofEG props
          → proofEG props'
          → EG {i} (props pre⟨ props' ▻⋯)
proj₁ ([]EG pre⟨ ConsEG (pos , _) ▻EG) = pos
nowE (proj₂ ([]EG pre⟨ ConsEG (_ , proof , _) ▻EG)) = proof
laterE (proj₂ ([]EG pre⟨ ConsEG (pos , proof , proofs) ▻EG)) =
  proofs pre⟨ ConsEG (pos , proof , proofs) ▻EG
proj₁ (ConsEG (pos , _) pre⟨ _ ▻EG) = pos
nowE   (proj₂ (ConsEG (pos , proof , proofs) pre⟨ _ ▻EG)) = proof
laterE (proj₂ (ConsEG (_   , _     , proofs) pre⟨ v ▻EG)) = proofs pre⟨ v ▻EG

-- TODO It's worth a thought whether we want to roll our own Sigma types
-- in order to have more meaningful projector names than projᵢ

⟨_▻EG : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁} {n} {props : FVec C (Set ℓ₂) (suc n)}
      → proofEG props → EG {i} (FNil pre⟨ props ▻⋯)
⟨_▻EG = []EG pre⟨_▻EG

_⟩EG : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁} {prop : ⟦ C ⟧ (Set ℓ₂)}
     → E prop
     → proofEG (FCons (fmap (_, FNil) prop))
(pos , proof) ⟩EG = ConsEG (pos , (proof , []EG))

_⟩EGᵢ : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁} {prop : ⟦ C ⟧ (Set ℓ₂)}
          {pos : Position C (proj₁ prop)}
      → proj₂ prop pos
      → proofEG (FCons (fmap (_, FNil) prop))
_⟩EGᵢ {pos = pos} proof = ConsEG (pos , (proof , []EG))

_▻EG_ : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁}
        {prop : ⟦ C ⟧ (Set ℓ₂)} {n} {props : FVec C (Set ℓ₂) n}
      → E prop
      → proofEG props
      → proofEG (FCons (fmap (_, props) prop))
(pos , proof) ▻EG proofs = ConsEG (pos , (proof , proofs))

_▻EGᵢ_ : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁} {prop : ⟦ C ⟧ (Set ℓ₂)} {n}
           {props : FVec C (Set ℓ₂) n} {pos : Position C (proj₁ prop)}
       → proj₂ prop pos
       → proofEG props
       → proofEG (FCons (fmap (_, props) prop))
_▻EGᵢ_ {pos = pos} proof proofs = ConsEG (pos , (proof , proofs))

mapEGlemma : ∀ {i} {ℓ₁ ℓ₂ ℓ₃} {C : Container ℓ₁} {A : Set ℓ₂}
               {f : A → Set ℓ₃} {m n}
           → (v : FVec C A m)
           → (v' : FVec C A (suc n))
           → EG {i} (vmap f v pre⟨ vmap f v' ▻⋯)
           → EG {i} (map f (v pre⟨ v' ▻⋯))
proj₁ (mapEGlemma FNil (FCons x) (pos , proof)) = pos
nowE (proj₂ (mapEGlemma FNil (FCons x) (pos , proofs))) = nowE proofs
laterE (proj₂ (mapEGlemma {f = f} FNil (FCons (shape , vals)) (pos , proof)))
  with vals pos
... | a , v = mapEGlemma v (FCons (shape , vals)) (laterE proof)
proj₁ (mapEGlemma (FCons (proj₃ , proj₄)) v' (pos , proofs)) = pos
nowE (proj₂ (mapEGlemma (FCons x) v' (pos , proofs))) = nowE proofs
laterE (proj₂ (mapEGlemma (FCons (shape , vals)) v' (pos , proofs)))
  with vals pos
... | a , v = mapEGlemma v v' (laterE proofs)

mapEG : ∀ {i} {ℓ₁ ℓ₂ ℓ₃} {C : Container ℓ₁} {A : Set ℓ₂} {f : A → Set ℓ₃}
          {m n} {v : FVec C A m} {v' : FVec C A (suc n)}
      → EG {i} ((vmap f v pre⟨ vmap f v' ▻⋯))
      → EG {i} (map f (v pre⟨ v' ▻⋯))
mapEG {v = v} {v' = v'} proofs = mapEGlemma v v' proofs

mutual
  -- TODO Rename to ∼EG?
  bisimEG : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁} {s₁ s₂ : FStream C (Set ℓ₂)}
          → s₁ ~ s₂ → EG {i} s₁ → EG {i} s₂
  proj₁ (bisimEG {C = C} bs (pos , proofs)) =
    subst (Position C) (sameInitShapes bs) pos
  proj₂ (bisimEG bs (pos , proofs)) = bisimEG' (bisim bs pos) proofs

  bisimEG' : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁} {s₁ s₂ : FStream' C (Set ℓ₂)}
           → s₁ ~' s₂ → EG' {i} s₁ → EG' {i} s₂
  -- TODO This subst trick must already exist in stdlib somewhere
  nowE (bisimEG' bs proof) = subst (λ x → x) (hd∼ bs) (nowE proof)
  laterE (bisimEG' {C = C} bs proof) = bisimEG (tl∼ bs) (laterE proof)


module Not-named-according-to-the-Haskell-lexical-syntax where

postulate
  IO : Set -> Set

{-# BUILTIN IO IO #-}
{-# COMPILED_TYPE IO IO #-}

postulate
  return : {A : Set} -> A -> IO A

{-# COMPILED return (\_ -> return :: a -> IO a) #-}
{-# COMPILED_EPIC return (u1 : Unit, a : Any) -> Any = ioreturn(a) #-}

data Unit : Set where
  unit : Unit

{-# COMPILED_DATA Unit () () #-}


module _ where

data Bool : Set where
  false true : Bool

{-# COMPILED_DATA Bool Bool False True #-}

postulate
  IO : Set → Set
  return : {A : Set} → A → IO A

{-# COMPILED_TYPE IO IO #-}
{-# COMPILED return \ _ -> return #-}
{-# COMPILED_UHC return \ _ x -> UHC.Agda.Builtins.primReturn x #-}
{-# COMPILED_JS return function(u) { return function(x) { return function(cb) { cb(x); }; }; } #-}

{-# IMPORT Data.Maybe #-}

{-# HASKELL printMaybe = putStrLn . Data.Maybe.fromMaybe "" #-}

returnTrue : IO Bool
returnTrue = return true

{-# COMPILED_EXPORT  returnTrue returnTrue #-}


-- 2013-02-18 reported by rotsor

module Issue796 where

data U : Set where
  a b : U

data A : Set where
data B : Set where

module Abs where
 abstract
  A' B' : Set

  A' = A
  B' = B

module Conc where

  open Abs

  -- Andreas, 2013-02-19
  -- this function should not be injective, since here
  -- it is not known whether A' and B' are actually different
  [_] : U → Set
  [_] a = A'
  [_] b = B'

  f : ∀ u → [ u ] → U
  f u _ = u

  postulate x : A'

  zzz = f _ x


_ : Set
_ : Set → Set


module Categories.Object.Zero where


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Tarski-style semantics with contexts as concrete worlds, and glueing for □ only.
-- Gentzen-style syntax.

module BasicIS4.Semantics.TarskiGluedGentzen where

open import BasicIS4.Syntax.Common public
open import Common.Semantics public

-- Intuitionistic Tarski models.

record Model : Set₁ where
  infix 3 _⊩ᵅ_ _[⊢]_ _[⊢⋆]_
  field
    -- Forcing for atomic propositions; monotonic.
    _⊩ᵅ_   : Cx Ty → Atom → Set
    mono⊩ᵅ : ∀ {P Γ Γ′} → Γ ⊆ Γ′ → Γ ⊩ᵅ P → Γ′ ⊩ᵅ P

    -- Gentzen-style syntax representation; monotonic.
    _[⊢]_     : Cx Ty → Ty → Set
    _[⊢⋆]_    : Cx Ty → Cx Ty → Set
    mono[⊢]   : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ [⊢] A → Γ′ [⊢] A
    [var]      : ∀ {A Γ}    → A ∈ Γ → Γ [⊢] A
    [lam]      : ∀ {A B Γ}  → Γ , A [⊢] B → Γ [⊢] A ▻ B
    [app]      : ∀ {A B Γ}  → Γ [⊢] A ▻ B → Γ [⊢] A → Γ [⊢] B
    [multibox] : ∀ {A Δ Γ}  → Γ [⊢⋆] □⋆ Δ → □⋆ Δ [⊢] A → Γ [⊢] □ A
    [down]     : ∀ {A Γ}    → Γ [⊢] □ A → Γ [⊢] A
    [pair]     : ∀ {A B Γ}  → Γ [⊢] A → Γ [⊢] B → Γ [⊢] A ∧ B
    [fst]      : ∀ {A B Γ}  → Γ [⊢] A ∧ B → Γ [⊢] A
    [snd]      : ∀ {A B Γ}  → Γ [⊢] A ∧ B → Γ [⊢] B
    [unit]     : ∀ {Γ}      → Γ [⊢] ⊤

    -- TODO: Workarounds for Agda bug #2143.
    top[⊢⋆] : ∀ {Γ}     → (Γ [⊢⋆] ∅) ≡ 𝟙
    pop[⊢⋆] : ∀ {Ξ A Γ} → (Γ [⊢⋆] Ξ , A) ≡ (Γ [⊢⋆] Ξ × Γ [⊢] A)

  infix 3 _[⊢]⋆_
  _[⊢]⋆_ : Cx Ty → Cx Ty → Set
  Γ [⊢]⋆ ∅     = 𝟙
  Γ [⊢]⋆ Ξ , A = Γ [⊢]⋆ Ξ × Γ [⊢] A

  [⊢⋆]→[⊢]⋆ : ∀ {Ξ Γ} → Γ [⊢⋆] Ξ → Γ [⊢]⋆ Ξ
  [⊢⋆]→[⊢]⋆ {∅}     {Γ} ts = ∙
  [⊢⋆]→[⊢]⋆ {Ξ , A} {Γ} ts rewrite pop[⊢⋆] {Ξ} {A} {Γ} = [⊢⋆]→[⊢]⋆ (π₁ ts) , π₂ ts

  [⊢]⋆→[⊢⋆] : ∀ {Ξ Γ} → Γ [⊢]⋆ Ξ → Γ [⊢⋆] Ξ
  [⊢]⋆→[⊢⋆] {∅}     {Γ} ∙        rewrite top[⊢⋆] {Γ}         = ∙
  [⊢]⋆→[⊢⋆] {Ξ , A} {Γ} (ts , t) rewrite pop[⊢⋆] {Ξ} {A} {Γ} = [⊢]⋆→[⊢⋆] ts , t

open Model {{…}} public

-- Forcing in a particular model.

module _ {{_ : Model}} where
  infix 3 _⊩_
  _⊩_ : Cx Ty → Ty → Set
  Γ ⊩ α P   = Γ ⊩ᵅ P
  Γ ⊩ A ▻ B = ∀ {Γ′} → Γ ⊆ Γ′ → Γ′ ⊩ A → Γ′ ⊩ B
  Γ ⊩ □ A   = ∀ {Γ′} → Γ ⊆ Γ′ → Glue (Γ′ [⊢] □ A) (Γ′ ⊩ A)
  Γ ⊩ A ∧ B = Γ ⊩ A × Γ ⊩ B
  Γ ⊩ ⊤    = 𝟙

  infix 3 _⊩⋆_
  _⊩⋆_ : Cx Ty → Cx Ty → Set
  Γ ⊩⋆ ∅     = 𝟙
  Γ ⊩⋆ Ξ , A = Γ ⊩⋆ Ξ × Γ ⊩ A

-- Monotonicity with respect to context inclusion.

module _ {{_ : Model}} where
  mono⊩ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊩ A → Γ′ ⊩ A
  mono⊩ {α P}   η s = mono⊩ᵅ η s
  mono⊩ {A ▻ B} η s = λ η′ → s (trans⊆ η η′)
  mono⊩ {□ A}   η s = λ η′ → s (trans⊆ η η′)
  mono⊩ {A ∧ B} η s = mono⊩ {A} η (π₁ s) , mono⊩ {B} η (π₂ s)
  mono⊩ {⊤}    η s = ∙

  mono⊩⋆ : ∀ {Ξ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊩⋆ Ξ → Γ′ ⊩⋆ Ξ
  mono⊩⋆ {∅}     η ∙        = ∙
  mono⊩⋆ {Ξ , A} η (ts , t) = mono⊩⋆ {Ξ} η ts , mono⊩ {A} η t

-- Shorthand for variables.

module _ {{_ : Model}} where
  [v₀] : ∀ {A Γ} → Γ , A [⊢] A
  [v₀] = [var] i₀

  [v₁] : ∀ {A B Γ} → Γ , A , B [⊢] A
  [v₁] = [var] i₁

  [v₂] : ∀ {A B C Γ} → Γ , A , B , C [⊢] A
  [v₂] = [var] i₂

-- Useful theorems in functional form.

module _ {{_ : Model}} where
  [multicut] : ∀ {Ξ A Γ} → Γ [⊢]⋆ Ξ → Ξ [⊢] A → Γ [⊢] A
  [multicut] {∅}     ∙        u = mono[⊢] bot⊆ u
  [multicut] {Ξ , B} (ts , t) u = [app] ([multicut] ts ([lam] u)) t

  [dist] : ∀ {A B Γ} → Γ [⊢] □ (A ▻ B) → Γ [⊢] □ A → Γ [⊢] □ B
  [dist] t u = [multibox] ([⊢]⋆→[⊢⋆] ((∙ , t) , u)) ([app] ([down] [v₁]) ([down] [v₀]))

  [up] : ∀ {A Γ} → Γ [⊢] □ A → Γ [⊢] □ □ A
  [up] t = [multibox] ([⊢]⋆→[⊢⋆] ((∙ , t))) [v₀]

-- Additional useful equipment.

module _ {{_ : Model}} where

  _⟪$⟫_ : ∀ {A B Γ} → Γ ⊩ A ▻ B → Γ ⊩ A → Γ ⊩ B
  s ⟪$⟫ a = s refl⊆ a

  ⟪K⟫ : ∀ {A B Γ} → Γ ⊩ A → Γ ⊩ B ▻ A
  ⟪K⟫ {A} a η = K (mono⊩ {A} η a)

  ⟪S⟫ : ∀ {A B C Γ} → Γ ⊩ A ▻ B ▻ C → Γ ⊩ A ▻ B → Γ ⊩ A → Γ ⊩ C
  ⟪S⟫ {A} {B} {C} s₁ s₂ a = _⟪$⟫_ {B} {C} (_⟪$⟫_ {A} {B ▻ C} s₁ a) (_⟪$⟫_ {A} {B} s₂ a)

  ⟪S⟫′ : ∀ {A B C Γ} → Γ ⊩ A ▻ B ▻ C → Γ ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ {A} {B} {C} s₁ η s₂ η′ a = let s₁′ = mono⊩ {A ▻ B ▻ C} (trans⊆ η η′) s₁
                                      s₂′ = mono⊩ {A ▻ B} η′ s₂
                                  in  ⟪S⟫ {A} {B} {C} s₁′ s₂′ a

  _⟪D⟫_ : ∀ {A B Γ} → Γ ⊩ □ (A ▻ B) → Γ ⊩ □ A → Γ ⊩ □ B
  _⟪D⟫_ {A} {B} s₁ s₂ η = let t ⅋ s₁′ = s₁ η
                              u ⅋ a   = s₂ η
                          in  [dist] t u ⅋ _⟪$⟫_ {A} {B} s₁′ a

  _⟪D⟫′_ : ∀ {A B Γ} → Γ ⊩ □ (A ▻ B) → Γ ⊩ □ A ▻ □ B
  _⟪D⟫′_ {A} {B} s₁ η = _⟪D⟫_ (mono⊩ {□ (A ▻ B)} η s₁)

  ⟪↑⟫ : ∀ {A Γ} → Γ ⊩ □ A → Γ ⊩ □ □ A
  ⟪↑⟫ s η = [up] (syn (s η)) ⅋ λ η′ → s (trans⊆ η η′)

  ⟪↓⟫ : ∀ {A Γ} → Γ ⊩ □ A → Γ ⊩ A
  ⟪↓⟫ s = sem (s refl⊆)

  _⟪,⟫′_ : ∀ {A B Γ} → Γ ⊩ A → Γ ⊩ B ▻ A ∧ B
  _⟪,⟫′_ {A} {B} a η = _,_ (mono⊩ {A} η a)

-- Forcing in a particular world of a particular model, for sequents.

module _ {{_ : Model}} where
  infix 3 _⊩_⇒_
  _⊩_⇒_ : Cx Ty → Cx Ty → Ty → Set
  w ⊩ Γ ⇒ A = w ⊩⋆ Γ → w ⊩ A

  infix 3 _⊩_⇒⋆_
  _⊩_⇒⋆_ : Cx Ty → Cx Ty → Cx Ty → Set
  w ⊩ Γ ⇒⋆ Ξ = w ⊩⋆ Γ → w ⊩⋆ Ξ

-- Entailment, or forcing in all models, for sequents.

infix 3 _⊨_
_⊨_ : Cx Ty → Ty → Set₁
Γ ⊨ A = ∀ {{_ : Model}} {w : Cx Ty} → w ⊩ Γ ⇒ A

infix 3 _⊨⋆_
_⊨⋆_ : Cx Ty → Cx Ty → Set₁
Γ ⊨⋆ Ξ = ∀ {{_ : Model}} {w : Cx Ty} → w ⊩ Γ ⇒⋆ Ξ

-- Additional useful equipment, for sequents.

module _ {{_ : Model}} where
  lookup : ∀ {A Γ w} → A ∈ Γ → w ⊩ Γ ⇒ A
  lookup top     (γ , a) = a
  lookup (pop i) (γ , b) = lookup i γ

  _⟦$⟧_ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A ▻ B → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ B
  _⟦$⟧_ {A} {B} s₁ s₂ γ = _⟪$⟫_ {A} {B} (s₁ γ) (s₂ γ)

  ⟦K⟧ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ B ▻ A
  ⟦K⟧ {A} {B} a γ = ⟪K⟫ {A} {B} (a γ)

  ⟦S⟧ : ∀ {A B C Γ w} → w ⊩ Γ ⇒ A ▻ B ▻ C → w ⊩ Γ ⇒ A ▻ B → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ C
  ⟦S⟧ {A} {B} {C} s₁ s₂ a γ = ⟪S⟫ {A} {B} {C} (s₁ γ) (s₂ γ) (a γ)

  _⟦D⟧_ : ∀ {A B Γ w} → w ⊩ Γ ⇒ □ (A ▻ B) → w ⊩ Γ ⇒ □ A → w ⊩ Γ ⇒ □ B
  (s₁ ⟦D⟧ s₂) γ = (s₁ γ) ⟪D⟫ (s₂ γ)

  ⟦↑⟧ : ∀ {A Γ w} → w ⊩ Γ ⇒ □ A → w ⊩ Γ ⇒ □ □ A
  ⟦↑⟧ s γ = ⟪↑⟫ (s γ)

  ⟦↓⟧ : ∀ {A Γ w} → w ⊩ Γ ⇒ □ A → w ⊩ Γ ⇒ A
  ⟦↓⟧ s γ = ⟪↓⟫ (s γ)

  _⟦,⟧_ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ B → w ⊩ Γ ⇒ A ∧ B
  (a ⟦,⟧ b) γ = a γ , b γ

  ⟦π₁⟧ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A ∧ B → w ⊩ Γ ⇒ A
  ⟦π₁⟧ s γ = π₁ (s γ)

  ⟦π₂⟧ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A ∧ B → w ⊩ Γ ⇒ B
  ⟦π₂⟧ s γ = π₂ (s γ)


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

module MidiEvent where

open import Data.Fin     using (Fin; #_)
open import Data.List    using (List; _∷_; []; concat; map)
open import Data.Nat     using (ℕ; _+_; _⊔_)
open import Data.Product using (_×_; _,_; proj₁)
open import Data.String  using (String)
open import Data.Vec     using (toList)
open import Function     using (_∘_)

open import Music        using (Melody; melody; Counterpoint; cp; Harmony; melody→notes; harmony→counterpoint)
open import Note         using (Note; tone; rest; duration)
open import Pitch        using (Pitch)

-- General MIDI instrument numbers range from 1 to 128,
-- so this is the actual instrument number minus 1.
InstrumentNumber-1 : Set
InstrumentNumber-1 = Fin 128

Tick : Set
Tick = ℕ

Velocity : Set
Velocity  = Fin 128

defaultVelocity : Velocity
defaultVelocity = # 60

-- percussion is channel 10, so 9 as Channel-1
Channel-1 : Set
Channel-1 = Fin 16

-- in bpm
Tempo : Set
Tempo = ℕ

record MidiEvent : Set where
  constructor midiEvent
  field
    pitch            : Pitch -- Pitch was defined to correspond to MIDI pitch
    start            : Tick
    stop             : Tick
    velocity         : Velocity

record MidiTrack : Set where
  constructor track
  field
    trackName        : String
    instrumentNumber : InstrumentNumber-1
    channel          : Channel-1
    tempo            : Tempo -- initial tempo
    events           : List MidiEvent

notes→events : Velocity → List Note → List MidiEvent
notes→events v ns = me 0 ns where
  me : Tick → List Note → List MidiEvent
  me t [] = []
  me t (tone (duration d) p ∷ ns) = midiEvent p t (t + d) v ∷ me (t + d) ns
  me t (rest (duration d)   ∷ ns) = me (t + d) ns

melody→events : {n : ℕ} → Velocity → Melody n → List MidiEvent
melody→events v = notes→events v ∘ melody→notes

counterpoint→events : {v d : ℕ} → Velocity → Counterpoint v d → List MidiEvent
counterpoint→events v (cp ms) = concat (map (melody→events v) (toList ms))

harmony→events : {v d : ℕ} → Velocity → Harmony v d → List MidiEvent
harmony→events v = counterpoint→events v ∘ harmony→counterpoint


module Generic.Lib.Data.Maybe where

open import Data.Maybe.Base using (Maybe; just; nothing; maybe; maybe′; from-just; fromMaybe) public

open import Generic.Lib.Intro
open import Generic.Lib.Category

infixr 0 _?>_

instance
  MaybeMonad : ∀ {α} -> RawMonad {α} Maybe
  MaybeMonad = record
    { return = just
    ; _>>=_  = Data.Maybe.Base._>>=_
    }

  MaybeApplicative : ∀ {α} -> RawApplicative {α} Maybe
  MaybeApplicative = rawIApplicative

  MaybeFunctor : ∀ {α} -> RawFunctor {α} Maybe
  MaybeFunctor = rawFunctor

_?>_ : ∀ {α} {A : Set α} -> Bool -> A -> Maybe A
true  ?> x = just x
false ?> x = nothing


open import Agda.Primitive
open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality

record R {A : Set} {B : A → Set} p@ab : Set where
  field
    prf : p ≡ p


-- Andreas, 2014-01-09, illegal double hiding info in typed bindings.

postulate
  ok  : ({A} : Set) → Set
  bad : {{A} : Set} → Set


module Issue784.Transformer where

open import Data.List using (List; []; _∷_; _++_; [_]; filter) renaming (map to mapL)
import Level

open import Issue784.Values
open import Issue784.Context

Transformer : ∀ {ℓ} → NonRepetitiveTypes ℓ → NonRepetitiveTypes ℓ → Set (Level.suc ℓ)
Transformer {ℓ} (t-in , nr-in) (t-out , nr-out) =
  (v : Context ℓ) → NonRepetitiveContext v → t-in ⊆ signature v → NonRepetitive (ctxnames v ∖ names t-in ∪ names t-out) →
  Σ[ w ∈ Context ℓ ] signature w ≋ signature v ∖∖ names t-in ∪ t-out

pipe : ∀ {ℓ} {t-in₁ t-out₁ t-in₂ t-out₂ : Types ℓ} {nr-in₁ nr-out₁ nr-in₂ nr-out₂} →
       Transformer (t-in₁ , nr-in₁) (t-out₁ , nr-out₁) →
       Transformer (t-in₂ , nr-in₂) (t-out₂ , nr-out₂) →
       let n-out₁ = names t-out₁
           n-in₂ = names t-in₂
           t-in = t-in₁ ∪ (t-in₂ ∖∖ n-out₁)
           t-out = t-out₁ ∖∖ n-in₂ ∪ t-out₂
       in
       filter-∈ t-out₁ n-in₂ ≋ filter-∈ t-in₂ n-out₁ →
       (nr-in : NonRepetitiveNames t-in) (nr-out : NonRepetitiveNames t-out) →
       Transformer (t-in , nr-in) (t-out , nr-out)
pipe {ℓ} {t-in₁} {t-out₁} {t-in₂} {t-out₂} {nr-in₁} {nr-out₁} {nr-in₂} {nr-out₂} tr₁ tr₂ pr-t nr-in nr-out = tr where
    n-in₁ = names t-in₁
    n-out₁ = names t-out₁
    n-in₂ = names t-in₂
    n-out₂ = names t-out₂

    t-in = t-in₁ ∪ (t-in₂ ∖∖ n-out₁)
    t-out = (t-out₁ ∖∖ n-in₂) ∪ t-out₂

    tr : Transformer (t-in , nr-in) (t-out , nr-out)
    tr ctx nr-v t-ì⊆v nr-ò = context w , w≋out where
        v = Context.get ctx
        n-in = names t-in
        v̀ = filter-∈ v n-in
        nr-v̀ : NonRepetitiveNames v̀
        nr-v̀ = nr-x⇒nr-x∩y nr-v n-in

        v̀≋i : types v̀ ≋ t-in
        v̀≋i = ≋-sym $ ≋-trans p₁ p₂ where
            p₁ : t-in ≋ filter-∈ (types v) n-in
            p₁ = t₁⊆t₂⇒t₁≋f∈-t₂-nt₁ nr-in (≡-elim′ NonRepetitive (≡-sym $ n-types v) nr-v) t-ì⊆v
            p₂ : filter-∈ (types v) n-in ≋ types v̀
            p₂ = ≡⇒≋ $ ≡-sym $ t-filter-∈ v n-in

        -- transformer₁
        i₁⊆v̀ : t-in₁ ⊆ types v̀
        i₁⊆v̀ = x⊆y≋z (x⊆x∪y t-in₁ (t-in₂ ∖∖ n-out₁)) (≋-sym v̀≋i)

        v̀∖i₁∪o₁≋i₂∖o₁∪o₁ : types v̀ ∖∖ n-in₁ ∪ t-out₁ ≋ t-in₂ ∖∖ n-out₁ ∪ t-out₁
        v̀∖i₁∪o₁≋i₂∖o₁∪o₁ = x≋x̀⇒x∪y≋x̀∪y p₂ t-out₁ where
            p₁ : NonRepetitiveNames (types v̀)
            p₁ = nr-x≋y (≡⇒≋ $ ≡-sym $ n-types v̀) nr-v̀
            p₂ : types v̀ ∖∖ n-in₁ ≋ t-in₂ ∖∖ n-out₁
            p₂ = t≋t₁∪t₂⇒t∖t₁≋t₂ p₁ t-in₁ (t-in₂ ∖∖ n-out₁) v̀≋i

        n-v̀∖i₁∪o₁≋i₂∖o₁∪o₁ : names v̀ ∖ n-in₁ ∪ n-out₁ ≋ n-in₂ ∖ n-out₁ ∪ n-out₁
        n-v̀∖i₁∪o₁≋i₂∖o₁∪o₁ = x≋x̀⇒x∪y≋x̀∪y p₃ n-out₁ where
            p₁ : names v̀ ≋ n-in
            p₁ = ≋-trans (≡⇒≋ $ n-filter-∈ v n-in) (y⊆x⇒x∩y≋y nr-in nr-v (≡-elim′ (λ x → n-in ⊆ x) (n-types v) (x⊆y⇒nx⊆ny t-ì⊆v)))
            p₂ : n-in ≋ n-in₁ ∪ (n-in₂ ∖ n-out₁)
            p₂ = ≡⇒≋ $ ≡-trans (n-x∪y t-in₁ $ t-in₂ ∖∖ n-out₁) (≡-cong (λ x → n-in₁ ∪ x) (n-x∖y t-in₂ n-out₁))
            p₃ : names v̀ ∖ n-in₁ ≋ n-in₂ ∖ n-out₁
            p₃ = x≋y∪z⇒x∖y≋z (nr-x≋y (≋-sym p₁) nr-in) n-in₁ (n-in₂ ∖ n-out₁) (≋-trans p₁ p₂)

        nr-v̀∖i₁∪o₁ : NonRepetitive (names v̀ ∖ n-in₁ ∪ n-out₁)
        nr-v̀∖i₁∪o₁ = nr-x≋y (≋-sym n-v̀∖i₁∪o₁≋i₂∖o₁∪o₁) p₁ where
            p₁ : NonRepetitive (n-in₂ ∖ n-out₁ ∪ n-out₁)
            p₁ = nr-x∖y∪y nr-in₂ nr-out₁

        w-all₁ : Σ[ w ∈ Context ℓ ] signature w ≋ signature (context v̀) ∖∖ names t-in₁ ∪ t-out₁
        w-all₁ = tr₁ (context v̀) nr-v̀ i₁⊆v̀ nr-v̀∖i₁∪o₁

        w₁ = Context.get $ proj₁ w-all₁
        w₁≋v̀∖i₁∪o₁ = proj₂ w-all₁

        -- transformer₂
        n-w₁≋v̀∖i₁∪o₁ : names w₁ ≋ names v̀ ∖ names t-in₁ ∪ names t-out₁
        n-w₁≋v̀∖i₁∪o₁ = ≡-elim p₆ p₅ where
            p₁ : names (types w₁) ≋ names (types v̀ ∖∖ names t-in₁ ∪ t-out₁)
            p₁ = n-x≋y w₁≋v̀∖i₁∪o₁
            p₂ : names (types v̀ ∖∖ names t-in₁ ∪ t-out₁) ≡ names (types v̀ ∖∖ names t-in₁) ∪ names t-out₁
            p₂ = n-x∪y (types v̀ ∖∖ names t-in₁) t-out₁
            p₃ : names (types v̀ ∖∖ names t-in₁) ≡ names (types v̀) ∖ names t-in₁
            p₃ = n-x∖y (types v̀) (names t-in₁)
            p₄ : names (types w₁) ≋ names (types v̀ ∖∖ names t-in₁) ∪ names t-out₁
            p₄ = ≡-elim′ (λ x → names (types w₁) ≋ x) p₂ p₁
            p₅ : names (types w₁) ≋ names (types v̀) ∖ names t-in₁ ∪ names t-out₁
            p₅ = ≡-elim′ (λ x → names (types w₁) ≋ x ∪ names t-out₁) p₃ p₄
            p₆ : (names (types w₁) ≋ names (types v̀) ∖ names t-in₁ ∪ names t-out₁) ≡
                 (names w₁ ≋ names v̀ ∖ names t-in₁ ∪ names t-out₁)
            p₆ = ≡-cong₂ (λ x y → x ≋ y ∖ names t-in₁ ∪ names t-out₁) (n-types w₁) (n-types v̀)

        nr-w₁ : NonRepetitiveNames w₁
        nr-w₁ = nr-x≋y (≋-sym n-w₁≋v̀∖i₁∪o₁) nr-v̀∖i₁∪o₁

        i₂⊆w₁ : t-in₂ ⊆ types w₁
        i₂⊆w₁ = x⊆y≋z (x≋y⊆z (≋-sym p₁) p₄) (≋-sym w₁≋v̀∖i₁∪o₁) where
            p₁ : t-in₂ ≋ (t-in₂ ∖∖ n-out₁) ∪ filter-∈ t-in₂ n-out₁
            p₁ = t≋t∖n∪t∩n t-in₂ n-out₁
            p₂ : filter-∈ t-in₂ n-out₁ ⊆ t-out₁
            p₂ = x≋y⊆z pr-t $ x∩y⊆x t-out₁ n-in₂
            p₃ : types v̀ ∖∖ n-in₁ ≋ t-in₂ ∖∖ n-out₁
            p₃ = t≋t₁∪t₂⇒t∖t₁≋t₂ (≡-elim′ NonRepetitive (≡-sym $ n-types v̀) nr-v̀) t-in₁ (t-in₂ ∖∖ n-out₁) v̀≋i
            p₄ : (t-in₂ ∖∖ n-out₁) ∪ (filter-∈ t-in₂ n-out₁) ⊆ (types v̀ ∖∖ n-in₁) ∪ t-out₁
            p₄ = x∪y⊆x̀∪ỳ (≋⇒⊆ $ ≋-sym p₃) p₂

        w₁∖i₂∪o₂≋out : types w₁ ∖∖ n-in₂ ∪ t-out₂ ≋ t-out
        w₁∖i₂∪o₂≋out = x≋x̀⇒x∪y≋x̀∪y p₄ t-out₂ where
            p₁ : t-in₂ ∖∖ n-out₁ ∪ t-out₁ ≋ t-out₁ ∖∖ n-in₂ ∪ t-in₂
            p₁ = ≋-sym $ x∖y∪y≋y∖x∪x t-out₁ t-in₂ pr-t
            p₂ : (t-out₁ ∖∖ n-in₂) ∪ t-in₂ ≋ t-in₂ ∪ (t-out₁ ∖∖ n-in₂)
            p₂ = ∪-sym (t-out₁ ∖∖ n-in₂) t-in₂
            p₃ : types w₁ ≋ t-in₂ ∪ (t-out₁ ∖∖ n-in₂)
            p₃ = ≋-trans w₁≋v̀∖i₁∪o₁ $ ≋-trans v̀∖i₁∪o₁≋i₂∖o₁∪o₁ $ ≋-trans p₁ p₂
            p₄ : types w₁ ∖∖ n-in₂ ≋ t-out₁ ∖∖ n-in₂
            p₄ = t≋t₁∪t₂⇒t∖t₁≋t₂ (nr-x≋y (≡⇒≋ $ ≡-sym $ n-types w₁) nr-w₁) t-in₂ (t-out₁ ∖∖ n-in₂) p₃

        nr-w₁∖i₂∪o₂ : NonRepetitive (names w₁ ∖ n-in₂ ∪ n-out₂)
        nr-w₁∖i₂∪o₂ = ≡-elim′ NonRepetitive p₄ p₅ where
            p₁ : names (types w₁ ∖∖ n-in₂ ∪ t-out₂) ≡ names (types w₁ ∖∖ n-in₂) ∪ n-out₂
            p₁ = n-x∪y (types w₁ ∖∖ n-in₂) t-out₂
            p₂ : names (types w₁ ∖∖ n-in₂) ∪ n-out₂ ≡ (names (types w₁) ∖ n-in₂) ∪ n-out₂
            p₂ = ≡-cong (λ x → x ∪ names t-out₂) (n-x∖y (types w₁) n-in₂)
            p₃ : (names (types w₁) ∖ n-in₂) ∪ n-out₂ ≡ names w₁ ∖ n-in₂ ∪ n-out₂
            p₃ = ≡-cong (λ x → x ∖ n-in₂ ∪ n-out₂) (n-types w₁)
            p₄ : names (types w₁ ∖∖ n-in₂ ∪ t-out₂) ≡ names w₁ ∖ n-in₂ ∪ n-out₂
            p₄ = ≡-trans p₁ $ ≡-trans p₂ p₃
            p₅ : NonRepetitiveNames (types w₁ ∖∖ n-in₂ ∪ t-out₂)
            p₅ = nr-x≋y (≋-sym $ n-x≋y w₁∖i₂∪o₂≋out) nr-out

        w-all₂ : Σ[ w ∈ Context ℓ ] signature w ≋ signature (context w₁) ∖∖ names t-in₂ ∪ t-out₂
        w-all₂ = tr₂ (context w₁) nr-w₁ i₂⊆w₁ nr-w₁∖i₂∪o₂

        w₂ = Context.get $ proj₁ w-all₂
        w₂≋out : types w₂ ≋ t-out
        w₂≋out = ≋-trans (proj₂ w-all₂) w₁∖i₂∪o₂≋out

        w =  Values ℓ ∋ v ∖∖ n-in ∪ w₂
        w≋out : types w ≋ types v ∖∖ n-in ∪ t-out
        w≋out = ≋-trans (≡⇒≋ p₁) p₂ where
            p₁ : types (v ∖∖ n-in ∪ w₂) ≡ types v ∖∖ n-in ∪ types w₂
            p₁ = ≡-trans (t-x∪y (v ∖∖ n-in) w₂) (≡-cong (λ x → x ∪ types w₂) (t-x∖y v n-in))
            p₂ : types v ∖∖ n-in ∪ types w₂ ≋ types v ∖∖ n-in ∪ t-out
            p₂ = y≋ỳ⇒x∪y≋x∪ỳ (types v ∖∖ n-in) w₂≋out

Transformer! : ∀ {ℓ} (t-in : Types ℓ) (t-out : Types ℓ) {nr!-in : NonRepetitiveNames! t-in} {nr!-out : NonRepetitiveNames! t-out} → Set (Level.suc ℓ)
Transformer! t-in t-out {nr!-in = nr!-in} {nr!-out} = Transformer (t-in , s-nr!⇒nr nr!-in) (t-out , s-nr!⇒nr nr!-out)

infix 1 _:=_
_:=_ : ∀ {ℓ} {A : String → Set ℓ} (n : String) → ((n : String) → A n) → A n
n := f = f n

infixl 0 _⇒⟦_⟧⇒_
_⇒⟦_⟧⇒_ : ∀ {ℓ} {t-in₁ t-out₁ t-in₂ t-out₂ : Types ℓ}
          {nr!-in₁ : NonRepetitiveNames! t-in₁}
          {nr!-out₁ : NonRepetitiveNames! t-out₁}
          {nr!-in₂ : NonRepetitiveNames! t-in₂}
          {nr!-out₂ : NonRepetitiveNames! t-out₂} →
       Transformer (t-in₁ , s-nr!⇒nr nr!-in₁) (t-out₁ , s-nr!⇒nr nr!-out₁) →

       let n-out₁ = names t-out₁
           n-in₂ = names t-in₂
           t-in = t-in₁ ∪ (t-in₂ ∖∖ n-out₁)
           t-out = t-out₁ ∖∖ n-in₂ ∪ t-out₂
       in
       filter-∈ t-out₁ n-in₂ ≋ filter-∈ t-in₂ n-out₁ →
       {nr!-in : NonRepetitiveNames! t-in} →
       {nr!-out : NonRepetitiveNames! t-out} →

       Transformer (t-in₂ , s-nr!⇒nr nr!-in₂) (t-out₂ , s-nr!⇒nr nr!-out₂) →
       Transformer (t-in , s-nr!⇒nr nr!-in) (t-out , s-nr!⇒nr nr!-out)

_⇒⟦_⟧⇒_ {nr!-in₁ = nr!-in₁} {nr!-out₁ = nr!-out₁} {nr!-in₂ = nr!-in₂} {nr!-out₂ = nr!-out₂}
        tr₁ f≋f {nr!-in = nr!-in} {nr!-out = nr!-out} tr₂ =
    pipe {nr-in₁ = s-nr!⇒nr nr!-in₁} {nr-out₁ = s-nr!⇒nr nr!-out₁} {nr-in₂ = s-nr!⇒nr nr!-in₂} {nr-out₂ = s-nr!⇒nr nr!-out₂}
        tr₁ tr₂ f≋f (s-nr!⇒nr nr!-in) (s-nr!⇒nr nr!-out)

record Pure {ℓ} (A : Set ℓ) : Set ℓ where
    constructor pure
    field get : A

record Unique {ℓ} (A : Set ℓ) : Set ℓ where
    constructor unique
    field get : A

extract : ∀ {ℓ} {n : String} {A : Set ℓ} → let t = [ (n , Pure A) ] in {nr!-t : NonRepetitiveNames! t} → Transformer ([] , []) (t , s-nr!⇒nr nr!-t) → A
extract {n = n} {A = A} {nr!-t = nr!-t} tr =
  let e = n , Pure A
      v , t-v≋t = (Σ[ v ∈ Context _ ] signature v ≋ [ e ]) ∋ tr (context []) [] (≋⇒⊆ refl) (s-nr!⇒nr nr!-t)
  in Pure.get ∘ getBySignature $ a∈x⇒x≋y⇒a∈y (e ∈ [ e ] ∋ here refl) (≋-sym t-v≋t)


------------------------------------------------------------------------
-- Untyped hereditary substitution in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Syntax.HereditarySubstitution where

open import Data.Fin using (Fin; zero; suc)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Nat using (zero; suc)
open import Data.List using ([]; _∷_; _++_)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε)
open import Relation.Binary.PropositionalEquality as P hiding ([_])

open import FOmegaInt.Reduction.Full
open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution

open Syntax

----------------------------------------------------------------------
-- Untyped hereditary substitution.

infixl 9 _?∙∙⟨_⟩_ _∙∙⟨_⟩_ _⌜·⌝⟨_⟩_ _↓⌜·⌝_
infixl 8 _/⟨_⟩_ _//⟨_⟩_ _Kind/⟨_⟩_ _Asc/⟨_⟩_

-- TODO: explain why there are degenerate cases.
mutual

  -- Apply a herediary substition to an elimination, kind or spine.

  _/⟨_⟩_ : ∀ {m n} → Elim m → SKind → SVSub m n → Elim n
  var x   ∙ as /⟨ k ⟩ σ = lookupSV σ x ?∙∙⟨ k ⟩ (as //⟨ k ⟩ σ)
  ⊥       ∙ as /⟨ k ⟩ σ = ⊥ ∙ (as //⟨ k ⟩ σ)
  ⊤       ∙ as /⟨ k ⟩ σ = ⊤ ∙ (as //⟨ k ⟩ σ)
  Π j a   ∙ as /⟨ k ⟩ σ = Π (j Kind/⟨ k ⟩ σ) (a /⟨ k ⟩ σ ↑) ∙ (as //⟨ k ⟩ σ)
  (a ⇒ b) ∙ as /⟨ k ⟩ σ = ((a /⟨ k ⟩ σ) ⇒ (b /⟨ k ⟩ σ))  ∙ (as //⟨ k ⟩ σ)
  Λ j a   ∙ as /⟨ k ⟩ σ = Λ (j Kind/⟨ k ⟩ σ) (a /⟨ k ⟩ σ ↑) ∙ (as //⟨ k ⟩ σ)
  ƛ a b   ∙ as /⟨ k ⟩ σ = ƛ (a /⟨ k ⟩ σ) (b /⟨ k ⟩ σ ↑) ∙ (as //⟨ k ⟩ σ)
  a ⊡ b   ∙ as /⟨ k ⟩ σ = (a /⟨ k ⟩ σ) ⊡ (b /⟨ k ⟩ σ)    ∙ (as //⟨ k ⟩ σ)

  _Kind/⟨_⟩_ : ∀ {m n} → Kind Elim m → SKind → SVSub m n → Kind Elim n
  (a ⋯ b) Kind/⟨ k ⟩ σ = (a /⟨ k ⟩ σ) ⋯ (b /⟨ k ⟩ σ)
  Π j₁ j₂   Kind/⟨ k ⟩ σ = Π (j₁ Kind/⟨ k ⟩ σ) (j₂ Kind/⟨ k ⟩ σ ↑)

  _//⟨_⟩_ : ∀ {m n} → Spine m → SKind → SVSub m n → Spine n
  []       //⟨ k ⟩ σ = []
  (a ∷ as) //⟨ k ⟩ σ = a /⟨ k ⟩ σ ∷ as //⟨ k ⟩ σ

  -- Apply a lookup-result to a spine, performing β-reduction if possible.

  _?∙∙⟨_⟩_ : ∀ {n} → SVRes n → SKind → Spine n → Elim n
  hit a  ?∙∙⟨ k ⟩ as = a  ∙∙⟨ k ⟩ as
  miss y ?∙∙⟨ k ⟩ as = var y ∙ as

  -- Apply an elimination to a spine, performing β-reduction if possible.
  --
  -- NOTE.  Degenerate cases are marked "!".

  _∙∙⟨_⟩_ : ∀ {n} → Elim n → SKind → Spine n → Elim n
  a ∙∙⟨ k ⟩     []       = a
  a ∙∙⟨ ★ ⟩     (b ∷ bs) = a ∙∙ (b ∷ bs)               -- ! a ill-kinded
  a ∙∙⟨ j ⇒ k ⟩ (b ∷ bs) = a ⌜·⌝⟨ j ⇒ k ⟩ b ∙∙⟨ k ⟩ bs

  -- Apply one elimination to another, performing β-reduction if possible.
  --
  -- NOTE.  Degenerate cases are marked "!".

  _⌜·⌝⟨_⟩_ : ∀ {n} → Elim n → SKind → Elim n → Elim n
  a              ⌜·⌝⟨ ★ ⟩     b = a ⌜·⌝ b              -- ! a ill-kinded
  (a ∙ (c ∷ cs)) ⌜·⌝⟨ j ⇒ k ⟩ b = a ∙ (c ∷ cs) ⌜·⌝ b   -- ! unless a = var x
  (Λ l a ∙ [])   ⌜·⌝⟨ j ⇒ k ⟩ b = a /⟨ j ⟩ (sub b)
  {-# CATCHALL #-}
  (a ∙ [])       ⌜·⌝⟨ j ⇒ k ⟩ b = a ∙ (b ∷ [])         -- ! unless a = var x

-- Apply a herediary substition to a kind or type ascription.

_Asc/⟨_⟩_ : ∀ {m n} → ElimAsc m → SKind → SVSub m n → ElimAsc n
kd j Asc/⟨ k ⟩ σ = kd (j Kind/⟨ k ⟩ σ)
tp a Asc/⟨ k ⟩ σ = tp (a /⟨ k ⟩ σ)

-- Some shorthands.

_[_∈_] : ∀ {n} → Elim (suc n) → Elim n → SKind → Elim n
a [ b ∈ k ] = a /⟨ k ⟩ sub b

_Kind[_∈_] : ∀ {n} → Kind Elim (suc n) → Elim n → SKind → Kind Elim n
j Kind[ a ∈ k ] = j Kind/⟨ k ⟩ sub a

-- A variant of application that is reducing (only) if the first
-- argument is a type abstraction.

_↓⌜·⌝_ : ∀ {n} → Elim n → Elim n → Elim n
(a ∙ (b ∷ bs)) ↓⌜·⌝ c = (a ∙ (b ∷ bs)) ⌜·⌝ c
(Λ k a ∙ [])   ↓⌜·⌝ b = a [ b ∈ ⌊ k ⌋ ]
{-# CATCHALL #-}
(a ∙ [])       ↓⌜·⌝ b = a ∙ (b ∷ [])

----------------------------------------------------------------------
-- Properties of (untyped) hereditary substitution.

-- Some exact lemmas about hereditary substitutions (up to
-- α-equality).

module _ where
  open SimpleCtx using (⌊_⌋Asc; kd; tp)

  -- Simplified kinds are stable under application of hereditary
  -- substitutions.

  ⌊⌋-Kind/⟨⟩ : ∀ {m n} (j : Kind Elim m) {k} {σ : SVSub m n} →
              ⌊ j Kind/⟨ k ⟩ σ ⌋ ≡ ⌊ j ⌋
  ⌊⌋-Kind/⟨⟩ (a ⋯ b) = refl
  ⌊⌋-Kind/⟨⟩ (Π j k) = cong₂ _⇒_ (⌊⌋-Kind/⟨⟩ j) (⌊⌋-Kind/⟨⟩ k)

  ⌊⌋-Asc/⟨⟩ : ∀ {m n} (a : ElimAsc m) {k} {σ : SVSub m n} →
             ⌊ a Asc/⟨ k ⟩ σ ⌋Asc ≡ ⌊ a ⌋Asc
  ⌊⌋-Asc/⟨⟩ (kd k) = cong kd (⌊⌋-Kind/⟨⟩ k)
  ⌊⌋-Asc/⟨⟩ (tp a) = refl

  -- Hereditary substitutions in spines commute with concatenation.

  ++-//⟨⟩ : ∀ {k m n} (as bs : Spine m) {σ : SVSub m n} →
            (as ++ bs) //⟨ k ⟩ σ ≡ as //⟨ k ⟩ σ ++ bs //⟨ k ⟩ σ
  ++-//⟨⟩ []       bs     = refl
  ++-//⟨⟩ (a ∷ as) bs {σ} = cong (a /⟨ _ ⟩ σ ∷_) (++-//⟨⟩ as bs)

  open Substitution using (_Elim/_; _Kind′/_; _//_)

  -- Hereditary substitutions and reducing applications at ★
  -- degenerate to ordinary substitutions and applications.

  mutual

    /⟨★⟩-/ : ∀ {m n} (a : Elim m) {σ : SVSub m n} →
             a /⟨ ★ ⟩ σ ≡ a Elim/ toSub σ
    /⟨★⟩-/ (var x   ∙ as) {σ} = begin
        lookupSV σ x ?∙∙⟨ ★ ⟩ (as //⟨ ★ ⟩ σ)
      ≡⟨ ?∙∙⟨★⟩-∙∙ (lookupSV σ x) ⟩
        toElim (lookupSV σ x) ∙∙ (as //⟨ ★ ⟩ σ)
      ≡⟨ cong₂ _∙∙_ (sym (⌜⌝∘⌞⌟-id _)) (//⟨★⟩-// as) ⟩
        ⌜ ⌞ toElim (lookupSV σ x) ⌟ ⌝ ∙∙ (as // toSub σ)
      ≡˘⟨ cong (_∙∙ _) (cong ⌜_⌝ (lookup-toSub σ x)) ⟩
        var x ∙ as Elim/ toSub σ
      ∎
      where open ≡-Reasoning
    /⟨★⟩-/ (⊥       ∙ as) = cong (⊥ ∙_) (//⟨★⟩-// as)
    /⟨★⟩-/ (⊤       ∙ as) = cong (⊤ ∙_) (//⟨★⟩-// as)
    /⟨★⟩-/ (Π k b   ∙ as) =
      cong₂ _∙_ (cong₂ Π (Kind/⟨★⟩-/ k) (/⟨★⟩-/ b)) (//⟨★⟩-// as)
    /⟨★⟩-/ ((b ⇒ c) ∙ as) =
      cong₂ _∙_ (cong₂ _⇒_ (/⟨★⟩-/ b) (/⟨★⟩-/ c)) (//⟨★⟩-// as)
    /⟨★⟩-/ (Λ k b   ∙ as) =
      cong₂ _∙_ (cong₂ Λ (Kind/⟨★⟩-/ k) (/⟨★⟩-/ b)) (//⟨★⟩-// as)
    /⟨★⟩-/ (ƛ b c   ∙ as) =
      cong₂ _∙_ (cong₂ ƛ (/⟨★⟩-/ b) (/⟨★⟩-/ c)) (//⟨★⟩-// as)
    /⟨★⟩-/ (b ⊡ c   ∙ as) =
      cong₂ _∙_ (cong₂ _⊡_ (/⟨★⟩-/ b) (/⟨★⟩-/ c)) (//⟨★⟩-// as)

    //⟨★⟩-// : ∀ {m n} (as : Spine m) {σ : SVSub m n} →
               as //⟨ ★ ⟩ σ ≡ as // toSub σ
    //⟨★⟩-// []       = refl
    //⟨★⟩-// (a ∷ as) = cong₂ _∷_ (/⟨★⟩-/ a) (//⟨★⟩-// as)

    Kind/⟨★⟩-/ : ∀ {m n} (k : Kind Elim m) {σ : SVSub m n} →
                 k Kind/⟨ ★ ⟩ σ ≡ k Kind′/ toSub σ
    Kind/⟨★⟩-/ (a ⋯ b) = cong₂ _⋯_ (/⟨★⟩-/ a) (/⟨★⟩-/ b)
    Kind/⟨★⟩-/ (Π j k) = cong₂ Π (Kind/⟨★⟩-/ j) (Kind/⟨★⟩-/ k)

    ?∙∙⟨★⟩-∙∙ : ∀ {n} (r : SVRes n) {as} → r ?∙∙⟨ ★ ⟩ as ≡ toElim r ∙∙ as
    ?∙∙⟨★⟩-∙∙ (hit a)  = ∙∙⟨★⟩-∙∙ a
    ?∙∙⟨★⟩-∙∙ (miss y) = refl

    ∙∙⟨★⟩-∙∙ : ∀ {n} (a : Elim n) {bs} → a ∙∙⟨ ★ ⟩ bs ≡ a ∙∙ bs
    ∙∙⟨★⟩-∙∙ a {[]}     = sym (∙∙-[] a)
    ∙∙⟨★⟩-∙∙ a {b ∷ bs} = refl

module RenamingCommutes where
  open Substitution
    hiding (_↑; _↑⋆_; sub; _/Var_) renaming (_Elim/Var_ to _/Var_)
  open P.≡-Reasoning
  private
    module S = Substitution
    module V = VarSubst

  mutual

    -- Hereditary substitution commutes with renaming.
    --
    -- NOTE: this is a variant of the `sub-commutes' lemma from
    -- Data.Fin.Substitution.Lemmas adapted to hereditary
    -- substitutions and renaming.

    /⟨⟩-/Var-↑⋆ : ∀ i {m n} a k b {ρ : Sub Fin m n} →
                  b /⟨ k ⟩ sub a ↑⋆ i /Var ρ V.↑⋆ i ≡
                    b /Var (ρ V.↑) V.↑⋆ i /⟨ k ⟩ sub (a /Var ρ) ↑⋆ i
    /⟨⟩-/Var-↑⋆ i a k (var x ∙ bs) {ρ} = begin
        var x ∙ bs /⟨ k ⟩ sub a ↑⋆ i /Var ρ V.↑⋆ i
      ≡⟨⟩
        lookupSV (sub a ↑⋆ i) x ?∙∙⟨ k ⟩ (bs //⟨ k ⟩ sub a ↑⋆ i) /Var ρ V.↑⋆ i
      ≡⟨ ?∙∙⟨⟩-/Var (lookupSV (sub a ↑⋆ i) x) k (bs //⟨ k ⟩ sub a ↑⋆ i) ⟩
        (lookupSV (sub a ↑⋆ i) x ?/Var ρ V.↑⋆ i) ?∙∙⟨ k ⟩
          (bs //⟨ k ⟩ sub a ↑⋆ i //Var ρ V.↑⋆ i)
      ≡⟨ cong₂ _?∙∙⟨ k ⟩_ (lookup-sub-/Var-↑⋆ a i x) (//⟨⟩-/Var-↑⋆ i a k bs) ⟩
        lookupSV (sub (a /Var ρ) ↑⋆ i) (x V./ (ρ V.↑) V.↑⋆ i) ?∙∙⟨ k ⟩
          (bs //Var (ρ V.↑) V.↑⋆ i //⟨ k ⟩ sub (a /Var ρ) ↑⋆ i)
      ≡⟨⟩
        var x ∙ bs /Var (ρ V.↑) V.↑⋆ i /⟨ k ⟩ sub (a /Var ρ) ↑⋆ i
      ∎
    /⟨⟩-/Var-↑⋆ i a k (⊥     ∙ bs)   = cong (⊥ ∙_) (//⟨⟩-/Var-↑⋆ i a k bs)
    /⟨⟩-/Var-↑⋆ i a k (⊤     ∙ bs)   = cong (⊤ ∙_) (//⟨⟩-/Var-↑⋆ i a k bs)
    /⟨⟩-/Var-↑⋆ i a k (Π j b ∙ bs)   =
      cong₂ _∙_ (cong₂ Π (Kind/⟨⟩-/Var-↑⋆ i a k j) (/⟨⟩-/Var-↑⋆ (suc i) a k b))
                (//⟨⟩-/Var-↑⋆ i a k bs)
    /⟨⟩-/Var-↑⋆ i a k ((b ⇒ c) ∙ bs) =
      cong₂ _∙_ (cong₂ _⇒_ (/⟨⟩-/Var-↑⋆ i a k b) (/⟨⟩-/Var-↑⋆ i a k c))
                (//⟨⟩-/Var-↑⋆ i a k bs)
    /⟨⟩-/Var-↑⋆ i a k (Λ j b ∙ bs)   =
      cong₂ _∙_ (cong₂ Λ (Kind/⟨⟩-/Var-↑⋆ i a k j) (/⟨⟩-/Var-↑⋆ (suc i) a k b))
                (//⟨⟩-/Var-↑⋆ i a k bs)
    /⟨⟩-/Var-↑⋆ i a k (ƛ b c ∙ bs)   =
      cong₂ _∙_ (cong₂ ƛ (/⟨⟩-/Var-↑⋆ i a k b) (/⟨⟩-/Var-↑⋆ (suc i) a k c))
                (//⟨⟩-/Var-↑⋆ i a k bs)
    /⟨⟩-/Var-↑⋆ i a k (b ⊡ c ∙ bs)   =
      cong₂ _∙_ (cong₂ _⊡_ (/⟨⟩-/Var-↑⋆ i a k b) (/⟨⟩-/Var-↑⋆ i a k c))
                (//⟨⟩-/Var-↑⋆ i a k bs)

    Kind/⟨⟩-/Var-↑⋆ : ∀ i {m n} a k j {ρ : Sub Fin m n} →
                      j Kind/⟨ k ⟩ sub a ↑⋆ i Kind′/Var ρ V.↑⋆ i ≡
                        j Kind′/Var (ρ V.↑) V.↑⋆ i Kind/⟨ k ⟩ sub (a /Var ρ) ↑⋆ i
    Kind/⟨⟩-/Var-↑⋆ i a k (b ⋯ c) =
      cong₂ _⋯_ (/⟨⟩-/Var-↑⋆ i a k b) (/⟨⟩-/Var-↑⋆ i a k c)
    Kind/⟨⟩-/Var-↑⋆ i a k (Π j l) =
      cong₂ Π (Kind/⟨⟩-/Var-↑⋆ i a k j) (Kind/⟨⟩-/Var-↑⋆ (suc i) a k l)

    //⟨⟩-/Var-↑⋆ : ∀ i {n m} a k bs {ρ : Sub Fin m n} →
                   bs //⟨ k ⟩ sub a ↑⋆ i //Var ρ V.↑⋆ i ≡
                     (bs //Var (ρ V.↑) V.↑⋆ i) //⟨ k ⟩ sub (a /Var ρ) ↑⋆ i
    //⟨⟩-/Var-↑⋆ i a k []       = refl
    //⟨⟩-/Var-↑⋆ i a k (b ∷ bs) =
      cong₂ _∷_ (/⟨⟩-/Var-↑⋆ i a k b) (//⟨⟩-/Var-↑⋆ i a k bs)

    -- Reducing applications commute with renaming.

    ?∙∙⟨⟩-/Var : ∀ {m n} r k bs {ρ : Sub Fin m n} →
                 r ?∙∙⟨ k ⟩ bs /Var ρ ≡ (r ?/Var ρ) ?∙∙⟨ k ⟩ (bs //Var ρ)
    ?∙∙⟨⟩-/Var (hit a)  k as = ∙∙⟨⟩-/Var a k as
    ?∙∙⟨⟩-/Var (miss y) k as = refl

    ∙∙⟨⟩-/Var : ∀ {m n} a k bs {ρ : Sub Fin m n} →
                a ∙∙⟨ k ⟩ bs /Var ρ ≡ (a /Var ρ) ∙∙⟨ k ⟩ (bs //Var ρ)
    ∙∙⟨⟩-/Var a k       []           = refl
    ∙∙⟨⟩-/Var a ★       (b ∷ bs)     = S.∙∙-/Var a (b ∷ bs)
    ∙∙⟨⟩-/Var a (j ⇒ k) (b ∷ bs) {ρ} = begin
        a ⌜·⌝⟨ j ⇒ k ⟩ b ∙∙⟨ k ⟩ bs /Var ρ
      ≡⟨ ∙∙⟨⟩-/Var (a ⌜·⌝⟨ j ⇒ k ⟩ b) k bs ⟩
        (a ⌜·⌝⟨ j ⇒ k ⟩ b /Var ρ) ∙∙⟨ k ⟩ (bs //Var ρ)
      ≡⟨ cong (_∙∙⟨ k ⟩ (bs //Var ρ)) (⌜·⌝⟨⟩-/Var a (j ⇒ k) b) ⟩
        (a /Var ρ) ⌜·⌝⟨ j ⇒ k ⟩ (b /Var ρ) ∙∙⟨ k ⟩ (bs //Var ρ)
      ∎

    ⌜·⌝⟨⟩-/Var : ∀ {m n} a k b {ρ : Sub Fin m n} →
                 a ⌜·⌝⟨ k ⟩ b /Var ρ ≡ (a /Var ρ) ⌜·⌝⟨ k ⟩ (b /Var ρ)
    ⌜·⌝⟨⟩-/Var a ★                    b     = S.⌜·⌝-/Var a b
    ⌜·⌝⟨⟩-/Var (a ∙ (c ∷ cs)) (j ⇒ k) b {ρ} = begin
        a ∙ (c ∷ cs) ⌜·⌝ b /Var ρ
      ≡⟨ S.⌜·⌝-/Var (a ∙ (c ∷ cs)) b ⟩
        (a ∙ (c ∷ cs) /Var ρ) ⌜·⌝ (b /Var ρ)
      ≡˘⟨ cong (λ a → a ∙∙ _ ⌜·⌝ (b /Var ρ)) (S.Head/Var-∙ a) ⟩
        (a Head/Var ρ) ∙ ((c ∷ cs) //Var ρ) ⌜·⌝⟨ j ⇒ k ⟩ (b /Var ρ)
      ≡⟨ cong (λ a → a ∙∙ _ ⌜·⌝⟨ j ⇒ k ⟩ (b /Var ρ)) (S.Head/Var-∙ a) ⟩
        (a ∙ (c ∷ cs) /Var ρ) ⌜·⌝⟨ j ⇒ k ⟩ (b /Var ρ)
      ∎
    ⌜·⌝⟨⟩-/Var (var x   ∙ []) (j ⇒ k) b = refl
    ⌜·⌝⟨⟩-/Var (⊥       ∙ []) (j ⇒ k) b = refl
    ⌜·⌝⟨⟩-/Var (⊤       ∙ []) (j ⇒ k) b = refl
    ⌜·⌝⟨⟩-/Var (Π l a   ∙ []) (j ⇒ k) b = refl
    ⌜·⌝⟨⟩-/Var ((a ⇒ b) ∙ []) (j ⇒ k) c = refl
    ⌜·⌝⟨⟩-/Var (Λ l a   ∙ []) (j ⇒ k) b = /⟨⟩-/Var-↑⋆ 0 b j a
    ⌜·⌝⟨⟩-/Var (ƛ a b   ∙ []) (j ⇒ k) c = refl
    ⌜·⌝⟨⟩-/Var (a ⊡ b   ∙ []) (j ⇒ k) c = refl

  -- Some corollaries of the above.

  Asc/⟨⟩-/Var-↑⋆ : ∀ i {m n} a k b {ρ : Sub Fin m n} →
                   b Asc/⟨ k ⟩ sub a ↑⋆ i ElimAsc/Var ρ V.↑⋆ i ≡
                     b ElimAsc/Var (ρ V.↑) V.↑⋆ i Asc/⟨ k ⟩ sub (a /Var ρ) ↑⋆ i
  Asc/⟨⟩-/Var-↑⋆ i a k (kd j) = cong kd (Kind/⟨⟩-/Var-↑⋆ i a k j)
  Asc/⟨⟩-/Var-↑⋆ i a k (tp b) = cong tp (/⟨⟩-/Var-↑⋆ i a k b)

  [∈⌊⌋]-/Var : ∀ {m n} a b k {ρ : Sub Fin m n} →
               a [ b ∈ ⌊ k ⌋ ] /Var ρ ≡
                 (a /Var ρ V.↑) [ b /Var ρ ∈ ⌊ k Kind′/Var ρ ⌋ ]
  [∈⌊⌋]-/Var a b k {ρ} = begin
      (a [ b ∈ ⌊ k ⌋ ] /Var ρ)
    ≡⟨ /⟨⟩-/Var-↑⋆ 0 b ⌊ k ⌋ a ⟩
      ((a /Var ρ V.↑) [ b /Var ρ ∈ ⌊ k ⌋ ])
    ≡˘⟨ cong (a /Var ρ V.↑ /⟨_⟩ sub (b /Var ρ)) (S.⌊⌋-Kind′/Var k) ⟩
      ((a /Var ρ V.↑) [ b /Var ρ ∈ ⌊ k Kind′/Var ρ ⌋ ])
    ∎

  Kind[∈⌊⌋]-/Var : ∀ {m n} j a k {ρ : Sub Fin m n} →
                   j Kind[ a ∈ ⌊ k ⌋ ] Kind′/Var ρ ≡
                     (j Kind′/Var ρ V.↑) Kind[ a /Var ρ ∈ ⌊ k Kind′/Var ρ ⌋ ]
  Kind[∈⌊⌋]-/Var j a k {ρ} = begin
      j Kind[ a ∈ ⌊ k ⌋ ] Kind′/Var ρ
    ≡⟨ Kind/⟨⟩-/Var-↑⋆ 0 a ⌊ k ⌋ j ⟩
      (j Kind′/Var ρ V.↑) Kind[ a /Var ρ ∈ ⌊ k ⌋ ]
    ≡˘⟨ cong (j Kind′/Var ρ V.↑ Kind/⟨_⟩ sub (a /Var ρ)) (S.⌊⌋-Kind′/Var k) ⟩
      (j Kind′/Var ρ V.↑) Kind[ a /Var ρ ∈ ⌊ k Kind′/Var ρ ⌋ ]
    ∎

  -- Potentially reducing applications commute with renaming.

  ↓⌜·⌝-/Var : ∀ {m n} a b {ρ : Sub Fin m n} →
              a ↓⌜·⌝ b /Var ρ ≡ (a /Var ρ) ↓⌜·⌝ (b /Var ρ)
  ↓⌜·⌝-/Var (a ∙ (c ∷ cs)) b {ρ} = begin
      a ∙ (c ∷ cs) ⌜·⌝ b /Var ρ
    ≡⟨ S.⌜·⌝-/Var (a ∙ (c ∷ cs)) b ⟩
      (a ∙ (c ∷ cs) /Var ρ) ⌜·⌝ (b /Var ρ)
    ≡˘⟨ cong (λ a → a ∙∙ _ ⌜·⌝ (b /Var ρ)) (S.Head/Var-∙ a) ⟩
      (a Head/Var ρ) ∙ ((c ∷ cs) //Var ρ) ↓⌜·⌝ (b /Var ρ)
    ≡⟨ cong (λ a → a ∙∙ _ ↓⌜·⌝ (b /Var ρ)) (S.Head/Var-∙ a) ⟩
      (a ∙ (c ∷ cs) /Var ρ) ↓⌜·⌝ (b /Var ρ)
    ∎
  ↓⌜·⌝-/Var (var x   ∙ []) b = refl
  ↓⌜·⌝-/Var (⊥       ∙ []) b = refl
  ↓⌜·⌝-/Var (⊤       ∙ []) b = refl
  ↓⌜·⌝-/Var (Π l a   ∙ []) b = refl
  ↓⌜·⌝-/Var ((a ⇒ b) ∙ []) c = refl
  ↓⌜·⌝-/Var (Λ l a   ∙ []) b = [∈⌊⌋]-/Var a b l
  ↓⌜·⌝-/Var (ƛ a b   ∙ []) c = refl
  ↓⌜·⌝-/Var (a ⊡ b   ∙ []) c = refl

  mutual

    -- Weakening commutes with application of lifted hereditary
    -- substitutions.
    --
    -- NOTE: this is a variant of the `wk-commutes' lemma from
    -- Data.Fin.Substitution.Lemmas adapted to hereditary
    -- substitutions.

    wk-/⟨⟩-↑⋆ : ∀ i {k m n} a {σ : SVSub m n} →
                a /Var V.wk V.↑⋆ i /⟨ k ⟩ (σ ↑) ↑⋆ i ≡
                  a /⟨ k ⟩ σ ↑⋆ i /Var V.wk V.↑⋆ i
    wk-/⟨⟩-↑⋆ i {k} (var x ∙ as) {σ} = begin
        var x ∙ as /Var V.wk V.↑⋆ i /⟨ k ⟩ (σ ↑) ↑⋆ i
      ≡⟨⟩
        lookupSV ((σ ↑) ↑⋆ i) (x V./ V.wk V.↑⋆ i) ?∙∙⟨ k ⟩
          (as //Var V.wk V.↑⋆ i //⟨ k ⟩ ((σ ↑) ↑⋆ i))
      ≡⟨ (cong₂ (_?∙∙⟨ k ⟩_)) (sym (lookup-/Var-wk-↑⋆ i x)) (wk-//⟨⟩-↑⋆ i as) ⟩
        (lookupSV (σ ↑⋆ i) x ?/Var V.wk V.↑⋆ i) ?∙∙⟨ k ⟩
          (as //⟨ k ⟩ (σ ↑⋆ i) //Var V.wk V.↑⋆ i)
      ≡˘⟨ ?∙∙⟨⟩-/Var (lookupSV (σ ↑⋆ i) x) k (as //⟨ k ⟩ (σ ↑⋆ i)) ⟩
        lookupSV (σ ↑⋆ i) x ?∙∙⟨ k ⟩ (as //⟨ k ⟩ (σ ↑⋆ i)) /Var V.wk V.↑⋆ i
      ≡⟨⟩
        var x ∙ as /⟨ k ⟩ σ ↑⋆ i /Var V.wk V.↑⋆ i
      ∎
    wk-/⟨⟩-↑⋆ i (⊥ ∙ as)       = cong (⊥ ∙_) (wk-//⟨⟩-↑⋆ i as)
    wk-/⟨⟩-↑⋆ i (⊤ ∙ as)       = cong (⊤ ∙_) (wk-//⟨⟩-↑⋆ i as)
    wk-/⟨⟩-↑⋆ i (Π k a ∙ as)   =
      cong₂ _∙_ (cong₂ Π (wk-Kind/⟨⟩-↑⋆ i k) (wk-/⟨⟩-↑⋆ (suc i) a))
                (wk-//⟨⟩-↑⋆ i as)
    wk-/⟨⟩-↑⋆ i ((a ⇒ b) ∙ as) =
      cong₂ _∙_ (cong₂ _⇒_ (wk-/⟨⟩-↑⋆ i a) (wk-/⟨⟩-↑⋆ i b)) (wk-//⟨⟩-↑⋆ i as)
    wk-/⟨⟩-↑⋆ i (Λ k a ∙ as)   =
      cong₂ _∙_ (cong₂ Λ (wk-Kind/⟨⟩-↑⋆ i k) (wk-/⟨⟩-↑⋆ (suc i) a))
                (wk-//⟨⟩-↑⋆ i as)
    wk-/⟨⟩-↑⋆ i (ƛ a b ∙ as)   =
      cong₂ _∙_ (cong₂ ƛ (wk-/⟨⟩-↑⋆ i a) (wk-/⟨⟩-↑⋆ (suc i) b)) (wk-//⟨⟩-↑⋆ i as)
    wk-/⟨⟩-↑⋆ i (a ⊡ b ∙ as)   =
      cong₂ _∙_ (cong₂ _⊡_ (wk-/⟨⟩-↑⋆ i a) (wk-/⟨⟩-↑⋆ i b)) (wk-//⟨⟩-↑⋆ i as)

    wk-Kind/⟨⟩-↑⋆ : ∀ i {k m n} j {σ : SVSub m n} →
                    j Kind′/Var V.wk V.↑⋆ i Kind/⟨ k ⟩ (σ ↑) ↑⋆ i ≡
                      j Kind/⟨ k ⟩ σ ↑⋆ i Kind′/Var V.wk V.↑⋆ i
    wk-Kind/⟨⟩-↑⋆ i (a ⋯ b) = cong₂ _⋯_ (wk-/⟨⟩-↑⋆ i a) (wk-/⟨⟩-↑⋆ i b)
    wk-Kind/⟨⟩-↑⋆ i (Π j k) =
      cong₂ Π (wk-Kind/⟨⟩-↑⋆ i j) (wk-Kind/⟨⟩-↑⋆ (suc i) k)

    wk-//⟨⟩-↑⋆ : ∀ i {k m n} as {σ : SVSub m n} →
                 as //Var V.wk V.↑⋆ i //⟨ k ⟩ (σ ↑) ↑⋆ i ≡
                   as //⟨ k ⟩ σ ↑⋆ i //Var V.wk V.↑⋆ i
    wk-//⟨⟩-↑⋆ i []       = refl
    wk-//⟨⟩-↑⋆ i (a ∷ as) = cong₂ _∷_ (wk-/⟨⟩-↑⋆ i a) (wk-//⟨⟩-↑⋆ i as)

  -- A corollary of the above.

  wk-Asc/⟨⟩-↑⋆ : ∀ i {k m n} a {σ : SVSub m n} →
                a ElimAsc/Var V.wk V.↑⋆ i Asc/⟨ k ⟩ (σ ↑) ↑⋆ i ≡
                  a Asc/⟨ k ⟩ σ ↑⋆ i ElimAsc/Var V.wk V.↑⋆ i
  wk-Asc/⟨⟩-↑⋆ i (kd a) = cong kd (wk-Kind/⟨⟩-↑⋆ i a)
  wk-Asc/⟨⟩-↑⋆ i (tp a) = cong tp (wk-/⟨⟩-↑⋆ i a)

  mutual

    -- Weakening of a term followed by hereditary substitution of the
    -- newly introduced extra variable leaves the term unchanged.
    --
    -- NOTE: this is a variant of the `wk-sub-vanishes' lemma from
    -- Data.Fin.Substitution.Lemmas adapted to hereditary
    -- substitutions.

    /Var-wk-↑⋆-hsub-vanishes : ∀ i {k m} a {b : Elim m} →
                               a /Var V.wk V.↑⋆ i /⟨ k ⟩ sub b ↑⋆ i ≡ a
    /Var-wk-↑⋆-hsub-vanishes i {k} (var x ∙ as) {b} = begin
        var x ∙ as /Var V.wk V.↑⋆ i /⟨ k ⟩ sub b ↑⋆ i
      ≡⟨ cong₂ _?∙∙⟨ k ⟩_ (lookup-sub-wk-↑⋆ i x)
                          (//Var-wk-↑⋆-hsub-vanishes i as) ⟩
        var x ∙ as
      ∎
    /Var-wk-↑⋆-hsub-vanishes i (⊥ ∙ as)       =
      cong (⊥ ∙_) (//Var-wk-↑⋆-hsub-vanishes i as)
    /Var-wk-↑⋆-hsub-vanishes i (⊤ ∙ as)       =
      cong (⊤ ∙_) (//Var-wk-↑⋆-hsub-vanishes i as)
    /Var-wk-↑⋆-hsub-vanishes i (Π k a ∙ as)   =
      cong₂ _∙_ (cong₂ Π (Kind/Var-wk-↑⋆-hsub-vanishes i k)
                         (/Var-wk-↑⋆-hsub-vanishes (suc i) a))
                (//Var-wk-↑⋆-hsub-vanishes i as)
    /Var-wk-↑⋆-hsub-vanishes i ((a ⇒ b) ∙ as) =
      cong₂ _∙_ (cong₂ _⇒_ (/Var-wk-↑⋆-hsub-vanishes i a)
                           (/Var-wk-↑⋆-hsub-vanishes i b))
                (//Var-wk-↑⋆-hsub-vanishes i as)
    /Var-wk-↑⋆-hsub-vanishes i (Λ k a ∙ as)   =
      cong₂ _∙_ (cong₂ Λ (Kind/Var-wk-↑⋆-hsub-vanishes i k)
                         (/Var-wk-↑⋆-hsub-vanishes (suc i) a))
                (//Var-wk-↑⋆-hsub-vanishes i as)
    /Var-wk-↑⋆-hsub-vanishes i (ƛ a b ∙ as)   =
      cong₂ _∙_ (cong₂ ƛ (/Var-wk-↑⋆-hsub-vanishes i a)
                           (/Var-wk-↑⋆-hsub-vanishes (suc i) b))
                (//Var-wk-↑⋆-hsub-vanishes i as)
    /Var-wk-↑⋆-hsub-vanishes i (a ⊡ b ∙ as)   =
      cong₂ _∙_ (cong₂ _⊡_ (/Var-wk-↑⋆-hsub-vanishes i a)
                           (/Var-wk-↑⋆-hsub-vanishes i b))
                (//Var-wk-↑⋆-hsub-vanishes i as)

    Kind/Var-wk-↑⋆-hsub-vanishes
      : ∀ i {k m} j {b : Elim m} →
        j Kind′/Var V.wk V.↑⋆ i Kind/⟨ k ⟩ sub b ↑⋆ i ≡ j
    Kind/Var-wk-↑⋆-hsub-vanishes i (a ⋯ b) =
      cong₂ _⋯_ (/Var-wk-↑⋆-hsub-vanishes i a) (/Var-wk-↑⋆-hsub-vanishes i b)
    Kind/Var-wk-↑⋆-hsub-vanishes i (Π j k) =
      cong₂ Π (Kind/Var-wk-↑⋆-hsub-vanishes i j)
              (Kind/Var-wk-↑⋆-hsub-vanishes (suc i) k)

    //Var-wk-↑⋆-hsub-vanishes : ∀ i {k m} as {b : Elim m} →
                                as //Var V.wk V.↑⋆ i //⟨ k ⟩ sub b ↑⋆ i ≡ as
    //Var-wk-↑⋆-hsub-vanishes i []       = refl
    //Var-wk-↑⋆-hsub-vanishes i (a ∷ as) =
      cong₂ _∷_ (/Var-wk-↑⋆-hsub-vanishes i a) (//Var-wk-↑⋆-hsub-vanishes i as)

  -- A corollary of the above.
  Asc/Var-wk-↑⋆-hsub-vanishes
    : ∀ i {k m} a {b : Elim m} →
      a S.ElimAsc/Var V.wk V.↑⋆ i Asc/⟨ k ⟩ sub b ↑⋆ i ≡ a
  Asc/Var-wk-↑⋆-hsub-vanishes i (kd a) =
    cong kd (Kind/Var-wk-↑⋆-hsub-vanishes i a)
  Asc/Var-wk-↑⋆-hsub-vanishes i (tp a) =
    cong tp (/Var-wk-↑⋆-hsub-vanishes i a)

open RenamingCommutes

module _ where
  private
    module EL = TermLikeLemmas Substitution.termLikeLemmasElim
    module KL = TermLikeLemmas Substitution.termLikeLemmasKind′
  open Substitution hiding (_↑; _↑⋆_; sub)
  open ≡-Reasoning

  -- Repeated weakening commutes with application of lifted hereditary
  -- substitutions.

  wk⋆-/⟨⟩-↑⋆ : ∀ i {k m n} a {σ : SVSub m n} →
               a Elim/ wk⋆ i /⟨ k ⟩ σ ↑⋆ i ≡ a /⟨ k ⟩ σ Elim/ wk⋆ i
  wk⋆-/⟨⟩-↑⋆ zero {k} a {σ} = begin
    a Elim/ id /⟨ k ⟩ σ   ≡⟨ cong (_/⟨ k ⟩ σ) (EL.id-vanishes a) ⟩
    a /⟨ k ⟩ σ            ≡˘⟨ EL.id-vanishes (a /⟨ k ⟩ σ) ⟩
    a /⟨ k ⟩ σ Elim/ id   ∎
  wk⋆-/⟨⟩-↑⋆ (suc i) {k} a {σ} = begin
      a Elim/ wk⋆ (suc i) /⟨ k ⟩ (σ ↑⋆ i) ↑
    ≡⟨ cong (_/⟨ k ⟩ (σ ↑⋆ i) ↑) (EL./-weaken a) ⟩
      a Elim/ wk⋆ i Elim/ wk /⟨ k ⟩ (σ ↑⋆ i) ↑
    ≡⟨ cong (_/⟨ k ⟩ (σ ↑⋆ i) ↑) (EL./-wk {t = a Elim/ wk⋆ i}) ⟩
      weakenElim (a Elim/ wk⋆ i) /⟨ k ⟩ (σ ↑⋆ i) ↑
    ≡⟨ wk-/⟨⟩-↑⋆ zero (a Elim/ wk⋆ i) ⟩
      weakenElim (a Elim/ wk⋆ i /⟨ k ⟩ σ ↑⋆ i)
    ≡⟨ cong weakenElim (wk⋆-/⟨⟩-↑⋆ i a) ⟩
      weakenElim (a /⟨ k ⟩ σ Elim/ wk⋆ i)
    ≡˘⟨ (EL./-wk {t = a /⟨ k ⟩ σ Elim/ wk⋆ i}) ⟩
      a /⟨ k ⟩ σ Elim/ wk⋆ i Elim/ wk
    ≡˘⟨ EL./-weaken (a /⟨ k ⟩ σ)  ⟩
      a /⟨ k ⟩ σ Elim/ wk⋆ (suc i)
    ∎

  wk⋆-Kind/⟨⟩-↑⋆ : ∀ i {k m n} j {σ : SVSub m n} →
                   j Kind′/ wk⋆ i Kind/⟨ k ⟩ σ ↑⋆ i ≡
                     j Kind/⟨ k ⟩ σ Kind′/ wk⋆ i
  wk⋆-Kind/⟨⟩-↑⋆ zero {k} j {σ} = begin
    j Kind′/ id Kind/⟨ k ⟩ σ   ≡⟨ cong (_Kind/⟨ k ⟩ σ) (KL.id-vanishes j) ⟩
    j Kind/⟨ k ⟩ σ             ≡˘⟨ KL.id-vanishes (j Kind/⟨ k ⟩ σ) ⟩
    j Kind/⟨ k ⟩ σ Kind′/ id   ∎
  wk⋆-Kind/⟨⟩-↑⋆ (suc i) {k} j {σ} = begin
      j Kind′/ wk⋆ (suc i) Kind/⟨ k ⟩ (σ ↑⋆ i) ↑
    ≡⟨ cong (_Kind/⟨ k ⟩ (σ ↑⋆ i) ↑) (KL./-weaken j) ⟩
      j Kind′/ wk⋆ i Kind′/ wk Kind/⟨ k ⟩ (σ ↑⋆ i) ↑
    ≡⟨ cong (_Kind/⟨ k ⟩ (σ ↑⋆ i) ↑) (KL./-wk {t = j Kind′/ wk⋆ i}) ⟩
      weakenKind′ (j Kind′/ wk⋆ i) Kind/⟨ k ⟩ (σ ↑⋆ i) ↑
    ≡⟨ wk-Kind/⟨⟩-↑⋆ zero (j Kind′/ wk⋆ i) ⟩
      weakenKind′ (j Kind′/ wk⋆ i Kind/⟨ k ⟩ σ ↑⋆ i)
    ≡⟨ cong weakenKind′ (wk⋆-Kind/⟨⟩-↑⋆ i j) ⟩
      weakenKind′ (j Kind/⟨ k ⟩ σ Kind′/ wk⋆ i)
    ≡˘⟨ (KL./-wk {t = j Kind/⟨ k ⟩ σ Kind′/ wk⋆ i}) ⟩
      j Kind/⟨ k ⟩ σ Kind′/ wk⋆ i Kind′/ wk
    ≡˘⟨ KL./-weaken (j Kind/⟨ k ⟩ σ)  ⟩
      j Kind/⟨ k ⟩ σ Kind′/ wk⋆ (suc i)
    ∎

  -- A corollary of the above.
  weaken⋆-/⟨⟩-↑⋆ : ∀ i {k m n} a {σ : SVSub m n} →
                   weakenElim⋆ i (a /⟨ k ⟩ σ) ≡ weakenElim⋆ i a /⟨ k ⟩ σ ↑⋆ i
  weaken⋆-/⟨⟩-↑⋆ i {k} a {σ} = begin
    weakenElim⋆ i (a /⟨ k ⟩ σ)     ≡˘⟨ EL./-wk⋆ i ⟩
    a /⟨ k ⟩ σ Elim/ wk⋆ i         ≡˘⟨ wk⋆-/⟨⟩-↑⋆ i a ⟩
    a Elim/ wk⋆ i /⟨ k ⟩ σ ↑⋆ i    ≡⟨ cong (_/⟨ k ⟩ σ ↑⋆ i) (EL./-wk⋆ i) ⟩
    weakenElim⋆ i a /⟨ k ⟩ σ ↑⋆ i  ∎

  -- NOTE. Unfortunately, we cannot prove that arbitrary untyped
  -- hereditary substitutions commute, because *untyped* hereditary
  -- substitutions need not commute with reducting applications in
  -- general.  We will prove a weaker result, namely that well-kinded
  -- hereditary substitutions in well-kinded types commute, later.
  -- See e.g. `Nf∈-[]-/⟨⟩-↑⋆` etc. in module Kinding.Simple.

-- Some commutation lemmas up to βη-equality.

module _ where
  open →β*-Reasoning
  open Substitution hiding (_↑; _↑⋆_; sub)
  private module Kd = Kd→β*-Reasoning

  mutual

    -- Hereditary substitution commutes with ⌞_⌟ up to β-reduction.

    ⌞⌟-/⟨⟩-β : ∀ {m n} a {k} {σ : SVSub m n} →
               ⌞ a ⌟ / toSub σ  →β*  ⌞ a /⟨ k ⟩ σ ⌟
    ⌞⌟-/⟨⟩-β (var x ∙ bs) {k} {σ} = begin
        ⌞ var x ∙ bs ⌟ / toSub σ
      ⟶⋆⟨ ⌞∙⌟-/⟨⟩-β (var x / toSub σ) (var x) bs ε ⟩
        (var x / toSub σ) ⌞∙⌟ ⌞ bs //⟨ k ⟩ σ ⌟Sp
      ≡⟨ cong (_⌞∙⌟ ⌞ bs //⟨ k ⟩ σ ⌟Sp) (lookup-toSub σ x) ⟩
        ⌞ toElim (lookupSV σ x) ⌟ ⌞∙⌟ ⌞ bs //⟨ k ⟩ σ ⌟Sp
      ⟶⋆⟨ ⌞⌟-?∙∙-β (lookupSV σ x) k (bs //⟨ k ⟩ σ) ⟩
        ⌞ lookupSV σ x ?∙∙⟨ k ⟩ (bs //⟨ k ⟩ σ) ⌟
      ∎
    ⌞⌟-/⟨⟩-β (⊥ ∙ bs) = ⌞∙⌟-/⟨⟩-β ⊥ ⊥ bs ε
    ⌞⌟-/⟨⟩-β (⊤ ∙ bs) = ⌞∙⌟-/⟨⟩-β ⊤ ⊤ bs ε
    ⌞⌟-/⟨⟩-β (Π j b ∙ bs) {k} {σ} = ⌞∙⌟-/⟨⟩-β _ _ bs (begin
        ⌞ Π j b ⌟Hd / toSub σ
      ⟶⋆⟨ →β*-Π (⌞⌟Kd-/⟨⟩-β j) (⌞⌟-/⟨⟩-β b) ⟩
        Π ⌞ j Kind/⟨ k ⟩ σ ⌟Kd ⌞ b /⟨ k ⟩ σ ↑ ⌟
      ∎)
    ⌞⌟-/⟨⟩-β ((a ⇒ b) ∙ bs) {k} {σ} = ⌞∙⌟-/⟨⟩-β _ _ bs (begin
        ⌞ a ⇒ b ⌟Hd / toSub σ
      ⟶⋆⟨ →β*-⇒ (⌞⌟-/⟨⟩-β a) (⌞⌟-/⟨⟩-β b) ⟩
        ⌞ a /⟨ k ⟩ σ ⌟ ⇒ ⌞ b /⟨ k ⟩ σ ⌟
      ∎)
    ⌞⌟-/⟨⟩-β (Λ j b ∙ bs) {k} {σ}  = ⌞∙⌟-/⟨⟩-β _ _ bs (begin
        ⌞ Λ j b ⌟Hd / toSub σ
      ⟶⋆⟨ →β*-Λ (⌞⌟Kd-/⟨⟩-β j) (⌞⌟-/⟨⟩-β b) ⟩
        Λ ⌞ j Kind/⟨ k ⟩ σ ⌟Kd ⌞ b /⟨ k ⟩ σ ↑ ⌟
      ∎)
    ⌞⌟-/⟨⟩-β (ƛ a b ∙ bs) {k} {σ}  = ⌞∙⌟-/⟨⟩-β _ _ bs (begin
        ⌞ ƛ a b ⌟Hd / toSub σ
      ⟶⋆⟨ →β*-ƛ (⌞⌟-/⟨⟩-β a) (⌞⌟-/⟨⟩-β b) ⟩
        ƛ ⌞ a /⟨ k ⟩ σ ⌟ ⌞ b /⟨ k ⟩ σ ↑ ⌟
      ∎)
    ⌞⌟-/⟨⟩-β (a ⊡ b ∙ bs) {k} {σ}  = ⌞∙⌟-/⟨⟩-β _ _ bs (begin
        ⌞ a ⊡ b ⌟Hd / toSub σ
      ⟶⋆⟨ →β*-⊡ (⌞⌟-/⟨⟩-β a) (⌞⌟-/⟨⟩-β b) ⟩
        ⌞ a /⟨ k ⟩ σ ⌟ ⊡ ⌞ b /⟨ k ⟩ σ ⌟
      ∎)

    ⌞⌟Kd-/⟨⟩-β : ∀ {m n} j {k} {σ : SVSub m n} →
                 ⌞ j ⌟Kd Kind/ toSub σ  Kd→β*  ⌞ j Kind/⟨ k ⟩ σ ⌟Kd
    ⌞⌟Kd-/⟨⟩-β (a ⋯ b) {k} {σ} = Kd.begin
        (⌞ a ⋯ b ⌟Kd Kind/ toSub σ)
      Kd.⟶⋆⟨ Kd→β*-⋯ (⌞⌟-/⟨⟩-β a) (⌞⌟-/⟨⟩-β b) ⟩
        ⌞ a /⟨ k ⟩ σ ⌟ ⋯ ⌞ b /⟨ k ⟩ σ ⌟
      Kd.∎
    ⌞⌟Kd-/⟨⟩-β (Π j l) {k} {σ} = Kd.begin
        (⌞ Π j l ⌟Kd Kind/ toSub σ)
      Kd.⟶⋆⟨ Kd→β*-Π (⌞⌟Kd-/⟨⟩-β j) (⌞⌟Kd-/⟨⟩-β l) ⟩
        Π ⌞ j Kind/⟨ k ⟩ σ ⌟Kd ⌞ l Kind/⟨ k ⟩ σ ↑ ⌟Kd
      Kd.∎

    ⌞∙⌟-/⟨⟩-β : ∀ {m n} a b bs {k} {σ : SVSub m n} →
                b / toSub σ →β* a →
                (b ⌞∙⌟ ⌞ bs ⌟Sp) / toSub σ  →β*  a ⌞∙⌟ ⌞ bs //⟨ k ⟩ σ ⌟Sp
    ⌞∙⌟-/⟨⟩-β a b []               hyp = hyp
    ⌞∙⌟-/⟨⟩-β a b (c ∷ cs) {k} {σ} hyp =
      ⌞∙⌟-/⟨⟩-β (a · ⌞ c /⟨ k ⟩ σ ⌟) (b · ⌞ c ⌟) cs
               (→β*-· hyp (⌞⌟-/⟨⟩-β c))

    -- Reducing applications commute with ⌞_⌟ up to β-reduction.

    ⌞⌟-?∙∙-β : ∀ {n} (r : SVRes n) k bs →
               ⌞ toElim r ⌟ ⌞∙⌟ ⌞ bs ⌟Sp →β* ⌞ r ?∙∙⟨ k ⟩ bs ⌟
    ⌞⌟-?∙∙-β (hit a)  k bs = ⌞⌟-∙∙-β a k bs
    ⌞⌟-?∙∙-β (miss y) k bs = ε

    ⌞⌟-∙∙-β : ∀ {n} (a : Elim n) k bs → ⌞ a ⌟ ⌞∙⌟ ⌞ bs ⌟Sp →β* ⌞ a ∙∙⟨ k ⟩ bs ⌟
    ⌞⌟-∙∙-β a k       []       = ε
    ⌞⌟-∙∙-β a ★       (b ∷ bs) = begin
      ⌞ a ⌟ ⌞∙⌟ (⌞ b ⌟ ∷ ⌞ bs ⌟Sp) ≡˘⟨ ⌞⌟-∙∙ a (b ∷ bs) ⟩
      ⌞ a ∙∙ (b ∷ bs) ⌟            ∎
    ⌞⌟-∙∙-β a (j ⇒ k) (b ∷ bs) = begin
        ⌞ a ⌟ ⌞∙⌟ (⌞ b ⌟ ∷ ⌞ bs ⌟Sp)
      ⟶⋆⟨ →β*-⌞∙⌟₁ (⌞⌟-⌜·⌝-β a (j ⇒ k) b) ⌞ bs ⌟Sp  ⟩
        ⌞ a ⌜·⌝⟨ j ⇒ k ⟩ b ⌟ ⌞∙⌟ ⌞ bs ⌟Sp
      ⟶⋆⟨ ⌞⌟-∙∙-β (a ⌜·⌝⟨ j ⇒ k ⟩ b) k bs ⟩
        ⌞ a ⌜·⌝⟨ j ⇒ k ⟩ b ∙∙⟨ k ⟩ bs ⌟
      ∎

    ⌞⌟-⌜·⌝-β : ∀ {n} (a : Elim n) k b → ⌞ a ⌟ · ⌞ b ⌟ →β* ⌞ a ⌜·⌝⟨ k ⟩ b ⌟
    ⌞⌟-⌜·⌝-β a ★ b = begin
      ⌞ a ⌟ · ⌞ b ⌟              ≡˘⟨ ⌞⌟-· a b ⟩
      ⌞ a ⌜·⌝ b ⌟                ∎
    ⌞⌟-⌜·⌝-β (a ∙ (c ∷ cs)) (j ⇒ k) b = begin
      ⌞ a ∙ (c ∷ cs) ⌟ · ⌞ b ⌟   ≡˘⟨ ⌞⌟-· (a ∙ (c ∷ cs)) b ⟩
      ⌞ a ∙ (c ∷ cs) ⌜·⌝ b ⌟     ∎
    ⌞⌟-⌜·⌝-β (var x   ∙ []) (j ⇒ k) b = ε
    ⌞⌟-⌜·⌝-β (⊥       ∙ []) (j ⇒ k) b = ε
    ⌞⌟-⌜·⌝-β (⊤       ∙ []) (j ⇒ k) b = ε
    ⌞⌟-⌜·⌝-β (Π l a   ∙ []) (j ⇒ k) b = ε
    ⌞⌟-⌜·⌝-β ((a ⇒ b) ∙ []) (j ⇒ k) c = ε
    ⌞⌟-⌜·⌝-β (Λ l a ∙ []) (j ⇒ k) b = begin
      Λ ⌞ l ⌟Kd ⌞ a ⌟ · ⌞ b ⌟    ⟶⟨ ⌈ cont-Tp· ⌞ l ⌟Kd ⌞ a ⌟ ⌞ b ⌟ ⌉ ⟩
      ⌞ a ⌟ [ ⌞ b ⌟ ]            ⟶⋆⟨ ⌞⌟-/⟨⟩-β a {j} {sub b} ⟩
      ⌞ a [ b ∈ j ] ⌟            ∎
    ⌞⌟-⌜·⌝-β (ƛ a b   ∙ []) (j ⇒ k) c = ε
    ⌞⌟-⌜·⌝-β (a ⊡ b   ∙ []) (j ⇒ k) c = ε

  -- Potentially reducing applications commute with ⌞_⌟ up to β-reduction.

  ⌞⌟-↓⌜·⌝-β : ∀ {n} (a : Elim n) b → ⌞ a ⌟ · ⌞ b ⌟ →β* ⌞ a ↓⌜·⌝ b ⌟
  ⌞⌟-↓⌜·⌝-β (a ∙ (c ∷ cs)) b = begin
    ⌞ a ∙ (c ∷ cs) ⌟ · ⌞ b ⌟   ≡˘⟨ ⌞⌟-· (a ∙ (c ∷ cs)) b ⟩
    ⌞ a ∙ (c ∷ cs) ⌜·⌝ b ⌟     ∎
  ⌞⌟-↓⌜·⌝-β (var x   ∙ []) b = ε
  ⌞⌟-↓⌜·⌝-β (⊥       ∙ []) b = ε
  ⌞⌟-↓⌜·⌝-β (⊤       ∙ []) b = ε
  ⌞⌟-↓⌜·⌝-β (Π l a   ∙ []) b = ε
  ⌞⌟-↓⌜·⌝-β ((a ⇒ b) ∙ []) c = ε
  ⌞⌟-↓⌜·⌝-β (Λ l a ∙ []) b = begin
    Λ ⌞ l ⌟Kd ⌞ a ⌟ · ⌞ b ⌟    ⟶⟨ ⌈ cont-Tp· ⌞ l ⌟Kd ⌞ a ⌟ ⌞ b ⌟ ⌉ ⟩
    ⌞ a ⌟ [ ⌞ b ⌟ ]            ⟶⋆⟨ ⌞⌟-/⟨⟩-β a {⌊ l ⌋} {sub b} ⟩
    ⌞ a [ b ∈ ⌊ l ⌋ ] ⌟        ∎
  ⌞⌟-↓⌜·⌝-β (ƛ a b   ∙ []) c = ε
  ⌞⌟-↓⌜·⌝-β (a ⊡ b   ∙ []) c = ε


-- Andreas, 2020-03-19, issue #4486
-- "did you mean?" now also for invalid imports

record Foo : Set₁ where
  field Θ : Set

open Foo using () renaming (θ to unwrap)

-- EXPECTED:
-- The module Foo doesn't export the following:
--   θ (did you mean 'Θ'?)

module M where
  private postulate S : Set

open M using (S)

-- EXPECTED:
-- The module M doesn't export the following:
--   S

module N where
  module O where
    record R : Set where
  open O public using (module R)

module N' where
  module O where
    record R : Set where
  open O public hiding (module R)

open N  using (R)
open N' using (module R)

-- EXPECTED:
-- The module N doesn't export the following:
--   R
-- The module N' doesn't export the following:
--   module R

module AB where
  record Ananas : Set where

open AB using (Bananas)

-- EXPECTED:
-- The module AB doesn't export the following:
--   Bananas (did you mean 'Ananas'?)

open AB using (module Bananas)

-- EXPECTED:
-- The module AB doesn't export the following:
--   module Bananas (did you mean 'Ananas'?)


{-# OPTIONS --no-auto-inline #-}

-- Agda doesn't have an Int type (only Word64). With some work we
-- can represent signed ints using Word64.

module Haskell.Prim.Int where

open import Agda.Builtin.Nat
open import Agda.Builtin.Word renaming (primWord64ToNat to w2n; primWord64FromNat to n2w)
open import Agda.Builtin.List
open import Agda.Builtin.Char
open import Agda.Builtin.String
open import Agda.Builtin.Unit
open import Agda.Builtin.Int using (pos; negsuc)
open import Agda.Builtin.Equality

open import Haskell.Prim
open import Haskell.Prim.Word
open import Haskell.Prim.Integer
open import Haskell.Prim.Bool

--------------------------------------------------
-- Definition

data Int : Set where
  int64 : Word64 → Int

intToWord : Int → Word64
intToWord (int64 a) = a

unsafeIntToNat : Int → Nat
unsafeIntToNat a = w2n (intToWord a)

--------------------------------------------------
-- Literals

private
  2⁶⁴ : Nat
  2⁶⁴ = 18446744073709551616

  2⁶³ : Nat
  2⁶³ = 9223372036854775808

  maxInt : Nat
  maxInt = 2⁶³ - 1

instance
  iNumberInt : Number Int
  iNumberInt .Number.Constraint n = IsTrue (n < 2⁶³)
  iNumberInt .fromNat n = int64 (n2w n)

  iNegativeInt : Negative Int
  iNegativeInt .Negative.Constraint n = IsTrue (n < 1 + 2⁶³)
  iNegativeInt .fromNeg n = int64 (n2w (2⁶⁴ - n))

--------------------------------------------------
-- Arithmetic

isNegativeInt : Int → Bool
isNegativeInt (int64 w) = maxInt < w2n w

eqInt : Int → Int → Bool
eqInt (int64 a) (int64 b) = w2n a == w2n b

negateInt : Int → Int
negateInt (int64 a) = int64 (n2w (2⁶⁴ - w2n a))

intToInteger : Int → Integer
intToInteger a = if isNegativeInt a then negsuc (unsafeIntToNat (negateInt a) - 1)
                                    else pos (unsafeIntToNat a)

integerToInt : Integer → Int
integerToInt (pos    n) = int64 (n2w n)
integerToInt (negsuc n) = negateInt (int64 (n2w (suc n)))

private
  ltPosInt : Int → Int → Bool
  ltPosInt (int64 a) (int64 b) = ltWord a b

ltInt : Int → Int → Bool
ltInt a b with isNegativeInt a | isNegativeInt b
... | true  | false = true
... | false | true  = false
... | true  | true  = ltPosInt (negateInt b) (negateInt a)
... | false | false = ltPosInt a b

addInt : Int → Int → Int
addInt (int64 a) (int64 b) = int64 (addWord a b)

subInt : Int → Int → Int
subInt a b = addInt a (negateInt b)

mulInt : Int → Int → Int
mulInt (int64 a) (int64 b) = int64 (mulWord a b)

absInt : Int → Int
absInt a = if isNegativeInt a then negateInt a else a

signInt : Int → Int
signInt a = if      isNegativeInt a then -1
            else if eqInt a 0       then 0 else 1

showInt : Int → List Char
showInt a = showInteger (intToInteger a)

--------------------------------------------------
-- Constraints

IsNonNegativeInt : Int → Set
IsNonNegativeInt a@(int64 _) =
  if isNegativeInt a then TypeError (primStringAppend (primStringFromList (showInt a)) " is negative")
                     else ⊤

intToNat : (a : Int) → ⦃ IsNonNegativeInt a ⦄ → Nat
intToNat a = unsafeIntToNat a


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

open import HoTT
open import homotopy.Bouquet
open import homotopy.FinWedge
open import homotopy.SphereEndomorphism
open import groups.SphereEndomorphism
open import cw.CW
open import cw.FinCW
open import cw.WedgeOfCells
open import cw.FinBoundary
open import cohomology.Theory

module cw.cohomology.cochainequiv.HigherCoboundary (OT : OrdinaryTheory lzero)
  {n} (⊙fin-skel : ⊙FinSkeleton (S (S n))) where

open OrdinaryTheory OT
open import cohomology.SubFinBouquet OT
open import cohomology.RephraseSubFinCoboundary OT

private
  fin-skel = ⊙FinSkeleton.skel ⊙fin-skel
  I = AttachedFinSkeleton.numCells fin-skel
  ac = ⊙FinSkeleton-has-cells-with-choice 0 ⊙fin-skel lzero
  dec = ⊙FinSkeleton-has-cells-with-dec-eq ⊙fin-skel

  ⊙fin-skel₋₁ = ⊙fcw-init ⊙fin-skel
  fin-skel₋₁ = ⊙FinSkeleton.skel ⊙fin-skel₋₁
  I₋₁ = AttachedFinSkeleton.numCells fin-skel₋₁
  ac₋₁ = ⊙FinSkeleton-has-cells-with-choice 0 ⊙fin-skel₋₁ lzero
  dec₋₁ = ⊙FinSkeleton-has-cells-with-dec-eq ⊙fin-skel₋₁

open import cw.cohomology.WedgeOfCells OT
open import cw.cohomology.reconstructed.HigherCoboundary OT ⊙⦉ ⊙fin-skel ⦊
open import cw.cohomology.cochainequiv.HigherCoboundaryAbstractDefs OT ⊙fin-skel

abstract
  rephrase-cw-co∂-last-in-degree : ∀ g
    → GroupIso.f (CXₙ/Xₙ₋₁-diag-β ⊙⦉ ⊙fin-skel ⦊ ac) (GroupHom.f cw-co∂-last (GroupIso.g (CXₙ/Xₙ₋₁-diag-β ⊙⦉ ⊙fin-skel₋₁ ⦊ ac₋₁) g))
    ∼ λ <I → Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁) (fdegree-last fin-skel <I <I₋₁))
  rephrase-cw-co∂-last-in-degree g <I =
    GroupIso.f (C-FinBouquet-diag (S (S n)) I)
      (CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel ⦊))
        (GroupHom.f cw-co∂-last
          (CEl-fmap (ℕ-to-ℤ (S n)) (⊙<– (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊))
            (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
              g)))) <I
      =⟨ ap
          (λ g →
            GroupIso.f (C-FinBouquet-diag (S (S n)) I)
              (CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel ⦊)) g) <I) $
          cw-co∂-last-β
            (CEl-fmap (ℕ-to-ℤ (S n)) (⊙<– (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊))
              (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
                g)) ⟩
    GroupIso.f (C-FinBouquet-diag (S (S n)) I)
      (CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel ⦊))
        (CEl-fmap (ℕ-to-ℤ (S (S n))) ⊙cw-∂-before-Susp
          (<– (CEl-Susp (ℕ-to-ℤ (S n)) (⊙Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊))
            (CEl-fmap (ℕ-to-ℤ (S n)) (⊙<– (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊))
              (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
                g))))) <I
      =⟨ ap
          (λ g →
            GroupIso.f (C-FinBouquet-diag (S (S n)) I)
              (CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel ⦊))
                (CEl-fmap (ℕ-to-ℤ (S (S n))) ⊙cw-∂-before-Susp g)) <I) $
          C-Susp-fmap' (ℕ-to-ℤ (S n)) (⊙<– (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊)) □$ᴳ
            (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
              g) ⟩
    GroupIso.f (C-FinBouquet-diag (S (S n)) I)
      (CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel ⦊))
        (CEl-fmap (ℕ-to-ℤ (S (S n))) ⊙cw-∂-before-Susp
          (CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙Susp-fmap (⊙<– (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊)))
            (<– (CEl-Susp (ℕ-to-ℤ (S n)) (⊙FinBouquet _ (S n)))
              (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
                g))))) <I
      =⟨ ap (λ g → GroupIso.f (C-FinBouquet-diag (S (S n)) I) g <I) $
            ∘-CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel ⦊)) ⊙cw-∂-before-Susp
              (CEl-fmap (ℕ-to-ℤ (S (S n))) (⊙Susp-fmap (⊙<– (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊)))
                (<– (CEl-Susp (ℕ-to-ℤ (S n)) (⊙FinBouquet _ (S n)))
                  (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
                    g)))
          ∙ ∘-CEl-fmap (ℕ-to-ℤ (S (S n)))
              (⊙cw-∂-before-Susp ⊙∘ ⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel ⦊))
              (⊙Susp-fmap (⊙<– (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ ⦉ fin-skel₋₁ ⦊)))
              (<– (CEl-Susp (ℕ-to-ℤ (S n)) (⊙FinBouquet _ (S n)))
                (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
                  g))
          ∙ ap (λ f → CEl-fmap (ℕ-to-ℤ (S (S n))) f
              (<– (CEl-Susp (ℕ-to-ℤ (S n)) (⊙FinBouquet _ (S n)))
                (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
                  g)))
              (! ⊙function₀'-β) ⟩
    GroupIso.f (C-FinBouquet-diag (S (S n)) I)
      (CEl-fmap (ℕ-to-ℤ (S (S n))) ⊙function₀'
        (<– (CEl-Susp (ℕ-to-ℤ (S n)) (⊙FinBouquet _ (S n)))
          (GroupIso.g (C-FinBouquet-diag (S n) I₋₁)
            g))) <I
      =⟨ rephrase-in-degree' (S n) {I = I} {J = I₋₁} ⊙function₀' g <I ⟩
    Group.sum (C2 0)
      (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁)
        (⊙SphereS-endo-degree (S n)
          (⊙Susp-fmap (⊙fwproj <I₋₁) ⊙∘ ⊙function₀' ⊙∘ ⊙fwin <I)))
      =⟨ ap (Group.sum (C2 0))
          (λ= λ <I₋₁ → ap (Group.exp (C2 0) (g <I₋₁)) $
            ⊙SphereS-endo-degree-base-indep (S n)
              {f = (  ⊙Susp-fmap (⊙fwproj <I₋₁)
                   ⊙∘ ⊙function₀'
                   ⊙∘ ⊙fwin <I)}
              {g = (Susp-fmap (function₁' <I <I₋₁) , idp)}
              (mega-reduction <I <I₋₁)) ⟩
    Group.sum (C2 0)
      (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁)
        (⊙SphereS-endo-degree (S n)
          (Susp-fmap (function₁' <I <I₋₁) , idp)))
      =⟨ ap (Group.sum (C2 0))
          (λ= λ <I₋₁ → ap (Group.exp (C2 0) (g <I₋₁)) $
            ⊙SphereS-endo-degree-Susp' n (function₁' <I <I₋₁)) ⟩
    Group.sum (C2 0)
      (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁)
        (Trunc-⊙SphereS-endo-degree n
          (Trunc-⊙SphereS-endo-in n
            [ function₁' <I <I₋₁ ])))
      =⟨ ap (Group.sum (C2 0))
          (λ= λ <I₋₁ → ap
            (λ f → Group.exp (C2 0) (g <I₋₁)
              (Trunc-⊙SphereS-endo-degree n
                (Trunc-⊙SphereS-endo-in n
                  [ f ])))
            (function₁'-β <I <I₋₁)) ⟩
    Group.sum (C2 0)
      (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁)
        (Trunc-⊙SphereS-endo-degree n
          (Trunc-⊙SphereS-endo-in n
            [ function₁ <I <I₋₁ ])))
      =∎


{-# OPTIONS --safe #-}

module Definition.Conversion.Conversion where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.RedSteps
open import Definition.Typed.Properties
open import Definition.Conversion
open import Definition.Conversion.Stability
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Equality
open import Definition.Typed.Consequences.Reduction

open import Tools.Product
import Tools.PropositionalEquality as PE

mutual

  -- Conversion of algorithmic equality.
  convConv↑Term : ∀ {t u A B Γ Δ l}
                → ⊢ Γ ≡ Δ
                → Γ ⊢ A ≡ B ^ [ ! , l ]
                → Γ ⊢ t [conv↑] u ∷ A ^ l
                → Δ ⊢ t [conv↑] u ∷ B ^ l
  convConv↑Term Γ≡Δ A≡B ([↑]ₜ B₁ t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    let _ , ⊢B = syntacticEq A≡B
        B′ , whnfB′ , D′ = whNorm ⊢B
        B₁≡B′ = trans (sym (subset* D)) (trans A≡B (subset* (red D′)))
    in  [↑]ₜ B′ t′ u′ (stabilityRed* Γ≡Δ (red D′))
             (stabilityRed*Term Γ≡Δ (conv* d B₁≡B′))
             (stabilityRed*Term Γ≡Δ (conv* d′ B₁≡B′)) whnfB′ whnft′ whnfu′
             (convConv↓Term Γ≡Δ B₁≡B′ whnfB′ t<>u)

  -- Conversion of algorithmic equality with terms and types in WHNF.
  convConv↓Term : ∀ {t u A B Γ Δ l}
                → ⊢ Γ ≡ Δ
                → Γ ⊢ A ≡ B ^ [ ! , l ]
                → Whnf B
                → Γ ⊢ t [conv↓] u ∷ A ^ l
                → Δ ⊢ t [conv↓] u ∷ B ^ l
  convConv↓Term Γ≡Δ A≡B whnfB (ℕ-ins x) rewrite ℕ≡A A≡B whnfB =
    ℕ-ins (stability~↓! Γ≡Δ x)
  convConv↓Term Γ≡Δ A≡B whnfB (ne x) rewrite U≡A-whnf A≡B whnfB = ne (stability~↓! Γ≡Δ x)
  convConv↓Term Γ≡Δ A≡B whnfB (ne-ins t u x x₁) with ne≡A x A≡B whnfB
  convConv↓Term Γ≡Δ A≡B whnfB (ne-ins t u x x₁) | B , neB , PE.refl =
    ne-ins (stabilityTerm Γ≡Δ (conv t A≡B)) (stabilityTerm Γ≡Δ (conv u A≡B))
           neB (stability~↓! Γ≡Δ x₁)
  convConv↓Term Γ≡Δ A≡B whnfB (zero-refl x) rewrite ℕ≡A A≡B whnfB =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  zero-refl ⊢Δ
  convConv↓Term Γ≡Δ A≡B whnfB (suc-cong x) rewrite ℕ≡A A≡B whnfB =
    suc-cong (stabilityConv↑Term Γ≡Δ x)
  convConv↓Term Γ≡Δ A≡B whnfB (η-eq l< l<' x x₁ x₂ y y₁ x₃) with Π≡A A≡B whnfB
  convConv↓Term Γ≡Δ A≡B whnfB (η-eq l< l<' x x₁ x₂ y y₁ x₃) | F′ , G′ , PE.refl =
    let F≡F′ , rF≡rF′ , _ , _ , G≡G′ = injectivity A≡B
        ⊢F , ⊢F′ = syntacticEq F≡F′
    in  η-eq l< l<'
             (stability Γ≡Δ ⊢F′) (stabilityTerm Γ≡Δ (conv x₁ A≡B))
             (stabilityTerm Γ≡Δ (conv x₂ A≡B)) y y₁
             (convConv↑Term (Γ≡Δ ∙ F≡F′) G≡G′ x₃)
  convConv↓Term Γ≡Δ A≡B whnfB (U-refl x x₁) rewrite U≡A-whnf A≡B whnfB =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ in U-refl x ⊢Δ
  convConv↓Term Γ≡Δ A≡B whnfB (ℕ-refl x) rewrite U≡A-whnf A≡B whnfB =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ in ℕ-refl ⊢Δ
  convConv↓Term Γ≡Δ A≡B whnfB (Empty-refl x _) rewrite U≡A-whnf A≡B whnfB =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ in Empty-refl x ⊢Δ
  convConv↓Term Γ≡Δ A≡B whnfB (Π-cong lΠ rF lF lG l< l<' x x₁ x₂) rewrite U≡A-whnf A≡B whnfB =
    Π-cong lΠ rF lF lG l< l<' (stability Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁) (stabilityConv↑Term (Γ≡Δ ∙ refl x) x₂)
  convConv↓Term Γ≡Δ A≡B whnfB (∃-cong lΠ x x₁ x₂) rewrite U≡A-whnf A≡B whnfB =
    ∃-cong lΠ (stability Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁) (stabilityConv↑Term (Γ≡Δ ∙ refl x) x₂)

-- Conversion of algorithmic equality with the same context.
convConvTerm : ∀ {t u A B Γ l}
              → Γ ⊢ t [conv↑] u ∷ A ^ l
              → Γ ⊢ A ≡ B ^ [ ! , l ]
              → Γ ⊢ t [conv↑] u ∷ B ^ l
convConvTerm t<>u A≡B = convConv↑Term (reflConEq (wfEq A≡B)) A≡B t<>u

conv~↑% : ∀ {t u A B Γ l}
              -- → ⊢ Γ ≡ Δ
              → Γ ⊢ t ~ u ↑% A ^ l
              → Γ ⊢ A ≡ B ^ [ % , l ]
              → Γ ⊢ t ~ u ↑% B ^ l
conv~↑% (%~↑ ⊢k ⊢l) e = %~↑ (conv ⊢k e) (conv ⊢l e)
--(stabilityTerm ⊢Γ≡Δ (conv ⊢k e)) (stabilityTerm ⊢Γ≡Δ (conv ⊢l e))

convConvTerm%! : ∀ {t u A B Γ r l}
              → Γ ⊢ t [genconv↑] u ∷ A ^ [ r , l ]
              → Γ ⊢ A ≡ B ^ [ r , l ]
              → Γ ⊢ t [genconv↑] u ∷ B ^ [ r , l ]
convConvTerm%! {r = !} = convConvTerm
convConvTerm%! {r = %} = conv~↑%


-- Also works for parts of operators.
module NotInScope where

postulate
  X : Set
  if_then_else_ : X -> X -> X -> X
  x : X

bad = if x thenn x else x

-- The error message should /not/ claim that "if" is out of scope.


-- P: <E[new s]> --> (vcd) <E[(c,d)]>
module Properties.StepNew where

open import Data.Maybe hiding (All)
open import Data.List
open import Data.List.All
open import Data.Product

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Typing
open import Syntax
open import Global
open import Channel
open import Values
open import Session
open import Schedule

open import ProcessSyntax
open import ProcessRun

open import Properties.Base

tch : SType → Type
tch s = (TPair (TChan (SType.force s)) (TChan (SType.force (dual s))))

mknew : ∀ {Φ} → (s : SType) → Expr (tch s ∷ Φ) TUnit → Expr Φ TUnit
mknew s E = letbind (split-all-right _) (new [] s) E

mklhs : ∀ {Φ} → (s : SType) → Expr (tch s ∷ Φ) TUnit → Proc Φ
mklhs s E = exp (mknew s E)

mkrhs : ∀ {Φ} → (s : SType) → Expr (tch s ∷ Φ) TUnit → Proc Φ
mkrhs s E = res s (exp (letbind (left (left (split-all-right _))) (pair (left (rght [])) (here []) (here [])) E))

reduction : (s : SType) (E : Expr (tch s ∷ []) TUnit) →
    let lhs = (runProc [] (mklhs s E) (vnil []-inactive)) in
    let rhs = (runProc [] (mkrhs s E) (vnil []-inactive)) in
    one-step lhs ≡
    (New , proj₁ rhs , proj₂ rhs)
reduction s E
  with ssplit-refl-left-inactive []
... | G' , ina-G' , ss-GG'
  = refl

-- reduction in open context

open-reduction-type : Set
open-reduction-type = ∀ {Φ} (s : SType) (E : Expr (tch s ∷ Φ) TUnit) (ϱ : VEnv [] Φ) →
    let lhs = (runProc [] (mklhs s E) ϱ) in
    let rhs = (runProc [] (mkrhs s E) ϱ) in
    one-step lhs ≡ (New , proj₁ rhs , proj₂ rhs)

open-reduction : open-reduction-type
open-reduction{Φ} s E ϱ
  with runProc [] (exp (mknew s E)) ϱ
... | rpse
  rewrite split-env-right-lemma0 ϱ
    | split-rotate-lemma {Φ}
    | split-env-right-lemma ϱ
  with ssplit-compose (ss-left{(SType.force s) , POSNEG} ss-[]) (ss-left ss-[])
... | ssc
  = refl

{-

-- reduction in open context with further resources

pairs : ∀ {A : Set} {B : A → Set} {p1 p2 : Σ A λ x → B x }
  → p1 ≡ p2 → Σ (proj₁ p1 ≡ proj₁ p2) λ { refl → proj₂ p1 ≡ proj₂ p2 }
pairs {A} {B} refl = refl , refl

split-env-right-lemma0' :
  ∀ {Φ G} (ϱ : VEnv G Φ) →
  let gis = ssplit-refl-right-inactive G in
  (split-env (split-all-right Φ) ϱ
  ≡
  ((proj₁ gis , G) , proj₂ (proj₂ gis) , vnil (proj₁ (proj₂ gis)) , ϱ))
split-env-right-lemma0' (vnil []-inactive) = refl
split-env-right-lemma0' (vnil (::-inactive ina))
  with split-env-right-lemma0' (vnil ina)
... | ih
  with pairs ih
... | p1== , p2==
  = {!!}
split-env-right-lemma0'{t ∷ Φ} (vcons ssp v ϱ)
  with split-env-right-lemma0' ϱ
... | ih
  with split-env (split-all-right Φ) ϱ
... | sesar
    = {!!}

full-reduction-type : Set
full-reduction-type = ∀ {Φ G} (s : SType) (E : Expr (tch s ∷ Φ) TUnit) (ϱ : VEnv G Φ) →
    let lhs = runProc G (mklhs s E) ϱ in
    let rhs = runProc G (mkrhs s E) ϱ in
    single-step (proj₁ lhs ++ G , proj₂ lhs) ≡ (New , proj₁ rhs ++ G , proj₂ rhs)

full-reduction : full-reduction-type
full-reduction{Φ}{G} s E ϱ
  with ssplit-refl-left-inactive G
... | ssrli
  rewrite split-env-right-lemma0' ϱ
    | split-rotate-lemma {Φ}
  = {!!}

-}


-- Andreas, 2016-06-13 issue #2027: Unbound variables in pattern synonyms
-- Quiz by Ulf

postulate Nat : Set

pattern hm = x
-- This pattern synonym should fail with a message like
-- Unbound variables in pattern synonym:  x

quiz₁ : Nat → Nat → Nat
quiz₁ hm hm = hm

quiz₂ : Nat → Nat
quiz₂ x = hm

quiz₃ : Nat → Nat
quiz₃ hm = x
-- OLD ERROR: Not in scope: x


module Sodium where

open import Category.Functor
open import Category.Applicative
open import Category.Monad
open import Data.Unit
open import Data.Bool
open import Data.Maybe
open import Data.Product
open import IO.Primitive

postulate

  -- Core.

  Reactive : Set → Set
  sync     : ∀ {A} → Reactive A → IO A

  Event     : Set → Set
  Behaviour : Set → Set

  listen    : ∀ {A} → Event A → (A → IO ⊤) → Reactive (IO ⊤)

  filterJust    : ∀ {A} → Event (Maybe A) → Event A
  hold          : ∀ {A} → A → Event A → Reactive (Behaviour A)
  updates value : ∀ {A} → Behaviour A → Event A
  snapshot      : ∀ {A B C} → (A → B → C) → Event A → Behaviour B → Event C

  -- Derived.

  gate     : ∀ {A} → Event A → Behaviour Bool → Event A
  filterE  : ∀ {A} → (A → Bool) → Event A → Event A

  collectE : ∀ {A B} {S : Set} → (A → S → (B × S)) → S →
             Event A → Reactive (Event B)

  collect  : ∀ {A B} {S : Set} → (A → S → (B × S)) → S →
             Behaviour A → Reactive (Behaviour B)

  accum    : ∀ {A} → A → Event (A → A) → Reactive (Behaviour A)

  -- IO.

  executeSyncIO executeAsyncIO : ∀ {A} → Event (IO A) → Event A

  -- Instances.

  reactiveMonad        : RawMonad Reactive
  behaviourApplicative : RawApplicative Behaviour
  eventFunctor         : RawFunctor Event


{-# OPTIONS --cubical --safe #-}

module Data.Lift where

open import Level

record Lift {a} ℓ (A : Type a) : Type (a ℓ⊔ ℓ) where
  constructor lift
  field lower : A

open Lift public


open import Nat
open import Prelude
open import dynamics-core

module lemmas-progress-checks where
  -- boxed values don't have an instruction transition
  boxedval-not-trans : ∀{d d'} → d boxedval → d →> d' → ⊥
  boxedval-not-trans (BVVal VNum) ()
  boxedval-not-trans (BVVal VLam) ()
  boxedval-not-trans (BVArrCast x bv) (ITCastID) = x refl
  boxedval-not-trans (BVHoleCast () bv) (ITCastID)
  boxedval-not-trans (BVHoleCast () bv) (ITCastSucceed x₁)
  boxedval-not-trans (BVHoleCast GArrHole bv) (ITGround (MGArr x)) = x refl
  boxedval-not-trans (BVHoleCast x a) (ITExpand ())
  boxedval-not-trans (BVHoleCast x x₁) (ITCastFail x₂ () x₄)
  boxedval-not-trans (BVVal (VInl x)) ()
  boxedval-not-trans (BVVal (VInr x)) ()
  boxedval-not-trans (BVSumCast x x₁) ITCastID = x refl
  boxedval-not-trans (BVHoleCast GSumHole x₁) (ITGround (MGSum x₂)) = x₂ refl
  boxedval-not-trans (BVInl bv) ()
  boxedval-not-trans (BVInr bv) ()
  boxedval-not-trans (BVPair bv bv₁) ()
  boxedval-not-trans (BVProdCast x bv) ITCastID = x refl
  boxedval-not-trans (BVHoleCast GProdHole bv) (ITGround (MGProd x)) = x refl

  -- indets don't have an instruction transition
  indet-not-trans : ∀{d d'} → d indet → d →> d' → ⊥
  indet-not-trans IEHole ()
  indet-not-trans (INEHole x) ()
  indet-not-trans (IAp x₁ () x₂) (ITLam)
  indet-not-trans (IAp x (ICastArr x₁ ind) x₂) ITApCast = x _ _ _ _ _ refl
  indet-not-trans (ICastArr x ind) (ITCastID) = x refl
  indet-not-trans (ICastGroundHole () ind) (ITCastID)
  indet-not-trans (ICastGroundHole x ind) (ITCastSucceed ())
  indet-not-trans (ICastGroundHole GArrHole ind) (ITGround (MGArr x)) = x refl
  indet-not-trans (ICastHoleGround x ind ()) (ITCastID)
  indet-not-trans (ICastHoleGround x ind x₁) (ITCastSucceed x₂) = x _ _ refl
  indet-not-trans (ICastHoleGround x ind GArrHole) (ITExpand (MGArr x₂)) = x₂ refl
  indet-not-trans (ICastGroundHole x a) (ITExpand ())
  indet-not-trans (ICastHoleGround x a x₁) (ITGround ())
  indet-not-trans (ICastGroundHole x x₁) (ITCastFail x₂ () x₄)
  indet-not-trans (ICastHoleGround x x₁ x₂) (ITCastFail x₃ x₄ x₅) = x _ _ refl
  indet-not-trans (IFailedCast x x₁ x₂ x₃) ()
  indet-not-trans (IPlus1 () x₁) (ITPlus x₂)
  indet-not-trans (IPlus2 x ()) (ITPlus x₂)
  indet-not-trans (ICase x x₂ x₃ (IInl x₄)) ITCaseInl = x _ _ refl
  indet-not-trans (ICase x x₂ x₃ (IInr x₄)) ITCaseInr = x₂ _ _ refl
  indet-not-trans (ICase x x₂ x₃ (ICastSum x₁ x₄)) ITCaseCast = x₃ _ _ _ _ _ refl
  indet-not-trans (ICastSum x x₂) ITCastID = x refl
  indet-not-trans (ICastGroundHole GSumHole x₂) (ITGround (MGSum x₁)) = x₁ refl
  indet-not-trans (ICastGroundHole GProdHole ind) (ITGround (MGProd x)) = x refl
  indet-not-trans (ICastHoleGround x x₂ GSumHole) (ITExpand (MGSum x₁)) = x₁ refl
  indet-not-trans (ICastHoleGround x ind GProdHole) (ITExpand (MGProd x₁)) = x₁ refl
  indet-not-trans (IInl ind) ()
  indet-not-trans (IInr ind) ()
  indet-not-trans (IPair1 ind x) ()
  indet-not-trans (IPair2 x ind) ()
  indet-not-trans (IFst x x₁ ind) ITFstPair = x _ _ refl
  indet-not-trans (IFst x x₁ ind) ITFstCast = x₁ _ _ _ _ _ refl
  indet-not-trans (ISnd x x₁ ind) ITSndPair = x _ _ refl
  indet-not-trans (ISnd x x₁ ind) ITSndCast = x₁ _ _ _ _ _ refl
  indet-not-trans (ICastProd x ind) ITCastID = x refl
  indet-not-trans (ICastGroundHole GNum ind) (ITGround ())
  indet-not-trans (ICastHoleGround x ind GNum) (ITExpand ())
  -- finals don't have an instruction transition
  final-not-trans : ∀{d d'} → d final → d →> d' → ⊥
  final-not-trans (FBoxedVal x) = boxedval-not-trans x
  final-not-trans (FIndet x) = indet-not-trans x

  -- finals cast from a ground are still final
  final-gnd-cast : ∀{ d τ } → d final → τ ground → (d ⟨ τ ⇒ ⦇-⦈ ⟩) final
  final-gnd-cast (FBoxedVal x) gnd = FBoxedVal (BVHoleCast gnd x)
  final-gnd-cast (FIndet x) gnd = FIndet (ICastGroundHole gnd x)

  -- if an expression results from filling a hole in an evaluation context,
  -- the hole-filler must have been final
  final-sub-final : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  final-sub-final x FHOuter = x
  final-sub-final (FBoxedVal (BVVal ())) (FHPlus1 eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHPlus2 eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHAp1 eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHAp2 eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHNEHole eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHCast eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHFailedCast y)
  final-sub-final (FBoxedVal (BVArrCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps
  final-sub-final (FBoxedVal (BVHoleCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps
  final-sub-final (FIndet (IPlus1 x x₁)) (FHPlus1 eps) = final-sub-final (FIndet x) eps
  final-sub-final (FIndet (IPlus2 x x₁)) (FHPlus1 eps) = final-sub-final x eps
  final-sub-final (FIndet (IPlus1 x x₁)) (FHPlus2 eps) = final-sub-final x₁ eps
  final-sub-final (FIndet (IPlus2 x x₁)) (FHPlus2 eps) = final-sub-final (FIndet x₁) eps
  final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp2 eps) = final-sub-final x₃ eps
  final-sub-final (FIndet (INEHole x₁)) (FHNEHole eps) = final-sub-final x₁ eps
  final-sub-final (FIndet (ICastArr x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (IFailedCast x₁ x₂ x₃ x₄)) (FHFailedCast y) = final-sub-final x₁ y
  final-sub-final (FBoxedVal (BVVal ())) (FHCase eps)
  final-sub-final (FBoxedVal (BVSumCast x x₁)) (FHCast eps) = final-sub-final (FBoxedVal x₁) eps
  final-sub-final (FIndet (ICase x x₁ x₂ x₃)) (FHCase eps) = final-sub-final (FIndet x₃) eps
  final-sub-final (FIndet (ICastSum x x₁)) (FHCast eps) = final-sub-final (FIndet x₁) eps
  final-sub-final (FBoxedVal (BVVal (VInl x))) (FHInl eps) = final-sub-final (FBoxedVal (BVVal x)) eps
  final-sub-final (FBoxedVal (BVInl x)) (FHInl eps) = final-sub-final (FBoxedVal x) eps
  final-sub-final (FIndet (IInl x)) (FHInl eps) = final-sub-final (FIndet x) eps
  final-sub-final (FBoxedVal (BVVal (VInr x))) (FHInr eps) = final-sub-final (FBoxedVal (BVVal x)) eps
  final-sub-final (FBoxedVal (BVInr x)) (FHInr eps) = final-sub-final (FBoxedVal x) eps
  final-sub-final (FBoxedVal (BVProdCast x x₁)) (FHCast eps) = final-sub-final (FBoxedVal x₁) eps
  final-sub-final (FIndet (IInr x)) (FHInr eps) = final-sub-final (FIndet x) eps
  final-sub-final (FBoxedVal (BVVal ())) (FHFst eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHSnd eps)
  final-sub-final (FBoxedVal (BVVal (VPair x x₁))) (FHPair1 eps) = final-sub-final (FBoxedVal (BVVal x)) eps
  final-sub-final (FBoxedVal (BVPair x x₁)) (FHPair1 eps) = final-sub-final (FBoxedVal x) eps
  final-sub-final (FBoxedVal (BVVal (VPair x x₁))) (FHPair2 eps) = final-sub-final (FBoxedVal (BVVal x₁)) eps
  final-sub-final (FBoxedVal (BVPair x x₁)) (FHPair2 eps) = final-sub-final (FBoxedVal x₁) eps
  final-sub-final (FIndet (IFst x x₁ x₂)) (FHFst eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (ISnd x x₁ x₂)) (FHSnd eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (IPair1 x x₁)) (FHPair1 eps) = final-sub-final (FIndet x) eps
  final-sub-final (FIndet (IPair2 x x₁)) (FHPair1 eps) = final-sub-final x eps
  final-sub-final (FIndet (IPair1 x x₁)) (FHPair2 eps) = final-sub-final x₁ eps
  final-sub-final (FIndet (IPair2 x x₁)) (FHPair2 eps) = final-sub-final (FIndet x₁) eps
  final-sub-final (FIndet (ICastProd x x₁)) (FHCast eps) = final-sub-final (FIndet x₁) eps

  final-sub-not-trans : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  final-sub-not-trans f sub step = final-not-trans (final-sub-final f sub) step


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Container.Relation.Unary.Any directly.
------------------------------------------------------------------------

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

module Data.Container.Any where

open import Data.Container.Relation.Unary.Any public
open import Data.Container.Relation.Unary.Any.Properties public


-- Andreas, 2020-11-16, issue #5055, reported by nad
-- Internal error caused by record pattern on pattern synonym lhs
-- (unreleased regression in 2.6.2).

open import Agda.Builtin.Sigma

data Shape : Set where
  c : Shape → Shape

pattern p (s , v) = c s , v

-- Should give some parse error or other controlled error.

-- Illegal pattern synonym argument  _ @ (s , v)
-- (Arguments to pattern synonyms cannot be patterns themselves.)
-- =<ERROR>
--  c s , v


-- Andreas, 2021-04-28, issue #5336
-- data...where is already extensible.

module _ where

module C where
  postulate
    Name QName : Set

variable
  x  y  : C.Name
  xs ys : C.QName

interleaved mutual

  -- Scope of a declaration.

  data Scope : Set
  variable
    sc sc' : Scope

  -- Declarations in a scope.

  data Decls (sc : Scope) : Set
  variable
    ds₀ ds ds' : Decls sc

  -- A definition in a scope.
  -- So far, we can only define modules, which hold declarations.

  data Val : (sc : Scope) → Set

  -- We use letter v ("value") for definitions.

  variable
    v v' : Val sc

  -- A well-scoped name pointing to its definition.

  data Name : (sc : Scope) → Val sc → Set

  variable
    n n' : Name sc v

  -- A well-scoped declaration is one of
  --
  --   * A module definition.
  --   * Importing the declarations of another module via `open`.

  data Decl (sc : Scope) : Set where
    modl : (x : C.Name) (ds : Decls sc) → Decl sc
    opn  : (n : Name sc v)              → Decl sc

  variable
    d d' : Decl sc

  -- A scope is a snoc list of lists of declarations.

  data Scope where
    ε   : Scope

  data Scope where
    _▷_ : (sc : Scope) (ds : Decls sc) → Scope

  -- Lists of declarations are also given in snoc-form.

  data Decls where
    ε   : Decls sc

  data Decls where
    _▷_ : (ds : Decls sc) (d : Decl (sc ▷ ds)) → Decls sc

  data Val where
    -- The content of a module.
    content : (ds : Decls sc) → Val sc
    -- Qualifying a value that is taken from inside module x.
    inside  : (x : C.Name) (v : Val ((sc ▷ ds) ▷ ds')) → Val (sc ▷ (ds ▷ modl x ds'))
    imp     : (n : Name (sc ▷ ds₀) (content ds')) (v : Val ((sc ▷ ds₀) ▷ ds'))
            → Val (sc ▷ (ds₀ ▷ opn n))

  -- Weakning from one scope to an extended scope.

  data _⊆_ : (sc sc' : Scope) → Set

  variable
    τ : sc ⊆ sc'

  -- Weakning by a list of declarations or a single declaration.

  wk1  : sc ⊆ (sc ▷ ds)
  wk01 : (sc ▷ ds) ⊆ (sc ▷ (ds ▷ d))

  -- Weakening a definition.

  data WkVal : (τ : sc ⊆ sc') → Val sc → Val sc' → Set

  variable
    wv wv' wv₀ : WkVal τ v v'

  data WkDecl  (τ : sc ⊆ sc') : Decl  sc → Decl  sc' → Set
  variable
    wd wd' : WkDecl τ d d'

  data WkDecls : (τ : sc ⊆ sc') → Decls sc → Decls sc' → Set
  variable
    wds₀ wds wds' : WkDecls τ ds ds'

  -- Names resolving in a list of declarations.

  data DsName (sc : Scope) : (ds : Decls sc) → Val (sc ▷ ds) → Set -- where
  variable
    nds nds' : DsName sc ds v

  -- Names resolving in a declaration.

  data DName  (sc : Scope) (ds₀ : Decls sc) : (d : Decl (sc ▷ ds₀)) → Val (sc ▷ (ds₀ ▷ d)) → Set where

    modl   : (wds : WkDecls wk01 ds ds')
           → DName sc ds₀ (modl x ds) (content ds')

    inside : (n : DsName (sc ▷ ds₀) ds' v)
           → DName sc ds₀ (modl x ds') (inside x v)

    imp    : (n : Name (sc ▷ ds₀) (content ds'))
             (nds : DsName (sc ▷ ds₀) ds' v)
           → DName sc ds₀ (opn n) (imp n v)

  variable
    nd nd' : DName sc ds d  v

  -- This finally allows us to define names resolving in a scope.

  data DsName where
    here  : (nd  : DName  sc ds d v)                     → DsName sc (ds ▷ d) v
    there : (w : WkVal wk01 v v') (nds : DsName sc ds v) → DsName sc (ds ▷ d) v'

  data Name where
    site   :                      (nds : DsName sc ds v) → Name (sc ▷ ds) v
    parent : (w : WkVal wk1 v v') (n   : Name   sc    v) → Name (sc ▷ ds) v'

  ------------------------------------------------------------------------
  -- Relating entities defined in a scope to their weakenings.

  -- Weakenings are order-preserving embeddings.

  data _⊆_ where
    ε    : ε ⊆ ε
    _▷_  : (τ : sc ⊆ sc') (wds : WkDecls τ ds ds') → (sc ▷ ds) ⊆ (sc' ▷ ds')
    _▷ʳ_ : (τ : sc ⊆ sc') (ds  : Decls sc')        → sc        ⊆ (sc' ▷ ds)

  data WkDecls where
    ε     : WkDecls τ ε ε
    _▷_   : (ws : WkDecls τ ds ds') (wd : WkDecl (τ ▷ ws) d d') → WkDecls τ (ds ▷ d) (ds' ▷ d')
    _▷ʳ_  : (ws : WkDecls τ ds ds') (d  : Decl (_ ▷ ds'))       → WkDecls τ  ds      (ds' ▷ d)

  refl-⊆         : sc ⊆ sc
  wkDecls-refl-⊆ : WkDecls τ ds ds
  wkDecl-refl-⊆  : WkDecl  τ d  d

  wkDecls-refl-⊆ {ds = ε}      = ε
  wkDecls-refl-⊆ {ds = ds ▷ d} = wkDecls-refl-⊆ ▷ wkDecl-refl-⊆

  refl-⊆ {sc = ε}       = ε
  refl-⊆ {sc = sc ▷ ds} = refl-⊆ ▷ wkDecls-refl-⊆

  -- We can now define the singleton weaknings.

  -- By another list of declarations.
  wk1 {ds = ds} = refl-⊆ ▷ʳ ds

  -- By a single declaration.
  wk01 {d = d} = refl-⊆ ▷ (wkDecls-refl-⊆ ▷ʳ d)

  -- Weakning names

  data WkName : (τ : sc ⊆ sc') (wv : WkVal τ v v') → Name sc v → Name sc' v' → Set

  postulate
    wkVal-refl-⊆  : WkVal  τ    v v
    wkName-refl-⊆ : WkName τ wv n n

  data WkDecl where
    modl : (w  : WkDecls τ    ds ds') → WkDecl τ (modl x ds) (modl x ds')
    opn  : (wn : WkName  τ wv n  n' ) → WkDecl τ (opn n)   (opn n')

  wkDecl-refl-⊆ {d = modl x ds} = modl wkDecls-refl-⊆
  wkDecl-refl-⊆ {d = opn n    } = opn {wv = wkVal-refl-⊆} wkName-refl-⊆

  -- We can prove that the identity weaking leaves definitions unchanged.

  data WkVal where
    content : (wds : WkDecls τ ds ds') → WkVal τ (content ds) (content ds')
    inside  : (wv : WkVal ((τ ▷ wds) ▷ wds') v  v' )
            → WkVal (τ ▷ (wds ▷ modl wds')) (inside x v) (inside x v')

  data WkName where
    site   : WkName τ wv (site nds) (site nds')