------------------------------------------------------------------------
-- Encodings and properties of higher-order extrema and intervals in
-- Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Typing.Encodings where

open import Data.Fin using (zero)
open import Data.Fin.Substitution using (Sub; Lift; TermSubst)
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Nat using (suc)
open import Data.Product using (_,_; proj₁; proj₂; _×_)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import FOmegaInt.Syntax
open import FOmegaInt.Typing
open import FOmegaInt.Typing.Validity

open Syntax
open TermCtx
open Substitution hiding (subst; _/_; _Kind/_)
open Typing
open TypedSubstitution
open TypedNarrowing

----------------------------------------------------------------------
-- Injection of shapes into kinds.

-- For every shape `k' there is a kind `⌈ k ⌉' that erases/simplifies
-- back to `k', i.e. `⌈_⌉' is a right inverse of kind erasure `⌊_⌋'.
--
-- NOTE. The definition of the injection `⌈_⌉' is rather intuitive,
-- but it is neither the only right inverse of `⌊_⌋', nor even the
-- "most canonical" one.  Below we define two alternatives `⌈_⌉↓' and
-- `⌈_⌉↑' which, in addition to being right-inverse to `⌊_⌋', have
-- some appealing order-theoretic properties.

⌈_⌉ : ∀ {n} → SKind → Kind Term n
⌈ ★     ⌉ = *
⌈ j ⇒ k ⌉ = Π ⌈ j ⌉ ⌈ k ⌉

⌊⌋∘⌈⌉-id : ∀ {n} k → ⌊ ⌈_⌉ {n} k ⌋ ≡ k
⌊⌋∘⌈⌉-id ★       = refl
⌊⌋∘⌈⌉-id (j ⇒ k) = cong₂ _⇒_ (⌊⌋∘⌈⌉-id j) (⌊⌋∘⌈⌉-id k)

-- The kind `⌈ k ⌉' is well-formed (in any well-formed context).

⌈⌉-kd : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢ ⌈ k ⌉ kd
⌈⌉-kd ★       Γ-ctx = *-kd Γ-ctx
⌈⌉-kd (j ⇒ k) Γ-ctx =
  let ⌈j⌉-kd = ⌈⌉-kd j Γ-ctx
  in kd-Π ⌈j⌉-kd (⌈⌉-kd k (wf-kd ⌈j⌉-kd ∷ Γ-ctx))

----------------------------------------------------------------------
-- Encodings and properties of extremal kinds.

-- The empty interval (note the use of absurd bounds).

∅ : ∀ {n} → Kind Term n
∅ = ⊤ ⋯ ⊥

-- Well-formedness of the empty interval kind.

∅-kd : ∀ {n} {Γ : Ctx n} → Γ ctx → Γ ⊢ ∅ kd
∅-kd Γ-ctx = kd-⋯ (∈-⊤-f Γ-ctx) (∈-⊥-f Γ-ctx)

-- Right-inverses of kind simplification: for every shape `k' there
-- are two canonical kinds `⌈ k ⌉↓' and `⌈ k ⌉↑', such that
--
--  1. `⌈_⌉↓' and `⌈_⌉↑' are right-inverses for `⌊_⌋', i.e. `⌈ k ⌉↓'
--     and `⌈ k ⌉↑' both simplify to `k',
--
--  2. `⌈ k ⌉↓' and `⌈ k ⌉↑' are limits, i.e. they are the least
--     resp. greatest kinds for which 1 holds.
--
-- NOTE. Rather than thinking of `⌈_⌉↓' and `⌈_⌉↑' as right-inverses
-- of kind simplifications, one may instead think of `⌊_⌋' as defining
-- a "kind space" `S(k, Γ) = { j | ⌊ j ⌋ ≡ k, Γ ⊢ j kd }' ordered by
-- subkinding, and interpret `⌈ k ⌉↓' and `⌈ k ⌉↑' as the extrema of
-- the space `S(k, Γ)' associated with `k'.

mutual

  ⌈_⌉↓ : ∀ {n} → SKind → Kind Term n
  ⌈ ★     ⌉↓ = ∅
  ⌈ j ⇒ k ⌉↓ = Π ⌈ j ⌉↑ ⌈ k ⌉↓

  ⌈_⌉↑ : ∀ {n} → SKind → Kind Term n
  ⌈ ★     ⌉↑ = *
  ⌈ j ⇒ k ⌉↑ = Π ⌈ j ⌉↓ ⌈ k ⌉↑

mutual

  -- Proof of point 1 above: `⌈_⌉↓' and `⌈_⌉↑' are right-inverses of
  -- `⌊_⌋'.

  ⌊⌋∘⌈⌉↓-id : ∀ {n} k → ⌊ ⌈_⌉↓ {n} k ⌋ ≡ k
  ⌊⌋∘⌈⌉↓-id ★       = refl
  ⌊⌋∘⌈⌉↓-id (j ⇒ k) = cong₂ _⇒_ (⌊⌋∘⌈⌉↑-id j) (⌊⌋∘⌈⌉↓-id k)

  ⌊⌋∘⌈⌉↑-id : ∀ {n} k → ⌊ ⌈_⌉↑ {n} k ⌋ ≡ k
  ⌊⌋∘⌈⌉↑-id ★       = refl
  ⌊⌋∘⌈⌉↑-id (j ⇒ k) = cong₂ _⇒_ (⌊⌋∘⌈⌉↓-id j) (⌊⌋∘⌈⌉↑-id k)

mutual

  -- `⌈ k ⌉↓' and `⌈ k ⌉↑' are well-formed (in any well-formed
  -- context).

  ⌈⌉↓-kd : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢ ⌈ k ⌉↓ kd
  ⌈⌉↓-kd ★       Γ-ctx = ∅-kd Γ-ctx
  ⌈⌉↓-kd (j ⇒ k) Γ-ctx =
    let ⌈j⌉↑-kd = ⌈⌉↑-kd j Γ-ctx
    in kd-Π ⌈j⌉↑-kd (⌈⌉↓-kd k (wf-kd ⌈j⌉↑-kd ∷ Γ-ctx))

  ⌈⌉↑-kd : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢ ⌈ k ⌉↑ kd
  ⌈⌉↑-kd ★       Γ-ctx = *-kd Γ-ctx
  ⌈⌉↑-kd (j ⇒ k) Γ-ctx =
    let ⌈j⌉↓-kd = ⌈⌉↓-kd j Γ-ctx
    in kd-Π ⌈j⌉↓-kd (⌈⌉↑-kd k (wf-kd ⌈j⌉↓-kd ∷ Γ-ctx))

mutual

  -- Proof of point 2 above: `⌈ k ⌉↓' and `⌈ k ⌉↑' are the least
  -- resp. greatest (well-formed) kinds that have shape `k'.

  ⌈⌉↑-maximum : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ⊢ k <∷ ⌈ ⌊ k ⌋ ⌉↑
  ⌈⌉↑-maximum (kd-⋯ a∈* b∈*)       = <∷-⋯ (<:-⊥ a∈*) (<:-⊤ b∈*)
  ⌈⌉↑-maximum (kd-Π {j} j-kd k-kd) =
    let ⌈⌊j⌋⌉↓<∷j = ⌈⌉↓-minimum j-kd
    in <∷-Π ⌈⌊j⌋⌉↓<∷j (⌈⌉↑-maximum (⇓-kd ⌈⌊j⌋⌉↓<∷j k-kd))
            (kd-Π j-kd k-kd)

  ⌈⌉↓-minimum : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ⊢ ⌈ ⌊ k ⌋ ⌉↓ <∷ k
  ⌈⌉↓-minimum (kd-⋯ a∈* b∈*)   = <∷-⋯ (<:-⊤ a∈*) (<:-⊥ b∈*)
  ⌈⌉↓-minimum (kd-Π {j} {k} j-kd k-kd) =
    <∷-Π (⌈⌉↑-maximum j-kd) (⌈⌉↓-minimum k-kd) (⌈⌉↓-kd ⌊ Π j k ⌋ (kd-ctx j-kd))

-- Some corollaries.

-- Minima are subkinds of maxima.

⌈⌉↓<∷⌈⌉↑ : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢ ⌈ k ⌉↓ <∷ ⌈ k ⌉↑
⌈⌉↓<∷⌈⌉↑ k Γ-ctx =
  subst (_ ⊢ ⌈ k ⌉↓ <∷_) (cong ⌈_⌉↑ (⌊⌋∘⌈⌉↓-id k))
        (⌈⌉↑-maximum (⌈⌉↓-kd k Γ-ctx))

-- Minima are subkinds of the "intuitively" injected shapes.

⌈⌉↓<∷⌈⌉ : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢ ⌈ k ⌉↓ <∷ ⌈ k ⌉
⌈⌉↓<∷⌈⌉ k Γ-ctx =
  subst (_ ⊢_<∷ ⌈ k ⌉) (cong ⌈_⌉↓ (⌊⌋∘⌈⌉-id k))
        (⌈⌉↓-minimum (⌈⌉-kd k Γ-ctx))

-- Maxima are superkinds of the "intuitively" injected shapes.

⌈⌉<∷⌈⌉↑ : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢ ⌈ k ⌉ <∷ ⌈ k ⌉↑
⌈⌉<∷⌈⌉↑ k Γ-ctx =
  subst (_ ⊢ ⌈ k ⌉ <∷_) (cong ⌈_⌉↑ (⌊⌋∘⌈⌉-id k))
        (⌈⌉↑-maximum (⌈⌉-kd k Γ-ctx))

-- Every well-kinded type inhabits the maximum kind associated with
-- its shape.

∈-⇑-⌈⌉↑ : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Tp a ∈ k → Γ ⊢Tp a ∈ ⌈ ⌊ k ⌋ ⌉↑
∈-⇑-⌈⌉↑ a∈k = ∈-⇑ a∈k (⌈⌉↑-maximum (Tp∈-valid a∈k))

----------------------------------------------------------------------
-- Encodings and properties of higher-order extrema

-- Higher-order extremal types, indexed by shapes.
--
-- NOTE. We will define a variant of the higher-order extrema indexed
-- by possibly dependent kinds below.

⊥⟨_⟩ : ∀ {n} → SKind → Term n
⊥⟨ ★ ⟩     = ⊥
⊥⟨ j ⇒ k ⟩ = Λ ⌈ j ⌉ ⊥⟨ k ⟩

⊤⟨_⟩ : ∀ {n} → SKind → Term n
⊤⟨ ★ ⟩     = ⊤
⊤⟨ j ⇒ k ⟩ = Λ ⌈ j ⌉ ⊤⟨ k ⟩

-- ⊥⟨ k ⟩ and ⊤⟨ k ⟩ inhabit ⌈ k ⌉.

∈-⊥⟨⟩ : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢Tp ⊥⟨ k ⟩ ∈ ⌈ k ⌉
∈-⊥⟨⟩ ★       Γ-ctx = ∈-⊥-f Γ-ctx
∈-⊥⟨⟩ (j ⇒ k) Γ-ctx =
  let ⌈j⌉-kd = ⌈⌉-kd j Γ-ctx
      ⌈j⌉∷Γ  = wf-kd ⌈j⌉-kd ∷ Γ-ctx
  in ∈-Π-i ⌈j⌉-kd (∈-⊥⟨⟩ k ⌈j⌉∷Γ)

∈-⊤⟨⟩ : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢Tp ⊤⟨ k ⟩ ∈ ⌈ k ⌉
∈-⊤⟨⟩ ★       Γ-ctx = ∈-⊤-f Γ-ctx
∈-⊤⟨⟩ (j ⇒ k) Γ-ctx =
  let ⌈j⌉-kd = ⌈⌉-kd j Γ-ctx
      ⌈j⌉∷Γ  = wf-kd ⌈j⌉-kd ∷ Γ-ctx
  in ∈-Π-i ⌈j⌉-kd (∈-⊤⟨⟩ k ⌈j⌉∷Γ)

-- ⊥⟨ k ⟩ and ⊤⟨ k ⟩ are extremal types in ⌈ k ⌉.

⊥⟨⟩-minimum : ∀ {n} {Γ : Ctx n} {a k} →
              Γ ⊢Tp a ∈ ⌈ k ⌉ → Γ ⊢ ⊥⟨ k ⟩ <: a ∈ ⌈ k ⌉
⊥⟨⟩-minimum {k = ★    } a∈*     = <:-⊥ a∈*
⊥⟨⟩-minimum {k = j ⇒ k} a∈⌈j⇒k⌉ =
  <:-trans (<:-λ (⊥⟨⟩-minimum a·z∈⌈k⌉) (∈-⊥⟨⟩ (j ⇒ k) Γ-ctx) Λa·z∈⌈j⇒k⌉)
           (<:-η₁ a∈⌈j⇒k⌉)
  where
    Γ-ctx  = Tp∈-ctx a∈⌈j⇒k⌉
    Λa·z∈⌈j⇒k⌉ = Tp∈-η a∈⌈j⇒k⌉
    a·z∈⌈k⌉    = proj₂ (Tp∈-Λ-inv Λa·z∈⌈j⇒k⌉)

⊤⟨⟩-maximum : ∀ {n} {Γ : Ctx n} {a k} →
              Γ ⊢Tp a ∈ ⌈ k ⌉ → Γ ⊢ a <: ⊤⟨ k ⟩ ∈ ⌈ k ⌉
⊤⟨⟩-maximum {k = ★    } a∈*     = <:-⊤ a∈*
⊤⟨⟩-maximum {k = j ⇒ k} a∈⌈j⇒k⌉ =
  <:-trans (<:-η₂ a∈⌈j⇒k⌉)
           (<:-λ (⊤⟨⟩-maximum a·z∈⌈k⌉) Λa·z∈⌈j⇒k⌉ (∈-⊤⟨⟩ (j ⇒ k) Γ-ctx))
  where
    Γ-ctx  = Tp∈-ctx a∈⌈j⇒k⌉
    Λa·z∈⌈j⇒k⌉ = Tp∈-η a∈⌈j⇒k⌉
    a·z∈⌈k⌉    = proj₂ (Tp∈-Λ-inv Λa·z∈⌈j⇒k⌉)

-- An alternate pair of higher-order extremal types inhabiting the
-- family of kinds ⌈ k ⌉↑, rather than ⌈ k ⌉.

⊥↑⟨_⟩ : ∀ {n} → SKind → Term n
⊥↑⟨ ★ ⟩     = ⊥
⊥↑⟨ j ⇒ k ⟩ = Λ ⌈ j ⌉↑ ⊥↑⟨ k ⟩

⊤↑⟨_⟩ : ∀ {n} → SKind → Term n
⊤↑⟨ ★ ⟩     = ⊤
⊤↑⟨ j ⇒ k ⟩ = Λ ⌈ j ⌉↑ ⊤↑⟨ k ⟩

-- ⊥↑⟨ k ⟩ and ⊤↑⟨ k ⟩ inhabit ⌈ k ⌉↑.

∈-⊥↑⟨⟩ : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢Tp ⊥↑⟨ k ⟩ ∈ ⌈ k ⌉↑
∈-⊥↑⟨⟩ ★       Γ-ctx = ∈-⊥-f Γ-ctx
∈-⊥↑⟨⟩ (j ⇒ k) Γ-ctx =
  let ⌈j⌉↑-kd = ⌈⌉↑-kd j Γ-ctx
      ⌈j⌉↑∷Γ  = wf-kd ⌈j⌉↑-kd ∷ Γ-ctx
      ⌈k⌉↑-kd = ⌈⌉↑-kd k ⌈j⌉↑∷Γ
  in ∈-⇑ (∈-Π-i ⌈j⌉↑-kd (∈-⊥↑⟨⟩ k ⌈j⌉↑∷Γ))
         (<∷-Π (⌈⌉↓<∷⌈⌉↑ j Γ-ctx)
               (<∷-refl (⌈⌉↑-kd k ((wf-kd (⌈⌉↓-kd j Γ-ctx)) ∷ Γ-ctx)))
               (kd-Π ⌈j⌉↑-kd ⌈k⌉↑-kd))

∈-⊤↑⟨⟩ : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢Tp ⊤↑⟨ k ⟩ ∈ ⌈ k ⌉↑
∈-⊤↑⟨⟩ ★       Γ-ctx = ∈-⊤-f Γ-ctx
∈-⊤↑⟨⟩ (j ⇒ k) Γ-ctx =
  let ⌈j⌉↑-kd = ⌈⌉↑-kd j Γ-ctx
      ⌈j⌉↑∷Γ  = wf-kd ⌈j⌉↑-kd ∷ Γ-ctx
      ⌈k⌉↑-kd = ⌈⌉↑-kd k ⌈j⌉↑∷Γ
  in ∈-⇑ (∈-Π-i ⌈j⌉↑-kd (∈-⊤↑⟨⟩ k ⌈j⌉↑∷Γ))
         (<∷-Π (⌈⌉↓<∷⌈⌉↑ j Γ-ctx)
               (<∷-refl (⌈⌉↑-kd k ((wf-kd (⌈⌉↓-kd j Γ-ctx)) ∷ Γ-ctx)))
               (kd-Π ⌈j⌉↑-kd ⌈k⌉↑-kd))

-- ⊥↑⟨ k ⟩ and ⊤↑⟨ k ⟩ are extremal types in ⌈ k ⌉↑.

⊥↑⟨⟩-minimum : ∀ {n} {Γ : Ctx n} {a k} →
               Γ ⊢Tp a ∈ k → Γ ⊢ ⊥↑⟨ ⌊ k ⌋ ⟩ <: a ∈ ⌈ ⌊ k ⌋ ⌉↑
⊥↑⟨⟩-minimum {k = b ⋯ c} a∈b⋯c = <:-⊥ a∈b⋯c
⊥↑⟨⟩-minimum {k = Π j k} a∈Πjk with Tp∈-valid a∈Πjk
... | kd-Π j-kd k-kd =
  <:-trans (<:-λ (⊥↑⟨⟩-minimum a·z∈k′) (∈-⊥↑⟨⟩ ⌊ Π j k ⌋ Γ-ctx)
                 (∈-⇑ Λa·z∈Πjk Πjk<∷⌈Πjk⌉↑))
           (<:-⇑ (<:-η₁ a∈Πjk) Πjk<∷⌈Πjk⌉↑)
  where
    Πjk<∷⌈Πjk⌉↑ = ⌈⌉↑-maximum (kd-Π j-kd k-kd)
    Γ-ctx       = Tp∈-ctx a∈Πjk
    ⌈⌊j⌋⌉↓<∷j   = ⌈⌉↓-minimum j-kd
    Λa·z∈Πjk    = Tp∈-η a∈Πjk
    a·z∈k       = proj₂ (Tp∈-Λ-inv Λa·z∈Πjk)
    a·z∈k′      = ⇓-Tp∈ ⌈⌊j⌋⌉↓<∷j a·z∈k

⊤↑⟨⟩-maximum : ∀ {n} {Γ : Ctx n} {a k} →
               Γ ⊢Tp a ∈ k → Γ ⊢ a <: ⊤↑⟨ ⌊ k ⌋ ⟩ ∈ ⌈ ⌊ k ⌋ ⌉↑
⊤↑⟨⟩-maximum {k = b ⋯ c} a∈b⋯c = <:-⊤ a∈b⋯c
⊤↑⟨⟩-maximum {k = Π j k} a∈Πjk with Tp∈-valid a∈Πjk
... | kd-Π j-kd k-kd =
  <:-trans (<:-⇑ (<:-η₂ a∈Πjk) Πjk<∷⌈Πjk⌉↑)
           (<:-λ (⊤↑⟨⟩-maximum a·z∈k′) (∈-⇑ Λa·z∈Πjk Πjk<∷⌈Πjk⌉↑)
                 (∈-⊤↑⟨⟩ ⌊ Π j k ⌋ Γ-ctx))
  where
    Πjk<∷⌈Πjk⌉↑ = ⌈⌉↑-maximum (kd-Π j-kd k-kd)
    Γ-ctx       = Tp∈-ctx a∈Πjk
    ⌈⌊j⌋⌉↓<∷j   = ⌈⌉↓-minimum j-kd
    Λa·z∈Πjk    = Tp∈-η a∈Πjk
    a·z∈k       = proj₂ (Tp∈-Λ-inv Λa·z∈Πjk)
    a·z∈k′      = ⇓-Tp∈ ⌈⌊j⌋⌉↓<∷j a·z∈k

-- Yet another variant of higher-order extremal types, this time
-- indexed by possibly dependent kinds.

⊥′⟨_⟩ : ∀ {n} → Kind Term n → Term n
⊥′⟨ a ⋯ b ⟩ = ⊥
⊥′⟨ Π j k ⟩ = Λ j ⊥′⟨ k ⟩

⊤′⟨_⟩ : ∀ {n} → Kind Term n → Term n
⊤′⟨ a ⋯ b ⟩ = ⊤
⊤′⟨ Π j k ⟩ = Λ j ⊤′⟨ k ⟩

-- A higher-order variant of *.

*⟨_⟩ : ∀ {n} → Kind Term n → Kind Term n
*⟨ a ⋯ b ⟩ = *
*⟨ Π j k ⟩ = Π j *⟨ k ⟩

-- Substitution commutes with ⊥′⟨_⟩, ⊤′⟨_⟩ and *⟨_⟩.

module EncSubstLemmas {T} (l : Lift T Term) where
  open SubstApp l
  open Lift l hiding (var)

  ⊥′⟨⟩-/ : ∀ {n m} {σ : Sub T m n} k → ⊥′⟨ k ⟩ / σ ≡ ⊥′⟨ k Kind/ σ ⟩
  ⊥′⟨⟩-/ (a ⋯ b) = refl
  ⊥′⟨⟩-/ (Π j k) = cong (Λ _) (⊥′⟨⟩-/ k)

  ⊤′⟨⟩-/ : ∀ {n m} {σ : Sub T m n} k → ⊤′⟨ k ⟩ / σ ≡ ⊤′⟨ k Kind/ σ ⟩
  ⊤′⟨⟩-/ (a ⋯ b) = refl
  ⊤′⟨⟩-/ (Π j k) = cong (Λ _) (⊤′⟨⟩-/ k)

  *⟨⟩-/ : ∀ {n m} {σ : Sub T m n} k → *⟨ k ⟩ Kind/ σ ≡ *⟨ k Kind/ σ ⟩
  *⟨⟩-/ (a ⋯ b) = refl
  *⟨⟩-/ (Π j k) = cong (Π _) (*⟨⟩-/ k)

open EncSubstLemmas (TermSubst.termLift termSubst) public
open EncSubstLemmas (TermSubst.varLift  termSubst) public
  renaming (⊥′⟨⟩-/ to ⊥′⟨⟩-/Var; ⊤′⟨⟩-/ to ⊤′⟨⟩-/Var; *⟨⟩-/ to *⟨⟩-/Var)

-- Well-formedness of higher-order star kinds.

kd-*⟨⟩ : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ⊢ *⟨ k ⟩ kd
kd-*⟨⟩ (kd-⋯ a∈* b∈*)   = *-kd (Tp∈-ctx a∈*)
kd-*⟨⟩ (kd-Π j-kd k-kd) = kd-Π j-kd (kd-*⟨⟩ k-kd)

-- ⊥′⟨ k ⟩ and ⊤′⟨ k ⟩ inhabit *⟨ k ⟩.

∈-⊥′⟨⟩ : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ⊢Tp ⊥′⟨ k ⟩ ∈ *⟨ k ⟩
∈-⊥′⟨⟩ (kd-⋯ a∈* b∈*)   = ∈-⊥-f (Tp∈-ctx a∈*)
∈-⊥′⟨⟩ (kd-Π j-kd k-kd) = ∈-Π-i j-kd (∈-⊥′⟨⟩ k-kd)

∈-⊤′⟨⟩ : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ⊢Tp ⊤′⟨ k ⟩ ∈ *⟨ k ⟩
∈-⊤′⟨⟩ (kd-⋯ a∈* b∈*)   = ∈-⊤-f (Tp∈-ctx a∈*)
∈-⊤′⟨⟩ (kd-Π j-kd k-kd) = ∈-Π-i j-kd (∈-⊤′⟨⟩ k-kd)

-- A helper: any well-formed kind k is a subkind of *⟨ k ⟩.

*⟨⟩-maximum : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ⊢ k <∷ *⟨ k ⟩
*⟨⟩-maximum (kd-⋯ a∈* b∈*)   = <∷-⋯ (<:-⊥ a∈*) (<:-⊤ b∈*)
*⟨⟩-maximum (kd-Π j-kd k-kd) =
  <∷-Π (<∷-refl j-kd) (*⟨⟩-maximum k-kd) (kd-Π j-kd k-kd)

-- ⊥′⟨ k ⟩ and ⊤′⟨ k ⟩ are extremal types in *⟨ k ⟩.

⊥′⟨⟩-minimum : ∀ {n} {Γ : Ctx n} {a k} →
               Γ ⊢Tp a ∈ k → Γ ⊢ ⊥′⟨ k ⟩ <: a ∈ *⟨ k ⟩
⊥′⟨⟩-minimum {k = b ⋯ c} a∈b⋯c = <:-⊥ a∈b⋯c
⊥′⟨⟩-minimum {k = Π j k} a∈Πjk =
  <:-trans (<:-λ (⊥′⟨⟩-minimum a·z∈k) (∈-⊥′⟨⟩ Πjk-kd)
                 (∈-⇑ Λa·z∈Πjk Πjk-kd<∷*⟨Πjk⟩))
           (<:-η₁ (∈-⇑ a∈Πjk Πjk-kd<∷*⟨Πjk⟩))
  where
    Λa·z∈Πjk       = Tp∈-η a∈Πjk
    a·z∈k          = proj₂ (Tp∈-Λ-inv Λa·z∈Πjk)
    Πjk-kd         = Tp∈-valid a∈Πjk
    Πjk-kd<∷*⟨Πjk⟩ = *⟨⟩-maximum Πjk-kd

⊤′⟨⟩-maximum : ∀ {n} {Γ : Ctx n} {a k} →
               Γ ⊢Tp a ∈ k → Γ ⊢ a <: ⊤′⟨ k ⟩ ∈ *⟨ k ⟩
⊤′⟨⟩-maximum {k = b ⋯ c} a∈b⋯c = <:-⊤ a∈b⋯c
⊤′⟨⟩-maximum {k = Π j k} a∈Πjk =
  <:-trans (<:-η₂ (∈-⇑ a∈Πjk Πjk-kd<∷*⟨Πjk⟩))
           (<:-λ (⊤′⟨⟩-maximum a·z∈k) (∈-⇑ Λa·z∈Πjk Πjk-kd<∷*⟨Πjk⟩)
                 (∈-⊤′⟨⟩ Πjk-kd))
  where
    Λa·z∈Πjk       = Tp∈-η a∈Πjk
    a·z∈k          = proj₂ (Tp∈-Λ-inv Λa·z∈Πjk)
    Πjk-kd         = Tp∈-valid a∈Πjk
    Πjk-kd<∷*⟨Πjk⟩ = *⟨⟩-maximum Πjk-kd

-- Applications of higher-order extrema result in lower-order extrema.

≃-⊥′⟨⟩-· : ∀ {n} {Γ : Ctx n} {a j k} → Γ ⊢ Π j k kd → Γ ⊢Tp a ∈ j →
           Γ ⊢ ⊥′⟨ Π j k ⟩ · a ≃ ⊥′⟨ k Kind[ a ] ⟩ ∈ *⟨ k Kind[ a ] ⟩
≃-⊥′⟨⟩-· (kd-Π {j} {k} j-kd k-kd) a∈j =
  subst₂ (_ ⊢ ⊥′⟨ Π j k ⟩ · _ ≃_∈_) (⊥′⟨⟩-/ _) (*⟨⟩-/ _)
         (≃-β′ ⊥⟨k⟩ a∈j ⊥⟨Πjk⟩)
  where
    ⊥⟨Πjk⟩ = ∈-⊥′⟨⟩ (kd-Π j-kd k-kd)
    ⊥⟨k⟩   = ∈-⊥′⟨⟩ k-kd

≃-⊤′⟨⟩-· : ∀ {n} {Γ : Ctx n} {a j k} → Γ ⊢ Π j k kd → Γ ⊢Tp a ∈ j →
           Γ ⊢ ⊤′⟨ Π j k ⟩ · a ≃ ⊤′⟨ k Kind[ a ] ⟩ ∈ *⟨ k Kind[ a ] ⟩
≃-⊤′⟨⟩-· (kd-Π {j} {k} j-kd k-kd) a∈j =
  subst₂ (_ ⊢ ⊤′⟨ Π j k ⟩ · _ ≃_∈_) (⊤′⟨⟩-/ _) (*⟨⟩-/ _)
         (≃-β′ ⊤⟨k⟩ a∈j ⊤⟨Πjk⟩)
  where
    ⊤⟨Πjk⟩ = ∈-⊤′⟨⟩ (kd-Π j-kd k-kd)
    ⊤⟨k⟩   = ∈-⊤′⟨⟩ k-kd

----------------------------------------------------------------------
-- Encodings and properties of higher-order intervals

infix 6 _⋯⟨_⟩_

-- Higher-order interval kinds.

_⋯⟨_⟩_ : ∀ {n} → Term n → Kind Term n → Term n → Kind Term n
a ⋯⟨ c ⋯ d ⟩ b = a ⋯ b
a ⋯⟨ Π j k ⟩ b = Π j (weaken a · var zero ⋯⟨ k ⟩ weaken b · var zero)

-- Higher order interval kinds have the same shape as their
-- kind-indices.

⌊⌋-⋯⟨⟩ : ∀ {n} {a b : Term n} k → ⌊ a ⋯⟨ k ⟩ b ⌋ ≡ ⌊ k ⌋
⌊⌋-⋯⟨⟩ (a ⋯ b) = refl
⌊⌋-⋯⟨⟩ (Π j k) = cong (⌊ j ⌋ ⇒_) (⌊⌋-⋯⟨⟩ k)

-- "Idempotence" of higher order interval kinds.

⋯⟨⟩-idempotent : ∀ {n} {a b : Term n} k → a ⋯⟨ a ⋯⟨ k ⟩ b ⟩ b ≡ a ⋯⟨ k ⟩ b
⋯⟨⟩-idempotent (a ⋯ b) = refl
⋯⟨⟩-idempotent (Π j k) = cong (Π j) (⋯⟨⟩-idempotent k)

-- Well-formedness of higher-order interval kinds.

kd-⋯⟨⟩ : ∀ {n} {Γ : Ctx n} {a b k} →
         Γ ⊢Tp a ∈ k → Γ ⊢Tp b ∈ k → Γ ⊢ a ⋯⟨ k ⟩ b kd
kd-⋯⟨⟩ a∈k   b∈k   with Tp∈-valid a∈k
kd-⋯⟨⟩ a∈c⋯d b∈c⋯d | kd-⋯ _ _       = kd-⋯ (Tp∈-⋯-* a∈c⋯d) (Tp∈-⋯-* b∈c⋯d)
kd-⋯⟨⟩ a∈Πjk b∈Πjk | kd-Π j-kd k-kd =
  kd-Π j-kd (kd-⋯⟨⟩ a·z∈k b·z∈k)
  where
    a·z∈k = proj₂ (Tp∈-Λ-inv (Tp∈-η a∈Πjk))
    b·z∈k = proj₂ (Tp∈-Λ-inv (Tp∈-η b∈Πjk))

-- NOTE.  We would like to show that the inverse of the above also
-- holds, i.e. that given a well-formed higher-order interval kind `a
-- ⋯⟨ k ⟩ b', we have `a ∈ k' and `b ∈ k'.  Unfortunately this is not
-- true because the definition of `a ⋯⟨ k ⟩ b' is a bit too forgetful
-- when the kind-index `k' is itself an interval `k = c ⋯ d', that is,
-- when `a' and `b' are proper types.  E.g. the kind `⊥ ⋯⟨ ∅ ⟩ ⊤' is
-- well-formed, but clearly `⊥ , ⊤ ∉ ø'.
--
-- However, as the following lemma illustrates, we can invert some
-- judgments about higher-order intervals with "sensible" kind
-- indices, such as those resulting from shapes via ⌈_⌉.  Still, a
-- proper inversion lemma would require more work, in particular one
-- has to contract the kinding derivations of the η-expanded bounds
-- `a' and `b' back into their non-expanded form.

-- Higher-order interval kinds indexed by `⌈ k ⌉' for some `k' are
-- subkinds of `⌈ k ⌉'.

⋯⟨⌈⌉⟩-<∷-⌈⌉ : ∀ {n} {Γ : Ctx n} {a b k} →
              Γ ⊢ a ⋯⟨ ⌈ k ⌉ ⟩ b kd → Γ ⊢ a ⋯⟨ ⌈ k ⌉ ⟩ b <∷ ⌈ k ⌉
⋯⟨⌈⌉⟩-<∷-⌈⌉ {k = ★    } (kd-⋯ a∈* b∈*) = <∷-⋯ (<:-⊥ a∈*) (<:-⊤ b∈*)
⋯⟨⌈⌉⟩-<∷-⌈⌉ {k = j ⇒ k} (kd-Π ⌈j⌉-kd a·z⋯⟨⌈k⌉⟩b·z-kd) =
  <∷-Π (<∷-refl ⌈j⌉-kd) (⋯⟨⌈⌉⟩-<∷-⌈⌉ a·z⋯⟨⌈k⌉⟩b·z-kd)
       (kd-Π ⌈j⌉-kd a·z⋯⟨⌈k⌉⟩b·z-kd)

-- Two corollaries.

-- Types inhabiting a type interval indexed by a shape `k' also
-- inhabit `⌈ k ⌉`.

Tp∈-⋯⟨⌈⌉⟩-inv : ∀ {n} {Γ : Ctx n} {a b c k} →
                Γ ⊢Tp a ∈ b ⋯⟨ ⌈ k ⌉ ⟩ c → Γ ⊢Tp a ∈ ⌈ k ⌉
Tp∈-⋯⟨⌈⌉⟩-inv a∈b⋯⟨⌈k⌉⟩c =
  ∈-⇑ a∈b⋯⟨⌈k⌉⟩c (⋯⟨⌈⌉⟩-<∷-⌈⌉ (Tp∈-valid a∈b⋯⟨⌈k⌉⟩c))

-- Types related in a type interval indexed by a shape `k' are also
-- related in `⌈ k ⌉`.

<:-⋯⟨⌈⌉⟩-inv : ∀ {n} {Γ : Ctx n} {a b c d k} →
               Γ ⊢ a <: b ∈ c ⋯⟨ ⌈ k ⌉ ⟩ d → Γ ⊢ a <: b ∈ ⌈ k ⌉
<:-⋯⟨⌈⌉⟩-inv a<:b∈c⋯⟨⌈k⌉⟩d =
  <:-⇑ a<:b∈c⋯⟨⌈k⌉⟩d (⋯⟨⌈⌉⟩-<∷-⌈⌉ (<:-valid-kd a<:b∈c⋯⟨⌈k⌉⟩d))

-- Subkinding of higher-order interval kinds.

<∷-⋯⟨⟩ : ∀ {n} {Γ : Ctx n} {a₁ a₂ b₁ b₂ k} →
         Γ ⊢ a₂ <: a₁ ∈ k → Γ ⊢ b₁ <: b₂ ∈ k → Γ ⊢ a₁ ⋯⟨ k ⟩ b₁ <∷ a₂ ⋯⟨ k ⟩ b₂
<∷-⋯⟨⟩ a₂<:a₁∈k   b₁<:b₂∈k   with <:-valid-kd a₂<:a₁∈k
<∷-⋯⟨⟩ a₂<:a₁∈c⋯d b₁<:b₂∈c⋯d | kd-⋯ _ _ =
  <∷-⋯ (<:-⋯-* a₂<:a₁∈c⋯d) (<:-⋯-* b₁<:b₂∈c⋯d)
<∷-⋯⟨⟩ a₂<:a₁∈Πjk b₁<:b₂∈Πjk | kd-Π j-kd k-kd =
  let a₂∈Πjk , a₁∈Πjk = <:-valid a₂<:a₁∈Πjk
      b₁∈Πjk , b₂∈Πjk = <:-valid b₁<:b₂∈Πjk
      Γ-ctx   = kd-ctx j-kd
      j-wf    = wf-kd j-kd
      j∷Γ-ctx = j-wf ∷ Γ-ctx
      z∈k     = ∈-var zero j∷Γ-ctx refl
      z≃z∈k   = ≃-refl z∈k
      a₂<:a₁∈Πjk′ = <:-weaken j-wf a₂<:a₁∈Πjk
      b₁<:b₂∈Πjk′ = <:-weaken j-wf b₁<:b₂∈Πjk
      k[z]≡k      = Kind-wk↑-sub-zero-vanishes _
      a₂·z<:a₁·z∈k[z] = <:-· a₂<:a₁∈Πjk′ z≃z∈k
      b₁·z<:b₂·z∈k[z] = <:-· b₁<:b₂∈Πjk′ z≃z∈k
      a₂·z<:a₁·z∈k = subst (_ ⊢ _ <: _ ∈_) k[z]≡k a₂·z<:a₁·z∈k[z]
      b₁·z<:b₂·z∈k = subst (_ ⊢ _ <: _ ∈_) k[z]≡k b₁·z<:b₂·z∈k[z]
  in <∷-Π (<∷-refl j-kd)
          (<∷-⋯⟨⟩ a₂·z<:a₁·z∈k b₁·z<:b₂·z∈k)
          (kd-⋯⟨⟩ a₁∈Πjk b₁∈Πjk)

-- A corollary: equality of higher-order interval kinds.

≅-⋯⟨⟩ : ∀ {n} {Γ : Ctx n} {a₁ a₂ b₁ b₂ k} →
        Γ ⊢ a₁ ≃ a₂ ∈ k → Γ ⊢ b₁ ≃ b₂ ∈ k → Γ ⊢ a₁ ⋯⟨ k ⟩ b₁ ≅ a₂ ⋯⟨ k ⟩ b₂
≅-⋯⟨⟩ (<:-antisym a₁<:a₂∈k a₂<:a₁∈k) (<:-antisym b₁<:b₂∈k b₂<:b₁∈k) =
  <∷-antisym (<∷-⋯⟨⟩ a₂<:a₁∈k b₁<:b₂∈k) (<∷-⋯⟨⟩ a₁<:a₂∈k b₂<:b₁∈k)

-- A variant of kind-driven η-expansion that only expands the head.

η-exp : ∀ {n} → Kind Term n → Term n → Term n
η-exp (_ ⋯ _) a = a
η-exp (Π j k) a = Λ j (η-exp k (weaken a · var zero))

-- Soundness of η-expansion.

≃-η-exp : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Tp a ∈ k → Γ ⊢ a ≃ η-exp k a ∈ k
≃-η-exp {_} {_} {_} {b ⋯ c} a∈b⋯c = ≃-refl a∈b⋯c
≃-η-exp {_} {_} {a} {Π j k} a∈Πjk with Tp∈-valid a∈Πjk
... | kd-Π j-kd k-kd = begin
  a                                     ≃⟨ ≃-sym (≃-η a∈Πjk) ⟩
  Λ j (weaken a · var zero)             ≃⟨ ≃-λ′ (≅-refl j-kd) (≃-η-exp a·z∈k) ⟩
  Λ j (η-exp k (weaken a · var zero))   ∎
  where
    open ≃-Reasoning
    a·z∈k = proj₂ (Tp∈-Λ-inv (Tp∈-η a∈Πjk))

-- A singleton introduction rule for higher-order interval kinds.

∈-s⟨⟩-i : ∀ {n} {Γ : Ctx n} {a k} →
          Γ ⊢Tp a ∈ k → Γ ⊢Tp η-exp k a ∈ a ⋯⟨ k ⟩ a
∈-s⟨⟩-i a∈k   with Tp∈-valid a∈k
∈-s⟨⟩-i a∈b⋯c | kd-⋯ _ _       = ∈-s-i a∈b⋯c
∈-s⟨⟩-i a∈Πjk | kd-Π j-kd k-kd =
  ∈-Π-i j-kd (∈-s⟨⟩-i a·z∈k)
  where
    a·z∈k = proj₂ (Tp∈-Λ-inv (Tp∈-η a∈Πjk))

-- A corollary: we can kind (the η-expansion of) a type with explicit
-- lower and uper bounds in the interval defined by these bounds.

Tp∈-<:-⋯ : ∀ {n} {Γ : Ctx n} {a b c k} →
           Γ ⊢ b <: a ∈ k → Γ ⊢ a <: c ∈ k → Γ ⊢Tp η-exp k a ∈ b ⋯⟨ k ⟩ c
Tp∈-<:-⋯ b<:a∈k a<:c∈k =
  ∈-⇑ (∈-s⟨⟩-i (proj₁ (<:-valid a<:c∈k))) (<∷-⋯⟨⟩ b<:a∈k a<:c∈k)

-- Bound projection rules for higher-order intervals.
--
-- NOTE.  These lemmas are a bit weaker than one might like.  In
-- particular, the additional premises `Γ ⊢ a , b , c ∈ k' might seem
-- redundant.  But recall that we cannot, in general, invert
-- well-formed higher-order intervals, i.e. `Γ ⊢ b ⋯⟨ k ⟩ c kd' does
-- *not* imply `Γ ⊢ b ∈ k' and `Γ ⊢ c ∈ k'.  Similarly, `Γ ⊢ a ∈ b ⋯⟨
-- k ⟩ c' does *not* imply `Γ ⊢ a ∈ k'.  To see this, consider again
-- the kind `⊥ ⋯⟨ ∅ ⟩ ⊤', which is well-formed and inhabited by both
-- `⊥' and `⊤', yet clearly `⊥ , ⊤ ∉ ø'.

<:-⋯⟨⟩-⟨|⟩ : ∀ {n} {Γ : Ctx n} {a b c k} →
             Γ ⊢Tp a ∈ k → Γ ⊢Tp b ∈ k → Γ ⊢Tp c ∈ k →
             Γ ⊢Tp a ∈ b ⋯⟨ k ⟩ c → Γ ⊢ b <: a ∈ k × Γ ⊢ a <: c ∈ k
<:-⋯⟨⟩-⟨|⟩ {k = _ ⋯ _} a∈d⋯e b∈d⋯e c∈d⋯e a∈b⋯c          =
  <:-⇑ (<:-⋯-i (<:-⟨| a∈b⋯c)) (<∷-⋯ (<:-⟨| b∈d⋯e) (<:-|⟩ a∈d⋯e)) ,
  <:-⇑ (<:-⋯-i (<:-|⟩ a∈b⋯c)) (<∷-⋯ (<:-⟨| a∈d⋯e) (<:-|⟩ c∈d⋯e))
<:-⋯⟨⟩-⟨|⟩ {k = Π _ _} a∈Πjk b∈Πjk c∈Πjk a∈Πjb·z⋯⟨k⟩c·z =
  let Λa·z∈Πjk  = Tp∈-η a∈Πjk
      Λb·z∈Πjk  = Tp∈-η b∈Πjk
      Λc·z∈Πjk  = Tp∈-η c∈Πjk
      _ , a·z∈k = Tp∈-Λ-inv Λa·z∈Πjk
      _ , b·z∈k = Tp∈-Λ-inv Λb·z∈Πjk
      _ , c·z∈k = Tp∈-Λ-inv Λc·z∈Πjk
      Λa·z∈Πjb·z⋯⟨k⟩c·z  = Tp∈-η a∈Πjb·z⋯⟨k⟩c·z
      _ , a·z∈b·z⋯⟨k⟩c·z = Tp∈-Λ-inv Λa·z∈Πjb·z⋯⟨k⟩c·z
      b·z<:a·z∈k , a·z<:c·z∈k = <:-⋯⟨⟩-⟨|⟩ a·z∈k b·z∈k c·z∈k a·z∈b·z⋯⟨k⟩c·z
      Λjb·z<:Λja·z∈Πjk = <:-λ b·z<:a·z∈k Λb·z∈Πjk Λa·z∈Πjk
      Λja·z<:Λjc·z∈Πjk = <:-λ a·z<:c·z∈k Λa·z∈Πjk Λc·z∈Πjk
      Λja·z<:a∈kΠjk    = <:-η₁ a∈Πjk
      a<:Λja·z∈kΠjk    = <:-η₂ a∈Πjk
      Λjc·z<:c∈kΠjk    = <:-η₁ c∈Πjk
      b<:Λjb·z∈kΠjk    = <:-η₂ b∈Πjk
  in <:-trans (<:-trans b<:Λjb·z∈kΠjk Λjb·z<:Λja·z∈Πjk) Λja·z<:a∈kΠjk ,
     <:-trans (<:-trans a<:Λja·z∈kΠjk Λja·z<:Λjc·z∈Πjk) Λjc·z<:c∈kΠjk

<:-⋯⟨⟩-⟨| : ∀ {n} {Γ : Ctx n} {a b c k} →
            Γ ⊢Tp a ∈ k → Γ ⊢Tp b ∈ k → Γ ⊢Tp c ∈ k →
            Γ ⊢Tp a ∈ b ⋯⟨ k ⟩ c → Γ ⊢ b <: a ∈ k
<:-⋯⟨⟩-⟨| a∈k b∈k c∈k a∈b⋯⟨k⟩c = proj₁ (<:-⋯⟨⟩-⟨|⟩ a∈k b∈k c∈k a∈b⋯⟨k⟩c)

<:-⋯⟨⟩-|⟩ : ∀ {n} {Γ : Ctx n} {a b c k} →
            Γ ⊢Tp a ∈ k → Γ ⊢Tp b ∈ k → Γ ⊢Tp c ∈ k →
            Γ ⊢Tp a ∈ b ⋯⟨ k ⟩ c → Γ ⊢ a <: c ∈ k
<:-⋯⟨⟩-|⟩ a∈k b∈k c∈k a∈b⋯⟨k⟩c = proj₂ (<:-⋯⟨⟩-⟨|⟩ a∈k b∈k c∈k a∈b⋯⟨k⟩c)

-- An interval introduction rule for subtypes inhabiting higher-order
-- interval kinds.

<:-⋯⟨⟩-i : ∀ {n} {Γ : Ctx n} {a b k} →
           Γ ⊢ a <: b ∈ k → Γ ⊢ η-exp k a <: η-exp k b ∈ a ⋯⟨ k ⟩ b
<:-⋯⟨⟩-i a<:b∈k   with <:-valid-kd a<:b∈k
<:-⋯⟨⟩-i a<:b∈c⋯d | kd-⋯ _ _    = <:-⋯-i a<:b∈c⋯d
<:-⋯⟨⟩-i a<:b∈Πjk | kd-Π j-kd _ =
  let j-wf          = wf-kd j-kd
      Γ-ctx         = <:-ctx a<:b∈Πjk
      j∷Γ-ctx       = j-wf ∷ Γ-ctx
      a∈Πjk , b∈Πjk = <:-valid a<:b∈Πjk
      a<:b∈Πjk′     = <:-weaken j-wf a<:b∈Πjk
      a·z<:b·z∈k[z] = <:-· a<:b∈Πjk′ (≃-refl (∈-var zero j∷Γ-ctx refl))
      a·z<:b·z∈k    = subst (_ ⊢ _ <: _ ∈_) (Kind-wk↑-sub-zero-vanishes _)
                            a·z<:b·z∈k[z]
      a·z<:b·z∈a·z⋯⟨k⟩b·z = <:-⋯⟨⟩-i a·z<:b·z∈k
  in <:-λ a·z<:b·z∈a·z⋯⟨k⟩b·z
          (∈-⇑ (∈-s⟨⟩-i a∈Πjk) (<∷-⋯⟨⟩ (<:-refl a∈Πjk) a<:b∈Πjk))
          (∈-⇑ (∈-s⟨⟩-i b∈Πjk) (<∷-⋯⟨⟩ a<:b∈Πjk (<:-refl b∈Πjk)))

-- Any interval indexed by *⟨ k ⟩ can be re-indexed by k

*⟨⟩-⋯⟨⟩ : ∀ {n} {a b : Term n} k → a ⋯⟨ *⟨ k ⟩ ⟩ b ≡ a ⋯⟨ k ⟩ b
*⟨⟩-⋯⟨⟩ (a ⋯ b) = refl
*⟨⟩-⋯⟨⟩ (Π j k) = cong (Π j) (*⟨⟩-⋯⟨⟩ k)

-- *⟨ k ⟩ is equal to the HO interval bounded by ⊥′⟨ k ⟩ and ⊤′⟨ k ⟩.

*⟨⟩-⊥⟨⟩⋯⟨⟩⊤⟨⟩ : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd →
                Γ ⊢ *⟨ k ⟩ ≅ ⊥′⟨ k ⟩ ⋯⟨ k ⟩ ⊤′⟨ k ⟩
*⟨⟩-⊥⟨⟩⋯⟨⟩⊤⟨⟩         (kd-⋯ a∈* b∈*)           = ≅-refl (*-kd (Tp∈-ctx a∈*))
*⟨⟩-⊥⟨⟩⋯⟨⟩⊤⟨⟩ {_} {Γ} (kd-Π {j} {k} j-kd k-kd) =
  ≅-Π (≅-refl j-kd)
      (≅-trans (*⟨⟩-⊥⟨⟩⋯⟨⟩⊤⟨⟩ k-kd)
               (subst₂ (_ ⊢_≅_) (*⟨⟩-⋯⟨⟩ k) (*⟨⟩-⋯⟨⟩ k)
                       (≅-⋯⟨⟩ ⊥⟨k⟩≃Λ⊥⟨k⟩·z ⊤⟨k⟩≃Λ⊤⟨k⟩·z)))
  where
    module KL = TermLikeLemmas termLikeLemmasKind

    Γ-ctx   = kd-ctx j-kd
    z∈j     = ∈-var zero (wf-kd j-kd ∷ Γ-ctx) refl
    Πjk-kd′ = kd-weaken (wf-kd j-kd) (kd-Π j-kd k-kd)
    eq₁     = cong (λ k → (Λ (weakenKind j) k) · var zero) (sym (⊥′⟨⟩-/Var k))
    eq₂     = cong (λ k → (Λ (weakenKind j) k) · var zero) (sym (⊤′⟨⟩-/Var k))
    k′[z]   = (k Kind/Var _) Kind[ var zero ]
    ⊥⟨k⟩≃Λ⊥⟨k⟩·z = subst₂ (_ ⊢_≃ weaken (Λ j ⊥′⟨ k ⟩) · var zero ∈_)
                          (cong ⊥′⟨_⟩ (Kind-wk↑-sub-zero-vanishes k))
                          (cong *⟨_⟩ (Kind-wk↑-sub-zero-vanishes k))
                          (subst (kd j ∷ Γ ⊢ ⊥′⟨ k′[z] ⟩ ≃_∈ *⟨ k′[z] ⟩) eq₁
                                 (≃-sym (≃-⊥′⟨⟩-· Πjk-kd′ z∈j)))
    ⊤⟨k⟩≃Λ⊤⟨k⟩·z = subst₂ (_ ⊢_≃ weaken (Λ j ⊤′⟨ k ⟩) · var zero ∈_)
                          (cong ⊤′⟨_⟩ (Kind-wk↑-sub-zero-vanishes k))
                          (cong *⟨_⟩ (Kind-wk↑-sub-zero-vanishes k))
                          (subst (kd j ∷ Γ ⊢ ⊤′⟨ k′[z] ⟩ ≃_∈ *⟨ k′[z] ⟩) eq₂
                                 (≃-sym (≃-⊤′⟨⟩-· Πjk-kd′ z∈j)))

----------------------------------------------------------------------
-- Encodings and admissible kinding rules of bounded quantifiers and
-- operators

-- Bounded operator kind.

Π′ : ∀ {n} → Term n → Term n → Kind Term n → Kind Term (suc n) → Kind Term n
Π′ a b j k = Π (a ⋯⟨ j ⟩ b) k

-- Bounded universal quantifiers.

∀′ : ∀ {n} → Term n → Term n → Kind Term n → Term (suc n) → Term n
∀′ a b k c = Π (a ⋯⟨ k ⟩ b) c

-- Bounded type abstraction.

Λ′ : ∀ {n} → Term n → Term n → Kind Term n → Term (suc n) → Term n
Λ′ a b k c = Λ (a ⋯⟨ k ⟩ b) c

-- A formation rule for bounded operator kinds.

∈-Π′-f : ∀ {n} {Γ : Ctx n} {a b j k} →
         Γ ⊢Tp a ∈ j → Γ ⊢Tp b ∈ j → kd (a ⋯⟨ j ⟩ b) ∷ Γ ⊢ k kd →
         Γ ⊢ Π′ a b j k kd
∈-Π′-f a∈j b∈j k-kd = kd-Π (kd-⋯⟨⟩ a∈j b∈j) k-kd

-- An introduction rule for bounded universal quantifiers.

∈-Π′-i : ∀ {n} {Γ : Ctx n} {a b j c k} →
         Γ ⊢Tp a ∈ j → Γ ⊢Tp b ∈ j → kd (a ⋯⟨ j ⟩ b) ∷ Γ ⊢Tp c ∈ k →
         Γ ⊢Tp Λ′ a b j c ∈ Π′ a b j k
∈-Π′-i a∈j b∈j c∈k = ∈-Π-i (kd-⋯⟨⟩ a∈j b∈j) c∈k

-- An elimination rule for bounded universal quantifiers.

∈-Π′-e : ∀ {n} {Γ : Ctx n} {a b c j k d} →
         Γ ⊢Tp a ∈ Π′ b c j k → Γ ⊢ b <: d ∈ j → Γ ⊢ d <: c ∈ j →
         Γ ⊢Tp a · η-exp j d ∈ k Kind[ η-exp j d ]
∈-Π′-e a∈Πbcjk b<:d∈j d<:c∈j =
  let d∈j , _ = <:-valid d<:c∈j
  in ∈-Π-e a∈Πbcjk (Tp∈-<:-⋯ b<:d∈j d<:c∈j)

-- A formation rule for bounded universal quantifiers.

∈-∀′-f : ∀ {n} {Γ : Ctx n} {a b k c} →
         Γ ⊢Tp a ∈ k → Γ ⊢Tp b ∈ k → kd (a ⋯⟨ k ⟩ b) ∷ Γ ⊢Tp c ∈ * →
         Γ ⊢Tp ∀′ a b k c ∈ *
∈-∀′-f a∈k b∈k c∈* = ∈-∀-f (kd-⋯⟨⟩ a∈k b∈k) c∈*

-- An introduction rule for bounded universal quantifiers.

∈-∀′-i : ∀ {n} {Γ : Ctx n} {a b k c d} →
         Γ ⊢Tp a ∈ k → Γ ⊢Tp b ∈ k → kd (a ⋯⟨ k ⟩ b) ∷ Γ ⊢Tm c ∈ d →
         Γ ⊢Tm Λ′ a b k c ∈ ∀′ a b k d
∈-∀′-i a∈k b∈k c∈d = ∈-∀-i (kd-⋯⟨⟩ a∈k b∈k) c∈d

-- An elimination rule for bounded universal quantifiers.

∈-∀′-e : ∀ {n} {Γ : Ctx n} {a b c k d e} →
         Γ ⊢Tm a ∈ ∀′ b c k d → Γ ⊢ b <: e ∈ k → Γ ⊢ e <: c ∈ k →
         Γ ⊢Tm a ⊡ η-exp k e ∈ d [ η-exp k e ]
∈-∀′-e a∈∀bckd b<:e∈k e<:c∈k =
  let e∈k , _ = <:-valid e<:c∈k
  in ∈-∀-e a∈∀bckd (Tp∈-<:-⋯ b<:e∈k e<:c∈k)

------------------------------------------------------------------------
-- Stone and Harper's singleton (sub)kinding rules.
--
-- See p. 3 (216) of C. A. Stone and R. Harper, Deciding Type
-- Equivalence in a Language with Singleton Kinds, proc. POPL'00, ACM,
-- 2000.

-- An encoding of Stone and Harper's singleton kinds.

S : ∀ {n} → Term n → Kind Term n
S a = a ⋯ a

-- Singleton kind formation.

kd-s : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢Tp a ∈ * → Γ ⊢ S a kd
kd-s a∈* = kd-⋯ a∈* a∈*

-- Singleton introduction for kinding is exactly the `∈-s-i' kinding rule.

-- Singleton introduction for equality.
--
-- NOTE. This is just a weaker version of `≃-s-i'.

≃-s-i′ : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a ≃ b ∈ * → Γ ⊢ a ≃ b ∈ S a
≃-s-i′ a≃b∈* = ≃-s-i a≃b∈*

-- Singleton elimination.
≃-s-e : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢Tp a ∈ S b → Γ ⊢ a ≃ b ∈ *
≃-s-e a∈b⋯b = <:-antisym (<:-|⟩ a∈b⋯b) (<:-⟨| a∈b⋯b)

-- Subkinding of singletons.

<∷-s-* : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢Tp a ∈ * → Γ ⊢ S a <∷ *
<∷-s-* a∈* = <∷-⋯ (<:-⊥ a∈*) (<:-⊤ a∈*)

<∷-s-s : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a ≃ b ∈ * → Γ ⊢ S a <∷ S b
<∷-s-s (<:-antisym a<:b∈* b<:a∈*) = <∷-⋯ b<:a∈* a<:b∈*

-- Equality of singleton kinds.
--
-- NOTE. This is just a weaker version of `≅-⋯'.

≅-s : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a ≃ b ∈ * → Γ ⊢ S a ≅ S b
≅-s a≃b∈* = ≅-⋯ a≃b∈* a≃b∈*

------------------------------------------------------------------------
-- Cardelli and Longo's power (sub)kinding rules.
--
-- See p. 8 (424) of L. Cardelli, G. Longo, A Semantic Basis for
-- Quest, JFP 1(4), Cambridge University Press, 1991.

-- An encoding of Cardelli and Longo's power kinds.

P : ∀ {n} → Term n → Kind Term n
P a = ⊥ ⋯ a

-- Power kind formation.

kd-p : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢Tp a ∈ * → Γ ⊢ P a kd
kd-p a∈* = kd-⋯ (∈-⊥-f (Tp∈-ctx a∈*)) a∈*

-- Power kind introduction.

∈-p-i : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢Tp a ∈ * → Γ ⊢Tp a ∈ P a
∈-p-i a∈* = ∈-⇑ (∈-s-i a∈*) (<∷-⋯ (<:-⊥ a∈*) (<:-refl a∈*))

-- Subkinding of power kinds.

<∷-p : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a <: b ∈ * → Γ ⊢ P a <∷ P b
<∷-p a<:b∈* = <∷-⋯ (<:-⊥ (∈-⊥-f (<:-ctx a<:b∈*))) a<:b∈*

-- Power kinding is equivalent to subtyping of proper types.

∈P⇒<: : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢Tp a ∈ P b → Γ ⊢ a <: b ∈ *
∈P⇒<: a∈Pb = <:-|⟩ a∈Pb

<:⇒∈P : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a <: b ∈ * → Γ ⊢Tp a ∈ P b
<:⇒∈P a<:b∈* = ∈-⇑ (∈-p-i (proj₁ (<:-valid a<:b∈*))) (<∷-p a<:b∈*)


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use the
-- Relation.Binary.Reasoning.MultiSetoid module directly.
------------------------------------------------------------------------

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

module Relation.Binary.SetoidReasoning where

open import Relation.Binary.Reasoning.MultiSetoid public


{-# OPTIONS --cubical #-}
module Cubical.Codata.Everything where

open import Cubical.Codata.EverythingSafe public

--- Modules making assumptions that might be incompatible with other
--  flags or make use of potentially unsafe features.

-- Assumes --guardedness
open import Cubical.Codata.Stream public

open import Cubical.Codata.Conat public

open import Cubical.Codata.M public

-- Also uses {-# TERMINATING #-}.
open import Cubical.Codata.M.Bisimilarity public


module Issue892a where

record R : Set₁ where
  field f : Set
  g : Set
  g = f

-- The type of R.g should print as (r : R) → Set
-- rather than ( : R) → Set.
bad : R.g
bad = ?


------------------------------------------------------------------------
-- Terminating parser combinator interface
------------------------------------------------------------------------

module RecursiveDescent.Coinductive where

open import RecursiveDescent.Index
import RecursiveDescent.Coinductive.Internal as P
open P public using (Parser)

open import Data.List
open import Data.Bool
open import Data.Maybe
open import Data.Product.Record hiding (map)
import Data.Product as Prod
open import Data.Function
import Data.BoundedVec.Inefficient as BVec

------------------------------------------------------------------------
-- Run function for the parsers

parse : forall {tok i r} ->
        Parser tok i r -> List tok -> List (Prod._×_ r (List tok))
parse p s = map (Prod.map id BVec.toList)
                (P.parse _ p (BVec.fromList s))

-- A variant which only returns parses which leave no remaining input.

parse-complete : forall {tok i r} ->
                 Parser tok i r -> List tok -> List r
parse-complete p s =
  map Prod.proj₁ (filter (null ∘ Prod.proj₂) (parse p s))

------------------------------------------------------------------------
-- Exported combinators

infixl 40 _∣_
infixl 10 _>>=_ _!>>=_

symbol : forall {tok} -> Parser tok 0I tok
symbol = P.symbol

return : forall {tok r} -> r -> Parser tok 1I r
return = P.ret

fail : forall {tok r} -> Parser tok 0I r
fail = P.fail

_>>=_ : forall {tok e₁ c₁ i₂ r₁ r₂} -> let i₁ = (e₁ , c₁) in
        Parser tok i₁ r₁ ->
        (r₁ -> Parser tok i₂ r₂) ->
        Parser tok (i₁ ·I i₂) r₂
_>>=_ {e₁ = true } = P.bind₀
_>>=_ {e₁ = false} = P.bind₁

-- If the first parser is guaranteed to consume something, then the
-- second parser's index can depend on the result of the first parser.

_!>>=_ : forall {tok c₁ r₁ r₂} {i₂ : r₁ -> Index} ->
         let i₁ = (false , c₁) in
         Parser tok i₁ r₁ ->
         ((x : r₁) -> Parser tok (i₂ x) r₂) ->
         Parser tok (i₁ ·I 1I) r₂
_!>>=_ = P.bind₁

_∣_ : forall {tok e₁ c₁ i₂ r} -> let i₁ = (e₁ , c₁) in
      Parser tok i₁ r ->
      Parser tok i₂ r ->
      Parser tok (i₁ ∣I i₂) r
_∣_ {e₁ = true } = P.alt₀
_∣_ {e₁ = false} = P.alt₁ _


module Issue478b where

record Ko (Q : Set) : Set₁ where
  field
    T : Set

  foo : T
  foo = Set

-- This previously said Set₁ !=< T r


module Coirc.Format where
open import Data.Empty
open import Data.Unit
open import Data.Bool
open import Data.Nat
open import Data.Char
open import Data.String
open import Data.List
open import Data.Sum
open import Data.Product
open import Coirc

infixr 3 _∣_
infixr 1 _>>_ _>>-_ _>>=_

within? : Char → ℕ → ℕ → Bool
within? c start end = toBool lower ∧ toBool higher
  where
  target = toNat c
  lower  = suc target ∸ start
  higher = suc end ∸ target
  toBool : ℕ → Bool
  toBool zero    = false
  toBool (suc _) = true

data DarRange (start end : ℕ) : Bool → Set where
  dar : (c : Char) → DarRange start end (within? c start end)

data Dar : ℕ → Set where
  dar : (c : Char) → Dar (toNat c)

data U : Set where
  CHAR : U
  DAR : ℕ → U
  DAR-RANGE : ℕ → ℕ → U
  `*! `*sp `*crlf : U

El : U → Set
El CHAR = Char
El (DAR n) = Dar n
El (DAR-RANGE n m) = DarRange n m true
El `*! = String
El `*sp = String
El `*crlf = String

mutual
  data Format : Set where
    Fail End : Format
    As : Event → Format
    Base : U → Format
    Skip Or And : Format → Format → Format
    Use : (f : Format) → (⟦ f ⟧ → Format) → Format

  ⟦_⟧ : Format → Set
  ⟦ Fail ⟧ = ⊥
  ⟦ End ⟧ = ⊤
  ⟦ As _ ⟧ = Event
  ⟦ Base u ⟧ = El u
  ⟦ Skip _ f ⟧ = ⟦ f ⟧
  ⟦ Or f₁ f₂ ⟧ = ⟦ f₁ ⟧ ⊎ ⟦ f₂ ⟧
  ⟦ And f₁ f₂ ⟧ = ⟦ f₁ ⟧ × ⟦ f₂ ⟧
  ⟦ Use f₁ f₂ ⟧ = Σ ⟦ f₁ ⟧ λ x → ⟦ f₂ x ⟧

_>>_ : Format → Format → Format
f₁ >> f₂ = Skip f₁ f₂

_>>-_ : Format → Format → Format
x >>- y = And x y

_>>=_ : (f : Format) → (⟦ f ⟧ → Format) → Format
x >>= y = Use x y

_∣_ : Format → Format → Format
x ∣ y = Or x y

char : Char → Format
char c = Base (DAR (toNat c))

str : String → Format
str s = chars (toList s)
  where
  chars : List Char → Format
  chars [] = End
  chars (x ∷ xs) = char x >>- chars xs

DIGIT = Base (DAR-RANGE (toNat '0') (toNat '9'))
cl    = char ':'
sp    = char ' '
cr    = char '\r'
lf    = char '\n'
crlf  = cr >>- lf

prefix = cl >> Base `*sp

Notice : Format
Notice =
  prefix >>
  sp >>
  str "NOTICE" >>
  sp >> char '*' >> sp >>
  Base `*crlf >> -- text
  crlf >>
  As notice

NumericReply : Format
NumericReply =
  prefix >>
  sp >>
  (DIGIT >>- DIGIT >>- DIGIT) >>
  sp >>
  Base `*sp >> -- target
  sp >>
  Base `*crlf >> -- text
  crlf >>
  As numeric

Mode : Format
Mode =
  prefix >>
  sp >>
  str "MODE" >>
  sp >>
  Base `*sp >> -- nickname
  sp >>
  Base `*crlf >> -- modes
  crlf >>
  As mode

Ping : Format
Ping =
  str "PING" >>
  sp >>
  Base `*crlf >> -- server
  crlf >>
  As ping

Privmsg : Format
Privmsg =
  cl >>
  Base `*! >>= λ source →
  Base `*sp >>
  sp >>
  str "PRIVMSG" >>
  sp >>
  Base `*sp >> -- target
  sp >>
  cl >>
  Base `*crlf >>= λ text →
  crlf >>
  As (privmsg source text)


module GUIgeneric.GUIModel where

open import GUIgeneric.Prelude renaming (inj₁ to secondButton; inj₂ to firstButton; WxColor to Color) hiding (IOInterfaceˢ)

open import GUIgeneric.GUIDefinitions renaming (add to add'; add' to add) --; ComponentEls to Frame)
open import GUIgeneric.GUI
open import GUIgeneric.GUIExampleLib
open import StateSizedIO.writingOOsUsingIOVers4ReaderMethods
open import StateSizedIO.Base
open import GUIgeneric.GUIExample -- hiding (HandlerGUIObject)

open IOInterfaceˢ public

open import Data.Product

-- How many trivial io commands such as putStrLn are ignored in the model
skippedIOcmds : ℕ
skippedIOcmds = 2

data MethodStarted
        (f : Frame)
        (prop : properties f)
        (obj : HandlerObject ∞ f) : Set where
   notStarted : MethodStarted f prop obj
   started :    (m    : methodsG f)
                (pr : IO' GuiLev1Interface ∞ StateAndGuiObj)
                → MethodStarted f prop obj

data ModelGuiState : Set where
   state : (f       : Frame)
           (prop    : properties f)
           (obj     : HandlerObject ∞ f)
           (m       : MethodStarted f prop obj)
           → ModelGuiState

modelGuiCommand : (s : ModelGuiState) → Set
modelGuiCommand  (state g prop obj notStarted)
                 = methodsG g
modelGuiCommand  (state g prop obj (started m (do' c f)))
    = GuiLev1Response c
modelGuiCommand  (state g prop obj
                       (started m (return' a)))
                 = ⊤

-- modelGuiResponse : Set
-- modelGuiResponse = ⊤

handlerReturnTypeToStateAndGuiObj :
          (g       : Frame)
          (prop    : properties g)
          (obj     : HandlerObject ∞ g)
          (res :  Σ[ r ∈ returnType g ]
                  IOObjectˢ GuiLev1Interface handlerInterface ∞ (nextStateFrame g r))
           → StateAndGuiObj
handlerReturnTypeToStateAndGuiObj g prop obj (noChange , obj') = g , prop , obj'
handlerReturnTypeToStateAndGuiObj g prop obj (changedAttributes prop' , obj') = g , prop' , obj'
handlerReturnTypeToStateAndGuiObj g prop obj (changedGUI g' prop' , obj') = g' , prop' , obj'

modelGuiNextProgramStarted : (g : Frame)
                             (prop : properties g)
                             (obj  : HandlerObject ∞ g)
                             (m    : methodsG g)
                             → IO GuiLev1Interface ∞ StateAndGuiObj
modelGuiNextProgramStarted g prop obj m =
     fmap ∞  (handlerReturnTypeToStateAndGuiObj g prop obj ) (obj .method m)

modelGuiNextProgramStarted' : (g : Frame)
                             (prop : properties g)
                             (obj  : HandlerObject ∞ g)
                             (m    : methodsG g)
                             → IO' GuiLev1Interface ∞ StateAndGuiObj
modelGuiNextProgramStarted' s prop obj m = force (modelGuiNextProgramStarted s prop obj m)

modelGuiNextaux : (g : Frame)(prop : properties g)(obj : HandlerObject ∞ g)
                  (m : methodsG g)(pr : IO' GuiLev1Interface ∞ StateAndGuiObj)
                  (skippedCms : ℕ)
                  → ModelGuiState
modelGuiNextaux g prop obj m (do' (putStrLn s) f) (suc n) =
    modelGuiNextaux g prop obj m (force (f _)) n
modelGuiNextaux g prop obj m (do' c' f) n =
        state g prop obj (started m (do' c' f))
modelGuiNextaux g prop obj m (return' (gNew , propNew , objNew)) n =
        state gNew propNew objNew notStarted

modelGuiNext : (s : ModelGuiState)
               (c : modelGuiCommand s)
               → ModelGuiState
modelGuiNext (state g prop obj notStarted) m     =
       modelGuiNextaux g prop obj m  (modelGuiNextProgramStarted' g prop obj m) skippedIOcmds
modelGuiNext (state g prop obj (started m (do' c' f))) c =
       modelGuiNextaux g prop obj m (force (f c)) skippedIOcmds
modelGuiNext (state g prop obj (started m (return' (gNew , propNew , objNew)))) c =
       state gNew propNew objNew notStarted

modelGuiInterface : IOInterfaceˢ
IOStateˢ   modelGuiInterface         = ModelGuiState
Commandˢ   modelGuiInterface         = modelGuiCommand
Responseˢ  modelGuiInterface  s m    = ⊤
IOnextˢ    modelGuiInterface  s m r  = modelGuiNext s m

_-gui->_ : (s s' : ModelGuiState ) → Set
s -gui-> s' = IOˢindₚ modelGuiInterface ⊤  s s'

data _-gui->¹_ (s : ModelGuiState )
               : (s' : ModelGuiState)→ Set where
   step :  (c : modelGuiCommand s)
           → s -gui->¹ modelGuiNext s c

nextGui : (s : ModelGuiState)(c : modelGuiCommand s) → ModelGuiState
nextGui s c = modelGuiNext s c

modelToIOprog : (s : ModelGuiState) → Maybe (IO' GuiLev1Interface ∞ StateAndGuiObj)
modelToIOprog (state g prop obj notStarted) = nothing
modelToIOprog (state g prop obj (started s pr)) = just pr

nextGuiProg : (s : ModelGuiState)(c : modelGuiCommand s)
              → Maybe (IO' GuiLev1Interface ∞ StateAndGuiObj)
nextGuiProg s c = modelToIOprog (nextGui s c)


-- Check that unquoted functions are termination checked.
module _ where

open import Common.Prelude hiding (_>>=_)
open import Common.Reflection
open import Common.Equality

`⊥ : Type
`⊥ = def (quote ⊥) []

⊥-elim : ∀ {a} {A : Set a} → ⊥ → A
⊥-elim ()

{-
Generate
  cheat : ⊥
  cheat = cheat
-}
makeLoop : TC Term
makeLoop =
  freshName "cheat" >>= λ cheat →
  declareDef (vArg cheat) `⊥ >>= λ _ →
  defineFun cheat (clause [] (def cheat []) ∷ []) >>= λ _ →
  returnTC (def cheat [])

macro
  magic : Tactic
  magic hole =
    makeLoop >>= λ loop →
    unify hole (def (quote ⊥-elim) (vArg loop ∷ []))

postulate
  ComplexityClass : Set
  P NP : ComplexityClass

thm : P ≡ NP → ⊥
thm = magic


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.List.Relation.Binary.Permutation.Inductive directly.
------------------------------------------------------------------------

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

module Data.List.Relation.Permutation.Inductive where

open import Data.List.Relation.Binary.Permutation.Inductive public


open import Data.Product using ( _×_ ; _,_ ; swap )
open import Data.Sum using ( inj₁ ; inj₂ )
open import Relation.Nullary using ( ¬_ ; yes ; no )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.ABox using ( ABox ; ε ; _,_ ; _∼_ ; _∈₁_ ; _∈₂_ )
open import Web.Semantic.DL.ABox.Interp using
  ( Interp ; ⌊_⌋ ; ind ; ind⁻¹ ; Surjective ; surj✓ )
open import Web.Semantic.DL.ABox.Interp.Morphism using
  ( _≲_ ; _≃_ ; _,_ ; ≲⌊_⌋ ; ≲-resp-ind )
open import Web.Semantic.DL.ABox.Interp.Meet using
  ( meet ; meet-lb ; meet-glb ; meet-uniq ; meet-surj )
open import Web.Semantic.DL.ABox.Model using ( _⊨a_ )
open import Web.Semantic.DL.Concept using
  ( Concept ; ⟨_⟩ ; ¬⟨_⟩ ; ⊤ ; ⊥ ; _⊔_ ; _⊓_ ; ∀[_]_ ; ∃⟨_⟩_ ; ≤1 ; >1 ; neg )
open import Web.Semantic.DL.Concept.Model using
  ( _⟦_⟧₁ ; neg-sound ; neg-complete )
open import Web.Semantic.DL.Integrity.Closed using
  ( Mediated₀ ; Initial₀ ; sur_⊨₀_ ; _,_ )
open import Web.Semantic.DL.Integrity.Closed.Alternate using
  ( _⊫_∼_ ; _⊫_∈₁_ ; _⊫_∈₂_ ; _⊫t_ ; _⊫a_ ; _⊫k_
  ; eq ; rel ; rev ; +atom ; -atom ; top ; inj₁ ; inj₂
  ; all ; ex ; uniq ; ¬uniq ; cn ; rl ; dis ; ref ; irr ; tra ; ε ; _,_ )
open import Web.Semantic.DL.KB using ( KB ; tbox ; abox )
open import Web.Semantic.DL.KB.Model using ( _⊨_ ; Interps ; ⊨-resp-≃ )
open import Web.Semantic.DL.Role using ( Role ; ⟨_⟩ ; ⟨_⟩⁻¹ )
open import Web.Semantic.DL.Role.Model using ( _⟦_⟧₂ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using
  ( TBox ; ε ; _,_ ; _⊑₁_ ; _⊑₂_ ; Dis ; Ref ; Irr ; Tra )
open import Web.Semantic.DL.TBox.Interp using ( _⊨_≈_ ; ≈-sym ; ≈-trans )
open import Web.Semantic.DL.TBox.Interp.Morphism using ( ≲-resp-≈ ; iso )
open import Web.Semantic.DL.TBox.Model using ( _⊨t_ )
open import Web.Semantic.Util using
  ( ExclMiddle ; ExclMiddle₁ ; smaller-excl-middle ; is! ; is✓ ; tt ; elim )

module Web.Semantic.DL.Integrity.Closed.Properties
  (excl-middle₁ : ExclMiddle₁) {Σ : Signature} {X : Set} where

-- The two definitions of closed-world integrity coincide for surjective interpretations.
-- Note that this requires excluded middle, as the alternate definition assumes a classical logic,
-- for example interpreting C ⊑ D as (¬ C ⊔ D) being a tautology.

min : KB Σ X → Interp Σ X
min K = meet excl-middle₁ (Interps K)

excl-middle : ExclMiddle
excl-middle = smaller-excl-middle excl-middle₁

sound∼ : ∀ K x y → (K ⊫ x ∼ y) → (⌊ min K ⌋ ⊨ x ≈ y)
sound∼ K x y (eq K⊫x∼y) = is! K⊫x∼y

complete∼ : ∀ K x y → (⌊ min K ⌋ ⊨ x ≈ y) → (K ⊫ x ∼ y)
complete∼ K x y x≈y = eq (is✓ x≈y)

sound₂ : ∀ K R xy → (K ⊫ xy ∈₂ R) → (xy ∈ ⌊ min K ⌋ ⟦ R ⟧₂)
sound₂ K ⟨ r ⟩   (x , y) (rel K⊫xy∈r) = is! K⊫xy∈r
sound₂ K ⟨ r ⟩⁻¹ (x , y) (rev K⊫yx∈r) = is! K⊫yx∈r

complete₂ : ∀ K R xy → (xy ∈ ⌊ min K ⌋ ⟦ R ⟧₂) → (K ⊫ xy ∈₂ R)
complete₂ K ⟨ r ⟩   (x , y) xy∈⟦r⟧ = rel (is✓ xy∈⟦r⟧)
complete₂ K ⟨ r ⟩⁻¹ (x , y) yx∈⟦r⟧ = rev (is✓ yx∈⟦r⟧)

sound₁ : ∀ K C x → (K ⊫ x ∈₁ C) → (x ∈ ⌊ min K ⌋ ⟦ C ⟧₁)
sound₁ K ⟨ c ⟩ x (+atom K⊨x∈c) =
  is! K⊨x∈c
sound₁ K ¬⟨ c ⟩ x (-atom K⊭x∈c) =
  λ x∈⟦c⟧ → K⊭x∈c (is✓ x∈⟦c⟧)
sound₁ K ⊤ x top = tt
sound₁ K ⊥ x ()
sound₁ K (C ⊓ D) x (K⊫x∈C , K⊫x∈D) =
  (sound₁ K C x K⊫x∈C , sound₁ K D x K⊫x∈D)
sound₁ K (C ⊔ D) x (inj₁ K⊫x∈C) =
  inj₁ (sound₁ K C x K⊫x∈C)
sound₁ K (C ⊔ D) x (inj₂ K⊫x∈D) =
  inj₂ (sound₁ K D x K⊫x∈D)
sound₁ K (∀[ R ] C) x (all K⊫x∈∀RC) =
  λ y xy∈⟦R⟧ → sound₁ K C y (K⊫x∈∀RC y (complete₂ K R _ xy∈⟦R⟧))
sound₁ K (∃⟨ R ⟩ C) x (ex y K⊫xy∈R K⊫y∈C) =
  (y , sound₂ K R _ K⊫xy∈R , sound₁ K C y K⊫y∈C)
sound₁ K (≤1 R) x (uniq K⊫x∈≤1R) =
  λ y z xy∈⟦R⟧ xz∈⟦R⟧ → sound∼ K y z
    (K⊫x∈≤1R y z (complete₂ K R _ xy∈⟦R⟧) (complete₂ K R _ xz∈⟦R⟧))
sound₁ K (>1 R) x (¬uniq y z K⊫xy∈R K⊫xz∈R K⊯y∼z) =
  ( y , z , sound₂ K R _ K⊫xy∈R , sound₂ K R _ K⊫xz∈R
  , λ y≈z → K⊯y∼z (complete∼ K y z y≈z) )

complete₁ : ∀ K C x → (x ∈ ⌊ min K ⌋ ⟦ C ⟧₁) → (K ⊫ x ∈₁ C)
complete₁ K ⟨ c ⟩ x x∈⟦c⟧ =
  +atom (is✓ x∈⟦c⟧)
complete₁ K ¬⟨ c ⟩ x x∉⟦c⟧ =
  -atom (λ K⊫x∈c → x∉⟦c⟧ (is! K⊫x∈c))
complete₁ K ⊤ x x∈⟦C⟧ =
  top
complete₁ K ⊥ x ()
complete₁ K (C ⊓ D) x (x∈⟦C⟧ , x∈⟦D⟧) =
  (complete₁ K C x x∈⟦C⟧ , complete₁ K D x x∈⟦D⟧)
complete₁ K (C ⊔ D) x (inj₁ x∈⟦C⟧) =
  inj₁ (complete₁ K C x x∈⟦C⟧)
complete₁ K (C ⊔ D) x (inj₂ x∈⟦D⟧) =
  inj₂ (complete₁ K D x x∈⟦D⟧)
complete₁ K (∀[ R ] C) x x∈⟦∀RC⟧ =
  all (λ y K⊫xy∈R → complete₁ K C y (x∈⟦∀RC⟧ y (sound₂ K R _ K⊫xy∈R)))
complete₁ K (∃⟨ R ⟩ C) x (y , xy∈⟦R⟧ , y∈⟦C⟧) =
  ex y (complete₂ K R (x , y) xy∈⟦R⟧) (complete₁ K C y y∈⟦C⟧)
complete₁ K (≤1 R) x x∈⟦≤1R⟧ =
  uniq (λ y z K⊫xy∈R K⊫xz∈R → complete∼ K y z
    (x∈⟦≤1R⟧ y z (sound₂ K R _ K⊫xy∈R) (sound₂ K R _ K⊫xz∈R)))
complete₁ K (>1 R) x (y , z , xy∈⟦R⟧ , xz∈⟦R⟧ , y≉z) =
  ¬uniq y z (complete₂ K R _ xy∈⟦R⟧) (complete₂ K R _ xz∈⟦R⟧)
    (λ K⊫y∼z → y≉z (sound∼ K y z K⊫y∼z))

⊫-impl-min⊨ : ∀ K L → (K ⊫k L) → (min K ⊨ L)
⊫-impl-min⊨ K L (K⊫T , K⊫A) = ( J⊨T K⊫T , J⊨A K⊫A ) where

  J : Interp Σ X
  J = min K

  J⊨T : ∀ {T} → (K ⊫t T) → (⌊ J ⌋ ⊨t T)
  J⊨T ε = tt
  J⊨T (K⊫T , K⊫U) = (J⊨T K⊫T , J⊨T K⊫U)
  J⊨T (rl Q R K⊫Q⊑R) =
    λ {xy} xy∈⟦Q⟧ → sound₂ K R xy (K⊫Q⊑R xy (complete₂ K Q xy xy∈⟦Q⟧))
  J⊨T (cn C D K⊫C⊑D) = λ {x} → lemma x (K⊫C⊑D x) where

    lemma : ∀ x → (K ⊫ x ∈₁ (neg C ⊔ D)) →
      (x ∈ ⌊ J ⌋ ⟦ C ⟧₁) → (x ∈ ⌊ J ⌋ ⟦ D ⟧₁)
    lemma x (inj₁ K⊫x∈¬C) x∈⟦C⟧ =
      elim (neg-sound ⌊ J ⌋ {x} C (sound₁ K (neg C) x K⊫x∈¬C) x∈⟦C⟧)
    lemma x (inj₂ K⊫x∈D) x∈⟦C⟧ =
      sound₁ K D x K⊫x∈D

  J⊨T (dis Q R K⊫DisQR) = λ {xy} xy∈⟦Q⟧ xy∈⟦R⟧ →
    K⊫DisQR xy (complete₂ K Q xy xy∈⟦Q⟧) (complete₂ K R xy xy∈⟦R⟧)
  J⊨T (ref R K⊫RefR) = λ x → sound₂ K R (x , x) (K⊫RefR x)
  J⊨T (irr R K⊫IrrR) = λ x xx∈⟦R⟧ → K⊫IrrR x (complete₂ K R (x , x) xx∈⟦R⟧)
  J⊨T (tra R K⊫TraR) = λ {x} {y} {z} xy∈⟦R⟧ yz∈⟦R⟧ →
    sound₂ K R (x , z) (K⊫TraR x y z
      (complete₂ K R (x , y) xy∈⟦R⟧) (complete₂ K R (y , z) yz∈⟦R⟧))

  J⊨A : ∀ {A} → (K ⊫a A) → (J ⊨a A)
  J⊨A ε = tt
  J⊨A (K⊫A , K⊫B) = (J⊨A K⊫A , J⊨A K⊫B)
  J⊨A (eq x y K⊫x∼y) = sound∼ K x y K⊫x∼y
  J⊨A (rl (x , y) r K⊫xy∈r) = sound₂ K ⟨ r ⟩ (x , y) K⊫xy∈r
  J⊨A (cn x c K⊫x∈c) = sound₁ K ⟨ c ⟩ x K⊫x∈c

min⊨-impl-⊫ : ∀ K L → (min K ⊨ L) → (K ⊫k L)
min⊨-impl-⊫ K L (J⊨T , J⊨A) =
  ( K⊫T (tbox L) J⊨T ,  K⊫A (abox L) J⊨A ) where

  J : Interp Σ X
  J = min K

  K⊫T : ∀ T → (⌊ J ⌋ ⊨t T) → (K ⊫t T)
  K⊫T ε J⊨ε = ε
  K⊫T (T , U) (J⊨T , J⊨U) = (K⊫T T J⊨T , K⊫T U J⊨U)
  K⊫T (Q ⊑₂ R) J⊨Q⊑R =
    rl Q R (λ xy K⊫xy∈Q → complete₂ K R xy (J⊨Q⊑R (sound₂ K Q xy K⊫xy∈Q)))
  K⊫T (C ⊑₁ D) J⊨C⊑D = cn C D lemma where

    lemma : ∀ x → (K ⊫ x ∈₁ neg C ⊔ D)
    lemma x with excl-middle (x ∈ ⌊ J ⌋ ⟦ C ⟧₁)
    lemma x | yes x∈⟦C⟧ =
      inj₂ (complete₁ K D x (J⊨C⊑D x∈⟦C⟧))
    lemma x | no  x∉⟦C⟧ =
      inj₁ (complete₁ K (neg C) x (neg-complete excl-middle ⌊ J ⌋ C x∉⟦C⟧))

  K⊫T (Dis Q R) J⊨DisQR =
    dis Q R (λ xy K⊫xy∈Q K⊫xy∈R →
      J⊨DisQR (sound₂ K Q xy K⊫xy∈Q) (sound₂ K R xy K⊫xy∈R))
  K⊫T (Ref R) J⊨RefR =
    ref R (λ x → complete₂ K R (x , x) (J⊨RefR x))
  K⊫T (Irr R) J⊨IrrR =
    irr R (λ x K⊫xx∈R → J⊨IrrR x (sound₂ K R (x , x) K⊫xx∈R))
  K⊫T (Tra R) J⊨TrR =
    tra R (λ x y z K⊫xy∈R K⊫yz∈R →
      complete₂ K R (x , z) (J⊨TrR
        (sound₂ K R (x , y) K⊫xy∈R) (sound₂ K R (y , z) K⊫yz∈R)))

  K⊫A : ∀ A → (J ⊨a A) → (K ⊫a A)
  K⊫A ε J⊨ε = ε
  K⊫A (A , B) (J⊨A , J⊨B) = (K⊫A A J⊨A , K⊫A B J⊨B)
  K⊫A (x ∼ y) x≈y = eq x y (complete∼ K x y x≈y)
  K⊫A (x ∈₁ c) x∈⟦c⟧ = cn x c (complete₁ K ⟨ c ⟩ x x∈⟦c⟧)
  K⊫A ((x , y) ∈₂ r) xy∈⟦r⟧ = rl (x , y) r (complete₂ K ⟨ r ⟩ (x , y) xy∈⟦r⟧)

min-med : ∀ (K : KB Σ X) J → (J ⊨ K) → Mediated₀ (min K) J
min-med K J J⊨K = (meet-lb excl-middle₁ (Interps K) J J⊨K , meet-uniq excl-middle₁ (Interps K) J J⊨K)

min-init : ∀ (K : KB Σ X) → (K ⊫k K) → (min K ∈ Initial₀ K)
min-init K K⊫K = ( ⊫-impl-min⊨ K K K⊫K , min-med K)

min-uniq : ∀ (I : Interp Σ X) (K : KB Σ X) → (I ∈ Surjective) → (I ∈ Initial₀ K) → (I ≃ min K)
min-uniq I K I∈Surj (I⊨K , I-med) =
  ( iso
      ≲⌊ meet-glb excl-middle₁ (Interps K) I I∈Surj lemma₁ ⌋
      ≲⌊ meet-lb excl-middle₁ (Interps K) I I⊨K ⌋
      (λ x → ≈-sym ⌊ I ⌋ (surj✓ I∈Surj x))
      (λ x → is! (lemma₂ x))
  , λ x → is! (lemma₂ x)) where

  lemma₁ : ∀ J J⊨K → I ≲ J
  lemma₁ J J⊨K with I-med J J⊨K
  lemma₁ J J⊨K | (I≲J , I≲J-uniq) = I≲J

  lemma₂ : ∀ x J J⊨K → ⌊ J ⌋ ⊨ ind J (ind⁻¹ I∈Surj (ind I x)) ≈ ind J x
  lemma₂ x J J⊨K =
    ≈-trans ⌊ J ⌋ (≈-sym ⌊ J ⌋ (≲-resp-ind (lemma₁ J J⊨K) (ind⁻¹ I∈Surj (ind I x))))
      (≈-trans ⌊ J ⌋ (≲-resp-≈ ≲⌊ lemma₁ J J⊨K ⌋ (≈-sym ⌊ I ⌋ (surj✓ I∈Surj (ind I x))))
        (≲-resp-ind (lemma₁ J J⊨K) x))

⊫-impl-⊨₀ : ∀ (KB₁ KB₂ : KB Σ X) → (KB₁ ⊫k KB₁) → (KB₁ ⊫k KB₂) → (sur KB₁ ⊨₀ KB₂)
⊫-impl-⊨₀ KB₁ KB₂ KB₁⊫KB₁ KB₁⊫KB₂ =
  ( min KB₁
  , meet-surj excl-middle₁ (Interps KB₁)
  , min-init KB₁ KB₁⊫KB₁
  , ⊫-impl-min⊨ KB₁ KB₂ KB₁⊫KB₂ )

⊨₀-impl-⊫₁ : ∀ (KB₁ KB₂ : KB Σ X) → (sur KB₁ ⊨₀ KB₂) → (KB₁ ⊫k KB₁)
⊨₀-impl-⊫₁ KB₁ KB₂ (I , I∈Surj , (I⊨KB₁ , I-med) , I⊨KB₂) =
  min⊨-impl-⊫ KB₁ KB₁ (⊨-resp-≃ (min-uniq I KB₁ I∈Surj (I⊨KB₁ , I-med)) KB₁ I⊨KB₁)

⊨₀-impl-⊫₂ : ∀ (KB₁ KB₂ : KB Σ X) → (sur KB₁ ⊨₀ KB₂) → (KB₁ ⊫k KB₂)
⊨₀-impl-⊫₂ KB₁ KB₂ (I , I∈Surj , I-init , I⊨KB₂) =
  min⊨-impl-⊫ KB₁ KB₂ (⊨-resp-≃ (min-uniq I KB₁ I∈Surj I-init) KB₂ I⊨KB₂)


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

open import lib.Basics
open import lib.NType2
open import lib.types.Empty
open import lib.types.Group
open import lib.types.Int
open import lib.types.List
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.SetQuotient
open import lib.types.Sigma
open import lib.types.Word
open import lib.groups.GroupProduct
open import lib.groups.Homomorphism
open import lib.groups.Isomorphism

module lib.groups.FreeAbelianGroup {i} where

-- the relation for making the quotient.

-- [fsr-sym] is not needed, but it seems more principled to
-- make [FormalSumRel] an equivalence relation.
data FormalSumRel {A : Type i} : Word A → Word A → Type i where
  fsr-refl : ∀ {l₁ l₂} → l₁ == l₂ → FormalSumRel l₁ l₂
  fsr-trans : ∀ {l₁ l₂ l₃} → FormalSumRel l₁ l₂ → FormalSumRel l₂ l₃ → FormalSumRel l₁ l₃
  fsr-sym : ∀ {l₁ l₂} → FormalSumRel l₁ l₂ → FormalSumRel l₂ l₁
  fsr-cons : ∀ x {l₁ l₂} → FormalSumRel l₁ l₂ → FormalSumRel (x :: l₁) (x :: l₂)
  fsr-swap : ∀ x₁ x₂ l → FormalSumRel (x₁ :: x₂ :: l) (x₂ :: x₁ :: l)
  fsr-flip : ∀ x₁ l → FormalSumRel (x₁ :: flip x₁ :: l) l

-- The quotient
FormalSum : Type i → Type i
FormalSum A = SetQuot (FormalSumRel {A})

module _ {A : Type i} where

  fs[_] : Word A → FormalSum A
  fs[_] = q[_]

  module FormalSumElim {k} {P : FormalSum A → Type k}
    {{p : {x : FormalSum A} → is-set (P x)}} (incl* : (a : Word A) → P fs[ a ])
    (rel* : ∀ {a₁ a₂} (r : FormalSumRel a₁ a₂) → incl* a₁ == incl* a₂ [ P ↓ quot-rel r ])
    = SetQuotElim incl* rel*
  open FormalSumElim public using () renaming (f to FormalSum-elim)

  module FormalSumRec {k} {B : Type k} {{p : is-set B}} (incl* : Word A → B)
    (rel* : ∀ {a₁ a₂} (r : FormalSumRel a₁ a₂) → incl* a₁ == incl* a₂)
    = SetQuotRec incl* rel*
  open FormalSumRec public using () renaming (f to FormalSum-rec)

module _ {A : Type i} where
  -- useful properties that remain public
  abstract
    FormalSumRel-cong-++-l :
      ∀ {l₁ l₁'} → FormalSumRel {A} l₁ l₁'
      → (l₂ : Word A)
      → FormalSumRel (l₁ ++ l₂) (l₁' ++ l₂)
    FormalSumRel-cong-++-l (fsr-refl idp) l₂ = fsr-refl idp
    FormalSumRel-cong-++-l (fsr-trans fsr₁ fsr₂) l₂ = fsr-trans (FormalSumRel-cong-++-l fsr₁ l₂) (FormalSumRel-cong-++-l fsr₂ l₂)
    FormalSumRel-cong-++-l (fsr-sym fsr) l₂ = fsr-sym (FormalSumRel-cong-++-l fsr l₂)
    FormalSumRel-cong-++-l (fsr-cons x fsr₁) l₂ = fsr-cons x (FormalSumRel-cong-++-l fsr₁ l₂)
    FormalSumRel-cong-++-l (fsr-swap x₁ x₂ l₁) l₂ = fsr-swap x₁ x₂ (l₁ ++ l₂)
    FormalSumRel-cong-++-l (fsr-flip x₁ l₁) l₂ = fsr-flip x₁ (l₁ ++ l₂)

    FormalSumRel-cong-++-r :
      ∀ (l₁ : Word A)
      → ∀ {l₂ l₂'} → FormalSumRel l₂ l₂'
      → FormalSumRel (l₁ ++ l₂) (l₁ ++ l₂')
    FormalSumRel-cong-++-r nil fsr₂ = fsr₂
    FormalSumRel-cong-++-r (x :: l₁) fsr₂ = fsr-cons x (FormalSumRel-cong-++-r l₁ fsr₂)

    FormalSumRel-swap1 : ∀ x l₁ l₂ → FormalSumRel {A} (l₁ ++ (x :: l₂)) (x :: l₁ ++ l₂)
    FormalSumRel-swap1 x nil l₂ = fsr-refl idp
    FormalSumRel-swap1 x (x₁ :: l₁) l₂ = fsr-trans (fsr-cons x₁ (FormalSumRel-swap1 x l₁ l₂)) (fsr-swap x₁ x (l₁ ++ l₂))

module _ (A : Type i) where
  private
    infixl 80 _⊞_
    _⊞_ : FormalSum A → FormalSum A → FormalSum A
    _⊞_ = FormalSum-rec
      (λ l₁ → FormalSum-rec (λ l₂ → fs[ l₁ ++ l₂ ])
        (λ r → quot-rel $ FormalSumRel-cong-++-r l₁ r))
      (λ {l₁} {l₁'} r → λ= $ FormalSum-elim
        (λ l₂ → quot-rel $ FormalSumRel-cong-++-l r l₂)
        (λ _ → prop-has-all-paths-↓))

    abstract
      FormalSumRel-cong-flip : ∀ {l₁ l₂}
        → FormalSumRel {A} l₁ l₂ → FormalSumRel (Word-flip l₁) (Word-flip l₂)
      FormalSumRel-cong-flip (fsr-refl idp) = fsr-refl idp
      FormalSumRel-cong-flip (fsr-trans fsr₁ fsr₂) = fsr-trans (FormalSumRel-cong-flip fsr₁) (FormalSumRel-cong-flip fsr₂)
      FormalSumRel-cong-flip (fsr-sym fsr) = fsr-sym (FormalSumRel-cong-flip fsr)
      FormalSumRel-cong-flip (fsr-cons x fsr₁) = fsr-cons (flip x) (FormalSumRel-cong-flip fsr₁)
      FormalSumRel-cong-flip (fsr-swap x₁ x₂ l) = fsr-swap (flip x₁) (flip x₂) (Word-flip l)
      FormalSumRel-cong-flip (fsr-flip (inl x) l) = fsr-flip (inr x) (Word-flip l)
      FormalSumRel-cong-flip (fsr-flip (inr x) l) = fsr-flip (inl x) (Word-flip l)

    ⊟ : FormalSum A → FormalSum A
    ⊟ = FormalSum-rec (fs[_] ∘ Word-flip)
      (λ r → quot-rel $ FormalSumRel-cong-flip r)

    ⊞-unit : FormalSum A
    ⊞-unit = fs[ nil ]

    abstract
      ⊞-unit-l : ∀ g → ⊞-unit ⊞ g == g
      ⊞-unit-l = FormalSum-elim
        (λ _ → idp)
        (λ _ → prop-has-all-paths-↓)

      ⊞-assoc : ∀ g₁ g₂ g₃ → (g₁ ⊞ g₂) ⊞ g₃ == g₁ ⊞ (g₂ ⊞ g₃)
      ⊞-assoc = FormalSum-elim
        (λ l₁ → FormalSum-elim
          (λ l₂ → FormalSum-elim
            (λ l₃ → ap fs[_] $ ++-assoc l₁ l₂ l₃)
            (λ _ → prop-has-all-paths-↓))
          (λ _ → prop-has-all-paths-↓))
        (λ _ → prop-has-all-paths-↓)

      Word-inv-l : ∀ l → FormalSumRel {A} (Word-flip l ++ l) nil
      Word-inv-l nil = fsr-refl idp
      Word-inv-l (x :: l) =
        fsr-trans (FormalSumRel-swap1 x (flip x :: Word-flip l) l) $
        fsr-trans (fsr-flip x (Word-flip l ++ l)) (Word-inv-l l)

      ⊟-inv-l : ∀ g → (⊟ g) ⊞ g == ⊞-unit
      ⊟-inv-l = FormalSum-elim
        (λ l → quot-rel (Word-inv-l l))
        (λ _ → prop-has-all-paths-↓)

      FormalSumRel-swap : ∀ l₁ l₂ → FormalSumRel {A} (l₁ ++ l₂) (l₂ ++ l₁)
      FormalSumRel-swap l₁ nil = fsr-refl (++-unit-r l₁)
      FormalSumRel-swap l₁ (x :: l₂) = fsr-trans (FormalSumRel-swap1 x l₁ l₂) (fsr-cons x (FormalSumRel-swap l₁ l₂))

      ⊞-comm : ∀ g₁ g₂ → g₁ ⊞ g₂ == g₂ ⊞ g₁
      ⊞-comm = FormalSum-elim
        (λ l₁ → FormalSum-elim
          (λ l₂ → quot-rel $ FormalSumRel-swap l₁ l₂)
          (λ _ → prop-has-all-paths-↓))
        (λ _ → prop-has-all-paths-↓)

  FormalSum-group-structure : GroupStructure (FormalSum A)
  FormalSum-group-structure = record
    { ident = ⊞-unit
    ; inv = ⊟
    ; comp = _⊞_
    ; unit-l = ⊞-unit-l
    ; assoc = ⊞-assoc
    ; inv-l = ⊟-inv-l
    }

  FreeAbGroup : AbGroup i
  FreeAbGroup = group _ FormalSum-group-structure , ⊞-comm

  module FreeAbGroup = AbGroup FreeAbGroup

{- Freeness (universal properties) -}

module _ {A : Type i} {j} (G : AbGroup j) where

  private
    module G = AbGroup G

    abstract
      Word-extendᴳ-emap : ∀ f {l₁ l₂}
        → FormalSumRel {A} l₁ l₂
        → Word-extendᴳ G.grp f l₁ == Word-extendᴳ G.grp f l₂
      Word-extendᴳ-emap f (fsr-refl idp) = idp
      Word-extendᴳ-emap f (fsr-trans fsr fsr₁) = (Word-extendᴳ-emap f fsr) ∙ (Word-extendᴳ-emap f fsr₁)
      Word-extendᴳ-emap f (fsr-sym fsr) = ! (Word-extendᴳ-emap f fsr)
      Word-extendᴳ-emap f (fsr-cons x fsr) = ap (G.comp (PlusMinus-extendᴳ G.grp f x)) (Word-extendᴳ-emap f fsr)
      Word-extendᴳ-emap f (fsr-swap x₁ x₂ l) =
          ! (G.assoc (PlusMinus-extendᴳ G.grp f x₁) (PlusMinus-extendᴳ G.grp f x₂) (Word-extendᴳ G.grp f l))
        ∙ ap (λ g → G.comp g (Word-extendᴳ G.grp f l)) (G.comm (PlusMinus-extendᴳ G.grp f x₁) (PlusMinus-extendᴳ G.grp f x₂))
        ∙ G.assoc (PlusMinus-extendᴳ G.grp f x₂) (PlusMinus-extendᴳ G.grp f x₁) (Word-extendᴳ G.grp f l)
      Word-extendᴳ-emap f (fsr-flip (inl x) l) =
          ! (G.assoc (f x) (G.inv (f x)) (Word-extendᴳ G.grp f l))
        ∙ ap (λ g → G.comp g (Word-extendᴳ G.grp f l)) (G.inv-r (f x)) ∙ G.unit-l _
      Word-extendᴳ-emap f (fsr-flip (inr x) l) =
          ! (G.assoc (G.inv (f x)) (f x) (Word-extendᴳ G.grp f l))
        ∙ ap (λ g → G.comp g (Word-extendᴳ G.grp f l)) (G.inv-l (f x)) ∙ G.unit-l _

  FormalSum-extend : (A → G.El) → FormalSum A → G.El
  FormalSum-extend f = FormalSum-rec (Word-extendᴳ G.grp f)
    (λ r → Word-extendᴳ-emap f r)

  FreeAbGroup-extend : (A → G.El) → (FreeAbGroup.grp A →ᴳ G.grp)
  FreeAbGroup-extend f' = record {M} where
    module M where
      f : FreeAbGroup.El A → G.El
      f = FormalSum-extend f'
      abstract
        pres-comp : preserves-comp (FreeAbGroup.comp A) G.comp f
        pres-comp =
          FormalSum-elim
            (λ l₁ → FormalSum-elim
              (λ l₂ → Word-extendᴳ-++ G.grp f' l₁ l₂)
              (λ _ → prop-has-all-paths-↓))
            (λ _ → prop-has-all-paths-↓)

  private
    module Lemma (hom : FreeAbGroup.grp A →ᴳ G.grp) where
      open GroupHom hom
      f* : A → G.El
      f* a = f fs[ inl a :: nil ]

      abstract
        PlusMinus-extend-hom : ∀ x → PlusMinus-extendᴳ G.grp f* x == f fs[ x :: nil ]
        PlusMinus-extend-hom (inl x) = idp
        PlusMinus-extend-hom (inr x) = ! $ pres-inv fs[ inl x :: nil ]

        Word-extend-hom : ∀ l → Word-extendᴳ G.grp f* l == f fs[ l ]
        Word-extend-hom nil = ! pres-ident
        Word-extend-hom (x :: l) = ap2 G.comp (PlusMinus-extend-hom x) (Word-extend-hom l) ∙ ! (pres-comp _ _)
    open Lemma

  FreeAbGroup-extend-is-equiv : is-equiv FreeAbGroup-extend
  FreeAbGroup-extend-is-equiv = is-eq _ from to-from from-to where
    to = FreeAbGroup-extend
    from = f*

    abstract
      to-from : ∀ h → to (from h) == h
      to-from h = group-hom= $ λ= $ FormalSum-elim
        (λ l → Word-extend-hom h l)
        (λ _ → prop-has-all-paths-↓)

      from-to : ∀ f → from (to f) == f
      from-to f = λ= λ a → G.unit-r (f a)

  FreeAbGroup-extend-hom : Πᴳ A (λ _ → G.grp) →ᴳ hom-group (FreeAbGroup.grp A) G
  FreeAbGroup-extend-hom = record {M} where
    module M where
      f : (A → G.El) → (FreeAbGroup.grp A →ᴳ G.grp)
      f = FreeAbGroup-extend
      abstract
        pres-comp : preserves-comp (Group.comp (Πᴳ A (λ _ → G.grp))) (Group.comp (hom-group (FreeAbGroup.grp A) G)) f
        pres-comp = λ f₁ f₂ → group-hom= $ λ= $
          FormalSum-elim
            (Word-extendᴳ-comp G f₁ f₂)
            (λ _ → prop-has-all-paths-↓)

  FreeAbGroup-extend-iso : Πᴳ A (λ _ → G.grp) ≃ᴳ hom-group (FreeAbGroup.grp A) G
  FreeAbGroup-extend-iso = FreeAbGroup-extend-hom , FreeAbGroup-extend-is-equiv

{- relation with [Word-exp] -}

module _ {A : Type i} where

  abstract
    FormalSumRel-pres-exp : ∀ (a : A) z →
      fs[ Word-exp a z ] == GroupStructure.exp (FormalSum-group-structure A) fs[ inl a :: nil ] z
    FormalSumRel-pres-exp a (pos O) = idp
    FormalSumRel-pres-exp a (pos (S O)) = idp
    FormalSumRel-pres-exp a (pos (S (S n))) =
      ap (Group.comp (FreeAbGroup.grp A) fs[ inl a :: nil ]) (FormalSumRel-pres-exp a (pos (S n)))
    FormalSumRel-pres-exp a (negsucc O) = idp
    FormalSumRel-pres-exp a (negsucc (S n)) =
      ap (Group.comp (FreeAbGroup.grp A) fs[ inr a :: nil ]) (FormalSumRel-pres-exp a (negsucc n))


{-# OPTIONS --rewriting --confluence-check #-}
module Issue4333.N1 where

open import Issue4333.M
{-# REWRITE p₁ #-}

b₁' : B a₁'
b₁' = b


open import Agda.Builtin.Reflection
open import Agda.Builtin.Equality
open import Agda.Builtin.Int
open import Agda.Builtin.String
open import Common.Prelude

getFixity = primQNameFixity

infixl -1729 _to_
_to_ : Set → Set → Set
A to B = A → B

data Check : Set₁ where
  equal : {A : Set} (x y : A) → x ≡ y → Check

pattern _==_ x y = equal x y refl

check-cons = getFixity (quote _∷_)  == fixity right-assoc (related (pos 5))
check-to   = getFixity (quote _to_) == fixity left-assoc  (related (negsuc 1728))
check-eq   = getFixity (quote _≡_)  == fixity non-assoc   (related (pos 4))
check-list = getFixity (quote List) == fixity non-assoc   unrelated

showAssoc : Associativity → String
showAssoc left-assoc  = "infixl"
showAssoc right-assoc = "infixr"
showAssoc non-assoc   = "infix"

showFixity : Fixity → String
showFixity (fixity a unrelated)   = "(no fixity)"
showFixity (fixity a (related p)) = showAssoc a +S+ " " +S+ intToString p

showFix : Name → String
showFix x = showFixity (getFixity x)

main : IO Unit
main = putStrLn (showFix (quote _∷_))  >>= λ _ →
       putStrLn (showFix (quote _to_)) >>= λ _ →
       putStrLn (showFix (quote _≡_))  >>= λ _ →
       putStrLn (showFix (quote List)) >>= λ _ →
       return unit


------------------------------------------------------------------------
-- A depth-first backend
------------------------------------------------------------------------

-- Based on the parser combinators in Wadler's "How to Replace Failure
-- by a List of Successes".

module StructurallyRecursiveDescentParsing.DepthFirst where

open import Data.Bool
open import Data.Product as Prod
import Data.List as L; open L using (List)
import Data.List.Categorical
open import Data.Nat
open import Data.Nat.Properties
open import Data.Vec using ([]; _∷_)
open import Data.Vec.Bounded hiding ([]; _∷_)
open import Function
open import Category.Applicative.Indexed
open import Category.Monad.Indexed
open import Category.Monad.State
open import Codata.Musical.Notation
import Level

open import StructurallyRecursiveDescentParsing.Simplified

------------------------------------------------------------------------
-- Parser monad

private

  P : Set → IFun ℕ Level.zero
  P Tok = IStateT (Vec≤ Tok) List

  open module M₁ {Tok : Set} =
    RawIMonadPlus (StateTIMonadPlus (Vec≤ Tok)
                     Data.List.Categorical.monadPlus)
    using ()
    renaming ( return to return′
             ; _>>=_  to _>>=′_
             ; _>>_   to _>>′_
             ; ∅      to fail′
             ; _∣_    to _∣′_
             )

  open module M₂ {Tok : Set} =
    RawIMonadState (StateTIMonadState (Vec≤ Tok)
                      Data.List.Categorical.monad)
    using ()
    renaming ( get    to get′
             ; put    to put′
             ; modify to modify′
             )

------------------------------------------------------------------------
-- Run function for the parsers

-- For every successful parse the run function returns the remaining
-- string. (Since there can be several successful parses a list of
-- strings is returned.)

-- This function is structurally recursive with respect to the
-- following lexicographic measure:
--
-- 1) The upper bound of the length of the input string.
-- 2) The parser's proper left corner tree.

mutual
  parse↓ : ∀ {Tok e R} n → Parser Tok e R →
           P Tok n (if e then n else n ∸ 1) R
  parse↓ n       (return x)                  = return′ x
  parse↓ n       fail                        = fail′
  parse↓ n       (_∣_ {true}          p₁ p₂) = parse↓ n       p₁   ∣′       parse↑ n     p₂
  parse↓ n       (_∣_ {false} {true}  p₁ p₂) = parse↑ n       p₁   ∣′       parse↓ n     p₂
  parse↓ n       (_∣_ {false} {false} p₁ p₂) = parse↓ n       p₁   ∣′       parse↓ n     p₂
  parse↓ n       (p₁ ?>>= p₂)                = parse↓ n       p₁ >>=′ λ x → parse↓ n    (p₂ x)
  parse↓ zero    (p₁ !>>= p₂)                = fail′
  parse↓ (suc n) (p₁ !>>= p₂)                = parse↓ (suc n) p₁ >>=′ λ x → parse↑ n (♭ (p₂ x))
  parse↓ n       token                       = get′ >>=′ eat
    where
    eat : ∀ {Tok n} → Vec≤ Tok n → P Tok n (n ∸ 1) Tok
    eat ([] , _)      = fail′
    eat s@(c ∷ _ , _) = put′ (drop 1 s) >>′ return′ c

  parse↑ : ∀ {e Tok R} n → Parser Tok e R → P Tok n n R
  parse↑ {true}  n       p = parse↓ n p
  parse↑ {false} zero    p = fail′
  parse↑ {false} (suc n) p = parse↓ (suc n) p           >>=′ λ r →
                             modify′ (≤-cast (n≤1+n _)) >>′
                             return′ r

-- Exported run function.

parse : ∀ {Tok i R} → Parser Tok i R → List Tok → List (R × List Tok)
parse p s = L.map (Prod.map id toList) (parse↓ _ p (fromList s))

-- A variant which only returns parses which leave no remaining input.

parseComplete : ∀ {Tok i R} → Parser Tok i R → List Tok → List R
parseComplete p s =
  L.map proj₁ (L.boolFilter (L.null ∘ proj₂) (parse p s))


module bstd.belt where

open import Agda.Builtin.Nat using () renaming (Nat to ℕ)
-- open import Agda.Builtin.Word using (Word64)

record traits : Set₁ where
  infixl 5 _⊕_
  infixl 6 _⊞_ _⊟_
  field
    w : Set
    _⊟_ : w → w → w
    _⊞_ : w → w → w
    _⊕_ : w → w → w
    G_ : ℕ → w → w
    _⋘_ : w → ℕ → w

module prim (t : traits) where

  open traits t
  record block : Set where
    constructor _∶_∶_∶_
    field
      a b c d : w

  record key : Set where

  G₅ = G 5
  G₁₃ = G 13
  G₂₁ = G 21

  encᵢ : w → (ℕ → w) → block → block
  encᵢ i k (a ∶ b ∶ c ∶ d) = b‴ ∶ d′ ∶ a′ ∶ c‴ where
    b′ = b ⊕ G₅ (a ⊞ k 0)
    c′ = c ⊕ G₂₁ (d ⊞ k 1)
    a′ = a ⊟ G₁₃ (b ⊞ k 2)
    e = G₂₁ (b ⊞ c ⊞ k 3) ⊕ i
    b″ = b′ ⊞ e
    c″ = c′ ⊟ e
    d′ = d ⊞ G₁₃ (c ⊞ k 4)
    b‴ = b″ ⊕ G₂₁ (a ⊞ k 5)
    c‴ = c″ ⊕ G₅ (d ⊞ k 6)

  𝔼 : key → block → block
  𝔼 k b = {!encᵢ 2 k (encᵢ 1 k x))!}

{-
0 B1 94 BA C8 0A 08 F5 3B 36 6D 00 8E 58 4A 5D E4
1 85 04 FA 9D 1B B6 C7 AC 25 2E 72 C2 02 FD CE 0D
2 5B E3 D6 12 17 B9 61 81 FE 67 86 AD 71 6B 89 0B
3 5C B0 C0 FF 33 C3 56 B8 35 C4 05 AE D8 E0 7F 99
4 E1 2B DC 1A E2 82 57 EC 70 3F CC F0 95 EE 8D F1
5 C1 AB 76 38 9F E6 78 CA F7 C6 F8 60 D5 BB 9C 4F
6 F3 3C 65 7B 63 7C 30 6A DD 4E A7 79 9E B2 3D 31
7 3E 98 B5 6E 27 D3 BC CF 59 1E 18 1F 4C 5A B7 93
8 E9 DE E7 2C 8F 0C 0F A6 2D DB 49 F4 6F 73 96 47
9 06 07 53 16 ED 24 7A 37 39 CB A3 83 03 A9 8B F6
A 92 BD 9B 1C E5 D1 41 01 54 45 FB C9 5E 4D 0E F2
B 68 20 80 AA 22 7D 64 2F 26 87 F9 34 90 40 55 11
C BE 32 97 13 43 FC 9A 48 A0 2A 88 5F 19 4B 09 A1
D 7E CD A4 D0 15 44 AF 8C A5 84 50 BF 66 D2 E8 8A
E A2 D7 46 52 42 A8 DF B3 69 74 C5 51 EB 23 29 21
F D4 EF D9 B4 3A 62 28 75 91 14 10 EA 77 6C DA 1D
-}


module FixityOutOfScopeInRecord where

record R : Set where
  infixl 30 _+_

-- Should complain that _+_ is not in scope
-- in its fixity declaration.


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

module Definition.Conversion.Consequences.Completeness where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Conversion

open import Definition.Conversion.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Escape
open import Definition.LogicalRelation.Fundamental

open import Tools.Product

-- Algorithmic equality is derivable from judgemental equality of types.
completeEq : ∀ {A B Γ} → Γ ⊢ A ≡ B → Γ ⊢ A [conv↑] B
completeEq A≡B =
  let [Γ] , [A] , [B] , [A≡B] = fundamentalEq A≡B
  in  escapeEqᵛ [Γ] [A] [A≡B]

-- Algorithmic equality is derivable from judgemental equality of terms.
completeEqTerm : ∀ {t u A Γ} → Γ ⊢ t ≡ u ∷ A → Γ ⊢ t [conv↑] u ∷ A
completeEqTerm t≡u =
  let [Γ] , modelsTermEq [A] [t] [u] [t≡u] = fundamentalTermEq t≡u
  in  escapeEqTermᵛ [Γ] [A] [t≡u]


module MacroNotToTerm where

open import Common.Reflection
open import Common.Prelude

data X : Set where

macro
  f : Term -> Set
  f x _ = X


open import Prelude hiding (_<_)

module Implicits.Resolution.GenericFinite.Resolution where

open import Coinduction
open import Data.List
open import Data.List.Any
open Membership-≡
open import Data.Fin.Substitution
open import Relation.Binary using (Rel)

open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas.MetaType
open import Implicits.Resolution.Termination
open import Implicits.Resolution.GenericFinite.TerminationCondition

private
  module M = MetaTypeMetaSubst

module ResolutionRules (cond : TerminationCondition) where
  open TerminationCondition cond

  mutual
    data _,_⊢_↓_ {ν} (Δ : ICtx ν) : (Φ : TCtx) → Type ν → SimpleType ν → Set where
      i-simp : ∀ {Φ} a → Δ , Φ ⊢ simpl a ↓ a
      i-iabs : ∀ {Φ ρ₁ ρ₂ a} → let Φ' = (step Φ Δ ρ₁ ρ₂ a) in
               Φ' < Φ → Δ , Φ' ⊢ᵣ ρ₁ → Δ , Φ ⊢ ρ₂ ↓ a → Δ , Φ ⊢ ρ₁ ⇒ ρ₂ ↓ a
      i-tabs : ∀ {Φ ρ a} b → Δ , Φ ⊢ ρ tp[/tp b ] ↓ a → Δ , Φ ⊢ ∀' ρ ↓ a

    data _,_⊢ᵣ_ {ν} (Δ : ICtx ν) : TCtx → Type ν → Set where
      r-simp : ∀ {Φ r τ} → r ∈ Δ → Δ , Φ ⊢ r ↓ τ → Δ , Φ ⊢ᵣ simpl τ
      r-iabs : ∀ {Φ} ρ₁ {ρ₂} → ((ρ₁ ∷ Δ) , Φ ⊢ᵣ ρ₂) → Δ , Φ ⊢ᵣ (ρ₁ ⇒ ρ₂)
      r-tabs : ∀ {Φ ρ} → ictx-weaken Δ , Φ ⊢ᵣ ρ → Δ , Φ ⊢ᵣ ∀' ρ


module Contexts where

open import Prelude
open import T
open import SubstTheory

module Contexts where

  infix 60 _e$_ _$e_
  -- Has a hole of type (Γ ⊢ A), produces a term of type (Γ' ⊢ A')
  data TCtx (Γ : Ctx) (A : TTp) : (Γ' : Ctx) → (A' : TTp) → Set where
    ∘ : TCtx Γ A Γ A
    _e$_ : ∀{Γ' A' B} (e₁ : TExp Γ' (A' ⇒ B)) (C₂ : TCtx Γ A Γ' A') → TCtx Γ A Γ' B
    _$e_ : ∀{Γ' A' B} (C₁ : TCtx Γ A Γ' (A' ⇒ B)) (e₂ : TExp Γ' A') → TCtx Γ A Γ' B

    Λ : ∀{A₁ A₂ Γ'} (C : TCtx Γ A (A₁ :: Γ') A₂) → TCtx Γ A Γ' (A₁ ⇒ A₂)
    suc : ∀{Γ'} (C : TCtx Γ A Γ' nat) → TCtx Γ A Γ' nat

    rec1 : ∀{Γ' B} → (C : TCtx Γ A Γ' nat) → (e₀ : TExp Γ' B) → (es : TExp (B :: Γ') B) →
                     TCtx Γ A Γ' B
    rec2 : ∀{Γ' B} → (e : TExp Γ' nat) → (C₀ : TCtx Γ A Γ' B) → (es : TExp (B :: Γ') B) →
                     TCtx Γ A Γ' B
    rec3 : ∀{Γ' B} → (e : TExp Γ' nat) → (e₀ : TExp Γ' B) → (Cs : TCtx Γ A (B :: Γ') B) →
                     TCtx Γ A Γ' B

  _<_> : ∀{Γ A Γ' A'} → TCtx Γ A Γ' A' → TExp Γ A → TExp Γ' A'
  ∘ < e' > = e'
  (e₁ e$ C₂) < e' > = e₁ $ C₂ < e' >
  (C₁ $e e₂) < e' > = C₁ < e' > $ e₂
  Λ C < e' > = Λ (C < e' >)
  suc C < e' > = suc (C < e' >)
  rec1 C e₀ es < e' > = rec (C < e' >) e₀ es
  rec2 e C₀ es < e' > = rec e (C₀ < e' >) es
  rec3 e e₀ Cs < e' > = rec e e₀ (Cs < e' >)

  infix 70 _<<_>> _<_>
  _<<_>> : ∀{Γ A Γ' A' Γ'' A''} → TCtx Γ' A' Γ'' A'' → TCtx Γ A Γ' A' →
            TCtx Γ A Γ'' A''
  ∘ << C' >> = C'
  (e₁ e$ C₂) << C' >> = e₁ e$ C₂ << C' >>
  (C₁ $e e₂) << C' >> = C₁ << C' >> $e e₂
  Λ C << C' >> = Λ (C << C' >>)
  suc C << C' >> = suc (C << C' >>)
  rec1 C e₀ es << C' >> = rec1 (C << C' >>) e₀ es
  rec2 e C₀ es << C' >> = rec2 e (C₀ << C' >>) es
  rec3 e e₀ Cs << C' >> = rec3 e e₀ (Cs << C' >>)

  -- I hate having to prove this sort of theorem.
  composing-commutes : ∀{Γ A Γ' A' Γ'' A''} →
                       (C : TCtx Γ' A' Γ'' A'') →
                       (C' : TCtx Γ A Γ' A') →
                       (e : TExp Γ A) →
                       ((C << C' >>) < e >) ≡ C < C' < e > >
  composing-commutes ∘ C' e = Refl
  composing-commutes (e₁ e$ C) C' e = resp (_$_ e₁) (composing-commutes C C' e)
  composing-commutes (C $e e₂) C' e = resp (λ x → x $ e₂) (composing-commutes C C' e)
  composing-commutes (Λ C) C' e = resp Λ (composing-commutes C C' e)
  composing-commutes (suc C) C' e = resp suc (composing-commutes C C' e)
  composing-commutes (rec1 C e₀ es) C' e = resp (λ x → rec x e₀ es) (composing-commutes C C' e)
  composing-commutes (rec2 e' C es) C' e = resp (λ x → rec e' x es) (composing-commutes C C' e)
  composing-commutes (rec3 e' e₀ C) C' e = resp (λ x → rec e' e₀ x) (composing-commutes C C' e)

  -- If the hole is closed, then the rest needs to be too.
  tctx-empty-thing : ∀{F : Set} {Γ A A' B} → TCtx [] A (B :: Γ) A' → F
  tctx-empty-thing (e₁ e$ C) = tctx-empty-thing C
  tctx-empty-thing (C $e e₂) = tctx-empty-thing C
  tctx-empty-thing (Λ C) = tctx-empty-thing C
  tctx-empty-thing (suc C) = tctx-empty-thing C
  tctx-empty-thing (rec1 C e₀ es) = tctx-empty-thing C
  tctx-empty-thing (rec2 e C es) = tctx-empty-thing C
  tctx-empty-thing (rec3 e e₀ C) = tctx-empty-thing C

  -- Very restricted function for weakening a program context where
  -- the hole also occurs under no free variables.
  weaken-closed-tctx : ∀{Γ A A'} → TCtx [] A [] A' → TCtx Γ A Γ A'
  weaken-closed-tctx ∘ = ∘
  weaken-closed-tctx (e₁ e$ C) = weaken-closed e₁ e$ weaken-closed-tctx C
  weaken-closed-tctx (C $e e₂) = weaken-closed-tctx C $e weaken-closed e₂
  weaken-closed-tctx (Λ C) = tctx-empty-thing C
  weaken-closed-tctx (suc C) = suc (weaken-closed-tctx C)
  weaken-closed-tctx (rec1 C e₀ es) =
    rec1 (weaken-closed-tctx C) (weaken-closed e₀) (ren (wk closed-wkγ) es)
  weaken-closed-tctx (rec2 e C es) =
    rec2 (weaken-closed e) (weaken-closed-tctx C) (ren (wk closed-wkγ) es)
  weaken-closed-tctx (rec3 e e₀ C) = tctx-empty-thing C

  -- Substitution commutes with a closed context
  subst-commutes-w-closed-tctx : ∀{Γ A A'} → (γ : TSubst Γ []) → (C : TCtx [] A [] A') → (e : TExp Γ A) →
                                 C < ssubst γ e > ≡ ssubst γ ((weaken-closed-tctx C) < e >)
  subst-commutes-w-closed-tctx γ ∘ e = Refl
  subst-commutes-w-closed-tctx γ (e₁ e$ C) e =
    resp2 _$_
    (symm (closed-subst _ e₁) ≡≡ symm (subren γ closed-wkγ e₁))
    (subst-commutes-w-closed-tctx γ C e)
  subst-commutes-w-closed-tctx γ (C $e e₂) e =
    resp2 _$_
    (subst-commutes-w-closed-tctx γ C e)
    (symm (closed-subst _ e₂) ≡≡ symm (subren γ closed-wkγ e₂))
  subst-commutes-w-closed-tctx γ (Λ C) e = tctx-empty-thing C
  subst-commutes-w-closed-tctx γ (suc C) e =
    resp suc (subst-commutes-w-closed-tctx γ C e)
  subst-commutes-w-closed-tctx γ (rec1 C e₀ es) e with subren (liftγ γ) (wk closed-wkγ) es
  ... | lol1 with subeq (liftwk γ closed-wkγ) es
  ... | lol2 with lift-closed-subst (γ o closed-wkγ) es
  ... | lol3 with symm lol3 ≡≡ symm lol2 ≡≡ symm lol1
  ... | lol = resp3 rec
              (subst-commutes-w-closed-tctx γ C e)
              (symm (closed-subst _ e₀) ≡≡ symm (subren γ closed-wkγ e₀))
              lol
  subst-commutes-w-closed-tctx γ (rec2 en C es) e with subren (liftγ γ) (wk closed-wkγ) es
  ... | lol1 with subeq (liftwk γ closed-wkγ) es
  ... | lol2 with lift-closed-subst (γ o closed-wkγ) es
  ... | lol3 with symm lol3 ≡≡ symm lol2 ≡≡ symm lol1
  ... | lol = resp3 rec
              (symm (closed-subst _ en) ≡≡ symm (subren γ closed-wkγ en))
              (subst-commutes-w-closed-tctx γ C e)
              lol
  subst-commutes-w-closed-tctx γ (rec3 e e₀ C) e₁ = tctx-empty-thing C

open Contexts public


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

open import HoTT renaming (pt to ⊙pt)
open import homotopy.Bouquet
open import homotopy.FinWedge
open import homotopy.SphereEndomorphism
open import homotopy.DisjointlyPointedSet
open import groups.SphereEndomorphism
open import groups.SumOfSubIndicator
open import groups.DisjointlyPointedSet
open import cw.CW
open import cw.DegreeByProjection
open import cw.FinBoundary
open import cw.FinCW
open import cw.WedgeOfCells
open import cohomology.Theory

module cw.cohomology.cochainequiv.FirstCoboundary (OT : OrdinaryTheory lzero)
  (⊙fin-skel : ⊙FinSkeleton 1) where

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

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

  fin-skel₋₁ = fcw-init fin-skel
  ac₋₁ = FinSkeleton-has-cells-with-choice 0 fin-skel₋₁ lzero
  endpoint = attaching-last skel
  I₋₁ = AttachedFinSkeleton.skel fin-skel
  ⊙head = ⊙cw-head ⊙skel
  pt = ⊙pt ⊙head

open DegreeAtOne skel dec
open import cw.cohomology.WedgeOfCells OT ⊙skel
open import cw.cohomology.reconstructed.TipAndAugment OT (⊙cw-init ⊙skel)
open import cw.cohomology.reconstructed.TipCoboundary OT ⊙skel
open import cw.cohomology.cochainequiv.FirstCoboundaryAbstractDefs OT ⊙fin-skel

abstract
  rephrase-cw-co∂-head'-in-degree : ∀ g
    → GroupIso.f (CXₙ/Xₙ₋₁-diag-β ac) (GroupHom.f cw-co∂-head' (GroupIso.g (CX₀-diag-β ac₋₁) g))
    ∼ λ <I → Group.subsum-r (C2 0) ⊙head-separate
        (λ b → Group.exp (C2 0) (g b) (degree <I (fst b)))
  rephrase-cw-co∂-head'-in-degree g <I =
    GroupIso.f (C-FinBouquet-diag 1 I)
      (CEl-fmap 1 (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ skel))
        (CEl-fmap 1 ⊙cw-∂-head'-before-Susp
          (<– (CEl-Susp 0 ⊙head)
            (CEl-fmap 0 (⊙<– (Bouquet-⊙equiv-X ⊙head-is-separable))
              (GroupIso.g (C-SubFinBouquet-diag 0 MinusPoint-⊙head-has-choice ⊙head-separate)
                g))))) <I
      =⟨ ap
          (λ g →
            GroupIso.f (C-FinBouquet-diag 1 I)
              (CEl-fmap 1 (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ skel))
                (CEl-fmap 1 ⊙cw-∂-head'-before-Susp g)) <I) $
          C-Susp-fmap' 0 (⊙<– (Bouquet-⊙equiv-X (Fin-has-dec-eq pt))) □$ᴳ
            (GroupIso.g (C-SubFinBouquet-diag 0 MinusPoint-⊙head-has-choice ⊙head-separate)
              g) ⟩
    GroupIso.f (C-FinBouquet-diag 1 I)
      (CEl-fmap 1 (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ skel))
        (CEl-fmap 1 ⊙cw-∂-head'-before-Susp
          (CEl-fmap 1 (⊙Susp-fmap (⊙<– (Bouquet-⊙equiv-X ⊙head-is-separable)))
            (<– (CEl-Susp 0 (⊙Bouquet (MinusPoint ⊙head) 0))
              (GroupIso.g (C-SubFinBouquet-diag 0 MinusPoint-⊙head-has-choice ⊙head-separate)
                g))))) <I
      =⟨ ap (λ g → GroupIso.f (C-FinBouquet-diag 1 I) g <I) $
            ∘-CEl-fmap 1 (⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ skel)) ⊙cw-∂-head'-before-Susp
              (CEl-fmap 1 (⊙Susp-fmap (⊙<– (Bouquet-⊙equiv-X ⊙head-is-separable)))
                (<– (CEl-Susp 0 (⊙Bouquet (MinusPoint ⊙head) 0))
                  (GroupIso.g (C-SubFinBouquet-diag 0 MinusPoint-⊙head-has-choice ⊙head-separate)
                    g)))
          ∙ ∘-CEl-fmap 1
              (⊙cw-∂-head'-before-Susp ⊙∘ ⊙–> (Bouquet-⊙equiv-Xₙ/Xₙ₋₁ skel))
              (⊙Susp-fmap (⊙<– (Bouquet-⊙equiv-X ⊙head-is-separable)))
              (<– (CEl-Susp 0 (⊙Bouquet (MinusPoint ⊙head) 0))
                (GroupIso.g (C-SubFinBouquet-diag 0 MinusPoint-⊙head-has-choice ⊙head-separate)
                  g))
          ∙ ap (λ f → CEl-fmap 1 f
              (<– (CEl-Susp 0 (⊙Bouquet (MinusPoint ⊙head) 0))
                (GroupIso.g (C-SubFinBouquet-diag 0 MinusPoint-⊙head-has-choice ⊙head-separate)
                  g)))
              (! ⊙function₀'-β) ⟩
    GroupIso.f (C-FinBouquet-diag 1 I)
      (CEl-fmap 1 ⊙function₀'
        (<– (CEl-Susp 0 (⊙Bouquet (MinusPoint ⊙head) 0))
          (GroupIso.g (C-SubFinBouquet-diag 0 MinusPoint-⊙head-has-choice ⊙head-separate)
            g))) <I
      =⟨ rephrase-in-degree 0 {I = I} MinusPoint-⊙head-has-choice
          MinusPoint-⊙head-has-dec-eq ⊙head-separate-equiv ⊙function₀' g <I ⟩
    Group.subsum-r (C2 0) ⊙head-separate
      (λ b → Group.exp (C2 0) (g b)
        (⊙SphereS-endo-degree 0
          (⊙Susp-fmap (⊙bwproj MinusPoint-⊙head-has-dec-eq b) ⊙∘ ⊙function₀' ⊙∘ ⊙fwin <I)))
      =⟨ ap (Group.subsum-r (C2 0) ⊙head-separate)
          (λ= λ b → ap (Group.exp (C2 0) (g b)) $
            ⊙SphereS-endo-degree-base-indep 0
              {f = (  ⊙Susp-fmap (⊙bwproj MinusPoint-⊙head-has-dec-eq b)
                   ⊙∘ ⊙function₀'
                   ⊙∘ ⊙fwin <I)}
              {g = (Susp-fmap (function₁' <I b) , idp)}
              (mega-reduction <I b)) ⟩
    Group.subsum-r (C2 0) ⊙head-separate
      (λ b → Group.exp (C2 0) (g b)
        (⊙SphereS-endo-degree 0
          (Susp-fmap (function₁' <I b) , idp)))
      =⟨ ap (Group.subsum-r (C2 0) ⊙head-separate)
          (λ= λ b → ap (Group.exp (C2 0) (g b)) $
            degree-matches <I b) ⟩
    Group.subsum-r (C2 0) ⊙head-separate
      (λ b → Group.exp (C2 0) (g b)
        (degree <I (fst b)))
      =∎

abstract
  private
    degree-true-≠ : ∀ {<I <I₋₁} → (<I₋₁ ≠ endpoint <I true) → degree-true <I <I₋₁ == 0
    degree-true-≠ {<I} {<I₋₁} neq with Fin-has-dec-eq <I₋₁ (endpoint <I true)
    ... | inl eq = ⊥-rec (neq eq)
    ... | inr _ = idp

    degree-true-diag : ∀ <I → degree-true <I (endpoint <I true) == -1
    degree-true-diag <I with Fin-has-dec-eq (endpoint <I true) (endpoint <I true)
    ... | inl _ = idp
    ... | inr neq = ⊥-rec (neq idp)

    sum-degree-true : ∀ <I g → Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) g (degree-true <I <I₋₁)) == Group.inv (C2 0) g
    sum-degree-true <I g =
        sum-subindicator (C2 0) (λ <I₋₁ → Group.exp (C2 0) g (degree-true <I <I₋₁))
          (endpoint <I true) (λ neq → ap (Group.exp (C2 0) g) (degree-true-≠ neq))
      ∙ ap (Group.exp (C2 0) g) (degree-true-diag <I)

    degree-false-≠ : ∀ {<I <I₋₁} → (<I₋₁ ≠ endpoint <I false) → degree-false <I <I₋₁ == 0
    degree-false-≠ {<I} {<I₋₁} neq with Fin-has-dec-eq <I₋₁ (endpoint <I false)
    ... | inl eq = ⊥-rec (neq eq)
    ... | inr _ = idp

    degree-false-diag : ∀ <I → degree-false <I (endpoint <I false) == 1
    degree-false-diag <I with Fin-has-dec-eq (endpoint <I false) (endpoint <I false)
    ... | inl _ = idp
    ... | inr neq = ⊥-rec (neq idp)

    sum-degree-false : ∀ <I g → Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) g (degree-false <I <I₋₁)) == g
    sum-degree-false <I g =
        sum-subindicator (C2 0) (λ <I₋₁ → Group.exp (C2 0) g (degree-false <I <I₋₁))
          (endpoint <I false) (λ neq → ap (Group.exp (C2 0) g) (degree-false-≠ neq))
      ∙ ap (Group.exp (C2 0) g) (degree-false-diag <I)

    sum-degree : ∀ <I g → Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) g (degree <I <I₋₁)) == Group.ident (C2 0)
    sum-degree <I g =
        ap (Group.sum (C2 0)) (λ= λ <I₋₁ → Group.exp-+ (C2 0) g (degree-true <I <I₋₁) (degree-false <I <I₋₁))
      ∙ AbGroup.sum-comp (C2-abgroup 0)
          (λ <I₋₁ → Group.exp (C2 0) g (degree-true <I <I₋₁))
          (λ <I₋₁ → Group.exp (C2 0) g (degree-false <I <I₋₁))
      ∙ ap2 (Group.comp (C2 0))
          (sum-degree-true <I g)
          (sum-degree-false <I g)
      ∙ Group.inv-l (C2 0) g

    merge-branches : ∀ (g : Fin I₋₁ → Group.El (C2 0)) (g-pt : g pt == Group.ident (C2 0)) x
      →  Coprod-rec (λ _ → Group.ident (C2 0)) (λ b → g (fst b)) (⊙head-separate x)
      == g x
    merge-branches g g-pt x with Fin-has-dec-eq pt x
    merge-branches g g-pt x | inl idp = ! g-pt
    merge-branches g g-pt x | inr _ = idp

  rephrase-cw-co∂-head-in-degree : ∀ g
    → GroupIso.f (CXₙ/Xₙ₋₁-diag-β ac) (GroupHom.f cw-co∂-head (GroupIso.g (C2×CX₀-diag-β ac₋₁) g))
    ∼ λ <I → Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁) (degree <I <I₋₁))
  rephrase-cw-co∂-head-in-degree g <I =
    GroupIso.f (CXₙ/Xₙ₋₁-diag-β ac) (GroupHom.f cw-co∂-head' (GroupIso.g (CX₀-diag-β ac₋₁) (snd (diff-and-separate (C2 0) g)))) <I
      =⟨ rephrase-cw-co∂-head'-in-degree (snd (diff-and-separate (C2 0) g)) <I ⟩
    Group.subsum-r (C2 0) ⊙head-separate
      (λ b → Group.exp (C2 0) (Group.diff (C2 0) (g (fst b)) (g pt))
        (degree <I (fst b)))
      =⟨ ap (Group.sum (C2 0)) (λ= λ <I₋₁ →
          merge-branches
            (λ <I₋₁ → Group.exp (C2 0) (Group.diff (C2 0) (g <I₋₁) (g pt)) (degree <I <I₋₁))
            ( ap (λ g → Group.exp (C2 0) g (degree <I pt)) (Group.inv-r (C2 0) (g pt))
            ∙ Group.exp-ident (C2 0) (degree <I pt))
            <I₋₁
          ∙ AbGroup.exp-comp (C2-abgroup 0) (g <I₋₁) (Group.inv (C2 0) (g pt)) (degree <I <I₋₁)) ⟩
    Group.sum (C2 0) (λ <I₋₁ →
      Group.comp (C2 0)
        (Group.exp (C2 0) (g <I₋₁) (degree <I <I₋₁))
        (Group.exp (C2 0) (Group.inv (C2 0) (g pt)) (degree <I <I₋₁)))
      =⟨ AbGroup.sum-comp (C2-abgroup 0)
          (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁) (degree <I <I₋₁))
          (λ <I₋₁ → Group.exp (C2 0) (Group.inv (C2 0) (g pt)) (degree <I <I₋₁)) ⟩
    Group.comp (C2 0)
      (Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁) (degree <I <I₋₁)))
      (Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) (Group.inv (C2 0) (g pt)) (degree <I <I₋₁)))
      =⟨ ap (Group.comp (C2 0) (Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁) (degree <I <I₋₁))))
          (sum-degree <I (Group.inv (C2 0) (g pt)))
        ∙ Group.unit-r (C2 0) _ ⟩
    Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁) (degree <I <I₋₁))
      =∎


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Implementation.Data.Empty where

open import Light.Library.Data.Empty using (Library ; Dependencies)
open import Light.Level using (0ℓ)
open import Light.Variable.Sets

instance dependencies : Dependencies
dependencies = record {}

instance library : Library dependencies
library = record { Implementation }
      where
      module Implementation where
            data Empty : Set where

            eliminate : Empty → 𝕒
            eliminate ()


module Utils.Exception where

{-# IMPORT Utils.Exception #-}

open import Utils.HaskellTypes

data Either (A : Set) (B : Set) : Set where
  Left : A → Either A B
  Right : B → Either A B
{-# COMPILED_DATA Either Either Left Right #-}

right : ∀{X A : Set} → A → Either X A
right x = Right x

error : ∀{X A : Set} → X → Either X A
error e = Left e

_>>=E_ : ∀{X A B : Set} → Either X A → (A → Either X B) → Either X B
_>>=E_ (Left x) f = Left x
_>>=E_ (Right x) f = f x

commExpTriple : {X A B C : Set} → Triple (Either X A) B C → Either X (Triple A B C)
commExpTriple (triple (Left e) b c) = error e
commExpTriple (triple (Right a) b c) = right (triple a b c)

commExpList : {X A : Set} → List (Either X A) → Either X (List A)
commExpList [] = right []
commExpList (Left e :: xs) = Left e
commExpList (Right y :: xs) = (commExpList xs) >>=E (λ ys → right (y :: ys))

data Exception : Set where
  IllformedLetPattern : Exception
  IllformedPromote : Exception
  VarNotInCtx : Exception
  Nonlinearity : Exception
  NonlocallyClosed : Exception
  NonEmptyCtx : Exception
  TypeErrorLetNotTop : Exception
  TypeErrorLetNotTensor : Exception
  TypeErrorPromoteNotBang : Exception
  TypeErrorTypesNotEqual : Exception
  TypeErrorAppNotImp : Exception
  NonLinearCtx : Exception
  TypeErrorDuplicatedFreeVar : Exception
{-# COMPILED_DATA Exception Utils.Exception.Exception Utils.Exception.IllformedLetPattern
                                                      Utils.Exception.IllformedPromote
                                                      Utils.Exception.VarNotInCtx
                                                      Utils.Exception.Nonlinearity
                                                      Utils.Exception.NonlocallyClosed
                                                      Utils.Exception.NonEmptyCtx
                                                      Utils.Exception.TypeErrorLetNotTop
                                                      Utils.Exception.TypeErrorLetNotTensor
                                                      Utils.Exception.TypeErrorPromoteNotBang
                                                      Utils.Exception.TypeErrorTypesNotEqual
                                                      Utils.Exception.TypeErrorAppNotImp
                                                      Utils.Exception.NonLinearCtx
                                                      Utils.Exception.TypeErrorDuplicatedFreeVar #-}


-- Andreas, Issue 1944, Bengtfest Marsstrand 2016-04-28

-- A reason why issue 1098 (automatic opening of record modules)
-- cannot easily be fixed

data Bool : Set where
  true false : Bool

if_then_else_ : ∀{A : Set} → Bool → A → A → A
if true  then t else e = t
if false then t else e = e

record Testable (A : Set) : Set where
  field
    test : A -> Bool
open Testable {{...}}
open Testable  -- overloading projection `test`

mytest : ∀{A} → Testable A → A → Bool
mytest dict = test dict  -- Should work.

t : ∀{A}{{_ : Testable A}} → A → A
t = λ x → if test x then x else x
-- This may fail when test is overloaded.


-- Andreas, 2014-03-27 fixed issue

{-# OPTIONS --copatterns --sized-types #-}

open import Common.Size

record R (i : Size) : Set where
  inductive
  constructor c
  field
    j : Size< i
    r : R j

data ⊥ : Set where

elim : (i : Size) → R i → ⊥
elim i (c j r) = elim j r

-- elim should be rejected by termination checker.

-- Being accepted, its is translated into
--
--   elim i x = elim (R.j x) (R.r x)
--
-- which is making reduceHead in the injectivity checker
-- produce larger and larger applications of elim.
-- Leading to a stack overflow.

inh : R ∞
R.j inh = ∞
R.r inh = inh

-- inh should also be rejected


module Impure.STLCRef.Readme where

open import Impure.STLCRef.Syntax
open import Impure.STLCRef.Welltyped
open import Impure.STLCRef.Eval
open import Impure.STLCRef.Properties.Soundness


module MissingWithClauses where

data D : Set where
  c : D

f : D -> D
f c with c


module NotLeqSort where

data Err : Set where
  err : (A : Set) -> Err


-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.meta:50 -v tc.conv:20 -v tc.conv.type:50 #-}
module Issue659 where

postulate
  Level : Set
  lzero : Level
  lsuc  : Level → Level
  _⊔_   : Level → Level → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO lzero #-}
{-# BUILTIN LEVELSUC  lsuc  #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}

record R (ℓ : Level) : Set ℓ where

postulate
  r : ∀ ℓ → R ℓ

module M (r : ∀ ℓ → R ℓ) where

  data D (ℓ : Level) : Set ℓ where

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

  data K : Set where
    k₁ k₂ : K

  P : ∀ {ℓ} → K → Set ℓ → Set ℓ
  P k₁ A = A → A
  P k₂ A = D _

open M r

postulate
  Foo : ∀ {k a} {A : Set a} → P k A → Set

Bar : Set
Bar = Foo M.id

-- Could this error message be improved?

-- Setω is not a valid type.
-- when checking that the expression M.id has type P M.k₁ _34

-- New error:
--
-- ((r₁ : (ℓ : Level) → R ℓ) {a : Level} {A : Set a} → A → A) !=<
-- (P {_33} _32 _34)
-- because this would result in an invalid use of Setω
-- when checking that the expression M.id has type (P {_33} _32 _34)


module Generic.Reflection.ReadData where

open import Generic.Core
open import Generic.Function.FoldMono

‵π : ArgInfo -> String -> Term -> Term -> Term
‵π i s a b = sate π (reify i) (sate refl) ∘ sate coerce ∘ sate _,_ a $
  appDef (quote appRel) (implRelArg (reify (relevance i)) ∷ explRelArg (explLam s b) ∷ [])

quoteHyp : Name -> ℕ -> Type -> Maybe (Maybe Term)
quoteHyp d p   (pi s (arg i a) b) =
  quoteHyp d p a >>= maybe (const nothing) (fmap (‵π i s a) <$> quoteHyp d p b)
quoteHyp d p t@(appDef n is)      = just $ d == n ?> sate var (toTuple ∘ map argVal $ drop p is)
quoteHyp d p t                    = just nothing

quoteDesc : Name -> ℕ -> Type -> Maybe Term
quoteDesc d p (pi s (arg i a) b) =
  (λ ma' b' -> maybe (λ a' -> sate _⊛_ a' (unshift′ b')) (‵π i s a b') ma')
    <$> quoteHyp d p a <*> quoteDesc d p b
quoteDesc d p  t                 = join $ quoteHyp d p t

-- We didn't need that `β` previously. Why do we need it now?
-- Or, perhaps, why didn't we need it earlier? It kinda makes sense.
quoteData : Data Type -> TC Term
quoteData (packData d a b cs ns) =
  case termLevelOf (monoLastType b) ⊗ mapM (quoteDesc d (countPis a)) cs of λ
    {  nothing         -> throw "can't read a data type"
    ; (just (β , cs′)) -> (λ qa qb -> explLamsBy a ∘ curryBy b ∘ appDef (quote μ)
           $ implRelArg unknown
           ∷ implRelArg β
           ∷ explRelArg (sate packData (reify d) qa qb (reify cs′) (reify ns))
           ∷ [])
         <$> quoteTC a <*> quoteTC b
    }

onFinalMu : ∀ {α} {A : Set α} -> (∀ {ι β} {I : Set ι} -> Data (Desc I β) -> TC A) -> Type -> TC A
onFinalMu k = monoLastType >>> λ
  { (appDef (quote μ) (implRelArg qι ∷ implRelArg qβ ∷ implRelArg qI ∷ explRelArg qD ∷ _)) ->
       bindTC (unquoteTC qι) λ ι ->
       bindTC (unquoteTC qβ) λ β ->
       bindTC (unquoteTC qI) λ I ->
       bindTC (unquoteTC qD) λ D -> k {ι} {β} {I} D
  ;  _                                                                                ->
       throw "the return type must be μ"
  }

guncoercePure : Data Type -> Term
guncoercePure (packData d a b cs ns) = explLam "x" ∘ vis appDef (quote curryFoldMono)
  $ explUncurryBy b (vis appDef d (replicate (countExplPis a) unknown))
  ∷ pureVar 0
  ∷ unmap pureCon ns

macro
  readData : Name -> Term -> TC _
  readData d ?r = getData d >>= quoteData >>= unify ?r

  gcoerce : Name -> Term -> TC _
  gcoerce fd ?r = inferNormType ?r >>= onFinalMu λ{ D@(packData _ _ b _ _) ->
      quoteTC (μ D) >>= λ μD ->
      traverseAll quoteTC (allCons D) >>= λ cs′ ->
      unify ?r $ vis appDef fd (curryBy b μD ∷ allToList cs′)
    }

  guncoerce : ∀ {ι β} {I : Set ι} {D : Data (Desc I β)} {j} -> μ D j -> Term -> TC _
  guncoerce {D = packData d a b cs ns} e ?r =
    quoteTC e >>= λ qe -> unify ?r ∘ vis appDef (quote curryFoldMono)
      $ explUncurryBy b (vis appDef d (replicate (countExplPis a) unknown))
      ∷ qe
      ∷ unmap pureCon ns