open import Nat
open import Prelude
open import core
open import contexts
open import lemmas-consistency
open import lemmas-ground

open import progress-checks

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

open import ground-decidable
open import htype-decidable

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress
  data ok : (d : ihexp) (Δ : hctx) → Set where
    S  : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → ok d Δ
    I  : ∀{d Δ} → d indet → ok d Δ
    BV : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : ihexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = BV (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam _ wt) = BV (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  progress (TAAp wt1 wt2) | I x | I x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | I y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | I y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
    -- similar if the left is indetermiante but the right is a boxed val
  progress (TAAp wt1 wt2) | I x | BV x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | BV y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | BV y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | BV v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | BV v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | CBFLam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | BV v | BV v₂
    with canonical-boxed-forms-arr wt1 v
  ... | CBFLam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)

    -- empty holes are indeterminate
  progress (TAEHole _ _ ) = I IEHole

    -- nonempty holes step if the innards step, indet otherwise
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I  x = I (INEHole (FIndet x))
  ... | BV x = I (INEHole (FBoxedVal x))

    -- casts
  progress (TACast wt con)
    with progress wt
    -- step if the innards step
  progress (TACast wt con) | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
    -- if indet, inspect how the types in the cast are realted by consistency:
    -- if they're the same, step by ID
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
    -- if first type is hole
  progress (TACast {τ1 = τ1} wt TCHole1) | I x
    with τ1
  progress (TACast wt TCHole1) | I x | b = I (ICastGroundHole GBase x)
  progress (TACast wt TCHole1) | I x | ⦇-⦈ = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x | τ11 ==> τ12
    with ground-decidable (τ11 ==> τ12)
  progress (TACast wt TCHole1) | I x₁ | .⦇-⦈ ==> .⦇-⦈ | Inl GHole = I (ICastGroundHole GHole x₁)
  progress (TACast wt TCHole1) | I x₁ | τ11 ==> τ12 | Inr x =  S (_ , Step FHOuter (ITGround (MGArr (ground-arr-not-hole x))) FHOuter)
    -- if second type is hole
  progress (TACast wt (TCHole2 {b})) | I x
    with canonical-indeterminate-forms-hole wt x
  progress (TACast wt (TCHole2 {b})) | I x | CIFHEHole (_ , _ , _ , refl , f)           = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHNEHole (_ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHAp (_ , _ , _ , refl , _ )             = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHCast (_ , τ , refl , _)
    with htype-dec τ b
  progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , .b , refl , _ , grn , _) | Inl refl = S (_ , Step FHOuter (ITCastSucceed grn ) FHOuter)
  progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , _ , refl , π2 , grn , _)  | Inr x =    S (_ , Step FHOuter (ITCastFail grn GBase x) FHOuter)
  progress (TACast wt (TCHole2 {⦇-⦈}))| I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x
    with ground-decidable (τ11 ==> τ12)
  progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x₁ | Inl GHole
    with canonical-indeterminate-forms-hole wt x₁
  progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHEHole (_ , _ , _ , refl , _)          = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHNEHole (_ , _ , _ , _ , _ , refl , _) = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHAp (_ , _ , _ , refl , _ )            = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , _ , GBase , _)  = S (_ , Step FHOuter (ITCastFail GBase GHole (λ ())) FHOuter )
  progress (TACast wt (TCHole2 {.⦇-⦈ ==> .⦇-⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , _ , GHole , _)  = S (_ , Step FHOuter (ITCastSucceed GHole) FHOuter)
  progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x₁ | Inr x = S (_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter)
    -- if both are arrows
  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x
    with htype-dec (τ1 ==> τ2)  (τ1' ==> τ2')
  progress (TACast wt (TCArr c1 c2)) | I x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCArr c1 c2)) | I x₁ | Inr x = I (ICastArr x x₁)
    -- boxed value cases, inspect how the casts are realted by consistency
    -- step by ID if the casts are the same
  progress (TACast wt TCRefl)  | BV x = S (_ , Step FHOuter ITCastID FHOuter)
    -- if left is hole
  progress (TACast wt (TCHole1 {τ = τ})) | BV x
    with ground-decidable τ
  progress (TACast wt TCHole1) | BV x₁ | Inl g = BV (BVHoleCast g x₁)
  progress (TACast wt (TCHole1 {b})) | BV x₁ | Inr x = abort (x GBase)
  progress (TACast wt (TCHole1 {⦇-⦈})) | BV x₁ | Inr x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₁ | Inr x
    with (htype-dec  (τ1 ==> τ2) (⦇-⦈ ==> ⦇-⦈))
  progress (TACast wt (TCHole1 {.⦇-⦈ ==> .⦇-⦈})) | BV x₂ | Inr x₁ | Inl refl = BV (BVHoleCast GHole x₂)
  progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₂ | Inr x₁ | Inr x = S (_ , Step FHOuter (ITGround (MGArr x)) FHOuter)
    -- if right is hole
  progress {τ = τ} (TACast wt TCHole2) | BV x
    with canonical-boxed-forms-hole wt x
  progress {τ = τ} (TACast wt TCHole2) | BV x | d' , τ' , refl , gnd , wt'
    with htype-dec τ τ'
  progress (TACast wt TCHole2) | BV x₁ | d' , τ , refl , gnd , wt' | Inl refl = S (_  , Step FHOuter (ITCastSucceed gnd) FHOuter)
  progress {τ = τ} (TACast wt TCHole2) | BV x₁ | _ , _ , refl , _ , _ | Inr _
    with ground-decidable τ
  progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , gnd , _ | Inr x₁ | Inl x = S(_ , Step FHOuter (ITCastFail gnd x (flip x₁)) FHOuter)
  progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , _ , _ | Inr x₁ | Inr x
    with notground x
  progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr _ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr x | Inr (_ , _ , refl) = S(_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter )
    -- if both arrows
  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x
    with htype-dec (τ1 ==> τ2) (τ1' ==> τ2')
  progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inr x = BV (BVArrCast x x₁)

   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  progress (TAFailedCast wt y z w) | S (d' , Step x a q) = S (_ , Step (FHFailedCast x) a (FHFailedCast q))
  progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w)
  progress (TAFailedCast wt y z w) | BV x = I (IFailedCast (FBoxedVal x) y z w)


-- Syntax of a second-order language
module SOAS.Metatheory.Syntax {T : Set} where

open import SOAS.Families.Core {T}
open import SOAS.Families.Build

open import SOAS.Common
open import SOAS.Context
open import Categories.Object.Initial
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive
open import SOAS.Coalgebraic.Strength
open import SOAS.Abstract.ExpStrength
open import SOAS.Metatheory.MetaAlgebra

-- Data characterising a second-order syntax:
-- * a signature endofunctor ⅀
-- * coalgebraic and exponential strength
-- * initial (⅀,𝔛)-meta-algebra for each 𝔛
-- + an inductive metavariable constructor for convenience
record Syntax : Set₁ where
  field
    ⅀F    : Functor 𝔽amiliesₛ 𝔽amiliesₛ
    ⅀:CS  : CompatStrengths ⅀F
    𝕋:Init : (𝔛 : Familyₛ) → Initial (𝕄etaAlgebras ⅀F 𝔛)
    mvarᵢ  : {𝔛 : Familyₛ}{τ : T}{Π Γ : Ctx} (open Initial (𝕋:Init 𝔛))
          → 𝔛 τ Π → Sub (𝐶 ⊥) Π Γ → 𝐶 ⊥ τ Γ

  module _ {𝔛 : Familyₛ} where
    open Initial (𝕋:Init 𝔛)

  private
    variable
      α α₁ α₂ α₃ α₄ α₅ α₆ α₇ α₈ α₉ : T
      Γ Π Π₁ Π₂ Π₃ Π₄ Π₅ Π₆ Π₇ Π₈ Π₉  : Ctx
      𝔐 : MCtx
    Tm : MCtx → Familyₛ
    Tm 𝔐 = 𝐶 (Initial.⊥ (𝕋:Init ∥ 𝔐 ∥))

  -- Shorthands for metavariables associated with a metavariable environment
  infix 100 𝔞⟨_ 𝔟⟨_ 𝔠⟨_ 𝔡⟨_ 𝔢⟨_
  infix 100 ◌ᵃ⟨_ ◌ᵇ⟨_ ◌ᶜ⟨_ ◌ᵈ⟨_ ◌ᵉ⟨_

  𝔞⟨_ : Sub (Tm (⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ → Tm (⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔞⟨ ε = mvarᵢ ↓ ε

  𝔟⟨_ : Sub (Tm (⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔟⟨ ε = mvarᵢ (↑ ↓) ε

  𝔠⟨_ : Sub (Tm (⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐))  Π Γ
      → Tm (⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔠⟨ ε = mvarᵢ (↑ ↑ ↓) ε

  𝔡⟨_ : Sub (Tm (⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔡⟨ ε = mvarᵢ (↑ ↑ ↑ ↓) ε
  𝔢⟨_ : Sub (Tm (⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔢⟨ ε = mvarᵢ (↑ ↑ ↑ ↑ ↓) ε

  𝔣⟨_ : Sub (Tm (⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔣⟨ ε = mvarᵢ (↑ ↑ ↑ ↑ ↑ ↓) ε

  𝔤⟨_ : Sub (Tm (⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔤⟨ ε = mvarᵢ (↑ ↑ ↑ ↑ ↑ ↑ ↓) ε

  𝔥⟨_ : Sub (Tm (⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔥⟨ ε = mvarᵢ (↑ ↑ ↑ ↑ ↑ ↑ ↑ ↓) ε

  𝔦⟨_ : Sub (Tm (⁅ Π₈ ⊩ₙ α₈ ⁆ ⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₈ ⊩ₙ α₈ ⁆ ⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔦⟨ ε = mvarᵢ (↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑ ↓) ε

  𝔧⟨_ : Sub (Tm (⁅ Π₉ ⊩ₙ α₉ ⁆ ⁅ Π₈ ⊩ₙ α₈ ⁆ ⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐)) Π Γ
      → Tm (⁅ Π₉ ⊩ₙ α₉ ⁆ ⁅ Π₈ ⊩ₙ α₈ ⁆ ⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ Π ⊩ₙ α ⁆ 𝔐) α Γ
  𝔧⟨ ε = mvarᵢ (↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑ ↑ ↓) ε

  -- Shorthands for metavariables with an empty metavariable environment
  𝔞 : Tm (⁅ α ⁆ 𝔐) α Γ
  𝔞 = 𝔞⟨ •
  𝔟 : Tm (⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ α ⁆ 𝔐) α Γ
  𝔟 = 𝔟⟨ •
  𝔠 : Tm (⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ α ⁆ 𝔐) α Γ
  𝔠 = 𝔠⟨ •
  𝔡 : Tm (⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ α ⁆ 𝔐) α Γ
  𝔡 = 𝔡⟨ •
  𝔢 : Tm (⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ α ⁆ 𝔐) α Γ
  𝔢 = 𝔢⟨ •

  𝔣 : Tm (⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅ α ⁆ 𝔐) α Γ
  𝔣 = 𝔣⟨ •

  𝔤 : Tm (⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅  α ⁆ 𝔐) α Γ
  𝔤 = 𝔤⟨ •

  𝔥 : Tm (⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅  α ⁆ 𝔐) α Γ
  𝔥 = 𝔥⟨ •

  𝔦 :  Tm (⁅ Π₈ ⊩ₙ α₈ ⁆ ⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅  α ⁆ 𝔐) α Γ
  𝔦 = 𝔦⟨ •

  𝔧 :  Tm (⁅ Π₉ ⊩ₙ α₉ ⁆ ⁅ Π₈ ⊩ₙ α₈ ⁆ ⁅ Π₇ ⊩ₙ α₇ ⁆ ⁅ Π₆ ⊩ₙ α₆ ⁆ ⁅ Π₅ ⊩ₙ α₅ ⁆ ⁅ Π₄ ⊩ₙ α₄ ⁆ ⁅ Π₃ ⊩ₙ α₃ ⁆ ⁅ Π₂ ⊩ₙ α₂ ⁆ ⁅ Π₁ ⊩ₙ α₁ ⁆ ⁅  α ⁆ 𝔐) α Γ
  𝔧 = 𝔧⟨ •

  -- Synonyms for holes
  ◌ᵃ = 𝔞 ; ◌ᵇ = 𝔟 ; ◌ᶜ = 𝔠 ; ◌ᵈ = 𝔡 ; ◌ᵉ = 𝔢
  ◌ᵃ⟨_ = 𝔞⟨_ ; ◌ᵇ⟨_ = 𝔟⟨_ ; ◌ᶜ⟨_ = 𝔠⟨_ ; ◌ᵈ⟨_ = 𝔡⟨_ ; ◌ᵉ⟨_ = 𝔢⟨_


open import Agda.Builtin.Bool

data D : Set where
  run-time        : D
  @0 compile-time : D

-- This code should be rejected: Both f compile-time and f run-time
-- are type-correct run-time terms.

f : @0 D → Bool
f compile-time = true
f run-time     = false


data A (B : Set) : Set where
module C where
  record D : Set where
module E (F : Set) (G : A F) where
  open C public using (module D)
module H (I : Set) (J : A I) where
  open E I J using ()


------------------------------------------------------------------------
-- Non-dependent and dependent lenses
-- Nils Anders Danielsson
------------------------------------------------------------------------

{-# OPTIONS --cubical --guardedness #-}

module README where

-- Non-dependent lenses.

import Lens.Non-dependent
import Lens.Non-dependent.Traditional
import Lens.Non-dependent.Traditional.Combinators
import Lens.Non-dependent.Higher
import Lens.Non-dependent.Higher.Combinators
import Lens.Non-dependent.Higher.Capriotti.Variant
import Lens.Non-dependent.Higher.Capriotti
import Lens.Non-dependent.Higher.Coherently.Not-coinductive
import Lens.Non-dependent.Higher.Coherently.Coinductive
import Lens.Non-dependent.Higher.Coinductive
import Lens.Non-dependent.Higher.Coinductive.Small
import Lens.Non-dependent.Higher.Surjective-remainder
import Lens.Non-dependent.Equivalent-preimages
import Lens.Non-dependent.Bijection

-- Non-dependent lenses with erased proofs.

import Lens.Non-dependent.Traditional.Erased
import Lens.Non-dependent.Higher.Erased
import Lens.Non-dependent.Higher.Capriotti.Variant.Erased
import Lens.Non-dependent.Higher.Capriotti.Variant.Erased.Variant
import Lens.Non-dependent.Higher.Coinductive.Erased
import Lens.Non-dependent.Higher.Coinductive.Small.Erased
import Lens.Non-dependent.Higher.Coherently.Coinductive.Erased

-- Dependent lenses.

import Lens.Dependent

-- Comparisons of different kinds of lenses, focusing on the
-- definition of composable record getters and setters.

import README.Record-getters-and-setters

-- Some code suggesting that types used in "programs" might not
-- necessarily be sets. (If lenses are only used in programs, and
-- types used in programs are always sets, then higher lenses might be
-- pointless.)

import README.Not-a-set

-- Pointers to code corresponding to many definitions and results from
-- the paper "Higher Lenses" by Paolo Capriotti, Nils Anders
-- Danielsson and Andrea Vezzosi.

import README.Higher-Lenses

-- The lenses fst and snd.

import README.Fst-snd

-- Pointers to code corresponding to some definitions and results from
-- the paper "Compiling Programs with Erased Univalence" by Andreas
-- Abel, Nils Anders Danielsson and Andrea Vezzosi.

import README.Compiling-Programs-with-Erased-Univalence


{-# OPTIONS --safe #-}

module Cubical.Algebra.CommAlgebra.FreeCommAlgebra where

open import Cubical.Algebra.CommAlgebra.FreeCommAlgebra.Base public
open import Cubical.Algebra.CommAlgebra.FreeCommAlgebra.Properties public


------------------------------------------------------------------------
-- An implementation of "A Unifying Approach to Recursive and
-- Co-recursive Definitions" by Pietro Di Gianantonio and Marino
-- Miculan
------------------------------------------------------------------------

-- See the paper for more explanations.

module Contractive where

open import Relation.Unary
open import Relation.Binary
import Relation.Binary.Reasoning.Setoid as EqR
open import Induction.WellFounded
open import Function
open import Level hiding (lift)

-- Well-founded orders.

record IsWellFoundedOrder {A} (_<_ : Rel A zero) : Set where
  field
    trans         : Transitive _<_
    isWellFounded : WellFounded _<_

-- Ordered families of equivalences.

record OFE : Set1 where
  field
    Carrier            : Set
    Domain             : Set
    _<_                : Rel Carrier zero
    isWellFoundedOrder : IsWellFoundedOrder _<_
    Eq                 : Carrier → Rel Domain zero
    isEquivalence      : ∀ a → IsEquivalence (Eq a)

  open IsWellFoundedOrder isWellFoundedOrder public
  open All isWellFounded public

  setoid : Carrier → Setoid _ _
  setoid a = record { Carrier       = Domain
                    ; _≈_           = Eq a
                    ; isEquivalence = isEquivalence a
                    }

  module EqReasoning {a : Carrier} where
    open EqR    (setoid a) public
    open Setoid (setoid a) public using (refl; sym)

  -- The set of predecessors of a.

  ↓ : Carrier → Carrier → Set
  ↓ a = λ a' → a' < a

  -- The intersection of all the equivalences.

  _≅_ : Rel Domain zero
  x ≅ y = ∀ a → Eq a x y

  Family : (Carrier → Set) → Set
  Family I = ∀ x → x ∈ I → Domain

  lift : ∀ {I} → (Carrier → Domain) → Family I
  lift P = λ x _ → P x

  IsCoherent : ∀ {I} → Family I → Set
  IsCoherent {I} fam = ∀ {a' a}
    (a'∈I : a' ∈ I) (a∈I : a ∈ I) → a' < a →
    Eq a' (fam a' a'∈I) (fam a a∈I)

  IsLimit : ∀ {I} → Family I → Domain → Set
  IsLimit {I} fam y = ∀ {a'}
    (a'∈I : a' ∈ I) → Eq a' (fam a' a'∈I) y

  IsContractive : (Domain → Domain) → Set
  IsContractive F = ∀ {x y a} →
    (∀ {a'} → a' < a → Eq a' x y) → Eq a (F x) (F y)

-- Complete ordered families of equivalences.

record COFE : Set1 where
  field
    ofe : OFE

  open OFE ofe

  field
    limU     : (Carrier → Domain) → Domain
    isLimitU : ∀ {fam} →
               IsCoherent {U} (lift fam) →
               IsLimit {U} (lift fam) (limU fam)

    lim↓     : ∀ a → Family (↓ a) → Domain
    isLimit↓ : ∀ a {fam : Family (↓ a)} →
               IsCoherent fam → IsLimit fam (lim↓ a fam)

  open OFE ofe public

-- Contractive functions over complete ordered families have
-- fixpoints.

record ContractiveFun (cofe : COFE) : Set where
  open COFE cofe
  field
    F             : Domain → Domain
    isContractive : IsContractive F

  open EqReasoning

  -- The fixpoint is the limit of the following family.

  fam : Carrier → Domain
  fam = wfRec _ (const Domain) (λ a rec → F (lim↓ a rec))

  fixpoint : Domain
  fixpoint = limU fam

  -- I am not sure if this lemma can be proved without assuming some
  -- kind of proof irrelevance and/or extensionality. It is not
  -- central to the ideas developed here, though, so I leave it as a
  -- postulate.

  postulate unfold : ∀ a → fam a ≅ F (lim↓ a (lift fam))

  -- The family is coherent in several ways.

  fam-isCoherent-↓ : ∀ a → IsCoherent {↓ a} (lift fam)
  fam-isCoherent-↓ = wfRec _ P step
    where
    P : Carrier → Set
    P a = IsCoherent {↓ a} (lift fam)

    step : ∀ a → WfRec _<_ P a → P a
    step a rec {c} {b} c<a b<a c<b = begin
      fam c                  ≈⟨ unfold c c ⟩
      F (lim↓ c (lift fam))  ≈⟨ isContractive (λ {d} d<c → begin
         lim↓ c (lift fam)      ≈⟨ sym $ isLimit↓ c (rec c c<a) d<c ⟩
         lift {↓ a} fam d
              (trans d<c c<a)   ≈⟨ isLimit↓ b (rec b b<a) (trans d<c c<b) ⟩
         lim↓ b (lift fam)      ∎) ⟩
      F (lim↓ b (lift fam))  ≈⟨ sym $ unfold b c ⟩
      fam b                  ∎

  fam-isCoherent-U : IsCoherent {U} (lift fam)
  fam-isCoherent-U {a'} {a} _ _ = wfRec _ P step a a'
    where
    P : Carrier → Set
    P a = ∀ a' → a' < a → Eq a' (fam a') (fam a)

    step : ∀ a → WfRec _<_ P a → P a
    step a rec a' a'<a = begin
      fam a'                  ≈⟨ unfold a' a' ⟩
      F (lim↓ a' (lift fam))  ≈⟨ isContractive (λ {b} b<a' → begin
         lim↓ a' (lift fam)      ≈⟨ sym $ isLimit↓ a' (fam-isCoherent-↓ a') b<a' ⟩
         fam b                   ≈⟨ isLimit↓ a (fam-isCoherent-↓ a) (trans b<a' a'<a) ⟩
         lim↓ a  (lift fam)      ∎) ⟩
      F (lim↓ a  (lift fam))  ≈⟨ sym $ unfold a a' ⟩
      fam a                   ∎

  -- The fixpoint is a fixpoint.

  isFixpoint : fixpoint ≅ F fixpoint
  isFixpoint a = begin
    fixpoint               ≈⟨ sym $ isLimitU fam-isCoherent-U _ ⟩
    fam a                  ≈⟨ unfold a a ⟩
    F (lim↓ a (lift fam))  ≈⟨ isContractive (λ {a'} a'<a → begin
       lim↓ a (lift fam)      ≈⟨ sym $ isLimit↓ a (fam-isCoherent-↓ a) a'<a ⟩
       fam a'                 ≈⟨ isLimitU fam-isCoherent-U _ ⟩
       limU fam               ∎) ⟩
    F (limU fam)           ≈⟨ refl ⟩
    F fixpoint             ∎

  -- And it is unique.

  unique : ∀ x → x ≅ F x → x ≅ fixpoint
  unique x isFix = wfRec _ P step
    where
    P = λ a → Eq a x fixpoint

    step : ∀ a → WfRec _<_ P a → P a
    step a rec = begin
      x           ≈⟨ isFix a ⟩
      F x         ≈⟨ isContractive (λ {a'} a'<a → rec a' a'<a) ⟩
      F fixpoint  ≈⟨ sym $ isFixpoint a ⟩
      fixpoint    ∎


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

module Definition.Typed.Consequences.InverseUniv where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Consequences.Syntactic

import Tools.Sum as Sum
open import Tools.Sum using (_⊎_; inj₁; inj₂)
open import Tools.Product
open import Tools.Empty
open import Tools.Nullary

-- Proposition for terms if they contain a U.
data UFull : Term → Set where
  ∃U  : UFull U
  ∃Π₁ : ∀ {F G} → UFull F → UFull (Π F ▹ G)
  ∃Π₂ : ∀ {F G} → UFull G → UFull (Π F ▹ G)

-- Terms cannot contain U.
noU : ∀ {t A Γ} → Γ ⊢ t ∷ A → ¬ (UFull t)
noU (ℕⱼ x) ()
noU (Πⱼ t ▹ t₁) (∃Π₁ ufull) = noU t ufull
noU (Πⱼ t ▹ t₁) (∃Π₂ ufull) = noU t₁ ufull
noU (var x₁ x₂) ()
noU (lamⱼ x t₁) ()
noU (t ∘ⱼ t₁) ()
noU (zeroⱼ x) ()
noU (sucⱼ t) ()
noU (natrecⱼ x t t₁ t₂) ()
noU (conv t₁ x) ufull = noU t₁ ufull

-- Neutrals cannot contain U.
noUNe : ∀ {A} → Neutral A → ¬ (UFull A)
noUNe (var n) ()
noUNe (∘ₙ neA) ()
noUNe (natrecₙ neA) ()

-- Helper function where if at least one Π-type does not contain U,
-- one of F and H will not contain U and one of G and E will not contain U.
pilem : ∀ {F G H E}
      → (¬ UFull (Π F ▹ G)) ⊎ (¬ UFull (Π H ▹ E))
      → (¬ UFull F) ⊎ (¬ UFull H) × (¬ UFull G) ⊎ (¬ UFull E)
pilem (inj₁ x) = inj₁ (λ x₁ → x (∃Π₁ x₁)) , inj₁ (λ x₁ → x (∃Π₂ x₁))
pilem (inj₂ x) = inj₂ (λ x₁ → x (∃Π₁ x₁)) , inj₂ (λ x₁ → x (∃Π₂ x₁))

-- If type A does not contain U, then A can be a term of type U.
inverseUniv : ∀ {A Γ} → ¬ (UFull A) → Γ ⊢ A → Γ ⊢ A ∷ U
inverseUniv q (ℕⱼ x) = ℕⱼ x
inverseUniv q (Uⱼ x) = ⊥-elim (q ∃U)
inverseUniv q (Πⱼ A ▹ A₁) = Πⱼ inverseUniv (λ x → q (∃Π₁ x)) A ▹ inverseUniv (λ x → q (∃Π₂ x)) A₁
inverseUniv q (univ x) = x

-- If A is a neutral type, then A can be a term of U.
inverseUnivNe : ∀ {A Γ} → Neutral A → Γ ⊢ A → Γ ⊢ A ∷ U
inverseUnivNe neA ⊢A = inverseUniv (noUNe neA) ⊢A

-- Helper function where if at least one type does not contain U, then the
-- equality of types can be an equality of term of type U.
inverseUnivEq′ : ∀ {A B Γ} → (¬ (UFull A)) ⊎ (¬ (UFull B)) → Γ ⊢ A ≡ B → Γ ⊢ A ≡ B ∷ U
inverseUnivEq′ q (univ x) = x
inverseUnivEq′ q (refl x) = refl (inverseUniv (Sum.id q) x)
inverseUnivEq′ q (sym A≡B) = sym (inverseUnivEq′ (Sum.sym q) A≡B)
inverseUnivEq′ (inj₁ x) (trans A≡B A≡B₁) =
  let w = inverseUnivEq′ (inj₁ x) A≡B
      _ , _ , t = syntacticEqTerm w
      y = noU t
  in  trans w (inverseUnivEq′ (inj₁ y) A≡B₁)
inverseUnivEq′ (inj₂ x) (trans A≡B A≡B₁) =
  let w = inverseUnivEq′ (inj₂ x) A≡B₁
      _ , t , _ = syntacticEqTerm w
      y = noU t
  in  trans (inverseUnivEq′ (inj₂ y) A≡B) w
inverseUnivEq′ q (Π-cong x A≡B A≡B₁) =
  let w , e = pilem q
  in  Π-cong x (inverseUnivEq′ w A≡B) (inverseUnivEq′ e A≡B₁)

-- If A is a term of U, then the equality of types is an equality of terms of type U.
inverseUnivEq : ∀ {A B Γ} → Γ ⊢ A ∷ U → Γ ⊢ A ≡ B → Γ ⊢ A ≡ B ∷ U
inverseUnivEq A A≡B = inverseUnivEq′ (inj₁ (noU A)) A≡B


module Issue833-2 where

-- Arbitrary data type
record unit : Set where
  constructor tt

module Test ⦃ m : unit ⦄ { n : unit } where

open Test { tt }


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

module Definition.Typed.Consequences.Reduction where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.Typed.Consequences.Syntactic
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Fundamental.Reducibility

open import Tools.Product

-- Helper function where all reducible types can be reduced to WHNF.
whNorm′ : ∀ {A Γ l} ([A] : Γ ⊩⟨ l ⟩ A)
                → ∃ λ B → Whnf B × Γ ⊢ A :⇒*: B
whNorm′ (Uᵣ′ .⁰ 0<1 ⊢Γ) = U , Uₙ , idRed:*: (Uⱼ ⊢Γ)
whNorm′ (ℕᵣ D) = ℕ , ℕₙ , D
whNorm′ (Emptyᵣ D) = Empty , Emptyₙ , D
whNorm′ (Unitᵣ D) = Unit , Unitₙ , D
whNorm′ (ne′ K D neK K≡K) = K , ne neK , D
whNorm′ (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) = Π F ▹ G , Πₙ , D
whNorm′ (Σᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) = Σ F ▹ G , Σₙ , D
whNorm′ (emb 0<1 [A]) = whNorm′ [A]

-- Well-formed types can all be reduced to WHNF.
whNorm : ∀ {A Γ} → Γ ⊢ A → ∃ λ B → Whnf B × Γ ⊢ A :⇒*: B
whNorm A = whNorm′ (reducible A)

-- Helper function where reducible all terms can be reduced to WHNF.
whNormTerm′ : ∀ {a A Γ l} ([A] : Γ ⊩⟨ l ⟩ A) → Γ ⊩⟨ l ⟩ a ∷ A / [A]
                → ∃ λ b → Whnf b × Γ ⊢ a :⇒*: b ∷ A
whNormTerm′ (Uᵣ x) (Uₜ A d typeA A≡A [t]) = A , typeWhnf typeA , d
whNormTerm′ (ℕᵣ x) (ℕₜ n d n≡n prop) =
  let natN = natural prop
  in  n , naturalWhnf natN , convRed:*: d (sym (subset* (red x)))
whNormTerm′ (Emptyᵣ x) (Emptyₜ n d n≡n prop) =
  let emptyN = empty prop
  in  n , ne emptyN , convRed:*: d (sym (subset* (red x)))
whNormTerm′ (Unitᵣ x) (Unitₜ n d prop) =
  n , prop , convRed:*: d (sym (subset* (red x)))
whNormTerm′ (ne (ne K D neK K≡K)) (neₜ k d (neNfₜ neK₁ ⊢k k≡k)) =
  k , ne neK₁ , convRed:*: d (sym (subset* (red D)))
whNormTerm′ (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Πₜ f d funcF f≡f [f] [f]₁) =
  f , functionWhnf funcF , convRed:*: d (sym (subset* (red D)))
whNormTerm′ (Σᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Σₜ p d pProd p≡p [fst] [snd]) =
  p , productWhnf pProd , convRed:*: d (sym (subset* (red D)))
whNormTerm′ (emb 0<1 [A]) [a] = whNormTerm′ [A] [a]

-- Well-formed terms can all be reduced to WHNF.
whNormTerm : ∀ {a A Γ} → Γ ⊢ a ∷ A → ∃ λ b → Whnf b × Γ ⊢ a :⇒*: b ∷ A
whNormTerm {a} {A} ⊢a =
  let [A] , [a] = reducibleTerm ⊢a
  in  whNormTerm′ [A] [a]

redMany : ∀ {t u A Γ} → Γ ⊢ t ⇒ u ∷ A → Γ ⊢ t ⇒* u ∷ A
redMany d =
  let _ , _ , ⊢u = syntacticEqTerm (subsetTerm d)
  in  d ⇨ id ⊢u


module _ where

module M (_ : Set₁) where

  record R₁ (A : Set) : Set₁ where
    no-eta-equality

    postulate
      x : A

  open R₁ ⦃ … ⦄ public

  record R₂ (A : Set) : Set₁ where
    field
      instance
        r₁ : R₁ A

  open R₂ ⦃ … ⦄

open module MSet = M Set

postulate
  A : Set

instance
  postulate
    m : R₁ A

a : A
a = x


{-

Index a structure T a positive structure S: X ↦ S X → T X

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.RelationalStructure
open import Cubical.Foundations.Univalence
open import Cubical.Functions.FunExtEquiv
open import Cubical.Data.Sigma
open import Cubical.Relation.Binary.Base
open import Cubical.Relation.ZigZag.Base
open import Cubical.HITs.SetQuotients
open import Cubical.HITs.PropositionalTruncation as Trunc

open import Cubical.Structures.Function

private
  variable
    ℓ ℓ₁ ℓ₁' ℓ₁'' ℓ₂ ℓ₂' ℓ₂'' : Level

FunctionRelStr : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  → StrRel S ℓ₁' → StrRel T ℓ₂' → StrRel (FunctionStructure S T) (ℓ-max ℓ₁ (ℓ-max ℓ₁' ℓ₂'))
FunctionRelStr ρ₁ ρ₂ R f g =
  ∀ {x y} → ρ₁ R x y → ρ₂ R (f x) (g y)

open isEquivRel

private
  composeWith[_] : {A : Type ℓ} (R : EquivPropRel A ℓ)
    → compPropRel (R .fst) (quotientPropRel (R .fst .fst)) .fst ≡ graphRel [_]
  composeWith[_] R =
    funExt₂ λ a t →
    hPropExt squash (squash/ _ _)
      (Trunc.rec (squash/ _ _) (λ {(b , r , p) → eq/ a b r ∙ p }))
      (λ p → ∣ a , R .snd .reflexive a , p ∣)

  [_]∙[_]⁻¹ : {A : Type ℓ} (R : EquivPropRel A ℓ)
    → compPropRel (quotientPropRel (R .fst .fst)) (invPropRel (quotientPropRel (R .fst .fst))) .fst
      ≡ R .fst .fst
  [_]∙[_]⁻¹ R =
    funExt₂ λ a b →
    hPropExt squash (R .fst .snd a b)
      (Trunc.rec (R .fst .snd a b)
        (λ {(c , p , q) → effective (R .fst .snd) (R .snd) a b (p ∙ sym q)}))
      (λ r → ∣ _ , eq/ a b r , refl ∣)

functionSuitableRel : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  {ρ₁ : StrRel S ℓ₁'} {ρ₂ : StrRel T ℓ₂'}
  (θ₁ : SuitableStrRel S ρ₁)
  → PositiveStrRel θ₁
  → SuitableStrRel T ρ₂
  → SuitableStrRel (FunctionStructure S T) (FunctionRelStr ρ₁ ρ₂)
functionSuitableRel {S = S} {T = T} {ρ₁ = ρ₁} {ρ₂} θ₁ σ₁ θ₂ .quo (X , f) R h =
  final
  where
  ref : (s : S X) → ρ₁ (R .fst .fst) s s
  ref = posRelReflexive σ₁ R

  [f] : S X / ρ₁ (R .fst .fst) → T (X / R .fst .fst)
  [f] [ s ] = θ₂ .quo (X , f s) R (h (ref s)) .fst .fst
  [f] (eq/ s₀ s₁ r i) =
    cong fst
      (θ₂ .quo (X , f s₀) R (h (ref s₀)) .snd
        ( [f] [ s₁ ]
        , subst (λ R' → ρ₂ R' (f s₀) ([f] [ s₁ ]))
          (composeWith[_] R)
          (θ₂ .transitive (R .fst) (quotientPropRel (R .fst .fst))
            (h r)
            (θ₂ .quo (X , f s₁) R (h (ref s₁)) .fst .snd))
        ))
      i
  [f] (squash/ _ _ p q j i) =
    θ₂ .set squash/ _ _ (cong [f] p) (cong [f] q) j i

  relLemma : (s : S X) (t : S X)
    → ρ₁ (graphRel [_]) s (funIsEq (σ₁ .quo R) [ t ])
    → ρ₂ (graphRel [_]) (f s) ([f] [ t ])
  relLemma s t r =
    subst (λ R' → ρ₂ R' (f s) ([f] [ t ]))
      (composeWith[_] R)
      (θ₂ .transitive (R .fst) (quotientPropRel (R .fst .fst))
        (h r')
        (θ₂ .quo (X , f t) R (h (ref t)) .fst .snd))
    where
    r' : ρ₁ (R .fst .fst) s t
    r' =
      subst (λ R' → ρ₁ R' s t) ([_]∙[_]⁻¹ R)
        (θ₁ .transitive
          (quotientPropRel (R .fst .fst))
          (invPropRel (quotientPropRel (R .fst .fst)))
          r
          (θ₁ .symmetric (quotientPropRel (R .fst .fst))
            (subst
              (λ t' → ρ₁ (graphRel [_]) t' (funIsEq (σ₁ .quo R) [ t ]))
              (σ₁ .act .actStrId t)
              (σ₁ .act .actRel eq/ t t (ref t)))))

  quoRelLemma : (s : S X) (t : S X / ρ₁ (R .fst .fst))
    → ρ₁ (graphRel [_]) s (funIsEq (σ₁ .quo R) t)
    → ρ₂ (graphRel [_]) (f s) ([f] t)
  quoRelLemma s =
    elimProp (λ _ → isPropΠ λ _ → θ₂ .prop (λ _ _ → squash/ _ _) _ _)
      (relLemma s)

  final : Σ (Σ _ _) _
  final .fst .fst = [f] ∘ invIsEq (σ₁ .quo R)
  final .fst .snd {s} {t} r =
    quoRelLemma s
      (invIsEq (σ₁ .quo R) t)
      (subst (ρ₁ (graphRel [_]) s) (sym (secIsEq (σ₁ .quo R) t)) r)
  final .snd (f' , c) =
    Σ≡Prop
      (λ _ → isPropImplicitΠ λ s →
        isPropImplicitΠ λ t →
        isPropΠ λ _ → θ₂ .prop (λ _ _ → squash/ _ _) _ _)
      (funExt λ s → contractorLemma (invIsEq (σ₁ .quo R) s) ∙ cong f' (secIsEq (σ₁ .quo R) s))
    where
    contractorLemma : (s : S X / ρ₁ (R .fst .fst))
      → [f] s ≡ f' (funIsEq (σ₁ .quo R) s)
    contractorLemma =
      elimProp
        (λ _ → θ₂ .set squash/ _ _)
        (λ s →
          cong fst
            (θ₂ .quo (X , f s) R (h (ref s)) .snd
              ( f' (funIsEq (σ₁ .quo R) [ s ])
              , c
                (subst
                  (λ s' → ρ₁ (graphRel [_]) s' (funIsEq (σ₁ .quo R) [ s ]))
                  (σ₁ .act .actStrId s)
                  (σ₁ .act .actRel eq/ s s (ref s)))
              )))
functionSuitableRel {ρ₁ = ρ₁} {ρ₂} θ₁ σ θ₂ .symmetric R h r =
  θ₂ .symmetric R (h (θ₁ .symmetric (invPropRel R) r))
functionSuitableRel {ρ₁ = ρ₁} {ρ₂} θ₁ σ θ₂ .transitive R R' h h' rr' =
  Trunc.rec
    (θ₂ .prop (λ _ _ → squash) _ _)
    (λ {(_ , r , r') → θ₂ .transitive R R' (h r) (h' r')})
    (σ .detransitive R R' rr')
functionSuitableRel {ρ₁ = ρ₁} {ρ₂} θ₁ σ θ₂ .set setX =
  isSetΠ λ _ → θ₂ .set setX
functionSuitableRel {ρ₁ = ρ₁} {ρ₂} θ₁ σ θ₂ .prop propR f g =
  isPropImplicitΠ λ _ →
  isPropImplicitΠ λ _ →
  isPropΠ λ _ →
  θ₂ .prop propR _ _

functionRelMatchesEquiv : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  (ρ₁ : StrRel S ℓ₁') {ι₁ : StrEquiv S ℓ₁''}
  (ρ₂ : StrRel T ℓ₂') {ι₂ : StrEquiv T ℓ₂''}
  → StrRelMatchesEquiv ρ₁ ι₁
  → StrRelMatchesEquiv ρ₂ ι₂
  → StrRelMatchesEquiv (FunctionRelStr ρ₁ ρ₂) (FunctionEquivStr ι₁ ι₂)
functionRelMatchesEquiv ρ₁ ρ₂ μ₁ μ₂ (X , f) (Y , g) e =
  equivImplicitΠCod (equivImplicitΠCod (equiv→ (μ₁ _ _ e) (μ₂ _ _ e)))

functionRelMatchesEquiv+ : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  (ρ₁ : StrRel S ℓ₁') (α₁ : EquivAction S)
  (ρ₂ : StrRel T ℓ₂') (ι₂ : StrEquiv T ℓ₂'')
  → StrRelMatchesEquiv ρ₁ (EquivAction→StrEquiv α₁)
  → StrRelMatchesEquiv ρ₂ ι₂
  → StrRelMatchesEquiv (FunctionRelStr ρ₁ ρ₂) (FunctionEquivStr+ α₁ ι₂)
functionRelMatchesEquiv+ ρ₁ α₁ ρ₂ ι₂ μ₁ μ₂ (X , f) (Y , g) e =
  compEquiv
    (functionRelMatchesEquiv ρ₁ ρ₂ μ₁ μ₂ (X , f) (Y , g) e)
    (isoToEquiv isom)
  where
  open Iso
  isom : Iso
    (FunctionEquivStr (EquivAction→StrEquiv α₁) ι₂ (X , f) (Y , g) e)
    (FunctionEquivStr+ α₁ ι₂ (X , f) (Y , g) e)
  isom .fun h s = h refl
  isom .inv k {x} = J (λ y _ → ι₂ (X , f x) (Y , g y) e) (k x)
  isom .rightInv k i x = JRefl (λ y _ → ι₂ (X , f x) (Y , g y) e) (k x) i
  isom .leftInv h =
    implicitFunExt λ {x} →
    implicitFunExt λ {y} →
    funExt λ p →
    J (λ y p → isom .inv (isom .fun h) p ≡ h p)
      (funExt⁻ (isom .rightInv (isom .fun h)) x)
      p


open import Structures
open import Data.String using (String)
open import Data.Nat
open import Data.Nat.Show renaming (show to showNat)
open import Data.Vec as V using (Vec; []; _∷_)
open import Data.List as L using (List; []; _∷_)
open import Data.Sum
open import Data.Product
open import Relation.Nullary
open import Function using (_$_)

data Nesting : Set where
  hom : Nesting
  nes : Nesting

data SacTy : Set where
  unit  : SacTy
  int   : SacTy
  float : SacTy
  bool  : SacTy
  char  : SacTy
          -- Nested `n`-dimensional array is isomorphic to Listⁿ
          -- Homogeneous `n`-dimensional array is isomorphic to Vecⁿ
          -- The first argument does not tell whether the entire array needs
          -- to be implemented as nested or not (just an annotation), e.g:
          --    akd hom (akd nest nat 3)
          --    akd nes nat 2
          --    akd nes (akd nes nat 1)
          -- and so on.  In actual sac (with no support for nested arrays)
          -- it all collapses to three cases, but it is convenient to keep
          -- this distinction in the model.
  aud   : Nesting → SacTy → (sh : Prog) → SacTy
  akd   : Nesting → SacTy → (sh : Prog) → ℕ → SacTy
  aks   : Nesting → SacTy → (sh : Prog) → (n : ℕ) → Vec ℕ n → SacTy

data SacBase : SacTy → Set where
  unit  : SacBase unit
  int   : SacBase int
  float : SacBase float
  bool  : SacBase bool
  char  : SacBase char

data SacArray : SacTy → Set where
  aud : ∀ {n? τ es} → SacArray (aud n? τ es)
  akd : ∀ {n? τ es n} → SacArray (akd n? τ es n)
  aks : ∀ {n? τ es n s} → SacArray (aks n? τ es n s)

array-or-base : ∀ τ → SacBase τ ⊎ SacArray τ
array-or-base unit = inj₁ unit
array-or-base int = inj₁ int
array-or-base float = inj₁ float
array-or-base bool = inj₁ bool
array-or-base char = inj₁ char
array-or-base (aud x τ es) = inj₂ aud
array-or-base (akd x τ es x₁) = inj₂ akd
array-or-base (aks x τ es n x₁) = inj₂ aks

is-base : ∀ τ → Dec (SacBase τ)
is-base τ with array-or-base τ
... | inj₁ bt = yes bt
... | inj₂ aud = no λ ()
... | inj₂ akd = no λ ()
... | inj₂ aks = no λ ()

is-array : ∀ τ → Dec (SacArray τ)
is-array τ with array-or-base τ
... | inj₂ ar = yes ar
... | inj₁ unit = no λ ()
... | inj₁ int = no λ ()
... | inj₁ float = no λ ()
... | inj₁ bool = no λ ()
... | inj₁ char = no λ ()

-- Is it the case that the entire array can be implemented
-- as a flattened homogeneous (multi-dimensional) array.
nested? : SacTy → Nesting
nested? unit = hom
nested? int = hom
nested? float = hom
nested? bool = hom
nested? char = hom
nested? (aud hom τ _) = nested? τ
nested? (aud nes _ _) = nes
nested? (akd hom τ _ _) = nested? τ
nested? (akd nes _ _ _) = nes
nested? (aks hom τ _ _ _) = nested? τ
nested? (aks nes _ _ _ _) = nes

get-base : SacTy → Σ[ τ ∈ SacTy ] SacBase τ
get-base unit = unit , unit
get-base int = int , int
get-base float = float , float
get-base bool = bool , bool
get-base char = char , char
get-base (aud x τ es) = get-base τ
get-base (akd x τ es x₁) = get-base τ
get-base (aks x τ es n x₁) = get-base τ

bt-tostring : ∀ {τ} → SacBase τ → String
bt-tostring unit = "unit"
bt-tostring int = "int"
bt-tostring float = "float"
bt-tostring bool = "bool"
bt-tostring char = "char"

postfix-aud = "[*]"

postfix-akd : ℕ → String
postfix-akd n = "[" ++ ("," ++/ L.replicate n ".") ++ "]"

postfix-aks : (n : ℕ) → Vec ℕ n → String
postfix-aks n s = "[" ++ ("," ++/ L.map showNat (V.toList s)) ++ "]"

bt : SacTy → String
bt τ = bt-tostring (proj₂ $ get-base τ)

sacty-to-string : SacTy → String
sacty-to-string σ with array-or-base σ
sacty-to-string σ | inj₁ bt = bt-tostring bt
sacty-to-string σ | inj₂ (aud {nes} {τ}) = sacty-to-string τ ++ postfix-aud
sacty-to-string σ | inj₂ (aud {hom} {τ}) with nested? τ
... | hom = bt τ  ++ postfix-aud
... | nes = sacty-to-string τ ++ postfix-aud

sacty-to-string σ | inj₂ (akd {nes} {τ} {_} {n}) = sacty-to-string τ ++ postfix-akd n
sacty-to-string σ | inj₂ (akd {hom} {τ} {_} {n}) with nested? τ
... | nes = sacty-to-string τ ++ postfix-akd n
... | hom with array-or-base τ
... | inj₁ bt =
           bt-tostring bt ++ postfix-akd n
... | inj₂ aud =
           --(τ[*])[.,.,.]   → τ([.,.,.] ++ [*])   = τ[*]
           bt τ ++ postfix-aud
... | inj₂ (akd {n = m}) =
           --(τ[.,.])[.,.,.] → τ([.,.,.] ++ [.,.]) = τ[.,.,., .,.]
           bt τ ++ postfix-akd (n + m)
... | inj₂ (aks {n = m}) =
           --(τ[5,6])[.,.,.] → τ([.,.,.] ++ [5,6]) = τ[.,.,., .,.]
           bt τ ++ postfix-akd (n + m)

sacty-to-string σ | inj₂ (aks {nes} {τ} {_} {n} {s}) = sacty-to-string τ ++ postfix-aks n s
sacty-to-string σ | inj₂ (aks {hom} {τ} {_} {n} {s}) with nested? τ
... | nes = sacty-to-string τ ++ postfix-aks n s
... | hom with array-or-base τ
... | inj₁ bt =
           bt-tostring bt ++ postfix-aks n s
... | inj₂ aud =
           -- (τ[*])[5,6]  → τ([5,6] ++ [*]) = τ[*]
           bt τ ++ postfix-aud
... | inj₂ (akd {n = m}) =
           --(τ[.,.])[5,6] → τ([5,6] ++ [.,.]) = τ[.,.,.,.]
           bt τ ++ postfix-akd (n + m)
... | inj₂ (aks {s = s′}) =
           --(τ[7,8])[5,6] → τ([5,6] ++ [7,8]) = τ[5,6,7,8]
           bt τ ++ postfix-aks _ (s V.++ s′)

-- For some rare cases we can eliminate nesting
-- Note that this function does not recurse, as:
--    a: List (hom X)         ~  Vec (hom X) (length a)
-- but
--    a: List (List (hom X))  ≁  Vec (Vec X _) _
sacty-normalise : SacTy → SacTy
sacty-normalise τ with array-or-base τ
sacty-normalise τ | inj₁ bt  = τ
sacty-normalise τ | inj₂ aud = τ
sacty-normalise τ | inj₂ (akd {hom}) = τ
sacty-normalise τ | inj₂ (akd {nes} {σ} {es} {0}) = -- There is no need to nest a 0-dimensional array
                                               akd hom σ es 0
sacty-normalise τ | inj₂ (akd {nes} {σ} {es} {1}) = -- Nested array of depth 1 of homogeneous elements
                                               -- is the same as homogeneous of dimension 1.
                                               akd hom σ es 1
sacty-normalise τ | inj₂ (akd {nes} {_} {_}) = τ
sacty-normalise τ | inj₂ (aks {hom}) = τ
sacty-normalise τ | inj₂ (aks {nes} {σ} {es} {n} {s}) = aks hom σ es n s

sacty-shape : SacTy → Prog
sacty-shape τ with array-or-base τ
... | inj₁ bt = ok $ "[]"
... | inj₂ (aud {hom} {σ} {s}) = s ⊕ " ++ "  ⊕ sacty-shape σ
... | inj₂ (aud {nes} {σ} {s}) = error $ "sacty-shape: nested-array `" ++ sacty-to-string τ ++ "`"
... | inj₂ (akd {hom} {σ} {s}) = s ⊕ " ++ "  ⊕ sacty-shape σ
... | inj₂ (akd {nes} {σ} {s}) = error $ "sacty-shape: nested-array `" ++ sacty-to-string τ ++ "`"
... | inj₂ (aks {hom} {σ} {s}) = s ⊕ " ++ "  ⊕ sacty-shape σ
... | inj₂ (aks {nes} {σ} {s}) = error $ "sacty-shape: nested-array `" ++ sacty-to-string τ ++ "`"


-- {-# OPTIONS -v tc.mod.apply:80 #-}

module Issue1985 where

module Def where
  postulate A : Set

module Par (X : Set₁) where
  postulate B : Set
  open Def public

-- module Works where
--   module Ren B = Par B
--   module App = Ren Set

module Fails where
  module RenP (X : Set₁) = Par X
  module Ren = Par
  -- Like RenP, Ren should contain
  --   A : (B : Set) → Set
  --   A B = Par.A B
  -- but it incorrectly contained
  --   A : Set
  --   A = Par.A

  A₁ A₂ B₁ B₂ : Set₁ → Set
  A₁ = RenP.A
  A₂ = Ren.A
  B₁ = RenP.B
  B₂ = Ren.B

  module App = Ren Set

  A₃ B₃ : Set
  A₃ = App.A
  B₃ = App.B


module PiFrac.Everything where
open import PiFrac.Syntax     -- Syntax of PiFrac
open import PiFrac.Opsem      -- Abstract machine semantics of PiFrac
open import PiFrac.AuxLemmas  -- Some auxiliary lemmas about opsem for forward/backward deterministic proof
open import PiFrac.NoRepeat   -- Forward/backward deterministic lemmas and Non-repeating lemma
open import PiFrac.Invariants -- Some invariants about abstract machine semantics
open import PiFrac.Eval       -- Evaluator for PiFrac
open import PiFrac.Interp     -- Big-step intepreter for PiFrac using Maybe monad
open import PiFrac.Properties -- Properties of PiFrac
open import PiFrac.Examples   -- Examples
open import PiFrac.Category   -- PiFrac pointed category


module builtinInModule where

module Str where

  postulate S : Set
  {-# BUILTIN STRING S #-}
  primitive primStringAppend : S → S → S


record Unit : Set where
  constructor tt

postulate
  C : Set
  c : C

g : C

f : Unit → C
f tt = c

record R : Set where
  constructor r

g = c


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

-- This module defines D<: normal form, proves its transitivity and shows its
-- equivalence to the original D<:. It turns out that D<: normal form can be used to
-- prove undecidability.
module DsubEquivSimpler where

open import Data.List as List
open import Data.List.All as All
open import Data.Nat as ℕ
open import Data.Maybe as Maybe
open import Data.Product
open import Data.Sum
open import Data.Empty renaming (⊥ to False)
open import Data.Vec as Vec renaming (_∷_ to _‼_ ; [] to nil) hiding (_++_)
open import Function

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

open import Induction.Nat

open import DsubDef
open import Dsub
open import Utils

-- D<: Normal Form
--
-- The following judgment defines D<: normal form as in Figure 4.
infix 4 _⊢″_<:_
data _⊢″_<:_ : Env → Typ → Typ → Set where
  <:⊤  : ∀ {Γ T} → Γ ⊢″ T <: ⊤
  ⊥<:  : ∀ {Γ T} → Γ ⊢″ ⊥ <: T
  refl : ∀ {Γ T} → Γ ⊢″ T <: T
  bnd  : ∀ {Γ S U S′ U′} →
           Γ ⊢″ S′ <: S →
           Γ ⊢″ U <: U′ →
           Γ ⊢″ ⟨A: S ⋯ U ⟩ <: ⟨A: S′ ⋯ U′ ⟩
  Π<:  : ∀ {Γ S U S′ U′} →
           Γ ⊢″ S′ <: S →
           Γ ‣ S′ ! ⊢″ U <: U′ →
           Γ ⊢″ Π S ∙ U <: Π S′ ∙ U′
  sel₁ : ∀ {Γ n T S} →
           env-lookup Γ n ≡ just T →
           Γ ⊢″ T <: ⟨A: S ⋯ ⊤ ⟩ →
           Γ ⊢″ S <: n ∙A
  sel₂ : ∀ {Γ n T U} →
           env-lookup Γ n ≡ just T →
           Γ ⊢″ T <: ⟨A: ⊥ ⋯ U ⟩ →
           Γ ⊢″ n ∙A <: U
  <:>  : ∀ {Γ n T S U} →
           env-lookup Γ n ≡ just T →
           Γ ⊢″ T <: ⟨A: S ⋯ ⊤ ⟩ →
           Γ ⊢″ T <: ⟨A: ⊥ ⋯ U ⟩ →
           Γ ⊢″ S <: U

-- First we show that D<: normal form admits weakening.
<:″-weakening-gen : ∀ {Γ S U} →
                      Γ ⊢″ S <: U →
                    ∀ Γ₁ Γ₂ T →
                      Γ ≡ Γ₁ ‣ Γ₂ →
                      Γ₁ ‣ T ! ‣ Γ₂ ⇑ ⊢″ S ↑ length Γ₂ <: U ↑ length Γ₂
<:″-weakening-gen <:⊤ Γ₁ Γ₂ T eqΓ               = <:⊤
<:″-weakening-gen ⊥<: Γ₁ Γ₂ T eqΓ               = ⊥<:
<:″-weakening-gen refl Γ₁ Γ₂ T eqΓ              = refl
<:″-weakening-gen (bnd S′<:S U<:U′) Γ₁ Γ₂ T eqΓ = bnd (<:″-weakening-gen S′<:S Γ₁ Γ₂ T eqΓ)
                                                      (<:″-weakening-gen U<:U′ Γ₁ Γ₂ T eqΓ)
<:″-weakening-gen (Π<: S′<:S U<:U′) Γ₁ Γ₂ T eqΓ = Π<: (<:″-weakening-gen S′<:S Γ₁ Γ₂ T eqΓ)
                                                      (<:″-weakening-gen U<:U′ Γ₁ (_ ∷ Γ₂) T (cong (_ ∷_) eqΓ))
<:″-weakening-gen (sel₁ {_} {n} T∈Γ T<:B) Γ₁ Γ₂ T eqΓ
  rewrite ↑-var n (length Γ₂)                   = sel₁ (↦∈-weaken′ T∈Γ Γ₁ Γ₂ T eqΓ)
                                                       (<:″-weakening-gen T<:B Γ₁ Γ₂ T eqΓ)
<:″-weakening-gen (sel₂ {_} {n} T∈Γ T<:B) Γ₁ Γ₂ T eqΓ
  rewrite ↑-var n (length Γ₂)                   = sel₂ (↦∈-weaken′ T∈Γ Γ₁ Γ₂ T eqΓ)
                                                       (<:″-weakening-gen T<:B Γ₁ Γ₂ T eqΓ)
<:″-weakening-gen (<:> {_} {n} T∈Γ T<:B T<:B′) Γ₁ Γ₂ T eqΓ
  rewrite ↑-var n (length Γ₂)                   = <:> (↦∈-weaken′ T∈Γ Γ₁ Γ₂ T eqΓ)
                                                      (<:″-weakening-gen T<:B Γ₁ Γ₂ T eqΓ)
                                                      (<:″-weakening-gen T<:B′ Γ₁ Γ₂ T eqΓ)

<:″-weakening : ∀ {Γ₁ Γ₂ S U} T →
                  Γ₁ ‣ Γ₂ ⊢″ S <: U →
                  Γ₁ ‣ T ! ‣ Γ₂ ⇑ ⊢″ S ↑ length Γ₂ <: U ↑ length Γ₂
<:″-weakening T S<:U = <:″-weakening-gen S<:U _ _ T refl

<:″-weakening-hd : ∀ {Γ S U} T →
                     Γ ⊢″ S <: U →
                     Γ ‣ T ! ⊢″ S ↑ 0 <: U ↑ 0
<:″-weakening-hd T = <:″-weakening {Γ₂ = []} T

-- Then we work on transitivity.
module SimplerTransitivity where
  -- This predicate asserts that the first context replaces _one_ type in the second
  -- context with its subtype. That is, the first context is more "precise" than the
  -- second context.
  infix 4 _≺:[_]_
  data _≺:[_]_ : Env → ℕ → Env → Set where
    ≺[_,_] : ∀ {Γ U} S → Γ ⊢″ S <: U → Γ ‣ S ! ≺:[ 0 ] Γ ‣ U !
    _∷_    : ∀ {Γ₁ n Γ₂} T → Γ₁ ≺:[ n ] Γ₂ → Γ₁ ‣ T ! ≺:[ suc n ] Γ₂ ‣ T !

  <:∈-find : ∀ {x T Γ Γ′ n} →
               x ↦ T ∈ Γ →
               Γ′ ≺:[ n ] Γ →
               x ≡ n × (∃ λ T′ → n ↦ T′ ∈ Γ′ × Γ′ ⊢″ T′ <: T) ⊎ x ≢ n × x ↦ T ∈ Γ′
  <:∈-find hd ≺[ T′ , T′<:T ]           = inj₁ (refl , T′ ↑ 0 , hd , <:″-weakening-hd T′ T′<:T)
  <:∈-find hd (T ∷ Γ′≺:Γ)               = inj₂ ((λ ()) , hd)
  <:∈-find (tl T∈Γ) ≺[ T′ , T′<:T ]     = inj₂ ((λ ()) , tl T∈Γ)
  <:∈-find (tl T∈Γ) (S ∷ Γ′≺:Γ) with <:∈-find T∈Γ Γ′≺:Γ
  ... | inj₁ (x≡n , T′ , T′∈Γ′ , T′<:T) = inj₁ (cong suc x≡n , T′ ↑ 0 , tl T′∈Γ′ , <:″-weakening-hd S T′<:T)
  ... | inj₂ (x≢n , T∈Γ′)               = inj₂ (x≢n ∘ suc-injective , tl T∈Γ′)

  <:∈-find′ : ∀ {x T Γ Γ′ n} →
                env-lookup Γ x ≡ just T →
                Γ′ ≺:[ n ] Γ →
                x ≡ n × (∃ λ T′ → env-lookup Γ′ n ≡ just T′ × Γ′ ⊢″ T′ <: T) ⊎ x ≢ n × env-lookup Γ′ x ≡ just T
  <:∈-find′ T∈Γ Γ′≺Γ with <:∈-find (lookup⇒↦∈ T∈Γ) Γ′≺Γ
  ... | inj₁ (x≡n , T′ , T′∈Γ′ , T′<:T) = inj₁ (x≡n , T′ , ↦∈⇒lookup T′∈Γ′ , T′<:T)
  ... | inj₂ (x≢n , T∈Γ′)               = inj₂ (x≢n , ↦∈⇒lookup T∈Γ′)

  private
    trans-on : Typ → Set
    trans-on T = ∀ {Γ S U} → Γ ⊢″ S <: T → Γ ⊢″ T <: U → Γ ⊢″ S <: U

    narrow-on : Typ → Set
    narrow-on T = ∀ {Γ Γ′ n S U} →
                    Γ ⊢″ S <: U →
                    Γ′ ≺:[ n ] Γ →
                    env-lookup Γ n ≡ just T →
                    Γ′ ⊢″ S <: U

  -- Per Definition 11, this defines type declaration hierarchy.
  ⟨A:⟩-layer : Typ → List Typ → Typ
  ⟨A:⟩-layer T []      = T
  ⟨A:⟩-layer T (S ∷ l) = ⟨A: S ⋯ ⟨A:⟩-layer T l ⟩

  -- Now we start proving transitivity and narrowing via a mutual induction.  This
  -- mutual induction begins exactly as presented in the paper: an induction of
  -- lexicographical order of the triple (T, 𝒟₁, 𝒟₂). Notice that this is
  -- automatically handled by Agda's termination checker, which makes the problem very
  -- nice to work with.
  --
  -- If one loads this file from Emacs, one shall see that some cases below are
  -- highlighted. The reason is that those cases are not defined
  -- _definitionally_. More details can be found in:
  -- https://agda.readthedocs.io/en/v2.5.4.2/language/function-definitions.html#case-trees.
  --
  -- In fact, those non-definitional cases hides many cases away, as they expand to
  -- numerous definitional cases, which is necessarily the case in Coq. The fact that
  -- Agda's termination checking is permissive and Agda allows non-definitional cases
  -- has significantly improved productivity of showing transitivity. In Coq, this
  -- would have required significant amount of technical setup which can easily wipe
  -- away the main idea of the proof and might not be finished within a reasonable
  -- time interval.
  mutual
    <:′-trans-rec : ∀ T → (∀ T′ → Typ-measure T′ < Typ-measure T → trans-on T′ × narrow-on T′) → trans-on T
    <:′-trans-rec (n ∙A) rec (sel₁ T∈Γ T<:B) (sel₂ T′∈Γ T<:B′)
      with ≡.trans (≡.sym T∈Γ) T′∈Γ
    ... | refl                                                           = <:> T′∈Γ T<:B T<:B′
    <:′-trans-rec ⟨A: S′ ⋯ U′ ⟩ rec (bnd S′<:S U<:U′) (bnd S″<:S U′<:U″) = bnd (<:′-trans-rec S′ (λ T′ T′<S′ → rec T′ (≤-step (≤-stepsʳ _ T′<S′))) S″<:S S′<:S)
                                                                               (<:′-trans-rec U′ (λ T′ T′<U′ → rec T′ (≤-step (≤-stepsˡ _ T′<U′))) U<:U′ U′<:U″)

    <:′-trans-rec (Π S′ ∙ U′) rec (Π<: S′<:S″ U″<:U′) (Π<: S‴<:S′ U′<:U‴)
      = Π<: (<:′-trans-rec S′ (λ T′ T′<S′ → rec T′ (≤-step (≤-stepsʳ _ T′<S′))) S‴<:S′ S′<:S″)
            (<:′-trans-rec U′ (λ T′ T′<U′ → rec T′ (≤-step (≤-stepsˡ _ T′<U′)))
                           (proj₂ (rec (S′ ↑ 0) (s≤s $ ≤-stepsʳ _ $ ≤-reflexive (Typ-measure-↑ S′ 0)))
                                  U″<:U′
                                  ≺[ _ , S‴<:S′ ]
                                  refl)
                           U′<:U‴)

    <:′-trans-rec T rec ⊥<: T<:U                     = ⊥<:
    <:′-trans-rec T rec refl T<:U                    = T<:U
    <:′-trans-rec T rec S<:T <:⊤                     = <:⊤
    <:′-trans-rec T rec S<:T refl                    = S<:T
    <:′-trans-rec T rec (sel₂ T′∈Γ T′<:B) T<:U       = sel₂ T′∈Γ (⟨A<:⟩-traverseʳ T rec T<:U T′<:B _ refl)
    <:′-trans-rec T rec (<:> T′∈Γ T′<:B T′<:B′) T<:U = <:> T′∈Γ T′<:B (⟨A<:⟩-traverseʳ T rec T<:U T′<:B′ _ refl)
    <:′-trans-rec T rec S<:T (sel₁ T′∈Γ T′<:B)       = sel₁ T′∈Γ (⟨A<:⟩-traverseˡ T rec S<:T T′<:B [] refl)
    <:′-trans-rec T rec S<:T (<:> T′∈Γ T′<:B T′<:B′) = <:> T′∈Γ (⟨A<:⟩-traverseˡ T rec S<:T T′<:B [] refl) T′<:B′

    ⟨A<:⟩-traverseʳ : ∀ T →
                        (∀ T′ → Typ-measure T′ < Typ-measure T → trans-on T′ × narrow-on T′) →
                      ∀ {Γ U} →
                        Γ ⊢″ T <: U →
                      ∀ {S S′ T′} →
                        Γ ⊢″ S <: ⟨A: S′ ⋯ T′ ⟩ →
                      ∀ l →
                        T′ ≡ ⟨A:⟩-layer T l →
                        Γ ⊢″ S <: ⟨A: S′ ⋯ ⟨A:⟩-layer U l ⟩
    ⟨A<:⟩-traverseʳ T rec T<:U ⊥<: l eqT′                        = ⊥<:
    ⟨A<:⟩-traverseʳ T rec T<:U refl [] refl                      = bnd refl T<:U
    ⟨A<:⟩-traverseʳ T rec T<:U refl (S′ ∷ l) refl                = bnd refl (⟨A<:⟩-traverseʳ T rec T<:U refl l refl)
    ⟨A<:⟩-traverseʳ T rec T<:U (bnd S₂<:S₁ U₁<:T) [] refl        = bnd S₂<:S₁ (<:′-trans-rec T rec U₁<:T T<:U)
    ⟨A<:⟩-traverseʳ T rec T<:U (bnd S₂<:S₁ U₁<:U₂) (S′ ∷ l) refl = bnd S₂<:S₁ (⟨A<:⟩-traverseʳ T rec T<:U U₁<:U₂ l refl)
    ⟨A<:⟩-traverseʳ T rec T<:U (sel₂ T′∈Γ T′<:B) l refl          = sel₂ T′∈Γ (⟨A<:⟩-traverseʳ T rec T<:U T′<:B (_ ∷ l) refl)
    ⟨A<:⟩-traverseʳ T rec T<:U (<:> T′∈Γ T′<:B T′<:B′) l refl    = <:> T′∈Γ T′<:B (⟨A<:⟩-traverseʳ T rec T<:U T′<:B′ (_ ∷ l) refl)

    ⟨A<:⟩-traverseˡ : ∀ T →
                        (∀ T′ → Typ-measure T′ < Typ-measure T → trans-on T′ × narrow-on T′) →
                      ∀ {Γ S} →
                        Γ ⊢″ S <: T →
                      ∀ {S′ T′} →
                        Γ ⊢″ S′ <: T′ →
                      ∀ {U} l →
                        T′ ≡ ⟨A:⟩-layer ⟨A: T ⋯ U ⟩ l →
                        Γ ⊢″ S′ <: ⟨A:⟩-layer ⟨A: S ⋯ U ⟩ l
    ⟨A<:⟩-traverseˡ T rec S<:T <:⊤ [] ()
    ⟨A<:⟩-traverseˡ T rec S<:T <:⊤ (_ ∷ l) ()
    ⟨A<:⟩-traverseˡ T rec S<:T ⊥<: l eqT′                        = ⊥<:
    ⟨A<:⟩-traverseˡ T rec S<:T refl [] refl                      = bnd S<:T refl
    ⟨A<:⟩-traverseˡ T rec S<:T refl (S′ ∷ l) refl                = bnd refl (⟨A<:⟩-traverseˡ T rec S<:T refl l refl)
    ⟨A<:⟩-traverseˡ T rec S<:T (bnd T<:S₁ U₁<:U₂) [] refl        = bnd (<:′-trans-rec T rec S<:T T<:S₁) U₁<:U₂
    ⟨A<:⟩-traverseˡ T rec S<:T (bnd S₂<:S₁ U₁<:U₂) (S′ ∷ l) refl = bnd S₂<:S₁ (⟨A<:⟩-traverseˡ T rec S<:T U₁<:U₂ l refl)
    ⟨A<:⟩-traverseˡ T rec S<:T (Π<: S₂<:S₁ U₁<:U₂) [] ()
    ⟨A<:⟩-traverseˡ T rec S<:T (Π<: S₂<:S₁ U₁<:U₂) (_ ∷ l) ()
    ⟨A<:⟩-traverseˡ T rec S<:T (sel₁ T′∈Γ T′<:B) [] ()
    ⟨A<:⟩-traverseˡ T rec S<:T (sel₁ T′∈Γ T′<:B) (_ ∷ l) ()
    ⟨A<:⟩-traverseˡ T rec S<:T (sel₂ T′∈Γ T′<:B) {U} l refl      = sel₂ T′∈Γ (⟨A<:⟩-traverseˡ T rec S<:T T′<:B {U} (_ ∷ l) refl)
    ⟨A<:⟩-traverseˡ T rec S<:T (<:> T′∈Γ T′<:B T′<:B′) l refl    = <:> T′∈Γ T′<:B (⟨A<:⟩-traverseˡ T rec S<:T T′<:B′ (_ ∷ l) refl)

  <:″-narrow-on : ∀ T → (∀ T′ → Typ-measure T′ ≡ Typ-measure T → trans-on T′) → narrow-on T
  <:″-narrow-on T trans <:⊤ Γ′≺Γ T∈Γ               = <:⊤
  <:″-narrow-on T trans ⊥<: Γ′≺Γ T∈Γ               = ⊥<:
  <:″-narrow-on T trans refl Γ′≺Γ T∈Γ              = refl
  <:″-narrow-on T trans (bnd S′<:S U<:U′) Γ′≺Γ T∈Γ = bnd (<:″-narrow-on T trans S′<:S Γ′≺Γ T∈Γ)
                                                         (<:″-narrow-on T trans U<:U′ Γ′≺Γ T∈Γ)
  <:″-narrow-on T trans {Γ} {Γ′} {n} (Π<: {S′ = S′} S′<:S U<:U′) Γ′≺Γ T∈Γ
    = Π<: (<:″-narrow-on T trans S′<:S Γ′≺Γ T∈Γ)
          (<:″-narrow-on (T ↑ 0)
                         (λ T′ eq → trans T′ (≡.trans eq (Typ-measure-↑ T 0)))
                         U<:U′ (_ ∷ Γ′≺Γ)
                         (↦∈⇒lookup (tl {n} {T′ = S′} {Γ} (lookup⇒↦∈ T∈Γ))))

  <:″-narrow-on T trans (sel₁ T′∈Γ T′<:B) Γ′≺Γ T∈Γ
    with <:∈-find′ T′∈Γ Γ′≺Γ
  ...  | inj₁ (refl , T″ , T″∈Γ′ , T″<:T)
    rewrite just-injective (≡.trans (≡.sym T′∈Γ) T∈Γ) = sel₁ T″∈Γ′ (trans T refl T″<:T (<:″-narrow-on T trans T′<:B Γ′≺Γ T∈Γ))
  ... | inj₂ (x≢n , T′∈Γ′)                            = sel₁ T′∈Γ′ (<:″-narrow-on T trans T′<:B Γ′≺Γ T∈Γ)
  <:″-narrow-on T trans (sel₂ T′∈Γ T′<:B) Γ′≺Γ T∈Γ
    with <:∈-find′ T′∈Γ Γ′≺Γ
  ...  | inj₁ (refl , T″ , T″∈Γ′ , T″<:T)
    rewrite just-injective (≡.trans (≡.sym T′∈Γ) T∈Γ) = sel₂ T″∈Γ′ (trans T refl T″<:T (<:″-narrow-on T trans T′<:B Γ′≺Γ T∈Γ))
  ... | inj₂ (x≢n , T′∈Γ′)                            = sel₂ T′∈Γ′ (<:″-narrow-on T trans T′<:B Γ′≺Γ T∈Γ)
  <:″-narrow-on T trans (<:> T′∈Γ T′<:B T′<:B′) Γ′≺Γ T∈Γ
    with <:∈-find′ T′∈Γ Γ′≺Γ
  ...  | inj₁ (refl , T″ , T″∈Γ′ , T″<:T)
    rewrite just-injective (≡.trans (≡.sym T′∈Γ) T∈Γ) = <:> T″∈Γ′
                                                            (trans T refl T″<:T (<:″-narrow-on T trans T′<:B Γ′≺Γ T∈Γ))
                                                            (trans T refl T″<:T (<:″-narrow-on T trans T′<:B′ Γ′≺Γ T∈Γ))
  ... | inj₂ (x≢n , T′∈Γ′)                            = <:> T′∈Γ′
                                                            (<:″-narrow-on T trans T′<:B Γ′≺Γ T∈Γ)
                                                            (<:″-narrow-on T trans T′<:B′ Γ′≺Γ T∈Γ)

  -- The previous functions achieve the inductive hypotheses of the well-founded
  -- induction on the size of the type T, and the following function combines those
  -- inductive hypotheses and conclude transitivity and narrowing.
  <:″-trans-narrow : ∀ T → trans-on T × narrow-on T
  <:″-trans-narrow = wfRec _ aux
    where open Measure <-wellFounded Typ-measure
          aux : ∀ T → (∀ T′ → Typ-measure T′ < Typ-measure T → trans-on T′ × narrow-on T′) → trans-on T × narrow-on T
          aux T rec = <:′-trans-rec T rec
                    , <:″-narrow-on T (λ T′ T′≡T →
                                         <:′-trans-rec T′ λ T″ T″<T′ → rec T″ (≤-trans T″<T′ (≤-reflexive T′≡T)))

  <:″-trans : ∀ {T} → trans-on T
  <:″-trans {T} = proj₁ (<:″-trans-narrow T)

  <:″-narrow : ∀ {T} → narrow-on T
  <:″-narrow {T} = proj₂ (<:″-trans-narrow T)

open SimplerTransitivity using (<:″-trans ; <:″-narrow) public

-- the following two functions show that the original D<: and D<: normal form are
-- equivalent.
<:⇒<:″ : ∀ {Γ S U} → Γ ⊢ S <: U → Γ ⊢″ S <: U
<:⇒<:″ dtop                 = <:⊤
<:⇒<:″ dbot                 = ⊥<:
<:⇒<:″ drefl                = refl
<:⇒<:″ (dtrans T S<:T T<:U) = <:″-trans (<:⇒<:″ S<:T) (<:⇒<:″ T<:U)
<:⇒<:″ (dbnd S′<:S U<:U′)   = bnd (<:⇒<:″ S′<:S) (<:⇒<:″ U<:U′)
<:⇒<:″ (dall S′<:S U<:U′)   = Π<: (<:⇒<:″ S′<:S) (<:⇒<:″ U<:U′)
<:⇒<:″ (dsel₁ T∈Γ T<:B)     = sel₁ T∈Γ (<:⇒<:″ T<:B)
<:⇒<:″ (dsel₂ T∈Γ T<:B)     = sel₂ T∈Γ (<:⇒<:″ T<:B)

<:″⇒<: : ∀ {Γ S U} → Γ ⊢″ S <: U → Γ ⊢ S <: U
<:″⇒<: <:⊤                  = dtop
<:″⇒<: ⊥<:                  = dbot
<:″⇒<: refl                 = drefl
<:″⇒<: (bnd S′<:S U<:U′)    = dbnd (<:″⇒<: S′<:S) (<:″⇒<: U<:U′)
<:″⇒<: (Π<: S′<:S U<:U′)    = dall (<:″⇒<: S′<:S) (<:″⇒<: U<:U′)
<:″⇒<: (sel₁ T∈Γ T<:B)      = dsel₁ T∈Γ (<:″⇒<: T<:B)
<:″⇒<: (sel₂ T∈Γ T<:B)      = dsel₂ T∈Γ (<:″⇒<: T<:B)
<:″⇒<: (<:> T∈Γ T<:B S<:B′) = dtrans _ (dsel₁ T∈Γ (dtrans _ (<:″⇒<: T<:B) (dbnd drefl dtop)))
                                       (dsel₂ T∈Γ (dtrans _ (<:″⇒<: S<:B′) (dbnd dbot drefl)))
-- D<: subtyping is undecidable.
module Undecidability′ where
  open import DsubReduced
  open FsubMinusToDsubR using (⟦_⟧ ; ⟪_⟫ ; D<:ᵣ⇒F<: ; F<:⇒D<:ᵣ ; ⟪⟫-contraEnv ; ⟦⟧-covar)
  open DsubInvProperties contraInvertible
  open import FsubMinus

  <:″⇒<:ᵣ : ∀ {Γ S U} →
              Γ ⊢″ S <: U →
              ContraEnv Γ → Covar S → Covar U →
              Γ ⊢ᵣ S <: U
  <:″⇒<:ᵣ <:⊤ cΓ cS cU                                           = drtop cS
  <:″⇒<:ᵣ ⊥<: cΓ () cU
  <:″⇒<:ᵣ refl cΓ cS cU                                          = drrefl cU
  <:″⇒<:ᵣ (bnd S′<:S U<:U′) cΓ cS ()
  <:″⇒<:ᵣ (Π<: <:⊤ U<:U′) cΓ () cU
  <:″⇒<:ᵣ (Π<: ⊥<: U<:U′) cΓ cS ()
  <:″⇒<:ᵣ (Π<: refl U<:U′) cΓ (cvΠ cS cU) (cvΠ cS′ cU′)          = drall cS′ cU cS′ cU′
                                                                         (drrefl cS′)
                                                                         (<:″⇒<:ᵣ U<:U′ (ctt cS′ ∷ cΓ) cU cU′)
  <:″⇒<:ᵣ (Π<: (bnd _ S′<:S) U<:U′) cΓ (cvΠ cS cU) (cvΠ cS′ cU′) = drall cS cU cS′ cU′
                                                                         (<:″⇒<:ᵣ S′<:S cΓ cS′ cS)
                                                                         (<:″⇒<:ᵣ U<:U′ (ctt cS′ ∷ cΓ) cU cU′)
  <:″⇒<:ᵣ (Π<: (Π<: S′<:S S′<:S₁) U<:U′) cΓ () cU
  <:″⇒<:ᵣ (Π<: (sel₁ x S′<:S) U<:U′) cΓ () cU
  <:″⇒<:ᵣ (Π<: (sel₂ x S′<:S) U<:U′) cΓ cS ()
  <:″⇒<:ᵣ (Π<: (<:> T∈Γ T<:B T<:B′) U<:U′) cΓ (cvΠ _ _) (cvΠ _ _)
    with lookupContraEnv T∈Γ cΓ
  ... | ctt _                                                    = case ⟨A:⟩<:⟨A:⟩′ (<:″⇒<: T<:B) cΓ of λ ()
  <:″⇒<:ᵣ (sel₁ T∈Γ T<:B) cΓ cS cU
    with lookupContraEnv T∈Γ cΓ
  ... | ctt _  rewrite ⟨A:⟩<:⟨A:⟩′ (<:″⇒<: T<:B) cΓ              = case cS of λ ()
  <:″⇒<:ᵣ (sel₂ T∈Γ T<:B) cΓ cS cU
    with lookupContraEnv T∈Γ cΓ
  ... | ctt cT                                                   = drsel T∈Γ cT (aux T<:B cΓ cT cU)
    where aux : ∀ {Γ T S U} → Γ ⊢″ ⟨A: ⊥ ⋯ T ⟩ <: ⟨A: S ⋯ U ⟩ → ContraEnv Γ → Covar T → Covar U → Γ ⊢ᵣ T <: U
          aux refl cΓ cT cU                                      = drrefl cU
          aux (bnd _ T<:U) cΓ cT cU                              = <:″⇒<:ᵣ T<:U cΓ cT cU
          aux (<:> T′∈Γ T′<:B _) cΓ cT cU
            with lookupContraEnv T′∈Γ cΓ
          ... | ctt _                                            = case ⟨A:⟩<:⟨A:⟩′ (<:″⇒<: T′<:B) cΓ of λ ()
  <:″⇒<:ᵣ (<:> T∈Γ T<:B T<:B′) cΓ cS cU
    with lookupContraEnv T∈Γ cΓ
  ... | ctt _  rewrite ⟨A:⟩<:⟨A:⟩′ (<:″⇒<: T<:B) cΓ              = case cS of λ ()

  <:ᵣ⇒<: : ∀ {Γ S U} → Γ ⊢ᵣ S <: U → Γ ⊢ S <: U
  <:ᵣ⇒<: (drtop _)                   = dtop
  <:ᵣ⇒<: (drrefl _)                  = drefl
  <:ᵣ⇒<: (drall _ _ _ _ S′<:S U<:U′) = dall (dbnd dbot (<:ᵣ⇒<: S′<:S)) (<:ᵣ⇒<: U<:U′)
  <:ᵣ⇒<: (drsel T∈Γ _ T<:B)          = dtrans _ (dsel₂ T∈Γ drefl) (<:ᵣ⇒<: T<:B)

  open FsubMinus.FsubMinus

  F<:⇒D<: : ∀ {Γ S U} → Γ ⊢F S <: U → ⟪ Γ ⟫ ⊢ ⟦ S ⟧ <: ⟦ U ⟧
  F<:⇒D<: = <:ᵣ⇒<: ∘ F<:⇒D<:ᵣ

  D<:⇒F<: : ∀ {Γ S U} → ⟪ Γ ⟫ ⊢ ⟦ S ⟧ <: ⟦ U ⟧ → Γ ⊢F S <: U
  D<:⇒F<: S<:U = D<:ᵣ⇒F<: (<:″⇒<:ᵣ (<:⇒<:″ S<:U) (⟪⟫-contraEnv _) (⟦⟧-covar _) (⟦⟧-covar _))
                          refl refl refl


open import Level
import Categories.Category
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; subst; cong)

open import Syntax
open import Renaming
open import Substitution
open import Instantiation

module SyntaxMap where

  open Signature
  open Expression
  open Equality

  infix 5 _→ᵐ_

  -- syntax map

  _→ᵐ_ : Signature → Signature → Set
  𝕊 →ᵐ 𝕋 = ∀ {cl} (S : symb 𝕊 cl) → Expr 𝕋 (obj cl) (symb-arg 𝕊 S) 𝟘

  -- equality of syntax maps

  infix 4 _≈ᵐ_

  _≈ᵐ_ : ∀ {𝕊 𝕋} (f g : 𝕊 →ᵐ 𝕋) → Set
  _≈ᵐ_ {𝕊 = 𝕊} {𝕋 = 𝕋} f g =
    ∀ {cl} (S : symb 𝕊 cl) → f S ≈ g S

  -- equality is an equivalence relation

  ≈ᵐ-refl : ∀ {𝕊 𝕋} {f : 𝕊 →ᵐ 𝕋} → f ≈ᵐ f
  ≈ᵐ-refl {𝕋 = 𝕋} S = ≈-refl

  ≈ᵐ-sym : ∀ {𝕊 𝕋} {f g : 𝕊 →ᵐ 𝕋} → f ≈ᵐ g → g ≈ᵐ f
  ≈ᵐ-sym {𝕋 = 𝕋} ξ S = ≈-sym (ξ S)

  ≈ᵐ-trans : ∀ {𝕊 𝕋} {f g h : 𝕊 →ᵐ 𝕋} → f ≈ᵐ g → g ≈ᵐ h → f ≈ᵐ h
  ≈ᵐ-trans {𝕋 = 𝕋} ζ ξ S = ≈-trans (ζ S) (ξ S)

  -- The identity raw syntax map

  𝟙ᵐ : ∀ {𝕊} → (𝕊 →ᵐ 𝕊)
  𝟙ᵐ {𝕊} S = expr-symb S (expr-meta-generic 𝕊)

  -- Action of a raw syntax map

  infixr 10 [_]ᵐ_

  [_]ᵐ_ : ∀ {𝕊 𝕋} → (𝕊 →ᵐ 𝕋) → ∀ {cl 𝕄 γ} → Expr 𝕊 𝕄 cl γ → Expr 𝕋 𝕄 cl γ
  [ f ]ᵐ (expr-var x) = expr-var x
  [_]ᵐ_ {𝕋 = 𝕋} f {𝕄 = 𝕄} (expr-symb S es) =
    [ (λ M → [ f ]ᵐ es M) ]ⁱ ([ 𝟘-initial ]ʳ f S)
  [ f ]ᵐ (expr-meta M ts) = expr-meta M (λ i → [ f ]ᵐ (ts i))
  [ f ]ᵐ expr-eqty = expr-eqty
  [ f ]ᵐ expr-eqtm = expr-eqtm

  -- Action preserves equality

  []ᵐ-resp-≈ : ∀ {𝕊 𝕋} {cl 𝕄 γ} (f : 𝕊 →ᵐ 𝕋) {t u : Expr 𝕊 𝕄 cl γ} →
               t ≈ u → [ f ]ᵐ t ≈ [ f ]ᵐ u
  []ᵐ-resp-≈ f (≈-≡ ξ) = ≈-≡ (cong ([ f ]ᵐ_) ξ)
  []ᵐ-resp-≈ {𝕋 = 𝕋} f (≈-symb {S = S} ξ) =
    []ⁱ-resp-≈ⁱ ([ 𝟘-initial ]ʳ f S) λ M → []ᵐ-resp-≈ f (ξ M)
  []ᵐ-resp-≈ f (≈-meta ξ) = ≈-meta (λ i → []ᵐ-resp-≈ f (ξ i))

  []ᵐ-resp-≈ᵐ : ∀ {𝕊 𝕋} {cl 𝕄 γ} {f g : 𝕊 →ᵐ 𝕋} (t : Expr 𝕊 𝕄 cl γ) →
               f ≈ᵐ g → [ f ]ᵐ t ≈ [ g ]ᵐ t
  []ᵐ-resp-≈ᵐ (expr-var x) ξ = ≈-refl
  []ᵐ-resp-≈ᵐ {f = f} {g = g} (expr-symb S es) ξ =
     []ⁱ-resp-≈ⁱ-≈ {I = λ M → [ f ]ᵐ es M} {J = λ M → [ g ]ᵐ es M}
       (λ M → []ᵐ-resp-≈ᵐ (es M) ξ)
       ([]ʳ-resp-≈ 𝟘-initial (ξ S))
  []ᵐ-resp-≈ᵐ (expr-meta M ts) ξ = ≈-meta (λ i → []ᵐ-resp-≈ᵐ (ts i) ξ)
  []ᵐ-resp-≈ᵐ expr-eqty ξ = ≈-eqty
  []ᵐ-resp-≈ᵐ expr-eqtm ξ = ≈-eqtm

  []ᵐ-resp-≈ᵐ-≈ : ∀ {𝕊 𝕋} {cl 𝕄 γ} {f g : 𝕊 →ᵐ 𝕋} {t u : Expr 𝕊 𝕄 cl γ} →
                  f ≈ᵐ g → t ≈ u → [ f ]ᵐ t ≈ [ g ]ᵐ u
  []ᵐ-resp-≈ᵐ-≈ {g = g} {t = t} ζ ξ = ≈-trans ([]ᵐ-resp-≈ᵐ t ζ) ([]ᵐ-resp-≈ g ξ)

  -- Composition of raw syntax maps

  infixl 7 _∘ᵐ_

  _∘ᵐ_ : ∀ {𝕊 𝕋 𝕌} → (𝕋 →ᵐ 𝕌) → (𝕊 →ᵐ 𝕋) → (𝕊 →ᵐ 𝕌)
  (g ∘ᵐ f) S =  [ g ]ᵐ (f S)

  -- Action preserves identity
  module _ {𝕊} where
    open Equality
    open Renaming
    open Substitution

    [𝟙ᵐ] : ∀ {cl 𝕄 γ} (t : Expr 𝕊 cl 𝕄 γ) → [ 𝟙ᵐ ]ᵐ t ≈ t
    [𝟙ᵐ] (expr-var x) = ≈-refl
    [𝟙ᵐ] (expr-symb S es) =
      ≈-symb (λ {cⁱ γⁱ} i → [𝟙ᵐ]-arg cⁱ γⁱ i)
        where [𝟙ᵐ]-arg : ∀ cⁱ γⁱ (i : [ cⁱ , γⁱ ]∈ symb-arg 𝕊 S) → _
              [𝟙ᵐ]-arg (obj x) γⁱ i =
                ≈-trans
                  ([]ˢ-resp-≈ _ ([]ʳ-resp-≈ _ ([𝟙ᵐ] (es i))))
                  (≈-trans (≈-sym ([ˢ∘ʳ] (es i))) ([]ˢ-id (λ { (var-left _) → ≈-refl ; (var-right _) → ≈-refl })))
              [𝟙ᵐ]-arg EqTy γⁱ i = ≈-eqty
              [𝟙ᵐ]-arg EqTm γⁱ i = ≈-eqtm
    [𝟙ᵐ] (expr-meta M ts) = ≈-meta λ i → [𝟙ᵐ] (ts i)
    [𝟙ᵐ] expr-eqty = ≈-eqty
    [𝟙ᵐ] expr-eqtm = ≈-eqtm

  -- interaction of maps with instantiation and substitution
  module _ {𝕊 𝕋} where
    open Substitution

    infixl 7 _ᵐ∘ˢ_
    _ᵐ∘ˢ_ : ∀ {𝕊 𝕋} {𝕄 γ δ} (f : 𝕊 →ᵐ 𝕋) (σ : 𝕊 % 𝕄 ∥ γ →ˢ δ) → (𝕋 % 𝕄 ∥ γ →ˢ δ)
    (f ᵐ∘ˢ σ) x = [ f ]ᵐ σ x

    []ᵐ-[]ʳ : ∀ {f : 𝕊 →ᵐ 𝕋} {cl 𝕄 γ δ} {ρ : γ →ʳ δ} (t : Expr 𝕊 cl 𝕄 γ) →
              ([ f ]ᵐ ([ ρ ]ʳ t)) ≈ ([ ρ ]ʳ [ f ]ᵐ t)
    []ᵐ-[]ʳ (expr-var x) = ≈-refl
    []ᵐ-[]ʳ {f = f} {ρ = ρ} (expr-symb S es) =
      ≈-trans
        ([]ⁱ-resp-≈ⁱ ([ 𝟘-initial ]ʳ f S) λ M → []ᵐ-[]ʳ (es M))
        (≈-trans
           ([]ⁱ-resp-≈ⁱ-≈
              {t = [ 𝟘-initial ]ʳ f S}
              {u = [ ρ ]ʳ ([ 𝟘-initial ]ʳ f S)}
              (λ M → ≈-refl)
              (≈-trans ([]ʳ-resp-≡ʳ (f S) (λ {()})) ([∘ʳ] (f S))))
           (≈-sym ([ʳ∘ⁱ] ([ 𝟘-initial ]ʳ f S))))
    []ᵐ-[]ʳ (expr-meta M ts) = ≈-meta (λ i → []ᵐ-[]ʳ (ts i))
    []ᵐ-[]ʳ expr-eqty = ≈-eqty
    []ᵐ-[]ʳ expr-eqtm = ≈-eqtm

    []ᵐ-[]ˢ : ∀ {cl 𝕄 γ δ} {f : 𝕊 →ᵐ 𝕋} {σ : 𝕊 % 𝕄 ∥ γ →ˢ δ} (t : Expr 𝕊 cl 𝕄 γ) →
              [ f ]ᵐ ([ σ ]ˢ t) ≈ [ f ᵐ∘ˢ σ ]ˢ [ f ]ᵐ t
    []ᵐ-[]ˢ (expr-var x) = ≈-refl
    []ᵐ-[]ˢ {f = f} {σ = σ} (expr-symb S es) =
      ≈-trans
        ([]ⁱ-resp-≈ⁱ ([ 𝟘-initial ]ʳ f S) (λ M → []ᵐ-[]ˢ (es M)))
        (≈-trans
           ([]ⁱ-resp-≈ⁱ
              ([ 𝟘-initial ]ʳ f S)
              (λ M → []ˢ-resp-≈ˢ
                       (λ { (var-left x) → []ᵐ-[]ʳ (σ x)
                          ; (var-right _) → ≈-refl})
                       ([ f ]ᵐ es M)))
           (≈-sym ([]ˢ-[]ⁱ {ρ = 𝟘-initial} (f S) λ {()})))
    []ᵐ-[]ˢ (expr-meta M ts) = ≈-meta (λ i → []ᵐ-[]ˢ (ts i))
    []ᵐ-[]ˢ expr-eqty = ≈-eqty
    []ᵐ-[]ˢ expr-eqtm = ≈-eqtm

    infixl 7 _ᵐ∘ⁱ_
    _ᵐ∘ⁱ_ : ∀ {𝕂 𝕄 γ} (f : 𝕊 →ᵐ 𝕋) (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) → 𝕋 % 𝕂 →ⁱ 𝕄 ∥ γ
    (f ᵐ∘ⁱ I) M =  [ f ]ᵐ I M

    ⇑ⁱ-resp-ᵐ∘ⁱ : ∀ {𝕂 𝕄 γ δ} {f : 𝕊 →ᵐ 𝕋} {I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ} →
                  ⇑ⁱ {δ = δ} (f ᵐ∘ⁱ I) ≈ⁱ f ᵐ∘ⁱ ⇑ⁱ I
    ⇑ⁱ-resp-ᵐ∘ⁱ {I = I} M = ≈-sym ([]ᵐ-[]ʳ (I M))

    []ᵐ-[]ⁱ : ∀ {cl 𝕂 𝕄 γ} {f : 𝕊 →ᵐ 𝕋} {I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ} (t : Expr 𝕊 cl 𝕂 γ) →
              [ f ]ᵐ ([ I ]ⁱ t) ≈ [ f ᵐ∘ⁱ I ]ⁱ [ f ]ᵐ t
    []ᵐ-[]ⁱ (expr-var x) = ≈-refl
    []ᵐ-[]ⁱ {f = f} {I = I} (expr-symb S es) =
      ≈-trans
        ([]ⁱ-resp-≈ⁱ
           ([ 𝟘-initial ]ʳ f S)
           λ M → ≈-trans
                   ([]ᵐ-[]ⁱ (es M))
                   ([]ⁱ-resp-≈ⁱ ([ f ]ᵐ es M) (≈ⁱ-sym (⇑ⁱ-resp-ᵐ∘ⁱ {I = I}))))
        ([∘ⁱ] ([ 𝟘-initial ]ʳ f S))
    []ᵐ-[]ⁱ {f = f} {I = I} (expr-meta M ts) =
      ≈-trans
        ([]ᵐ-[]ˢ (I M))
        ([]ˢ-resp-≈ˢ (λ { (var-left _) → ≈-refl ; (var-right x) → []ᵐ-[]ⁱ (ts x)}) ([ f ]ᵐ I M))
    []ᵐ-[]ⁱ expr-eqty = ≈-eqty
    []ᵐ-[]ⁱ expr-eqtm = ≈-eqtm

  -- idenity is right-neutral

  []ᵐ-meta-generic : ∀ {𝕊 𝕋} {𝕄 γ} {f : 𝕊 →ᵐ 𝕋} {clᴹ γᴹ} {M : [ clᴹ , γᴹ ]∈ 𝕄} →
                     [ f ]ᵐ (expr-meta-generic 𝕊 {γ = γ} M) ≈ expr-meta-generic 𝕋 M
  []ᵐ-meta-generic {clᴹ = obj _} = ≈-refl
  []ᵐ-meta-generic {clᴹ = EqTy} = ≈-eqty
  []ᵐ-meta-generic {clᴹ = EqTm} = ≈-eqtm

  𝟙ᵐ-right : ∀ {𝕊 𝕋} {f : 𝕊 →ᵐ 𝕋} → f ∘ᵐ 𝟙ᵐ ≈ᵐ f
  𝟙ᵐ-right {f = f} S =
    ≈-trans
      ([]ⁱ-resp-≈ⁱ ([ 𝟘-initial ]ʳ (f S)) λ M → []ᵐ-meta-generic {M = M})
      (≈-trans ([𝟙ⁱ] ([ 𝟘-initial ]ʳ f S)) ([]ʳ-id (λ { ()})))

  -- Action preserves composition

  module _ {𝕊 𝕋 𝕌} where
    [∘ᵐ] : ∀ {f : 𝕊 →ᵐ 𝕋} {g : 𝕋 →ᵐ 𝕌} {cl 𝕄 γ} (t : Expr 𝕊 cl 𝕄 γ) → [ g ∘ᵐ f ]ᵐ t ≈ [ g ]ᵐ [ f ]ᵐ t
    [∘ᵐ] (expr-var x) = ≈-refl
    [∘ᵐ] {f = f} {g = g} (expr-symb S es) =
      ≈-trans
        ([]ⁱ-resp-≈ⁱ-≈ (λ M → [∘ᵐ] (es M)) (≈-sym ([]ᵐ-[]ʳ (f S))))
        (≈-sym ([]ᵐ-[]ⁱ ([ 𝟘-initial ]ʳ f S)))
    [∘ᵐ] (expr-meta M ts) = ≈-meta (λ i → [∘ᵐ] (ts i))
    [∘ᵐ] expr-eqty = ≈-eqty
    [∘ᵐ] expr-eqtm = ≈-eqtm

  -- Associativity of composition

  assocᵐ : ∀ {𝕊 𝕋 𝕌 𝕍} {f : 𝕊 →ᵐ 𝕋} {g : 𝕋 →ᵐ 𝕌} {h : 𝕌 →ᵐ 𝕍} →
           (h ∘ᵐ g) ∘ᵐ f ≈ᵐ h ∘ᵐ (g ∘ᵐ f)
  assocᵐ {f = f} S = [∘ᵐ] (f S)

  -- The category of signatures and syntax maps

  module _ where

   open Categories.Category

   SyntaxMaps : Category (suc zero) zero zero
   SyntaxMaps =
     record
       { Obj = Signature
       ; _⇒_ = _→ᵐ_
       ; _≈_ = _≈ᵐ_
       ; id = 𝟙ᵐ
       ; _∘_ = _∘ᵐ_
       ; assoc = λ {_} {_} {_} {_} {f} {_} {_} {_} S → [∘ᵐ] (f S)
       ; sym-assoc = λ {_} {_} {_} {𝕍} {f} {_} {_} {_} S → ≈-sym ([∘ᵐ] (f S))
       ; identityˡ = λ S → [𝟙ᵐ] _
       ; identityʳ = λ {_} {_} {f} {_} → 𝟙ᵐ-right {f = f}
       ; identity² = λ _ → [𝟙ᵐ] _
       ; equiv = record { refl = λ _ → ≈-refl ; sym = ≈ᵐ-sym ; trans = ≈ᵐ-trans }
       ; ∘-resp-≈ = λ ζ ξ S → []ᵐ-resp-≈ᵐ-≈ ζ (ξ S)
       }


{-# OPTIONS --allow-unsolved-metas #-}
module HasSubstantiveDischarge where

open import OscarPrelude

record HasSubstitution (T : Set) (S : Set) : Set where
  field
    _◃_ : S → T → T

open HasSubstitution ⦃ … ⦄ public

record HasPairUnification (T : Set) (S : Set) : Set where
  field
    ⦃ hasSubstitution ⦄ : HasSubstitution T S

  Property : Set₁
  Property = S × S → Set

  Nothing : Property → Set
  Nothing P = ∀ s → P s → ⊥

  IsPairUnifier : (t₁ t₂ : T) → Property
  IsPairUnifier t₁ t₂ s = let s₁ , s₂ = s in s₁ ◃ t₁ ≡ s₂ ◃ t₂

  field
    unify : (t₁ t₂ : T) → Dec ∘ ∃ $ IsPairUnifier t₁ t₂

open HasPairUnification ⦃ … ⦄ public

open import HasNegation

record HasSubstantiveDischarge (A : Set) : Set₁
 where
  field
    _o≽o_ : A → A → Set

  field
    ⦃ hasNegation ⦄ : HasNegation A

  _⋡_ : A → A → Set
  _⋡_ (+) (-) = ¬ + o≽o -

  field
    ≽-reflexive : (x : A) → x o≽o x
    ≽-consistent : (+ - : A) → + o≽o - → + ⋡ ~ -
    ≽-contrapositive : ∀ x y → ~ x o≽o y → x o≽o ~ y

  ≽-contrapositive' : ∀ x y → x o≽o ~ y → ~ x o≽o y
  ≽-contrapositive' = {!!}

open HasSubstantiveDischarge ⦃ … ⦄ public

{-# DISPLAY HasSubstantiveDischarge._o≽o_ _ = _o≽o_ #-}

open import Membership

record HasGenericSubstantiveDischarge (A : Set) (B : Set) : Set₁
 where
  field
    _≽_ : A → B → Set

open HasGenericSubstantiveDischarge ⦃ … ⦄ public

{-# DISPLAY HasGenericSubstantiveDischarge._≽_ _ = _≽_ #-}

instance HasGenericSubstantiveDischargeReflexive : ∀ {A} ⦃ _ : HasSubstantiveDischarge A ⦄ → HasGenericSubstantiveDischarge A A
HasGenericSubstantiveDischarge._≽_ HasGenericSubstantiveDischargeReflexive = _o≽o_

instance HasGenericSubstantiveDischargeAList : ∀ {A} ⦃ _ : HasSubstantiveDischarge A ⦄ → HasGenericSubstantiveDischarge A (List A)
HasGenericSubstantiveDischarge._≽_ (HasGenericSubstantiveDischargeAList {A}) (+) -s = ∃ λ (i : A) → i ∈ -s × (+ ≽ i)

instance HasGenericSubstantiveDischargeListA : ∀ {A} ⦃ _ : HasSubstantiveDischarge A ⦄ → HasGenericSubstantiveDischarge (List A) A
HasGenericSubstantiveDischarge._≽_ (HasGenericSubstantiveDischargeListA {A}) (+s) (-) = ∃ λ (c : A) → c ∈ +s × c ≽ -

instance HasGenericSubstantiveDischargeListList : ∀ {A} ⦃ _ : HasSubstantiveDischarge A ⦄ → HasGenericSubstantiveDischarge (List A) (List A)
HasGenericSubstantiveDischarge._≽_ (HasGenericSubstantiveDischargeListList {A}) +s -s = ∀ (i : A) → i ∈ -s → +s ≽ i

⋆≽⋆-reflexive : ∀ {A} ⦃ _ : HasSubstantiveDischarge A ⦄ → (xs : List A) → xs ≽ xs
⋆≽⋆-reflexive _ i i∈ys⋆ = _ , i∈ys⋆ , ≽-reflexive i

◁_ : ∀ {A} ⦃ _ : HasSubstantiveDischarge A ⦄ → List A → Set
◁_ {A} +s = ∃ λ (s : A) → s ∈ +s × +s ≽ ~ s

⋪_ : ∀ {A} ⦃ _ : HasSubstantiveDischarge A ⦄ → List A → Set
⋪_ = ¬_ ∘ ◁_

record HasDecidableSubstantiveDischarge (A : Set) : Set₁
 where
  field
    ⦃ hasSubstantiveDischarge ⦄ : HasSubstantiveDischarge A
    _≽?_ : (+ - : A) → Dec $ + o≽o -

open HasDecidableSubstantiveDischarge ⦃ … ⦄ public

{-# DISPLAY HasDecidableSubstantiveDischarge._≽?_ _ = _≽?_ #-}

_⋆≽?_ : ∀ {A} ⦃ _ : HasDecidableSubstantiveDischarge A ⦄ → (+s : List A) → (- : A) → Dec (+s ≽ -)
_⋆≽?_ [] - = no λ { (_ , () , _)}
_⋆≽?_ (+ ∷ +s) - with + ≽? -
… | yes +≽- = yes $ _ , zero , +≽-
… | no +⋡- with +s ⋆≽? -
… | yes (+' , +'∈+s , +'≽-) = yes $ _ , suc +'∈+s , +'≽-
… | no +s⋡- = no λ { (_ , zero , +≽-) → +⋡- +≽-
                   ; (+' , suc +'∈+s , +'≽-) → +s⋡- $ _ , +'∈+s , +'≽- }

_≽⋆?_ : ∀ {A} ⦃ _ : HasDecidableSubstantiveDischarge A ⦄ → (+ : A) → (-s : List A) → Dec (+ ≽ -s)
+ ≽⋆? [] = no (λ { (fst₁ , () , snd₁)})
+ ≽⋆? (- ∷ -s) with + ≽? -
… | yes +≽- = yes (_ , zero , +≽-)
… | no +⋡- with + ≽⋆? -s
… | yes (_ , i∈-s , +≽⋆i) = yes (_ , suc i∈-s , +≽⋆i)
… | no +⋡⋆-s = no (λ { (_ , zero , +≽-) → +⋡- +≽-
                     ; (_ , suc -'∈-s , +≽-') → +⋡⋆-s (_ , -'∈-s , +≽-')})

_⋆≽⋆?_ : ∀ {A} ⦃ _ : HasDecidableSubstantiveDischarge A ⦄ → (+s : List A) → (-s : List A) → Dec (+s ≽ -s)
_⋆≽⋆?_ +s [] = yes λ _ ()
_⋆≽⋆?_ +s (- ∷ -s) with +s ⋆≽? -
… | no +s⋡- = no λ +s≽-∷-s → +s⋡- $ +s≽-∷-s (-) zero
… | yes +s≽- with +s ⋆≽⋆? -s
… | yes +s≽-s = yes λ { _ zero → +s≽-
                      ; -' (suc -'∈-∷-s) → +s≽-s -' -'∈-∷-s }
… | no +s⋡-s = no λ +s≽-∷-s → +s⋡-s λ +' +'∈-s → +s≽-∷-s +' (suc +'∈-s)

◁?_ : ∀ {+} ⦃ _ : HasDecidableSubstantiveDischarge (+) ⦄
            → (+s : List +) → Dec $ ◁ +s
◁? [] = no λ {(_ , () , _)}
◁?_ (+ ∷ +s) with +s ⋆≽? ~ +
… | yes (_ , +'∈+s , +'≽~+) = yes $ _ , zero , _ , suc +'∈+s , +'≽~+
… | no +s⋆⋡~+ with ~ + ≽⋆? +s
… | yes (_ , c∈+s , ~+≽c) = yes (_ , suc c∈+s , _ , zero , ≽-contrapositive (+) _ ~+≽c)
… | no ~+⋡⋆+s with ◁? +s
… | yes (s , s∈+s , c , c∈+s , c≽~s) = yes $ _ , suc s∈+s , _ , suc c∈+s , c≽~s
… | no ⋪+s = no
  λ { (_ , zero , _ , zero , c≽~s) → ≽-consistent (+) (+) (≽-reflexive +) c≽~s
  ; (_ , zero , c , suc c∈+s , c≽~s) → +s⋆⋡~+ (_ , c∈+s , c≽~s)
  ; (s , suc s∈+s , .+ , zero , +≽~s) → ~+⋡⋆+s (_ , s∈+s , ≽-contrapositive' (+) s +≽~s)
  ; (s , suc s∈+s , c , suc c∈+s , c≽~s) → ⋪+s (_ , s∈+s , _ , c∈+s , c≽~s) }


module test.StringLiteral where

open import Type
open import Declarative
open import Builtin
open import Builtin.Constant.Type
open import Builtin.Constant.Term Ctx⋆ Kind * # _⊢⋆_ con size⋆

-- zerepoch/zerepoch-core/test/data/stringLiteral.plc

postulate str1 : ByteString
{-# FOREIGN GHC import qualified Data.ByteString.Char8 as BS #-}
{-# COMPILE GHC str1 = BS.pack "4321758fabce1aa4780193f" #-}

open import Relation.Binary.PropositionalEquality
open import Agda.Builtin.TrustMe

lemma1 : length str1 ≡ 23
lemma1 = primTrustMe

open import Data.Nat

lemma1' : BoundedB 100 str1
lemma1' rewrite lemma1 = gen _ _ _

stringLit : ∀{Γ} → Γ ⊢ con bytestring (size⋆ 100)
stringLit = con (bytestring 100  str1 lemma1')


module ReflectionExposeConstraints where

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

_>>=_ : ∀ {a b} {A : Set a} {B : Set b} → TC A → (A → TC B) → TC B
_>>=_ = bindTC

_ifMeta_ : {A : Set} → Term → (Meta → TC A) → TC A
meta x x₁ ifMeta f = f x
_ ifMeta _ = typeError (strErr "Error1" ∷ [])

infixr 0 case_of_
case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
case x of f = f x

foo : Constraint → TC Term
foo (valueCmp cmpEq y t1 (def f args)) = returnTC (def f [])
foo _ = typeError (strErr "Error2" ∷ [])

q : Nat → Nat
q zero = 4
q (suc x) = 4

macro
  mfun : Term → TC ⊤
  mfun hole
     = delayMacro >>= (λ _ →
         hole ifMeta (λ x → do
                              c ← getConstraintsMentioning (x ∷ [])
                              case c of
                                λ {[] → typeError (strErr "Error3" ∷ [])
                                  ; (c ∷ cs) → do
                                                 g ← foo c
                                                 unify hole g }
                              ))
postulate
  g : (Q : Nat → Nat) → ∀ k → Q k ≡ 4

f : ∀ k → q k ≡ 4
f k = g mfun k