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

open import HoTT
open import cohomology.Theory

{- Ordinary cohomology groups of the n-torus Tⁿ = (S¹)ⁿ.
 - We have Cᵏ(Tⁿ) == C⁰(S⁰)^(n choose' k) where _choose'_ defined as below.
 - This argument could give Cᵏ((Sᵐ)ⁿ) with a little more work. -}

module cohomology.Torus {i} (OT : OrdinaryTheory i) where

open OrdinaryTheory OT
open import cohomology.Sphere OT
open import cohomology.SphereProduct cohomology-theory

{- Almost n choose k, but with n choose' O = 0 for any n. -}
_choose'_ : ℕ → ℤ → ℕ
n choose' negsucc _ = 0
n choose' pos O = 0
n choose' pos (S O) = n
O choose' pos (S (S k)) = 0
S n choose' pos (S (S k)) = (n choose' (pos (S (S k)))) + (n choose' (pos (S k)))

_-⊙Torus : ℕ → Ptd₀
O -⊙Torus = ⊙Unit
(S n) -⊙Torus = ⊙S¹ ⊙× (n -⊙Torus)

C-nTorus : (k : ℤ) (n : ℕ)
  → C k (⊙Lift (n -⊙Torus)) ≃ᴳ C 0 (⊙Lift ⊙S⁰) ^ᴳ (n choose' k)

C-nTorus (negsucc k) O = lift-iso ∘eᴳ trivial-iso-0ᴳ (C-Unit (negsucc k))

C-nTorus (negsucc k) (S n) =
  C (negsucc k) (⊙Lift (S n -⊙Torus))
    ≃ᴳ⟨ C-emap (negsucc k) (⊙lift-equiv ⊙∘e ⊙×-emap (⊙ide _) ⊙lower-equiv) ⟩
  C (negsucc k) (⊙S¹ ⊙× ⊙Lift (n -⊙Torus))
    ≃ᴳ⟨ C-Sphere× (negsucc k) 1 (⊙Lift (n -⊙Torus)) ⟩
  C (negsucc k) (⊙Lift ⊙S¹) ×ᴳ (C (negsucc k) (⊙Lift (n -⊙Torus)) ×ᴳ C (negsucc k) (⊙Susp (⊙Lift (n -⊙Torus))))
    ≃ᴳ⟨ ×ᴳ-emap (trivial-iso-0ᴳ (C-Sphere-≠-is-trivial (negsucc k) 1 (ℤ-negsucc≠pos _ _))) (idiso _) ⟩
  0ᴳ ×ᴳ (C (negsucc k) (⊙Lift (n -⊙Torus)) ×ᴳ C (negsucc k) (⊙Susp (⊙Lift (n -⊙Torus))))
    ≃ᴳ⟨ ×ᴳ-unit-l _ ⟩
  C (negsucc k) (⊙Lift (n -⊙Torus)) ×ᴳ C (negsucc k) (⊙Susp (⊙Lift (n -⊙Torus)))
    ≃ᴳ⟨ ×ᴳ-emap
          (lower-iso ∘eᴳ C-nTorus (negsucc k) n)
          (C-nTorus (negsucc (S k)) n ∘eᴳ C-Susp (negsucc (S k)) (⊙Lift (n -⊙Torus))) ⟩
  0ᴳ ×ᴳ Lift-group 0ᴳ
    ≃ᴳ⟨ ×ᴳ-unit-l (Lift-group 0ᴳ) ⟩
  Lift-group 0ᴳ
    ≃ᴳ∎

C-nTorus (pos O) O = lift-iso ∘eᴳ trivial-iso-0ᴳ (C-Unit 0)

C-nTorus (pos O) (S n) =
  C 0 (⊙Lift (S n -⊙Torus))
    ≃ᴳ⟨ C-emap 0 (⊙lift-equiv ⊙∘e ⊙×-emap (⊙ide _) ⊙lower-equiv) ⟩
  C 0 (⊙S¹ ⊙× ⊙Lift (n -⊙Torus))
    ≃ᴳ⟨ C-Sphere× 0 1 (⊙Lift (n -⊙Torus)) ⟩
  C 0 (⊙Lift ⊙S¹) ×ᴳ (C 0 (⊙Lift (n -⊙Torus)) ×ᴳ C 0 (⊙Susp (⊙Lift (n -⊙Torus))))
    ≃ᴳ⟨ ×ᴳ-emap (trivial-iso-0ᴳ (C-Sphere-≠-is-trivial 0 1 (pos-≠ (ℕ-O≠S _)))) (idiso _) ⟩
  0ᴳ ×ᴳ (C 0 (⊙Lift (n -⊙Torus)) ×ᴳ C 0 (⊙Susp (⊙Lift (n -⊙Torus))))
    ≃ᴳ⟨ ×ᴳ-unit-l _ ⟩
  C 0 (⊙Lift (n -⊙Torus)) ×ᴳ C 0 (⊙Susp (⊙Lift (n -⊙Torus)))
    ≃ᴳ⟨ ×ᴳ-emap
          (lower-iso ∘eᴳ C-nTorus 0 n)
          (C-nTorus -1 n ∘eᴳ C-Susp -1 (⊙Lift (n -⊙Torus))) ⟩
  0ᴳ ×ᴳ Lift-group 0ᴳ
    ≃ᴳ⟨ ×ᴳ-unit-l _ ⟩
  Lift-group 0ᴳ
    ≃ᴳ∎

C-nTorus (pos (S O)) O = lift-iso ∘eᴳ trivial-iso-0ᴳ (C-Unit 1)

C-nTorus (pos (S O)) (S n) =
  C 1 (⊙Lift (S n -⊙Torus))
    ≃ᴳ⟨ C-emap 1 (⊙lift-equiv ⊙∘e ⊙×-emap (⊙ide _) ⊙lower-equiv) ⟩
  C 1 (⊙S¹ ⊙× ⊙Lift (n -⊙Torus))
    ≃ᴳ⟨ C-Sphere× 1 1 (⊙Lift (n -⊙Torus)) ⟩
  C 1 (⊙Lift ⊙S¹) ×ᴳ (C 1 (⊙Lift (n -⊙Torus)) ×ᴳ C 1 (⊙Susp (⊙Lift (n -⊙Torus))))
    ≃ᴳ⟨ ×ᴳ-emap (C-Sphere-diag 1)
          ( ×ᴳ-unit-r _
        ∘eᴳ ×ᴳ-emap
              (C-nTorus 1 n)
              (lower-iso
                ∘eᴳ C-nTorus 0 n
                ∘eᴳ C-Susp 0 (⊙Lift (n -⊙Torus)))) ⟩
  C 0 (⊙Lift ⊙S⁰) ×ᴳ (C 0 (⊙Lift ⊙S⁰) ^ᴳ n)
    ≃ᴳ∎

C-nTorus (pos (S (S k))) O = lift-iso ∘eᴳ trivial-iso-0ᴳ (C-Unit (pos (S (S k))))

C-nTorus (pos (S (S k))) (S n) =
  C (pos (S (S k))) (⊙Lift (S n -⊙Torus))
    ≃ᴳ⟨ C-emap (pos (S (S k))) (⊙lift-equiv ⊙∘e ⊙×-emap (⊙ide _) ⊙lower-equiv) ⟩
  C (pos (S (S k))) (⊙S¹ ⊙× ⊙Lift (n -⊙Torus))
    ≃ᴳ⟨ C-Sphere× (pos (S (S k))) 1 (⊙Lift (n -⊙Torus)) ⟩
  C (pos (S (S k))) (⊙Lift ⊙S¹) ×ᴳ (C (pos (S (S k))) (⊙Lift (n -⊙Torus)) ×ᴳ C (pos (S (S k))) (⊙Susp (⊙Lift (n -⊙Torus))))
    ≃ᴳ⟨ ×ᴳ-emap (trivial-iso-0ᴳ (C-Sphere-≠-is-trivial (pos (S (S k))) 1 (pos-≠ (ℕ-S-≠ (ℕ-S≠O k))))) (idiso _) ⟩
  0ᴳ ×ᴳ (C (pos (S (S k))) (⊙Lift (n -⊙Torus)) ×ᴳ C (pos (S (S k))) (⊙Susp (⊙Lift (n -⊙Torus))))
    ≃ᴳ⟨ ×ᴳ-unit-l _ ⟩
  C (pos (S (S k))) (⊙Lift (n -⊙Torus)) ×ᴳ C (pos (S (S k))) (⊙Susp (⊙Lift (n -⊙Torus)))
    ≃ᴳ⟨ ×ᴳ-emap
        (C-nTorus (pos (S (S k))) n)
        (C-nTorus (pos (S k)) n ∘eᴳ C-Susp (pos (S k)) (⊙Lift (n -⊙Torus))) ⟩
  (C 0 (⊙Lift ⊙S⁰) ^ᴳ (n choose' pos (S (S k)))) ×ᴳ (C 0 (⊙Lift ⊙S⁰) ^ᴳ (n choose' pos (S k)))
    ≃ᴳ⟨ ^ᴳ-+ (C 0 (⊙Lift ⊙S⁰)) (n choose' pos (S (S k))) (n choose' pos (S k)) ⁻¹ᴳ ⟩
  C 0 (⊙Lift ⊙S⁰) ^ᴳ (S n choose' pos (S (S k)))
    ≃ᴳ∎


-- Andreas, 2012-01-13
module Issue555b where

data Empty : Set where
record Unit : Set where
  constructor tt

-- Do we want to allow this?
data Exp (A : Set) : Set1
data Exp where -- ? needs to report that too few parameters are given
  var : Exp Empty
  app : {A B : Set} → Exp (A → B) → Exp A → Exp B

-- Basically, A is first declared as a parameter, but later,
-- in the definition, it is turned into an index.

bla : {A : Set} → Exp A → Unit
bla var = tt
bla (app f a) = bla f


module UnifyMguPair where

open import UnifyTerm
open import UnifyMgu
open import UnifyMguCorrect

open import Data.Fin using (Fin; suc; zero)
open import Data.Nat hiding (_≤_)
open import Relation.Binary.PropositionalEquality renaming ([_] to [[_]])
open import Function using (_∘_; id; case_of_; _$_)
open import Relation.Nullary
open import Data.Product
open import Data.Empty
open import Data.Maybe
open import Data.Sum

l1 : ∀ m → Data.Fin.toℕ (Data.Fin.fromℕ m) ≡ m
l1 zero = refl
l1 (suc m) = cong suc (l1 m)

l2 : ∀ m → m ≡ m + 0
l2 zero = refl
l2 (suc m) = cong suc (l2 m)

fixup : ∀ m → Fin (Data.Fin.toℕ (Data.Fin.fromℕ m) + m) → Fin (m + (m + 0))
fixup m x rewrite l1 m | sym (l2 m) = x

revise-down : ∀ {m} → Fin m → Fin (2 * m)
revise-down {m} x = Data.Fin.inject+ (m + 0) x

revise-up : ∀ {m} → Fin m → Fin (2 * m)
revise-up {m} x = fixup m (Data.Fin.fromℕ m Data.Fin.+ x)

write-variable-down : ∀ {m} → Term m → Term (2 * m)
write-variable-down {m} (i l) = i $ revise-down l
write-variable-down {m} leaf = leaf
write-variable-down {m} (s fork t) = write-variable-down s fork write-variable-down t

write-variable-up : ∀ {m} → Term m → Term (2 * m)
write-variable-up {m} (i r) = i (revise-up r)
write-variable-up {m} leaf = leaf
write-variable-up {m} (s fork t) = write-variable-up s fork write-variable-up t

write-variables-apart : ∀ {m} (s t : Term m) → Term (2 * m) × Term (2 * m)
write-variables-apart s t = write-variable-down s , write-variable-up t

separate-substitutions-down : ∀ {m n} → (Fin (2 * m) → Term n) → Fin m → Term n
separate-substitutions-down {m} f x = f $ revise-down x

separate-substitutions-up : ∀ {m n} → (Fin (2 * m) → Term n) → Fin m → Term n
separate-substitutions-up {m} f x = f $ revise-up x

separate-substitutions : ∀ {m n} → (Fin (2 * m) → Term n) → (Fin m → Term n) × (Fin m → Term n)
separate-substitutions {m} x = separate-substitutions-down {m} x , separate-substitutions-up {m} x

write≡separate : ∀ {m n} (σ : AList (2 * m) n) (t : Term m) → (sub σ ◃_) (write-variable-down t) ≡ ((separate-substitutions-down $ sub σ) ◃_) t
write≡separate {zero} {.0} anil (i x) = refl
write≡separate {suc m} {.(suc (m + suc (m + 0)))} anil (i x) = refl
write≡separate {suc m} {n} (σ asnoc t' / x) (i x₁) = refl
write≡separate σ leaf = refl
write≡separate σ (t₁ fork t₂) = cong₂ _fork_ (write≡separate σ t₁) (write≡separate σ t₂)

write≡separate' : ∀ {m n} (σ : AList (2 * m) n) (t : Term m) → (sub σ ◃_) (write-variable-down t) ≡ ((separate-substitutions-down $ sub σ) ◃_) t
write≡separate' {zero} {.0} anil (i x) = refl
write≡separate' {suc m} {.(suc (m + suc (m + 0)))} anil (i x) = refl
write≡separate' {suc m} {n} (σ asnoc t' / x) (i x₁) = refl
write≡separate' σ leaf = refl
write≡separate' σ (t₁ fork t₂) = cong₂ _fork_ (write≡separate σ t₁) (write≡separate σ t₂)

Property'2 : (m : ℕ) -> Set1
Property'2 m = ∀ {n} -> (Fin (2 * m) -> Term n) -> Set

Nothing'2 : ∀{m} -> (P : Property'2 m) -> Set
Nothing'2 P = ∀{n} f -> P {n} f -> ⊥

Unifies'2 : ∀ {m} (s t : Term m) -> Property'2 m
Unifies'2 s t f =
  let --s' , t' = write-variables-apart s t
      f₁ , f₂ = separate-substitutions f
  in f₁ ◃ s ≡ f₂ ◃ t

pair-mgu' : ∀ {m} -> (s t : Term m) -> Maybe (∃ (AList (2 * m)))
pair-mgu' {m} s t =
  let s' , t' = write-variables-apart s t
      mgu' = mgu s' t'
  in
    mgu'

up-equality : ∀ {m n} {f : (2 * m) ~> n} (t : Term m) → (f ∘ revise-up) ◃ t ≡ f ◃ write-variable-up t
up-equality (i x) = refl
up-equality leaf = refl
up-equality (t₁ fork t₂) = cong₂ _fork_ (up-equality t₁) (up-equality t₂)

down-equality : ∀ {m n} {f : (2 * m) ~> n} (t : Term m) → (f ∘ revise-down) ◃ t ≡ f ◃ write-variable-down t
down-equality (i x) = refl
down-equality leaf = refl
down-equality (t₁ fork t₂) = cong₂ _fork_ (down-equality t₁) (down-equality t₂)

revise-to-write : ∀ {m n} {f : (2 * m) ~> n} (s t : Term m) → (f ∘ revise-down) ◃ s ≡ (f ∘ revise-up) ◃ t → f ◃ write-variable-down s ≡ f ◃ write-variable-up t
revise-to-write (i x) (i x₁) x₂ = x₂
revise-to-write (i x) leaf x₁ = x₁
revise-to-write (i x) (t fork t₁) x₁ = trans x₁ (up-equality (t fork t₁))
revise-to-write leaf (i x) x₁ = x₁
revise-to-write leaf leaf x = refl
revise-to-write leaf (t₁ fork t₂) x = trans x (up-equality (t₁ fork t₂))
revise-to-write (s₁ fork s₂) (i x) x₁ = trans (sym (down-equality (s₁ fork s₂))) x₁
revise-to-write (s₁ fork s₂) leaf x = trans (sym (down-equality (s₁ fork s₂))) x
revise-to-write (s₁ fork s₂) (t₁ fork t₂) x = trans (trans (sym (down-equality (s₁ fork s₂))) x) (up-equality (t₁ fork t₂))

write-to-revise : ∀ {m n} {f : (2 * m) ~> n} (s t : Term m) → f ◃ write-variable-down s ≡ f ◃ write-variable-up t → (f ∘ revise-down) ◃ s ≡ (f ∘ revise-up) ◃ t
write-to-revise (i x) (i x₁) x₂ = x₂
write-to-revise (i x) leaf x₁ = x₁
write-to-revise (i x) (t fork t₁) x₁ = trans x₁ (sym (up-equality (t fork t₁)))
write-to-revise leaf (i x) x₁ = x₁
write-to-revise leaf leaf x = refl
write-to-revise leaf (t fork t₁) x = trans x (sym (up-equality (t fork t₁)))
write-to-revise (s₁ fork s₂) (i x) x₁ = trans ((down-equality (s₁ fork s₂))) x₁
write-to-revise (s₁ fork s₂) leaf x = trans ((down-equality (s₁ fork s₂))) x
write-to-revise (s₁ fork s₂) (t fork t₁) x = trans (trans ((down-equality (s₁ fork s₂))) x) (sym (up-equality (t fork t₁)))

pair-mgu-c' : ∀ {m} (s t : Term m) ->
                (∃ λ n → ∃ λ σ → (Max⋆ (Unifies'2 s t)) (sub σ) × pair-mgu' s t ≡ just (n , σ))
                ⊎ (Nothing⋆ (Unifies'2 s t)                     × pair-mgu' s t ≡ nothing)
pair-mgu-c' {m} s t with write-variable-down s | write-variable-up t | inspect write-variable-down s | inspect write-variable-up t
… | s' | t' | [[ refl ]] | [[ refl ]] with mgu-c s' t'
… | (inj₁ (n , σ , (σ◃s'=σ◃t' , max-σ) , amgu=just)) =
  inj₁ $
  n ,
  σ ,
  ( write-to-revise s t σ◃s'=σ◃t' ,
    ( λ {n'} f f◃s≡f◃t → (proj₁ $ max-σ f (revise-to-write s t f◃s≡f◃t)) ,
      (λ x → proj₂ (max-σ f (revise-to-write s t f◃s≡f◃t)) x) ) ) ,
  amgu=just
… | (inj₂ (notunified , amgu=nothing)) = inj₂ ((λ {n} f x → notunified f (revise-to-write s t x)) , amgu=nothing)


open import Agda.Builtin.Bool

data Test : Set where
  CTest : Bool -> {Bool} -> Test
{-# COMPILE AGDA2HS Test #-}

getTest : Test → Bool
getTest (CTest b) = b
{-# COMPILE AGDA2HS getTest #-}

putTest : Bool → Test → Test
putTest b (CTest _ {b'}) = CTest b {b'}
{-# COMPILE AGDA2HS putTest #-}


{- This example used to fail but after the point-free evaluation fix
   it seems to work #-}
module Issue259c where

postulate
  A : Set
  a : A
  b : ({x : A} → A) → A
  C : A → Set

d : {x : A} → A
d {x} = a

e : A
e = b (λ {x} → d {x})

F : C e → Set₁
F _ with Set
F _ | _ = Set


-- Andreas, 2018-10-27, issue #3327
--
-- Test that {-# NO_UNIVERSE_CHECK #-} pragma only applies to the following definition.

module _ where

-- The following pragma should only apply to the following definition,
-- but due to a bug is actually applying to the rest of the module.

{-# NO_UNIVERSE_CHECK #-}
data ⊥ : Set where

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

-- This passes only with {-# NO_UNIVERSE_CHECK #-}:

record Type : Set where
  constructor inn
  field out : Set
open Type

-- The rest is Hurken's paradox.

⊥′ : Type
⊥′ = inn ((A : Type) → out A)

_⇒_ : (A B : Type) → Type
inn A ⇒ inn B = inn (A → B)

Π : (A : Type) (B : out A → Type) → Type
Π A B = inn ((x : out A) → out (B x))

¬_ : Type → Type
¬ A = A ⇒ ⊥′

P : Type → Type
P A = inn (out A → Type)

U : Type
U = inn ((X : Type) → out ((P (P X) ⇒ X) ⇒ P (P X)))

τ : out (P (P U) ⇒ U)
τ t = λ X f p → t λ x → p (f (x X f))

σ : out (U ⇒ P (P U))
σ s pu = s U (λ t → τ t) pu

Δ : out (P U)
Δ = λ y → ¬ (Π (P U) λ p → σ y p ⇒ p (τ (σ y)))

Ω : out U
Ω X t px = τ (λ p → Π U λ x → σ x p ⇒ p x) X t px

D : Type
D = Π (P U) λ p → σ Ω p ⇒ p (τ (σ Ω))

lem₁ : out (Π (P U) λ p → (Π U λ x → σ x p ⇒ p x) ⇒ p Ω)
lem₁ p H1 = H1 Ω λ x → H1 (τ (σ x))

lem₂ : out (¬ D)
lem₂ d A = lem₁ Δ (λ x H2 H3 → H3 Δ H2 λ p → H3 λ y → p (τ (σ y))) d A

lem₃ : out D
lem₃ p = lem₁ λ y → p (τ (σ y))

loop : out ⊥′
loop = λ A → lem₂ lem₃ A

absurd : ⊥
absurd = loop (inn ⊥)


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

module Definition.Typed where

open import Definition.Untyped hiding (_∷_)

open import Tools.Fin
open import Tools.Nat
open import Tools.Product

infixl 30 _∙_
infix 30 Πⱼ_▹_
infix 30 Σⱼ_▹_
infix 30 ⟦_⟧ⱼ_▹_

private
  variable
    n m : Nat
    Γ  : Con Term n
    A B F : Term n
    G : Term (1+ n)
    x : Fin n

-- Well-typed variables
data _∷_∈_ : (x : Fin n) (A : Term n) (Γ : Con Term n) → Set where
  here  :                       x0 ∷ wk1 A ∈ (Γ ∙ A)
  there : (h : x ∷ A ∈ Γ) → (x +1) ∷ wk1 A ∈ (Γ ∙ B)

mutual
  -- Well-formed context
  data ⊢_ : Con Term n → Set where
    ε   : ⊢ ε
    _∙_ : ⊢ Γ
        → Γ ⊢ A
        → ⊢ Γ ∙ A

  -- Well-formed type
  data _⊢_ (Γ : Con Term n) : Term n → Set where
    Uⱼ     : ⊢ Γ → Γ ⊢ U
    ℕⱼ     : ⊢ Γ → Γ ⊢ ℕ
    Emptyⱼ : ⊢ Γ → Γ ⊢ Empty
    Unitⱼ  : ⊢ Γ → Γ ⊢ Unit
    Πⱼ_▹_  : Γ     ⊢ F
           → Γ ∙ F ⊢ G
           → Γ     ⊢ Π F ▹ G
    Σⱼ_▹_  : Γ     ⊢ F
           → Γ ∙ F ⊢ G
           → Γ     ⊢ Σ F ▹ G
    univ   : Γ ⊢ A ∷ U
           → Γ ⊢ A

  -- Well-formed term of a type
  data _⊢_∷_ (Γ : Con Term n) : Term n → Term n → Set where
    Πⱼ_▹_     : ∀ {F G}
              → Γ     ⊢ F ∷ U
              → Γ ∙ F ⊢ G ∷ U
              → Γ     ⊢ Π F ▹ G ∷ U
    Σⱼ_▹_     : ∀ {F G}
              → Γ     ⊢ F ∷ U
              → Γ ∙ F ⊢ G ∷ U
              → Γ     ⊢ Σ F ▹ G ∷ U
    ℕⱼ        : ⊢ Γ → Γ ⊢ ℕ ∷ U
    Emptyⱼ    : ⊢ Γ → Γ ⊢ Empty ∷ U
    Unitⱼ     : ⊢ Γ → Γ ⊢ Unit ∷ U

    var       : ∀ {A x}
              → ⊢ Γ
              → x ∷ A ∈ Γ
              → Γ ⊢ var x ∷ A

    lamⱼ      : ∀ {F G t}
              → Γ     ⊢ F
              → Γ ∙ F ⊢ t ∷ G
              → Γ     ⊢ lam t ∷ Π F ▹ G
    _∘ⱼ_      : ∀ {g a F G}
              → Γ ⊢     g ∷ Π F ▹ G
              → Γ ⊢     a ∷ F
              → Γ ⊢ g ∘ a ∷ G [ a ]

    prodⱼ     : ∀ {F G t u}
              → Γ ⊢ F
              → Γ ∙ F ⊢ G
              → Γ ⊢ t ∷ F
              → Γ ⊢ u ∷ G [ t ]
              → Γ ⊢ prod t u ∷ Σ F ▹ G
    fstⱼ      : ∀ {F G t}
              → Γ ⊢ F
              → Γ ∙ F ⊢ G
              → Γ ⊢ t ∷ Σ F ▹ G
              → Γ ⊢ fst t ∷ F
    sndⱼ      : ∀ {F G t}
              → Γ ⊢ F
              → Γ ∙ F ⊢ G
              → Γ ⊢ t ∷ Σ F ▹ G
              → Γ ⊢ snd t ∷ G [ fst t ]

    zeroⱼ     : ⊢ Γ
              → Γ ⊢ zero ∷ ℕ
    sucⱼ      : ∀ {n}
              → Γ ⊢       n ∷ ℕ
              → Γ ⊢ suc n ∷ ℕ
    natrecⱼ   : ∀ {G s z n}
              → Γ ∙ ℕ ⊢ G
              → Γ       ⊢ z ∷ G [ zero ]
              → Γ       ⊢ s ∷ Π ℕ ▹ (G ▹▹ G [ suc (var x0) ]↑)
              → Γ       ⊢ n ∷ ℕ
              → Γ       ⊢ natrec G z s n ∷ G [ n ]

    Emptyrecⱼ : ∀ {A e}
              → Γ ⊢ A → Γ ⊢ e ∷ Empty → Γ ⊢ Emptyrec A e ∷ A

    starⱼ     : ⊢ Γ → Γ ⊢ star ∷ Unit

    conv      : ∀ {t A B}
              → Γ ⊢ t ∷ A
              → Γ ⊢ A ≡ B
              → Γ ⊢ t ∷ B

  -- Type equality
  data _⊢_≡_ (Γ : Con Term n) : Term n → Term n → Set where
    univ   : ∀ {A B}
           → Γ ⊢ A ≡ B ∷ U
           → Γ ⊢ A ≡ B
    refl   : ∀ {A}
           → Γ ⊢ A
           → Γ ⊢ A ≡ A
    sym    : ∀ {A B}
           → Γ ⊢ A ≡ B
           → Γ ⊢ B ≡ A
    trans  : ∀ {A B C}
           → Γ ⊢ A ≡ B
           → Γ ⊢ B ≡ C
           → Γ ⊢ A ≡ C
    Π-cong : ∀ {F H G E}
           → Γ     ⊢ F
           → Γ     ⊢ F ≡ H
           → Γ ∙ F ⊢ G ≡ E
           → Γ     ⊢ Π F ▹ G ≡ Π H ▹ E
    Σ-cong : ∀ {F H G E}
           → Γ     ⊢ F
           → Γ     ⊢ F ≡ H
           → Γ ∙ F ⊢ G ≡ E
           → Γ     ⊢ Σ F ▹ G ≡ Σ H ▹ E

  -- Term equality
  data _⊢_≡_∷_ (Γ : Con Term n) : Term n → Term n → Term n → Set where
    refl          : ∀ {t A}
                  → Γ ⊢ t ∷ A
                  → Γ ⊢ t ≡ t ∷ A
    sym           : ∀ {t u A}
                  → Γ ⊢ t ≡ u ∷ A
                  → Γ ⊢ u ≡ t ∷ A
    trans         : ∀ {t u r A}
                  → Γ ⊢ t ≡ u ∷ A
                  → Γ ⊢ u ≡ r ∷ A
                  → Γ ⊢ t ≡ r ∷ A
    conv          : ∀ {A B t u}
                  → Γ ⊢ t ≡ u ∷ A
                  → Γ ⊢ A ≡ B
                  → Γ ⊢ t ≡ u ∷ B
    Π-cong        : ∀ {E F G H}
                  → Γ     ⊢ F
                  → Γ     ⊢ F ≡ H       ∷ U
                  → Γ ∙ F ⊢ G ≡ E       ∷ U
                  → Γ     ⊢ Π F ▹ G ≡ Π H ▹ E ∷ U
    Σ-cong        : ∀ {E F G H}
                  → Γ     ⊢ F
                  → Γ     ⊢ F ≡ H       ∷ U
                  → Γ ∙ F ⊢ G ≡ E       ∷ U
                  → Γ     ⊢ Σ F ▹ G ≡ Σ H ▹ E ∷ U
    app-cong      : ∀ {a b f g F G}
                  → Γ ⊢ f ≡ g ∷ Π F ▹ G
                  → Γ ⊢ a ≡ b ∷ F
                  → Γ ⊢ f ∘ a ≡ g ∘ b ∷ G [ a ]
    β-red         : ∀ {a t F G}
                  → Γ     ⊢ F
                  → Γ ∙ F ⊢ t ∷ G
                  → Γ     ⊢ a ∷ F
                  → Γ     ⊢ (lam t) ∘ a ≡ t [ a ] ∷ G [ a ]
    η-eq          : ∀ {f g F G}
                  → Γ     ⊢ F
                  → Γ     ⊢ f ∷ Π F ▹ G
                  → Γ     ⊢ g ∷ Π F ▹ G
                  → Γ ∙ F ⊢ wk1 f ∘ var x0 ≡ wk1 g ∘ var x0 ∷ G
                  → Γ     ⊢ f ≡ g ∷ Π F ▹ G
    fst-cong      : ∀ {t t' F G}
                  → Γ ⊢ F
                  → Γ ∙ F ⊢ G
                  → Γ ⊢ t ≡ t' ∷ Σ F ▹ G
                  → Γ ⊢ fst t ≡ fst t' ∷ F
    snd-cong      : ∀ {t t' F G}
                  → Γ ⊢ F
                  → Γ ∙ F ⊢ G
                  → Γ ⊢ t ≡ t' ∷ Σ F ▹ G
                  → Γ ⊢ snd t ≡ snd t' ∷ G [ fst t ]
    Σ-β₁          : ∀ {F G t u}
                  → Γ ⊢ F
                  → Γ ∙ F ⊢ G
                  → Γ ⊢ t ∷ F
                  → Γ ⊢ u ∷ G [ t ]
                  → Γ ⊢ fst (prod t u) ≡ t ∷ F
    Σ-β₂          : ∀ {F G t u}
                  → Γ ⊢ F
                  → Γ ∙ F ⊢ G
                  → Γ ⊢ t ∷ F
                  → Γ ⊢ u ∷ G [ t ]
                  → Γ ⊢ snd (prod t u) ≡ u ∷ G [ fst (prod t u) ]
    Σ-η           : ∀ {p r F G}
                  → Γ ⊢ F
                  → Γ ∙ F ⊢ G
                  → Γ ⊢ p ∷ Σ F ▹ G
                  → Γ ⊢ r ∷ Σ F ▹ G
                  → Γ ⊢ fst p ≡ fst r ∷ F
                  → Γ ⊢ snd p ≡ snd r ∷ G [ fst p ]
                  → Γ ⊢ p ≡ r ∷ Σ F ▹ G
    suc-cong      : ∀ {m n}
                  → Γ ⊢ m ≡ n ∷ ℕ
                  → Γ ⊢ suc m ≡ suc n ∷ ℕ
    natrec-cong   : ∀ {z z′ s s′ n n′ F F′}
                  → Γ ∙ ℕ ⊢ F ≡ F′
                  → Γ     ⊢ z ≡ z′ ∷ F [ zero ]
                  → Γ     ⊢ s ≡ s′ ∷ Π ℕ ▹ (F ▹▹ F [ suc (var x0) ]↑)
                  → Γ     ⊢ n ≡ n′ ∷ ℕ
                  → Γ     ⊢ natrec F z s n ≡ natrec F′ z′ s′ n′ ∷ F [ n ]
    natrec-zero   : ∀ {z s F}
                  → Γ ∙ ℕ ⊢ F
                  → Γ     ⊢ z ∷ F [ zero ]
                  → Γ     ⊢ s ∷ Π ℕ ▹ (F ▹▹ F [ suc (var x0) ]↑)
                  → Γ     ⊢ natrec F z s zero ≡ z ∷ F [ zero ]
    natrec-suc    : ∀ {n z s F}
                  → Γ     ⊢ n ∷ ℕ
                  → Γ ∙ ℕ ⊢ F
                  → Γ     ⊢ z ∷ F [ zero ]
                  → Γ     ⊢ s ∷ Π ℕ ▹ (F ▹▹ F [ suc (var x0) ]↑)
                  → Γ     ⊢ natrec F z s (suc n) ≡ (s ∘ n) ∘ (natrec F z s n)
                          ∷ F [ suc n ]
    Emptyrec-cong : ∀ {A A' e e'}
                  → Γ ⊢ A ≡ A'
                  → Γ ⊢ e ≡ e' ∷ Empty
                  → Γ ⊢ Emptyrec A e ≡ Emptyrec A' e' ∷ A
    η-unit        : ∀ {e e'}
                  → Γ ⊢ e ∷ Unit
                  → Γ ⊢ e' ∷ Unit
                  → Γ ⊢ e ≡ e' ∷ Unit

-- Term reduction
data _⊢_⇒_∷_ (Γ : Con Term n) : Term n → Term n → Term n → Set where
  conv           : ∀ {A B t u}
                 → Γ ⊢ t ⇒ u ∷ A
                 → Γ ⊢ A ≡ B
                 → Γ ⊢ t ⇒ u ∷ B
  app-subst      : ∀ {A B t u a}
                 → Γ ⊢ t ⇒ u ∷ Π A ▹ B
                 → Γ ⊢ a ∷ A
                 → Γ ⊢ t ∘ a ⇒ u ∘ a ∷ B [ a ]
  β-red          : ∀ {A B a t}
                 → Γ     ⊢ A
                 → Γ ∙ A ⊢ t ∷ B
                 → Γ     ⊢ a ∷ A
                 → Γ     ⊢ (lam t) ∘ a ⇒ t [ a ] ∷ B [ a ]
  fst-subst      : ∀ {t t' F G}
                 → Γ ⊢ F
                 → Γ ∙ F ⊢ G
                 → Γ ⊢ t ⇒ t' ∷ Σ F ▹ G
                 → Γ ⊢ fst t ⇒ fst t' ∷ F
  snd-subst      : ∀ {t t' F G}
                 → Γ ⊢ F
                 → Γ ∙ F ⊢ G
                 → Γ ⊢ t ⇒ t' ∷ Σ F ▹ G
                 → Γ ⊢ snd t ⇒ snd t' ∷ G [ fst t ]
  Σ-β₁           : ∀ {F G t u}
                 → Γ ⊢ F
                 → Γ ∙ F ⊢ G
                 → Γ ⊢ t ∷ F
                 → Γ ⊢ u ∷ G [ t ]
                 → Γ ⊢ fst (prod t u) ⇒ t ∷ F
  Σ-β₂           : ∀ {F G t u}
                 → Γ ⊢ F
                 → Γ ∙ F ⊢ G
                 → Γ ⊢ t ∷ F
                 → Γ ⊢ u ∷ G [ t ]
                 -- TODO(WN): Prove that 𝔍 ∷ G [ t ] is admissible
                 → Γ ⊢ snd (prod t u) ⇒ u ∷ G [ fst (prod t u) ]
  natrec-subst   : ∀ {z s n n′ F}
                 → Γ ∙ ℕ ⊢ F
                 → Γ     ⊢ z ∷ F [ zero ]
                 → Γ     ⊢ s ∷ Π ℕ ▹ (F ▹▹ F [ suc (var x0) ]↑)
                 → Γ     ⊢ n ⇒ n′ ∷ ℕ
                 → Γ     ⊢ natrec F z s n ⇒ natrec F z s n′ ∷ F [ n ]
  natrec-zero    : ∀ {z s F}
                 → Γ ∙ ℕ ⊢ F
                 → Γ     ⊢ z ∷ F [ zero ]
                 → Γ     ⊢ s ∷ Π ℕ ▹ (F ▹▹ F [ suc (var x0) ]↑)
                 → Γ     ⊢ natrec F z s zero ⇒ z ∷ F [ zero ]
  natrec-suc     : ∀ {n z s F}
                 → Γ     ⊢ n ∷ ℕ
                 → Γ ∙ ℕ ⊢ F
                 → Γ     ⊢ z ∷ F [ zero ]
                 → Γ     ⊢ s ∷ Π ℕ ▹ (F ▹▹ F [ suc (var x0) ]↑)
                 → Γ     ⊢ natrec F z s (suc n) ⇒ (s ∘ n) ∘ (natrec F z s n) ∷ F [ suc n ]
  Emptyrec-subst : ∀ {n n′ A}
                 → Γ ⊢ A
                 → Γ     ⊢ n ⇒ n′ ∷ Empty
                 → Γ     ⊢ Emptyrec A n ⇒ Emptyrec A n′ ∷ A

-- Type reduction
data _⊢_⇒_ (Γ : Con Term n) : Term n → Term n → Set where
  univ : ∀ {A B}
       → Γ ⊢ A ⇒ B ∷ U
       → Γ ⊢ A ⇒ B

-- Term reduction closure
data _⊢_⇒*_∷_ (Γ : Con Term n) : Term n → Term n → Term n → Set where
  id  : ∀ {A t}
      → Γ ⊢ t ∷ A
      → Γ ⊢ t ⇒* t ∷ A
  _⇨_ : ∀ {A t t′ u}
      → Γ ⊢ t  ⇒  t′ ∷ A
      → Γ ⊢ t′ ⇒* u  ∷ A
      → Γ ⊢ t  ⇒* u  ∷ A

-- Type reduction closure
data _⊢_⇒*_ (Γ : Con Term n) : Term n → Term n → Set where
  id  : ∀ {A}
      → Γ ⊢ A
      → Γ ⊢ A ⇒* A
  _⇨_ : ∀ {A A′ B}
      → Γ ⊢ A  ⇒  A′
      → Γ ⊢ A′ ⇒* B
      → Γ ⊢ A  ⇒* B

-- Type reduction to whnf
_⊢_↘_ : (Γ : Con Term n) → Term n → Term n → Set
Γ ⊢ A ↘ B = Γ ⊢ A ⇒* B × Whnf B

-- Term reduction to whnf
_⊢_↘_∷_ : (Γ : Con Term n) → Term n → Term n → Term n → Set
Γ ⊢ t ↘ u ∷ A = Γ ⊢ t ⇒* u ∷ A × Whnf u

-- Type eqaulity with well-formed types
_⊢_:≡:_ : (Γ : Con Term n) → Term n → Term n → Set
Γ ⊢ A :≡: B = Γ ⊢ A × Γ ⊢ B × (Γ ⊢ A ≡ B)

-- Term equality with well-formed terms
_⊢_:≡:_∷_ : (Γ : Con Term n) → Term n → Term n → Term n → Set
Γ ⊢ t :≡: u ∷ A = (Γ ⊢ t ∷ A) × (Γ ⊢ u ∷ A) × (Γ ⊢ t ≡ u ∷ A)

-- Type reduction closure with well-formed types
record _⊢_:⇒*:_ (Γ : Con Term n) (A B : Term n) : Set where
  constructor [_,_,_]
  field
    ⊢A : Γ ⊢ A
    ⊢B : Γ ⊢ B
    D  : Γ ⊢ A ⇒* B

open _⊢_:⇒*:_ using () renaming (D to red; ⊢A to ⊢A-red; ⊢B to ⊢B-red) public

-- Term reduction closure with well-formed terms
record _⊢_:⇒*:_∷_ (Γ : Con Term n) (t u A : Term n) : Set where
  constructor [_,_,_]
  field
    ⊢t : Γ ⊢ t ∷ A
    ⊢u : Γ ⊢ u ∷ A
    d  : Γ ⊢ t ⇒* u ∷ A

open _⊢_:⇒*:_∷_ using () renaming (d to redₜ; ⊢t to ⊢t-redₜ; ⊢u to ⊢u-redₜ) public

-- Well-formed substitutions.
data _⊢ˢ_∷_ (Δ : Con Term m) : (σ : Subst m n) (Γ : Con Term n) → Set where
  id  : ∀ {σ} → Δ ⊢ˢ σ ∷ ε
  _,_ : ∀ {A σ}
      → Δ ⊢ˢ tail σ ∷ Γ
      → Δ ⊢  head σ ∷ subst (tail σ) A
      → Δ ⊢ˢ σ      ∷ Γ ∙ A

-- Conversion of well-formed substitutions.
data _⊢ˢ_≡_∷_ (Δ : Con Term m) : (σ σ′ : Subst m n) (Γ : Con Term n) → Set where
  id  : ∀ {σ σ′} → Δ ⊢ˢ σ ≡ σ′ ∷ ε
  _,_ : ∀ {A σ σ′}
      → Δ ⊢ˢ tail σ ≡ tail σ′ ∷ Γ
      → Δ ⊢  head σ ≡ head σ′ ∷ subst (tail σ) A
      → Δ ⊢ˢ      σ ≡ σ′      ∷ Γ ∙ A

-- Note that we cannot use the well-formed substitutions.
-- For that, we need to prove the fundamental theorem for substitutions.

⟦_⟧ⱼ_▹_ : (W : BindingType) → ∀ {F G}
     → Γ     ⊢ F
     → Γ ∙ F ⊢ G
     → Γ     ⊢ ⟦ W ⟧ F ▹ G
⟦ BΠ ⟧ⱼ ⊢F ▹ ⊢G = Πⱼ ⊢F ▹ ⊢G
⟦ BΣ ⟧ⱼ ⊢F ▹ ⊢G = Σⱼ ⊢F ▹ ⊢G

⟦_⟧ⱼᵤ_▹_ : (W : BindingType) → ∀ {F G}
     → Γ     ⊢ F ∷ U
     → Γ ∙ F ⊢ G ∷ U
     → Γ     ⊢ ⟦ W ⟧ F ▹ G ∷ U
⟦ BΠ ⟧ⱼᵤ ⊢F ▹ ⊢G = Πⱼ ⊢F ▹ ⊢G
⟦ BΣ ⟧ⱼᵤ ⊢F ▹ ⊢G = Σⱼ ⊢F ▹ ⊢G


-- Andreas, 2017-01-20, issue #2329

-- Neutral sizes cannot be used by the size solver,
-- thus, should be handled by coerceSize.

-- {-# OPTIONS -v tc:10 #-}
-- {-# OPTIONS -v tc.conv.coerce:20 #-}
-- {-# OPTIONS -v tc.size:20 #-}
-- {-# OPTIONS -v tc.size.solve:50 #-}

open import Agda.Builtin.Size

record R (i : Size) : Set where
  field
    j : Size< i

postulate
  f : ∀ i → R i

works : ∀ i → R i
R.j (works i) = R.j {i} (f i)

test : ∀ i → R i
R.j (test i) = R.j (f i)

-- Error WAS:
-- Unsolved constraint:
-- ↑ R.j (f i) =< i : Size


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Everything where

import Cubical.HITs.Cylinder
import Cubical.HITs.Hopf
import Cubical.HITs.Interval
import Cubical.HITs.Ints.BiInvInt
import Cubical.HITs.Ints.DeltaInt
import Cubical.HITs.Ints.HAEquivInt
import Cubical.HITs.Ints.IsoInt
import Cubical.HITs.Ints.QuoInt
import Cubical.HITs.Join
import Cubical.HITs.ListedFiniteSet
import Cubical.HITs.Pushout
import Cubical.HITs.Modulo
import Cubical.HITs.S1
import Cubical.HITs.S2
import Cubical.HITs.S3
import Cubical.HITs.Rational
import Cubical.HITs.Susp
import Cubical.HITs.SmashProduct
import Cubical.HITs.Torus
import Cubical.HITs.PropositionalTruncation
import Cubical.HITs.SetTruncation
import Cubical.HITs.GroupoidTruncation
import Cubical.HITs.2GroupoidTruncation
import Cubical.HITs.SetQuotients
import Cubical.HITs.FiniteMultiset
import Cubical.HITs.Sn
import Cubical.HITs.RPn
import Cubical.HITs.Truncation
import Cubical.HITs.Colimit
import Cubical.HITs.MappingCones
import Cubical.HITs.InfNat
import Cubical.HITs.KleinBottle
import Cubical.HITs.DunceCap
import Cubical.HITs.Localization
import Cubical.HITs.Nullification
import Cubical.HITs.AssocList


module Scope where

{-

  So this goes through (we don't actually check scope). But what could really
  go wrong? This actually isn't captured by the main theorem, since we're type
  checking multiple definitions. Maybe it should be strengthened.

  Still nothing _bad_ happens here. Could we get some weird circular thing?
  Probably not. The main reason to check scope is to be able to state soundness
  in a reasonable way. So maybe we shouldn't make a big deal of scope.

-}

id : _ -> _
id x = x

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

z = id zero


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

module M-types.Coalg where
    open import M-types.Coalg.Core public
    open import M-types.Coalg.Bisim public
    open import M-types.Coalg.M public


module STLC1.Kovacs.Convertibility where

open import STLC1.Kovacs.Substitution public

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

-- Convertibility (_~_ ; ~refl ; _~⁻¹ ; lam ; app ; β ; η)
infix 3 _∼_
data _∼_ : ∀ {Γ A} → Γ ⊢ A → Γ ⊢ A → Set
  where
    refl∼ : ∀ {Γ A} → {M : Γ ⊢ A}
                    → M ∼ M

    _⁻¹∼  : ∀ {Γ A} → {M₁ M₂ : Γ ⊢ A}
                    → (p : M₁ ∼ M₂)
                    → M₂ ∼ M₁

    _⦙∼_  : ∀ {Γ A} → {M₁ M₂ M₃ : Γ ⊢ A}
                    → (p : M₁ ∼ M₂) (q : M₂ ∼ M₃)
                    → M₁ ∼ M₃

    ƛ∼    : ∀ {Γ A B} → {M₁ M₂ : Γ , A ⊢ B}
                      → (p : M₁ ∼ M₂)
                      → ƛ M₁ ∼ ƛ M₂

    _∙∼_  : ∀ {Γ A B} → {M₁ M₂ : Γ ⊢ A ⇒ B} {N₁ N₂ : Γ ⊢ A}
                      → (p : M₁ ∼ M₂) (q : N₁ ∼ N₂)
                      → M₁ ∙ N₁ ∼ M₂ ∙ N₂

    _,∼_  : ∀ {Γ A B} → {M₁ M₂ : Γ ⊢ A} {N₁ N₂ : Γ ⊢ B}
                      → (p : M₁ ∼ M₂) (q : N₁ ∼ N₂)
                      → M₁ , N₁ ∼ M₂ , N₂

    π₁∼   : ∀ {Γ A B} → {M₁ M₂ : Γ ⊢ A ⩕ B}
                      → (p : M₁ ∼ M₂)
                      → π₁ M₁ ∼ π₁ M₂

    π₂∼   : ∀ {Γ A B} → {M₁ M₂ : Γ ⊢ A ⩕ B}
                      → (p : M₁ ∼ M₂)
                      → π₂ M₁ ∼ π₂ M₂

    red⇒ : ∀ {Γ A B} → (M : Γ , A ⊢ B) (N : Γ ⊢ A)
                      → (ƛ M) ∙ N ∼ cut N M

    red⩕₁ : ∀ {Γ A B} → (M : Γ ⊢ A) (N : Γ ⊢ B)
                      → π₁ (M , N) ∼ M

    red⩕₂ : ∀ {Γ A B} → (M : Γ ⊢ A) (N : Γ ⊢ B)
                      → π₂ (M , N) ∼ N

    exp⇒ : ∀ {Γ A B} → (M : Γ ⊢ A ⇒ B)
                      → M ∼ ƛ (wk M ∙ 0)

    exp⩕  : ∀ {Γ A B} → (M : Γ ⊢ A ⩕ B)
                      → M ∼ π₁ M , π₂ M

    exp⫪ : ∀ {Γ} → (M : Γ ⊢ ⫪)
                  → M ∼ τ

≡→∼ : ∀ {Γ A} → {M₁ M₂ : Γ ⊢ A}
               → M₁ ≡ M₂
               → M₁ ∼ M₂
≡→∼ refl = refl∼

instance
  per∼ : ∀ {Γ A} → PER (Γ ⊢ A) _∼_
  per∼ =
    record
      { _⁻¹ = _⁻¹∼
      ; _⦙_ = _⦙∼_
      }

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

renwk : ∀ {Γ Γ′ A B} → (η : Γ′ ⊇ Γ) (M : Γ ⊢ A)
                     → (wk {B} ∘ ren η) M ≡
                        (ren (liftₑ η) ∘ wk) M
renwk η M = ren○ (wkₑ idₑ) η M ⁻¹
          ⦙ (λ η′ → ren (wkₑ η′) M) & ( rid○ η
                                       ⦙ lid○ η ⁻¹
                                       )
          ⦙ ren○ (liftₑ η) (wkₑ idₑ) M

rencut : ∀ {Γ Γ′ A B} → (η : Γ′ ⊇ Γ) (M : Γ ⊢ A) (N : Γ , A ⊢ B)
                      → (cut (ren η M) ∘ ren (liftₑ η)) N ≡
                         (ren η ∘ cut M) N
rencut η M N = sub◑ (idₛ , ren η M) (liftₑ η) N ⁻¹
             ⦙ (λ σ → sub (σ , ren η M) N) & ( rid◑ η
                                              ⦙ lid◐ η ⁻¹
                                              )
             ⦙ sub◐ η (idₛ , M) N

-- (~ₑ)
ren∼ : ∀ {Γ Γ′ A} → {M₁ M₂ : Γ ⊢ A}
                  → (η : Γ′ ⊇ Γ) → M₁ ∼ M₂
                  → ren η M₁ ∼ ren η M₂
ren∼ η refl∼       = refl∼
ren∼ η (p ⁻¹∼)     = ren∼ η p ⁻¹
ren∼ η (p ⦙∼ q)    = ren∼ η p ⦙ ren∼ η q
ren∼ η (ƛ∼ p)      = ƛ∼ (ren∼ (liftₑ η) p)
ren∼ η (p ∙∼ q)    = ren∼ η p ∙∼ ren∼ η q
ren∼ η (p ,∼ q)    = ren∼ η p ,∼ ren∼ η q
ren∼ η (π₁∼ p)     = π₁∼ (ren∼ η p)
ren∼ η (π₂∼ p)     = π₂∼ (ren∼ η p)
ren∼ η (red⇒ M N) = coe (((ƛ (ren (liftₑ η) M) ∙ ren η N) ∼_)
                          & rencut η N M)
                         (red⇒ (ren (liftₑ η) M) (ren η N))
ren∼ η (red⩕₁ M N) = red⩕₁ (ren η M) (ren η N)
ren∼ η (red⩕₂ M N) = red⩕₂ (ren η M) (ren η N)
ren∼ η (exp⇒ M)   = coe ((λ M′ → ren η M ∼ ƛ (M′ ∙ 0))
                          & renwk η M)
                         (exp⇒ (ren η M))
ren∼ η (exp⩕ M)    = exp⩕ (ren η M)
ren∼ η (exp⫪ M)   = exp⫪ (ren η M)

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


open import Prelude

module MJ.Classtable (c : ℕ) where

open import MJ.Classtable.Core c public


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Surjection
open import Oscar.Data.Proposequality

module Oscar.Class.Smap where

open import Oscar.Class.Hmap public

module Smap
  {𝔵₁ 𝔵₁'} {𝔛₁ : Ø 𝔵₁} {𝔛₁' : Ø 𝔵₁'}
  {𝔵₂ 𝔵₂'} {𝔛₂ : Ø 𝔵₂} {𝔛₂' : Ø 𝔵₂'}
  {𝔯₁₂} {𝔯₁₂'}
  (ℜ₁₂ : 𝔛₁ → 𝔛₂ → Ø 𝔯₁₂)
  (ℜ₁₂' : 𝔛₁' → 𝔛₂' → Ø 𝔯₁₂')
  (p₁ : 𝔛₁ → 𝔛₁')
  (p₂ : 𝔛₂ → 𝔛₂')
  where
  class = Hmap.class ℜ₁₂ (λ x y → ℜ₁₂' (p₁ x) (p₂ y))
  type = ∀ {x y} → ℜ₁₂ x y → ℜ₁₂' (p₁ x) (p₂ y)
  method : ⦃ _ : class ⦄ → type
  method = Hmap.method ℜ₁₂ (λ x y → ℜ₁₂' (p₁ x) (p₂ y)) _ _

module _
  {𝔵₁ 𝔯₁ 𝔵₂ 𝔯₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  {_∼₁_ : 𝔛₁ → 𝔛₁ → Ø 𝔯₁}
  (_∼₂_ : 𝔛₂ → 𝔛₂ → Ø 𝔯₂)
  (μ₁ μ₂ : Surjection.type 𝔛₁ 𝔛₂)
  where
  open Smap _∼₁_ _∼₂_ μ₁ μ₂
  smap⟦_/_/_⟧ : ⦃ _ : class ⦄ → type
  smap⟦_/_/_⟧ = smap

module ≡-Smap
  {𝔵₁ 𝔯₁ 𝔵₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (∼₁ : 𝔛₁ → 𝔛₁ → Ø 𝔯₁)
  (μ₁ μ₂ : Surjection.type 𝔛₁ 𝔛₂)
  = Smap ∼₁ _≡_ μ₁ μ₂

module _
  {𝔵₁ 𝔯₁ 𝔵₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  {_∼₁_ : 𝔛₁ → 𝔛₁ → Ø 𝔯₁}
  (μ₁ μ₂ : Surjection.type 𝔛₁ 𝔛₂)
  where
  open Smap _∼₁_ _≡_ μ₁ μ₂
  ≡-smap⟦_⟧ : ⦃ _ : class ⦄ → type
  ≡-smap⟦_⟧ = smap

module Smap!
  {𝔵₁ 𝔯₁ 𝔵₂ 𝔯₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (∼₁ : 𝔛₁ → 𝔛₁ → Ø 𝔯₁)
  (∼₂ : 𝔛₂ → 𝔛₂ → Ø 𝔯₂)
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  = Smap ∼₁ ∼₂ surjection surjection

module Smaparrow
  {𝔵₁ 𝔵₂ 𝔯 𝔭₁ 𝔭₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  (𝔓₁ : 𝔛₂ → Ø 𝔭₁)
  (𝔓₂ : 𝔛₂ → Ø 𝔭₂)
  (surjection₁ surjection₂ : Surjection.type 𝔛₁ 𝔛₂)
  = Smap ℜ (Arrow 𝔓₁ 𝔓₂) surjection₁ surjection₂

module _
  {𝔵₁ 𝔯 𝔭₁ 𝔭₂} {𝔛₁ : Ø 𝔵₁}
  {ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯}
  {𝔓₁ : 𝔛₁ → Ø 𝔭₁}
  {𝔓₂ : 𝔛₁ → Ø 𝔭₂}
  where
  smaparrow = Smaparrow.method ℜ 𝔓₁ 𝔓₂ ¡ ¡
  infixr 10 _◃_
  _◃_ = smaparrow
  smaparrow[]syntax = _◃_
  syntax smaparrow[]syntax 𝔛₂ x∼y fx = x∼y ◃[ 𝔛₂ ] fx

module Smaparrow!
  {𝔵₁ 𝔵₂ 𝔯 𝔭₁ 𝔭₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  (𝔓₁ : 𝔛₂ → Ø 𝔭₁)
  (𝔓₂ : 𝔛₂ → Ø 𝔭₂)
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  = Smaparrow ℜ 𝔓₁ 𝔓₂ surjection surjection

module Smaphomarrow
  {𝔵₁ 𝔯₁ 𝔵₂ 𝔯₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯₁)
  (𝔓 : 𝔛₂ → Ø 𝔯₂)
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  = Smaparrow ℜ 𝔓 𝔓 surjection surjection

module Smaphomarrow!
  {𝔵₁ 𝔯₁ 𝔵₂ 𝔯₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯₁)
  (𝔓 : 𝔛₂ → Ø 𝔯₂)
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  = Smaphomarrow ℜ 𝔓 surjection


module classify-tests where

open import lib
open import classify
open import syntax-util

test = check-beta-inequiv (mlam "a" (mlam "b" (mvar "a"))) (mlam "a" (mlam "b" (mvar "b")))


open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

_ : 10_000 * 100_000 ≡ 1_000_000_000
_ = refl


------------------------------------------------------------------------------
-- Testing the erasing of proof terms
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module ProofTerm2 where

postulate
  D   : Set
  N   : D → Set
  _≡_ : D → D → Set

postulate foo : ∀ {m n} → (Nm : N m) → (Nn : N n) → m ≡ m
{-# ATP prove foo #-}


module _ where

module M (A : _) where

  y = Set -- type of A is solved if this is removed

  x : Set
  x = A

-- WAS: yellow on type of A
-- SHOULD: succeed


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

open import lib.Base

module test.succeed.Test1 where

module _ where

  private
    data #I : Type₀ where
      #zero : #I
      #one : #I

  I : Type₀
  I = #I

  zero : I
  zero = #zero

  one : I
  one = #one

  postulate
    seg : zero == one

absurd : zero ≠ one
absurd ()


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

module Harmony where

open import Data.Bool       using (Bool; true; false; if_then_else_; _∨_; not; _∧_)
open import Data.Fin        using (#_; toℕ) renaming (zero to fz; suc to fs)
open import Data.List       using (List; map; []; _∷_; concatMap; foldr; head; zip; null)
open import Data.Maybe      using (fromMaybe; is-nothing; Maybe; just; nothing)
open import Data.Nat        using (ℕ; suc; _∸_; _<ᵇ_)
open import Data.Nat.DivMod using (_mod_; _div_)
open import Data.Product    using (_×_; _,_; proj₁; proj₂; uncurry)
open import Data.Vec        using (Vec; toList; []; _∷_)
open import Function        using (_∘_)

open import BitVec          using (BitVec; empty; insert; elements; _∩_; _∈_)
open import Counterpoint
open import Diatonic        using (DiatonicDegree; thirdUp; _≡ᵈ_; degree→PC; major; pitch→DegreeCMajor)
open import Interval
open import Music
open import Note
open import Pitch           hiding (I)
open import Util            using (filter; concatMaybe)

-- either 0 or 1 pitch class
pointToPC : Point → List PC
pointToPC (tone p) = pitchToClass p ∷ []
pointToPC (hold p) = pitchToClass p ∷ []
pointToPC rest     = []

chordToPCes : {n : ℕ} → Chord n → List PC
chordToPCes (chord ps) = concatMap pointToPC (toList ps)

pitchClassListToSet : List PC → PCSet
pitchClassListToSet = foldr insert empty

pitchClassSetToList : PCSet → List PC
pitchClassSetToList ps = fn 0 (toList ps)
  where fn : ℕ → List Bool → List PC
        fn i []           = []
        fn i (false ∷ bs) = fn (suc i) bs
        fn i (true  ∷ bs) = i mod s12 ∷ fn (suc i) bs

-- Primary chords, assuming the tonic is pitch class 0.

I-maj I-min IV-maj V-maj : PCSet

I-maj  = pitchClassListToSet (# 0 ∷ # 4 ∷ # 7  ∷ [])
I-min  = pitchClassListToSet (# 0 ∷ # 3 ∷ # 7  ∷ [])
IV-maj = pitchClassListToSet (# 0 ∷ # 5 ∷ # 9  ∷ [])
V-maj  = pitchClassListToSet (# 2 ∷ # 7 ∷ # 11 ∷ [])

-- Triads, without quality
data Triad : Set where
  I   : Triad
  II  : Triad
  III : Triad
  IV  : Triad
  V   : Triad
  VI  : Triad
  VII : Triad

--data Triad : Set where
--  I : Triad; II : Triad; III : Triad; IV : Triad; V : Triad; VI : Triad; VII : Triad

allTriads : List Triad
allTriads = I ∷ II ∷ III ∷ IV ∷ V ∷ VI ∷ VII ∷ []

triadRoot : Triad → DiatonicDegree
triadRoot I   = (# 0)
triadRoot II  = (# 1)
triadRoot III = (# 2)
triadRoot IV  = (# 3)
triadRoot V   = (# 4)
triadRoot VI  = (# 5)
triadRoot VII = (# 6)

rootTriad : DiatonicDegree → Triad
rootTriad fz                                 = I
rootTriad ((fs fz))                          = II
rootTriad ((fs (fs fz)))                     = III
rootTriad ((fs (fs (fs fz))))                = IV
rootTriad ((fs (fs (fs (fs fz)))))           = V
rootTriad ((fs (fs (fs (fs (fs fz))))))      = VI
rootTriad ((fs (fs (fs (fs (fs (fs fz))))))) = VII

triadDegrees : Triad → Vec DiatonicDegree 3
triadDegrees t =
  let root = triadRoot t
      third = thirdUp root
      fifth = thirdUp third
  in root ∷ third ∷ fifth ∷ []

infix 4 _≡ᵗ_
_≡ᵗ_ : Triad → Triad → Bool
t ≡ᵗ u = triadRoot t ≡ᵈ triadRoot u

TriadSet : Set
TriadSet = BitVec s7

triadListToSet : List Triad → TriadSet
triadListToSet []       = empty
triadListToSet (t ∷ ts) = insert (triadRoot t) (triadListToSet ts)

triadSetToList : TriadSet → List Triad
triadSetToList ts = map rootTriad (elements ts)

containingTriads : DiatonicDegree → List Triad
containingTriads fz                                 = I   ∷ IV  ∷ VI  ∷ []
containingTriads ((fs fz))                          = II  ∷ V   ∷ VII ∷ []
containingTriads ((fs (fs fz)))                     = III ∷ VI  ∷ I   ∷ []
containingTriads ((fs (fs (fs fz))))                = IV  ∷ VII ∷ II  ∷ []
containingTriads ((fs (fs (fs (fs fz)))))           = V   ∷ I   ∷ III ∷ []
containingTriads ((fs (fs (fs (fs (fs fz))))))      = VI  ∷ II  ∷ IV  ∷ []
containingTriads ((fs (fs (fs (fs (fs (fs fz))))))) = VII ∷ III ∷ V   ∷ []

-- from Table of Usual Root Progressions (Major Mode), Harmony (Piston 5e), page 23
record NextTriad : Set where
  constructor nextTriad
  field
    usual     : List Triad
    sometimes : List Triad
    rare      : List Triad
open NextTriad

rootProgression : Triad → NextTriad
rootProgression I   = nextTriad (IV ∷ V   ∷ []) (VI       ∷ []) (II  ∷ III     ∷ [])
rootProgression II  = nextTriad (V        ∷ []) (IV  ∷ VI ∷ []) (I   ∷ III     ∷ [])
rootProgression III = nextTriad (VI       ∷ []) (IV       ∷ []) (I   ∷ II  ∷ V ∷ [])
rootProgression IV  = nextTriad (V        ∷ []) (I   ∷ II ∷ []) (III ∷ VI      ∷ [])
rootProgression V   = nextTriad (I        ∷ []) (IV  ∷ VI ∷ []) (II  ∷ III     ∷ [])
rootProgression VI  = nextTriad (II ∷ V   ∷ []) (III ∷ IV ∷ []) (I             ∷ [])
rootProgression VII = nextTriad (I  ∷ III ∷ []) (VI       ∷ []) (II  ∷ IV  ∷ V ∷ [])

previousTriads : Triad → List Triad
previousTriads I   = V ∷ IV ∷ VII ∷ []
previousTriads II  = VI ∷ IV ∷ []
previousTriads III = VI ∷ VII ∷ []
previousTriads IV  = I ∷ V ∷ II ∷ III ∷ []
previousTriads V   = I ∷ IV ∷ II ∷ VI ∷ []
previousTriads VI  = IV ∷ I ∷ II ∷ V ∷ VII ∷ []
previousTriads VII = []

harmonizations : {n : ℕ} → Vec DiatonicDegree n → List (Vec Triad n)
harmonizations [] = []
harmonizations (d ∷ []) = map (_∷ []) (containingTriads d)
harmonizations (d ∷ d' ∷ ds) =
  let tss = harmonizations (d' ∷ ds)
      dTriads  = containingTriads d
  in concatMap (λ t → concatMaybe (map (prependTriad t) tss)) dTriads
  where
    prevOk : Triad → Triad → Bool
    prevOk t x = (triadRoot t) ∈ triadListToSet (previousTriads x)
    prependTriad : {n : ℕ} → Triad → Vec Triad (suc n) → Maybe (Vec Triad (suc (suc n)))
    prependTriad t ts = if prevOk t (Data.Vec.head ts) then just (t ∷ ts) else nothing

halfCadence : {n : ℕ} → Vec Triad n → Bool
halfCadence []           = false
halfCadence (t ∷ [])     = t ≡ᵗ V
halfCadence (_ ∷ t ∷ ts) = halfCadence (t ∷ ts)

-- Given a pitch p and a diatontic degree d, return a pitch that
-- has degree d and is 1-2 octaves lower than p.
pitchLower : Pitch → DiatonicDegree → Pitch
pitchLower p d =
  let (c , o) = absoluteToRelative p
      c'      = degree→PC major d
  in relativeToAbsolute (c' , o ∸ 2)

-- Given a soporano voice s a pitch and the other voices
-- as diatonic degrees of a major scale, voice the
-- accompaniment in close position.
voiceChord : Pitch → Vec DiatonicDegree 3 → Vec Pitch 3
voiceChord s (a ∷ t ∷ b ∷ [])  =
  let (s' , o) = absoluteToRelative s
      a'       = degree→PC major a
      t'       = degree→PC major t
      b'       = degree→PC major b
      ao       = downOctave a' s' o
      to       = downOctave t' a' ao
      bo       = downOctave b' t' to
  in relativeToAbsolute (a' , ao) ∷
     relativeToAbsolute (t' , to) ∷
     relativeToAbsolute (b' , bo) ∷ []
  where downOctave : PC → PC → Octave → Octave
        downOctave pc₁ pc₂ o =
          if toℕ pc₁ <ᵇ toℕ pc₂ then o
          else (o ∸ 1)

-- Given a soprano pitch p and a triad harmonization t,
-- generate a list of possible bass notes.
-- Assumes p is in t. Only the root of the triad is
-- allowed to be doubled.
-- Each bass note is pitched 1-2 octaves below p.
bassNotes : Pitch → Triad → List Pitch
bassNotes p t =
  let sop  = pitch→DegreeCMajor p
      root = triadRoot t
      ds   = toList (triadDegrees t)
      ds'  = filter (λ d → (sop ≡ᵈ root) ∨ not (sop ≡ᵈ d)) ds
  in map (pitchLower p) ds'

-- Given a soprano pitch p and a triad harmonization t,
-- generate a harmonizing chord in root position.
-- Assumes p is in t. Only the root of the triad is
-- allowed to be doubled.
-- Each bass note is pitched 1-2 octaves below p.
-- Alto and Tenor fit inside.
-- Currently root or third is preferred for alto.
harmonizingChord : Pitch → Triad → Vec Pitch 3
harmonizingChord p t =
  let sop   = pitch→DegreeCMajor p
      root  = triadRoot t
      third = thirdUp root
      fifth = thirdUp third
      alto  = if sop ≡ᵈ root then third else root
      tenor = if sop ≡ᵈ fifth then third else fifth
  in voiceChord p (alto ∷ tenor ∷ root ∷ [])
  where
    remove : DiatonicDegree → Vec DiatonicDegree 3 → Vec DiatonicDegree 2
    remove sop (d ∷ d₁ ∷ d₂ ∷ []) =
      if d ≡ᵈ sop then d₁ ∷ d₂ ∷ []
      else (if d₁ ≡ᵈ sop then d ∷ d₂ ∷ [] else d ∷ d₁ ∷ [])

-- Create 4 part harmonizations ending in V for a melody in C major.
voicedHarmonizations : {n : ℕ} → Vec Pitch n → List (Vec (Vec Pitch 4) n)
voicedHarmonizations {n} ps =
  let ds = Data.Vec.map pitch→DegreeCMajor ps
      hs : List (Vec Triad n)
      hs = filter halfCadence (harmonizations ds)
  in map (λ ts → Data.Vec.map (λ pt → proj₁ pt ∷ harmonizingChord (proj₁ pt) (proj₂ pt))
                              (Data.Vec.zip ps ts)) hs

-- Check interval between each pair of voices.
intervalsOkFilter : Vec Pitch 4 → Bool
intervalsOkFilter (s ∷ a ∷ t ∷ b ∷ []) =
  null (concatMaybe (map (intervalCheck ∘ toPitchInterval)
--                         ((s , a) ∷ (s , t) ∷ (s , b) ∷ (a , t) ∷ (a , b) ∷ (t , b) ∷ [])))
                         ((s , a) ∷ (s , b) ∷ (s , t) ∷ [])))

filterIntervalsOk : {n : ℕ} → List (Vec (Vec Pitch 4) n) → List (Vec (Vec Pitch 4) n)
filterIntervalsOk xs =
  let f : List (Vec Pitch 4) → Bool
      f xs = foldr _∧_ true (map intervalsOkFilter xs)
  in filter (f ∘ toList) xs

motionErrors : {n : ℕ} → Vec (Vec Pitch 4) n → List MotionError
motionErrors xs =
  let ss = Data.Vec.map (Data.Vec.head) xs
      as = Data.Vec.map (Data.Vec.head ∘ Data.Vec.tail) xs
      ts = Data.Vec.map (Data.Vec.head ∘ Data.Vec.tail ∘ Data.Vec.tail) xs
      bs = Data.Vec.map (Data.Vec.head ∘ Data.Vec.tail ∘ Data.Vec.tail ∘ Data.Vec.tail) xs

      sas = map toPitchInterval (toList (Data.Vec.zip as ss))
      sts = map toPitchInterval (toList (Data.Vec.zip ts ss))
      sbs = map toPitchInterval (toList (Data.Vec.zip bs ss))
      ats = map toPitchInterval (toList (Data.Vec.zip ts as))
      abs = map toPitchInterval (toList (Data.Vec.zip bs as))
      tbs = map toPitchInterval (toList (Data.Vec.zip bs ts))
  in concatMap checkMotion (sas ∷ sts ∷ sbs ∷ ats ∷ abs ∷ tbs ∷ [])

--filterSBMotionOk : {n : ℕ} → List (Vec (Vec Pitch 4) n) → List (Vec (Vec Pitch 4) n)
--filterSBMotionOk = filter motionOkFilter

-- Given a soprano line with harmonization, generate
-- a list of possible bass lines 1-1 with soprano notes.
-- The SB counterpoint must satisfy 1st species
-- interval and motion rules.
bassLines : List (Pitch × Triad) → List (List Pitch)
-- We need to make the base case a singleton list of an empty list for
-- the general case to work. Possibly look into modifying the general
-- case to handle a base case of an empty list.
bassLines [] = [] ∷ []
bassLines ((sop , triad) ∷ pts) =
  let pss = bassLines pts
      basses  = bassNotes sop triad
      intervalOkSBs : List PitchInterval -- list of bass notes with interval (to sop) that pass intervalCheck
      intervalOkSBs = filter (is-nothing ∘ intervalCheck) (map (toPitchInterval ∘ (_, sop)) basses)
      intervalOkBs = map proj₁ intervalOkSBs
      intervalOkBassLines = concatMap (λ ps → (map (_∷ ps) intervalOkBs)) pss
  in filter (mCheck sop (Data.Maybe.map proj₁ (head pts))) intervalOkBassLines
  where
    -- Given a soprano pitch, possibly a second soprano pitch and a list of
    -- bass pitches, if the second soprano pitch exists and there are at
    -- least two bass pitches, check that the motion from the first SB pair to
    -- the second is allowed. If there aren't two SB pairs, return true.
    mCheck : Pitch → Maybe Pitch → List Pitch → Bool
    mCheck _ nothing  _               = true
    mCheck _ (just _) []              = true
    mCheck _ (just _) (_ ∷ [])        = true
    mCheck s₁ (just s₂) (b₁ ∷ b₂ ∷ _) =
      let sb₁ = toPitchInterval (b₁ , s₁)
          sb₂ = toPitchInterval (b₂ , s₂)
      in (is-nothing ∘ uncurry motionCheck) (sb₁ , sb₂)

-- Given a soprano line with harmonization, generate
-- a list of possible triads 1-1 with soprano notes.
-- All pairwise counterpoint must satisfy 1st species
-- interval and motion rules.
chordProg : List (Pitch × Triad) → List (List Pitch)
-- We need to make the base case a singleton list of an empty list for
-- the general case to work. Possibly look into modifying the general
-- case to handle a base case of an empty list.
chordProg [] = [] ∷ []
chordProg ((sop , triad) ∷ pts) =
  let pss = chordProg pts
      basses  = bassNotes sop triad
      intervalOkSBs : List PitchInterval -- list of bass notes with interval (to sop) that pass intervalCheck
      intervalOkSBs = filter (is-nothing ∘ intervalCheck) (map (toPitchInterval ∘ (_, sop)) basses)
      intervalOkBs = map proj₁ intervalOkSBs
      intervalOkBassLines = concatMap (λ ps → (map (_∷ ps) intervalOkBs)) pss
  in filter (mCheck sop (Data.Maybe.map proj₁ (head pts))) intervalOkBassLines
  where
    -- Given a soprano pitch, possibly a second soprano pitch and a list of
    -- bass pitches, if the second soprano pitch exists and there are at
    -- least two bass pitches, check that the motion from the first SB pair to
    -- the second is allowed. If there aren't two SB pairs, return true.
    mCheck : Pitch → Maybe Pitch → List Pitch → Bool
    mCheck _ nothing  _               = true
    mCheck _ (just _) []              = true
    mCheck _ (just _) (_ ∷ [])        = true
    mCheck s₁ (just s₂) (b₁ ∷ b₂ ∷ _) =
      let sb₁ = toPitchInterval (b₁ , s₁)
          sb₂ = toPitchInterval (b₂ , s₂)
      in (is-nothing ∘ uncurry motionCheck) (sb₁ , sb₂)


module Issue1760g where

data ⊥ : Set where

{-# NO_POSITIVITY_CHECK #-}
{-# NON_TERMINATING     #-}
mutual
  record U : Set where
    constructor roll
    field ap : U → U

  lemma : U → ⊥
  lemma (roll u) = lemma (u (roll u))

  bottom : ⊥
  bottom = lemma (roll λ x → x)


module Issue477b where

record D where
  field A : Set


module Thesis.SIRelBigStep.IlcSILR where

open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Thesis.SIRelBigStep.Lang public
open import Thesis.SIRelBigStep.DLang public

open import Thesis.SIRelBigStep.ArithExtra public

rrelT3-skeleton :
  ∀ {τ Γ} →
  ((v1 : Val τ) → (dv : DVal τ) → (v2 : Val τ) → (k : ℕ) → Set) →
  (t1 : Term Γ τ) (dt : DTerm Γ τ) (t2 : Term Γ τ)
  (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) →
  ℕ → Set
rrelT3-skeleton {τ} ternary-rel t1 dt t2 ρ1 dρ ρ2 k =
  (v1 v2 : Val τ) →
  ∀ j (j<k : j < k) →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t1 ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t2 ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ dt ↓ dv ×
  ternary-rel v1 dv v2 (k ∸ j)

mutual
  rrelT3 : ∀ {τ Γ} (t1 : Term Γ τ) (dt : DTerm Γ τ) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  rrelT3 {τ} = rrelT3-skeleton (rrelV3 τ)

  rrelV3 : ∀ τ (v1 : Val τ) (dv : DVal τ) (v2 : Val τ) → (n : ℕ) → Set
  -- Making this case first ensures rrelV3 splits on its second argument, hence
  -- that all its equations hold definitionally.
  rrelV3 τ v1 (bang v2) v2' n = v2 ≡ v2'
  rrelV3 nat (natV v1) (dnatV dv) (natV v2) n = dv + v1 ≡ v2
  rrelV3 (σ ⇒ τ) (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ dρ) (closure {Γ2} t2 ρ2) n =
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ρ1 ≡ ρ ×
        ρ1 ⊕ρ dρ ≡ ρ2 ×
        t1 ≡ t2 ×
        dt ≡ derive-dterm t1 ×
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        rrelV3 σ v1 dv v2 k →
        rrelT3
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
          k
      }
  rrelV3 (pair τ1 τ2) (pairV va1 vb1) (dpairV dva dvb) (pairV va2 vb2) n =
    rrelV3 τ1 va1 dva va2 n × rrelV3 τ2 vb1 dvb vb2 n

rrelV3→⊕ : ∀ {τ n} v1 dv v2 → rrelV3 τ v1 dv v2 n → v1 ⊕ dv ≡ v2
rrelV3→⊕ v1 (bang v2) v2' vv = vv
rrelV3→⊕ (closure {Γ} t ρ) (dclosure .(derive-dterm t) .ρ dρ) (closure .t .(ρ ⊕ρ dρ)) ((refl , refl) , refl , refl , refl , refl , dvv) with Γ ≟Ctx Γ | ≟Ctx-refl Γ
... | .(yes refl) | refl = refl
rrelV3→⊕ (natV n) (dnatV dn) (natV .(dn + n)) refl rewrite +-comm n dn = refl
rrelV3→⊕ (pairV va1 vb1) (dpairV dva dvb) (pairV va2 vb2) (vaa , vbb) rewrite rrelV3→⊕  va1 dva va2 vaa | rrelV3→⊕ vb1 dvb vb2 vbb = refl

rrelρ3 : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
rrelρ3 ∅ ∅ ∅ ∅ n = ⊤
rrelρ3 (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) n = rrelV3 τ v1 dv v2 n × rrelρ3 Γ ρ1 dρ ρ2 n

rrelρ3→⊕ : ∀ {Γ n} ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → ρ1 ⊕ρ dρ ≡ ρ2
rrelρ3→⊕ ∅ ∅ ∅ tt = refl
rrelρ3→⊕ (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) rewrite rrelV3→⊕ v1 dv v2 vv | rrelρ3→⊕ ρ1 dρ ρ2 ρρ = refl

rrelV3-mono : ∀ m n → m ≤ n → ∀ τ v1 dv v2 → rrelV3 τ v1 dv v2 n → rrelV3 τ v1 dv v2 m
rrelV3-mono m n m≤n τ v1 (bang v2) v2′ vv = vv
rrelV3-mono m n m≤n (σ ⇒ τ) (closure t ρ) (dclosure dt ρ₁ dρ) (closure t₁ ρ₂)
  -- Validity
  ((refl , refl) , refl , refl , refl , refl , vv) =
  (refl  , refl) , refl , refl , refl , refl , λ k k<m → vv k (≤-trans k<m m≤n)
rrelV3-mono m n m≤n nat (natV n₁) (dnatV n₂) (natV n₃) vv = vv
rrelV3-mono m n m≤n (pair τ1 τ2) (pairV va1 vb1) (dpairV dva dvb) (pairV va2 vb2) (vaa , vbb) =
  rrelV3-mono m n m≤n τ1 va1 dva va2 vaa , rrelV3-mono m n m≤n τ2 vb1 dvb vb2 vbb

rrelρ3-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → rrelρ3 Γ ρ1 dρ ρ2 m
rrelρ3-mono m n m≤n ∅ ∅ ∅ ∅ tt = tt
rrelρ3-mono m n m≤n (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) = rrelV3-mono m n m≤n _ v1 dv v2 vv , rrelρ3-mono m n m≤n Γ ρ1 dρ ρ2 ρρ

⟦_⟧RelVar3 : ∀ {Γ τ n} (x : Var Γ τ) {ρ1 dρ ρ2} →
  rrelρ3 Γ ρ1 dρ ρ2 n →
  rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
⟦ this ⟧RelVar3   {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = vv
⟦ that x ⟧RelVar3 {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = ⟦ x ⟧RelVar3 ρρ

-- Direct analogue of rrelV3→⊕ for rrelT3: simply say that the resulting values
-- are related.
-- Alternatively, one could try internalizing ⊕ and giving some term equivalence, but it does not seem worthwhile.
rrelT3→⊕ : ∀ {τ Γ k}
  (t1 : Term Γ τ) (dt : DTerm Γ τ) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) →
  rrelT3 {τ} t1 dt t2 ρ1 dρ ρ2 k →
  rrelT3-skeleton (λ v1 dv v2 _ → v1 ⊕ dv ≡ v2) t1 dt t2 ρ1 dρ ρ2 k
rrelT3→⊕ t1 dt t2 ρ1 dρ ρ2 ttrel v1 v2 j j<k ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 with ttrel v1 v2 j j<k ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dv , ↓dv , vv = dv , ↓dv , rrelV3→⊕ v1 dv v2 vv


record R (A : Set) : Set where
  constructor c₂
  field
    f : A → A

open module R′ (A : Set) (r : R A) = R {A = A} r
  renaming (f to f′)

_ : (@0 A : Set) → R A → A → A
_ = λ A → f′ {A = A}


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.IdPi {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening as T hiding (wk; wkTerm; wkEqTerm)
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Weakening
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Irrelevance as S
open import Definition.LogicalRelation.Substitution.Reflexivity
open import Definition.LogicalRelation.Substitution.Introductions.Sigma
open import Definition.LogicalRelation.Substitution.Introductions.Fst
open import Definition.LogicalRelation.Substitution.Introductions.Snd
open import Definition.LogicalRelation.Substitution.Introductions.Pi
open import Definition.LogicalRelation.Substitution.Introductions.Lambda
open import Definition.LogicalRelation.Substitution.Introductions.Application
open import Definition.LogicalRelation.Substitution.Introductions.Cast
open import Definition.LogicalRelation.Substitution.Introductions.Id
open import Definition.LogicalRelation.Substitution.Introductions.IdUPiPi
open import Definition.LogicalRelation.Substitution.Introductions.Transp
open import Definition.LogicalRelation.Substitution.Introductions.SingleSubst
open import Definition.LogicalRelation.Substitution.MaybeEmbed
open import Definition.LogicalRelation.Substitution.Introductions.Universe
open import Definition.LogicalRelation.Substitution.Reduction
open import Definition.LogicalRelation.Substitution.Weakening
open import Definition.LogicalRelation.Substitution.Conversion
open import Definition.LogicalRelation.Substitution.ProofIrrelevance
open import Definition.LogicalRelation.Fundamental.Variable

open import Tools.Product
import Tools.PropositionalEquality as PE

abstract
  Id-Πᵗᵛ : ∀ {A B rA lA lB l Γ t u} ([Γ] : ⊩ᵛ Γ)
           → lA ≤ l
           → lB ≤ l →
             let [UA] = maybeEmbᵛ {A = Univ rA _} [Γ] (Uᵛ (proj₂ (levelBounded lA)) [Γ])
             in
             ([A] : Γ ⊩ᵛ⟨ ∞ ⟩ A ^ [ rA , ι lA ] / [Γ])
             ([UB] : Γ ∙ A ^ [ rA , ι lA ] ⊩ᵛ⟨ ∞ ⟩ Univ ! lB ^ [ ! , next lB ] / [Γ] ∙ [A])
             ([A]ₜ : Γ ⊩ᵛ⟨ ∞ ⟩ A ∷ Univ rA lA ^ [ ! , next lA ] / [Γ] / [UA])
             ([B]ₜ : Γ ∙ A ^ [ rA , ι lA ] ⊩ᵛ⟨ ∞ ⟩ B ∷ Univ ! lB ^ [ ! , next lB ] / [Γ] ∙ [A] / (λ {Δ} {σ} → [UB] {Δ} {σ}))
             ([ΠAB] : Γ ⊩ᵛ⟨ ∞ ⟩ Π A ^ rA ° lA ▹ B ° lB ° l ^ [ ! , ι l ] / [Γ])
             ([t]ₜ : Γ ⊩ᵛ⟨ ∞ ⟩ t ∷ Π A ^ rA ° lA ▹ B ° lB ° l ^ [ ! , ι l ] / [Γ] / [ΠAB]) →
             ([u]ₜ : Γ ⊩ᵛ⟨ ∞ ⟩ u ∷ Π A ^ rA ° lA ▹ B ° lB ° l ^ [ ! , ι l ] / [Γ] / [ΠAB]) →
             [ Γ ⊩ᵛ⟨ ∞ ⟩ Id (Π A ^ rA ° lA ▹ B ° lB ° l) t u ≡ Π A ^ rA ° lA ▹ (Id B ((wk1 t) ∘ (var 0) ^ l) ((wk1 u) ∘ (var 0) ^ l)) ° lB ° l ∷ SProp l ^ [ ! , next l ]  / [Γ] ]

  Id-Πᵗᵛ {A} {B} {rA} {lA} {lB} {l} {Γ} {t} {u} [Γ] lA≤ lB≤
            [A] [UB] [A]ₜ [B]ₜ [ΠAB] [t]ₜ [u]ₜ =
    let [SProp] = maybeEmbᵛ {A = Univ _ _} [Γ] (Uᵛ {rU = %} (proj₂ (levelBounded l)) [Γ])
        [UA] = maybeEmbᵛ {A = Univ rA _} [Γ] (Uᵛ (proj₂ (levelBounded lA)) [Γ])
        [ΓA] = _∙_ {A = A} [Γ] [A]
        ⊢AₜΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UA] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([A]ₜ ⊢Δ [σ]))
        [B] = maybeEmbᵛ {A = B} [ΓA] (univᵛ {A = B} [ΓA] (≡is≤ PE.refl) (λ {Δ} {σ} → [UB] {Δ} {σ}) [B]ₜ)
        ⊢BΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([UB] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([B]ₜ ⊢Δ [σ]))
        ⊢tΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([ΠAB] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([t]ₜ ⊢Δ [σ]))
        ⊢uΔ = λ {Δ} {σ} ⊢Δ [σ] → escapeTerm (proj₁ ([ΠAB] {Δ} {σ} ⊢Δ [σ])) (proj₁ ([u]ₜ ⊢Δ [σ]))
        Id-Π-res = λ A B → Π A ^ rA ° lA ▹ (Id B ((wk1 t) ∘ (var 0) ^ l ) ((wk1 u) ∘ (var 0) ^ l)) ° lB ° l
        [liftσ] = λ {Δ} {σ} ⊢Δ [σ] → liftSubstS {F = A} {σ = σ} {Δ  = Δ} [Γ] ⊢Δ [A] [σ]
        ⊢AΔ = λ {Δ} {σ} ⊢Δ [σ] → escape (proj₁ ([A] {Δ  = Δ} {σ = σ} ⊢Δ [σ]))
        [SPropB] = maybeEmbᵛ {A = SProp lB} [ΓA] (λ {Δ} {σ} → Uᵛ <next [ΓA] {Δ} {σ})
        [wA] = wk1ᵛ {A = A} {F = A} [Γ] [A] [A]
        [wΠ] = wk1ᵛ {A =  Π A ^ rA ° lA ▹ B ° lB ° l} {F = A} [Γ] [A] [ΠAB]
        [wt] = wk1Termᵛ {F = A} {G = Π A ^ rA ° lA ▹ B ° lB ° l} {t = t} [Γ] [A] [ΠAB] [t]ₜ
        [wu] = wk1Termᵛ {F = A} {G = Π A ^ rA ° lA ▹ B ° lB ° l} {t = u} [Γ] [A] [ΠAB] [u]ₜ
        [Id-Π] : Γ ⊩ᵛ Id (Π A ^ rA ° lA ▹ B ° lB ° l) t u ⇒ Id-Π-res A B ∷ SProp l ^ next l / [Γ]
        [Id-Π] = λ {Δ} {σ} ⊢Δ [σ] →
                   PE.subst (λ ret → Δ ⊢ Id (Π (subst σ A) ^ rA ° lA ▹ (subst (liftSubst σ) B) ° lB ° l) (subst σ t) (subst σ u) ⇒ Π subst σ A ^ rA ° lA ▹ ret ° lB ° l ∷ SProp l ^ next l)
                            (PE.cong₂ (λ a b → Id (subst (liftSubst σ) B) (a ∘ (var 0) ^ l) (b ∘ (var 0) ^ l)) (PE.sym (Idsym-subst-lemma σ t)) (PE.sym (Idsym-subst-lemma σ u)))
                            (Id-Π {A = subst σ A} {rA} {lA} {lB} {l} {subst (liftSubst σ) B} {subst σ t} {subst σ u} lA≤ lB≤
                                  (⊢AₜΔ {Δ} {σ} ⊢Δ [σ]) (⊢BΔ (⊢Δ ∙ ⊢AΔ {Δ} {σ} ⊢Δ [σ]) ([liftσ] {Δ} {σ} ⊢Δ [σ])) (⊢tΔ {Δ} {σ} ⊢Δ [σ]) (⊢uΔ {Δ} {σ} ⊢Δ [σ]))
        [UB'] = maybeEmbᵛ {l = next lB} {A = U _} [ΓA] (λ {Δ} {σ} → Uᵛ <next [ΓA] {Δ} {σ})
        [Id-Π-res] : Γ ⊩ᵛ⟨ ∞ ⟩ Id-Π-res A B ∷ SProp l ^ [ ! , next l ] / [Γ] / [SProp]
        [Id-Π-res] = Πᵗᵛ {F = A} {G = Id B ((wk1 t) ∘ (var 0) ^ l) ((wk1 u) ∘ (var 0) ^ l)} lA≤ lB≤ [Γ] [A] (λ {Δ} {σ} → [SPropB] {Δ} {σ}) [A]ₜ
                         (Idᵗᵛ {A = B} {t = (wk1 t) ∘ (var 0) ^ l} {u = (wk1 u) ∘ (var 0) ^ l} [ΓA] [B]
                            (S.irrelevanceTerm′ {A = (wk1d B) [ var 0 ]} {A′ = B} {t = (wk1 t) ∘ (var 0) ^ l}
                                                (wkSingleSubstId B) PE.refl [ΓA] [ΓA]
                                                (substSΠ {wk1 A} {wk1d B} {var 0} [ΓA] [wA] [wΠ] (proj₂ (fundamentalVar here [ΓA]))) [B]
                                                (appᵛ {F = wk1 A} {G = wk1d B} {t = wk1 t} {u = var 0} [ΓA] [wA] [wΠ] [wt] (proj₂ (fundamentalVar here [ΓA]))))
                            (S.irrelevanceTerm′ {A = (wk1d B) [ var 0 ]} {A′ = B} {t = (wk1 u) ∘ (var 0) ^ l}
                                                (wkSingleSubstId B) PE.refl [ΓA] [ΓA]
                                                (substSΠ {wk1 A} {wk1d B} {var 0} [ΓA] [wA] [wΠ] (proj₂ (fundamentalVar here [ΓA]))) [B]
                                                (appᵛ {F = wk1 A} {G = wk1d B} {t = wk1 u} {u = var 0} [ΓA] [wA] [wΠ] [wu] (proj₂ (fundamentalVar here [ΓA]))))
                            (S.irrelevanceTerm {A = Univ _ _} {t = B} [ΓA] [ΓA] (λ {Δ} {σ} → [UB] {Δ} {σ}) (λ {Δ} {σ} → [UB'] {Δ} {σ}) [B]ₜ))
        [id] , [eq] = redSubstTermᵛ {SProp l} {Id (Π A ^ rA ° lA ▹ B ° lB ° l) t u} {Id-Π-res A B}
                                    [Γ] (λ {Δ} {σ} ⊢Δ [σ] → [Id-Π] {Δ} {σ} ⊢Δ [σ])
                                    [SProp] [Id-Π-res]
    in modelsTermEq [SProp] [id] [Id-Π-res] [eq]


{-# OPTIONS --rewriting #-}

module Properties.TypeSaturation where

open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.Either using (Either; Left; Right)
open import Luau.Subtyping using (Tree; Language; ¬Language; _<:_; _≮:_; witness; scalar; function; function-err; function-ok; function-ok₁; function-ok₂; scalar-function; _,_; never)
open import Luau.Type using (Type; _⇒_; _∩_; _∪_; never; unknown)
open import Luau.TypeNormalization using (_∩ⁿ_; _∪ⁿ_)
open import Luau.TypeSaturation using (_⋓_; _⋒_; _∩ᵘ_; _∩ⁱ_; ∪-saturate; ∩-saturate; saturate)
open import Properties.Subtyping using (dec-language; language-comp; <:-impl-⊇; <:-refl; <:-trans; <:-trans-≮:; <:-impl-¬≮: ; <:-never; <:-unknown; <:-function; <:-union; <:-∪-symm; <:-∪-left; <:-∪-right; <:-∪-lub; <:-∪-assocl; <:-∪-assocr; <:-intersect; <:-∩-symm; <:-∩-left; <:-∩-right; <:-∩-glb; ≮:-function-left; ≮:-function-right; <:-function-∩-∪; <:-function-∩-∩; <:-∩-assocl; <:-∩-assocr; ∩-<:-∪; <:-∩-distl-∪; ∩-distl-∪-<:; <:-∩-distr-∪; ∩-distr-∪-<:)
open import Properties.TypeNormalization using (Normal; FunType; _⇒_; _∩_; _∪_; never; unknown; normal-∪ⁿ; normal-∩ⁿ; ∪ⁿ-<:-∪; ∪-<:-∪ⁿ; ∩ⁿ-<:-∩; ∩-<:-∩ⁿ)
open import Properties.Contradiction using (CONTRADICTION)
open import Properties.Functions using (_∘_)

-- Saturation preserves normalization
normal-⋒ : ∀ {F G} → FunType F → FunType G → FunType (F ⋒ G)
normal-⋒ (R ⇒ S) (T ⇒ U) = (normal-∩ⁿ R T) ⇒ (normal-∩ⁿ S U)
normal-⋒ (R ⇒ S) (G ∩ H) = normal-⋒ (R ⇒ S) G ∩ normal-⋒ (R ⇒ S) H
normal-⋒ (E ∩ F) G = normal-⋒ E G ∩ normal-⋒ F G

normal-⋓ : ∀ {F G} → FunType F → FunType G → FunType (F ⋓ G)
normal-⋓ (R ⇒ S) (T ⇒ U) = (normal-∪ⁿ R T) ⇒ (normal-∪ⁿ S U)
normal-⋓ (R ⇒ S) (G ∩ H) = normal-⋓ (R ⇒ S) G ∩ normal-⋓ (R ⇒ S) H
normal-⋓ (E ∩ F) G = normal-⋓ E G ∩ normal-⋓ F G

normal-∩-saturate : ∀ {F} → FunType F → FunType (∩-saturate F)
normal-∩-saturate (S ⇒ T) = S ⇒ T
normal-∩-saturate (F ∩ G) = (normal-∩-saturate F ∩ normal-∩-saturate G) ∩ normal-⋒ (normal-∩-saturate F) (normal-∩-saturate G)

normal-∪-saturate : ∀ {F} → FunType F → FunType (∪-saturate F)
normal-∪-saturate (S ⇒ T) = S ⇒ T
normal-∪-saturate (F ∩ G) = (normal-∪-saturate F ∩ normal-∪-saturate G) ∩ normal-⋓ (normal-∪-saturate F) (normal-∪-saturate G)

normal-saturate : ∀ {F} → FunType F → FunType (saturate F)
normal-saturate F = normal-∪-saturate (normal-∩-saturate F)

-- Saturation resects subtyping
∪-saturate-<: : ∀ {F} → FunType F → ∪-saturate F <: F
∪-saturate-<: (S ⇒ T) = <:-refl
∪-saturate-<: (F ∩ G) = <:-trans <:-∩-left (<:-intersect (∪-saturate-<: F) (∪-saturate-<: G))

∩-saturate-<: : ∀ {F} → FunType F → ∩-saturate F <: F
∩-saturate-<: (S ⇒ T) = <:-refl
∩-saturate-<: (F ∩ G) = <:-trans <:-∩-left (<:-intersect (∩-saturate-<: F) (∩-saturate-<: G))

saturate-<: : ∀ {F} → FunType F → saturate F <: F
saturate-<: F = <:-trans (∪-saturate-<: (normal-∩-saturate F)) (∩-saturate-<: F)

∩-<:-⋓ : ∀ {F G} → FunType F → FunType G → (F ∩ G) <: (F ⋓ G)
∩-<:-⋓ (R ⇒ S) (T ⇒ U) = <:-trans <:-function-∩-∪ (<:-function (∪ⁿ-<:-∪ R T) (∪-<:-∪ⁿ S U))
∩-<:-⋓ (R ⇒ S) (G ∩ H) = <:-trans (<:-∩-glb (<:-intersect <:-refl <:-∩-left) (<:-intersect <:-refl <:-∩-right)) (<:-intersect (∩-<:-⋓ (R ⇒ S) G) (∩-<:-⋓ (R ⇒ S) H))
∩-<:-⋓ (E ∩ F) G = <:-trans (<:-∩-glb (<:-intersect <:-∩-left <:-refl) (<:-intersect <:-∩-right <:-refl)) (<:-intersect (∩-<:-⋓ E G) (∩-<:-⋓ F G))

∩-<:-⋒ : ∀ {F G} → FunType F → FunType G → (F ∩ G) <: (F ⋒ G)
∩-<:-⋒ (R ⇒ S) (T ⇒ U) = <:-trans <:-function-∩-∩ (<:-function (∩ⁿ-<:-∩ R T) (∩-<:-∩ⁿ S U))
∩-<:-⋒ (R ⇒ S) (G ∩ H) = <:-trans (<:-∩-glb (<:-intersect <:-refl <:-∩-left) (<:-intersect <:-refl <:-∩-right)) (<:-intersect (∩-<:-⋒ (R ⇒ S) G) (∩-<:-⋒ (R ⇒ S) H))
∩-<:-⋒ (E ∩ F) G = <:-trans (<:-∩-glb (<:-intersect <:-∩-left <:-refl) (<:-intersect <:-∩-right <:-refl)) (<:-intersect (∩-<:-⋒ E G) (∩-<:-⋒ F G))

<:-∪-saturate : ∀ {F} → FunType F → F <: ∪-saturate F
<:-∪-saturate (S ⇒ T) = <:-refl
<:-∪-saturate (F ∩ G) = <:-∩-glb (<:-intersect (<:-∪-saturate F) (<:-∪-saturate G)) (<:-trans (<:-intersect (<:-∪-saturate F) (<:-∪-saturate G)) (∩-<:-⋓ (normal-∪-saturate F) (normal-∪-saturate G)))

<:-∩-saturate : ∀ {F} → FunType F → F <: ∩-saturate F
<:-∩-saturate (S ⇒ T) = <:-refl
<:-∩-saturate (F ∩ G) = <:-∩-glb (<:-intersect (<:-∩-saturate F) (<:-∩-saturate G)) (<:-trans (<:-intersect (<:-∩-saturate F) (<:-∩-saturate G)) (∩-<:-⋒ (normal-∩-saturate F) (normal-∩-saturate G)))

<:-saturate : ∀ {F} → FunType F → F <: saturate F
<:-saturate F = <:-trans (<:-∩-saturate F) (<:-∪-saturate (normal-∩-saturate F))

-- Overloads F is the set of overloads of F
data Overloads : Type → Type → Set where

   here : ∀ {S T} → Overloads (S ⇒ T) (S ⇒ T)
   left : ∀ {S T F G} → Overloads F (S ⇒ T) → Overloads (F ∩ G) (S ⇒ T)
   right : ∀ {S T F G} → Overloads G (S ⇒ T) → Overloads (F ∩ G) (S ⇒ T)

normal-overload-src : ∀ {F S T} → FunType F → Overloads F (S ⇒ T) → Normal S
normal-overload-src (S ⇒ T) here = S
normal-overload-src (F ∩ G) (left o) = normal-overload-src F o
normal-overload-src (F ∩ G) (right o) = normal-overload-src G o

normal-overload-tgt : ∀ {F S T} → FunType F → Overloads F (S ⇒ T) → Normal T
normal-overload-tgt (S ⇒ T) here = T
normal-overload-tgt (F ∩ G) (left o) = normal-overload-tgt F o
normal-overload-tgt (F ∩ G) (right o) = normal-overload-tgt G o

-- An inductive presentation of the overloads of F ⋓ G
data ∪-Lift (P Q : Type → Set) : Type → Set where

  union : ∀ {R S T U} →

    P (R ⇒ S) →
    Q (T ⇒ U) →
    --------------------
    ∪-Lift P Q ((R ∪ T) ⇒ (S ∪ U))

-- An inductive presentation of the overloads of F ⋒ G
data ∩-Lift (P Q : Type → Set) : Type → Set where

  intersect : ∀ {R S T U} →

    P (R ⇒ S) →
    Q (T ⇒ U) →
    --------------------
    ∩-Lift P Q ((R ∩ T) ⇒ (S ∩ U))

-- An inductive presentation of the overloads of ∪-saturate F
data ∪-Saturate (P : Type → Set) : Type → Set where

  base : ∀ {S T} →

    P (S ⇒ T) →
    --------------------
    ∪-Saturate P (S ⇒ T)

  union : ∀ {R S T U} →

    ∪-Saturate P (R ⇒ S) →
    ∪-Saturate P (T ⇒ U) →
    --------------------
    ∪-Saturate P ((R ∪ T) ⇒ (S ∪ U))

-- An inductive presentation of the overloads of ∩-saturate F
data ∩-Saturate (P : Type → Set) : Type → Set where

  base : ∀ {S T} →

    P (S ⇒ T) →
    --------------------
    ∩-Saturate P (S ⇒ T)

  intersect : ∀ {R S T U} →

    ∩-Saturate P (R ⇒ S) →
    ∩-Saturate P (T ⇒ U) →
    --------------------
    ∩-Saturate P ((R ∩ T) ⇒ (S ∩ U))

-- The <:-up-closure of a set of function types
data <:-Close (P : Type → Set) : Type → Set where

  defn : ∀ {R S T U} →

    P (S ⇒ T) →
    R <: S →
    T <: U →
    ------------------
    <:-Close P (R ⇒ U)

-- F ⊆ᵒ G whenever every overload of F is an overload of G
_⊆ᵒ_ : Type → Type → Set
F ⊆ᵒ G = ∀ {S T} → Overloads F (S ⇒ T) → Overloads G (S ⇒ T)

-- F <:ᵒ G when every overload of G is a supertype of an overload of F
_<:ᵒ_ : Type → Type → Set
_<:ᵒ_ F G = ∀ {S T} → Overloads G (S ⇒ T) → <:-Close (Overloads F) (S ⇒ T)

-- P ⊂: Q when any type in P is a subtype of some type in Q
_⊂:_ : (Type → Set) → (Type → Set) → Set
P ⊂: Q = ∀ {S T} → P (S ⇒ T) → <:-Close Q (S ⇒ T)

-- <:-Close is a monad
just : ∀ {P S T} → P (S ⇒ T) → <:-Close P (S ⇒ T)
just p = defn p <:-refl <:-refl

infixl 5 _>>=_ _>>=ˡ_ _>>=ʳ_
_>>=_ : ∀ {P Q S T} → <:-Close P (S ⇒ T) → (P ⊂: Q) → <:-Close Q (S ⇒ T)
(defn p p₁ p₂) >>= P⊂Q with P⊂Q p
(defn p p₁ p₂) >>= P⊂Q | defn q q₁ q₂ = defn q (<:-trans p₁ q₁) (<:-trans q₂ p₂)

_>>=ˡ_ : ∀ {P R S T} → <:-Close P (S ⇒ T) → (R <: S) → <:-Close P (R ⇒ T)
(defn p p₁ p₂) >>=ˡ q = defn p (<:-trans q p₁) p₂

_>>=ʳ_ : ∀ {P S T U} → <:-Close P (S ⇒ T) → (T <: U) → <:-Close P (S ⇒ U)
(defn p p₁ p₂) >>=ʳ q = defn p p₁ (<:-trans p₂ q)

-- Properties of ⊂:
⊂:-refl : ∀ {P} → P ⊂: P
⊂:-refl p = just p

_[∪]_ : ∀ {P Q R S T U} → <:-Close P (R ⇒ S) → <:-Close Q (T ⇒ U) → <:-Close (∪-Lift P Q) ((R ∪ T) ⇒ (S ∪ U))
(defn p p₁ p₂) [∪] (defn q q₁ q₂) = defn (union p q) (<:-union p₁ q₁) (<:-union p₂ q₂)

_[∩]_ : ∀ {P Q R S T U} → <:-Close P (R ⇒ S) → <:-Close Q (T ⇒ U) → <:-Close (∩-Lift P Q) ((R ∩ T) ⇒ (S ∩ U))
(defn p p₁ p₂) [∩] (defn q q₁ q₂) = defn (intersect p q) (<:-intersect p₁ q₁) (<:-intersect p₂ q₂)

⊂:-∩-saturate-inj : ∀ {P} → P ⊂: ∩-Saturate P
⊂:-∩-saturate-inj p = defn (base p) <:-refl <:-refl

⊂:-∪-saturate-inj : ∀ {P} → P ⊂: ∪-Saturate P
⊂:-∪-saturate-inj p = just (base p)

⊂:-∩-lift-saturate : ∀ {P} → ∩-Lift (∩-Saturate P) (∩-Saturate P) ⊂: ∩-Saturate P
⊂:-∩-lift-saturate (intersect p q) = just (intersect p q)

⊂:-∪-lift-saturate : ∀ {P} → ∪-Lift (∪-Saturate P) (∪-Saturate P) ⊂: ∪-Saturate P
⊂:-∪-lift-saturate (union p q) = just (union p q)

⊂:-∩-lift : ∀ {P Q R S} → (P ⊂: Q) → (R ⊂: S) → (∩-Lift P R ⊂: ∩-Lift Q S)
⊂:-∩-lift P⊂Q R⊂S (intersect n o) = P⊂Q n [∩] R⊂S o

⊂:-∪-lift : ∀ {P Q R S} → (P ⊂: Q) → (R ⊂: S) → (∪-Lift P R ⊂: ∪-Lift Q S)
⊂:-∪-lift P⊂Q R⊂S (union n o) = P⊂Q n [∪] R⊂S o

⊂:-∩-saturate : ∀ {P Q} → (P ⊂: Q) → (∩-Saturate P ⊂: ∩-Saturate Q)
⊂:-∩-saturate P⊂Q (base p) = P⊂Q p >>= ⊂:-∩-saturate-inj
⊂:-∩-saturate P⊂Q (intersect p q) = (⊂:-∩-saturate P⊂Q p [∩] ⊂:-∩-saturate P⊂Q q) >>= ⊂:-∩-lift-saturate

⊂:-∪-saturate : ∀ {P Q} → (P ⊂: Q) → (∪-Saturate P ⊂: ∪-Saturate Q)
⊂:-∪-saturate P⊂Q (base p) = P⊂Q p >>= ⊂:-∪-saturate-inj
⊂:-∪-saturate P⊂Q (union p q) = (⊂:-∪-saturate P⊂Q p [∪] ⊂:-∪-saturate P⊂Q q) >>= ⊂:-∪-lift-saturate

⊂:-∩-saturate-indn : ∀ {P Q} → (P ⊂: Q) → (∩-Lift Q Q ⊂: Q) → (∩-Saturate P ⊂: Q)
⊂:-∩-saturate-indn P⊂Q QQ⊂Q (base p) = P⊂Q p
⊂:-∩-saturate-indn P⊂Q QQ⊂Q (intersect p q) = (⊂:-∩-saturate-indn P⊂Q QQ⊂Q p [∩] ⊂:-∩-saturate-indn P⊂Q QQ⊂Q q) >>= QQ⊂Q

⊂:-∪-saturate-indn : ∀ {P Q} → (P ⊂: Q) → (∪-Lift Q Q ⊂: Q) → (∪-Saturate P ⊂: Q)
⊂:-∪-saturate-indn P⊂Q QQ⊂Q (base p) = P⊂Q p
⊂:-∪-saturate-indn P⊂Q QQ⊂Q (union p q) = (⊂:-∪-saturate-indn P⊂Q QQ⊂Q p [∪] ⊂:-∪-saturate-indn P⊂Q QQ⊂Q q) >>= QQ⊂Q

∪-saturate-resp-∩-saturation : ∀ {P} → (∩-Lift P P ⊂: P) → (∩-Lift (∪-Saturate P) (∪-Saturate P) ⊂: ∪-Saturate P)
∪-saturate-resp-∩-saturation ∩P⊂P (intersect (base p) (base q)) = ∩P⊂P (intersect p q) >>= ⊂:-∪-saturate-inj
∪-saturate-resp-∩-saturation ∩P⊂P (intersect p (union q q₁)) = (∪-saturate-resp-∩-saturation ∩P⊂P (intersect p q) [∪] ∪-saturate-resp-∩-saturation ∩P⊂P (intersect p q₁)) >>= ⊂:-∪-lift-saturate >>=ˡ <:-∩-distl-∪ >>=ʳ ∩-distl-∪-<:
∪-saturate-resp-∩-saturation ∩P⊂P (intersect (union p p₁) q) = (∪-saturate-resp-∩-saturation ∩P⊂P (intersect p q) [∪] ∪-saturate-resp-∩-saturation ∩P⊂P (intersect p₁ q)) >>= ⊂:-∪-lift-saturate >>=ˡ <:-∩-distr-∪ >>=ʳ ∩-distr-∪-<:

ov-language : ∀ {F t} → FunType F → (∀ {S T} → Overloads F (S ⇒ T) → Language (S ⇒ T) t) → Language F t
ov-language (S ⇒ T) p = p here
ov-language (F ∩ G) p = (ov-language F (p ∘ left) , ov-language G (p ∘ right))

ov-<: : ∀ {F R S T U} → FunType F → Overloads F (R ⇒ S) → ((R ⇒ S) <: (T ⇒ U)) → F <: (T ⇒ U)
ov-<: F here p = p
ov-<: (F ∩ G) (left o) p = <:-trans <:-∩-left (ov-<: F o p)
ov-<: (F ∩ G) (right o) p = <:-trans <:-∩-right (ov-<: G o p)

<:ᵒ-impl-<: : ∀ {F G} → FunType F → FunType G → (F <:ᵒ G) → (F <: G)
<:ᵒ-impl-<: F (T ⇒ U) F<G with F<G here
<:ᵒ-impl-<: F (T ⇒ U) F<G | defn o o₁ o₂ = ov-<: F o (<:-function o₁ o₂)
<:ᵒ-impl-<: F (G ∩ H) F<G = <:-∩-glb (<:ᵒ-impl-<: F G (F<G ∘ left)) (<:ᵒ-impl-<: F H (F<G ∘ right))

⊂:-overloads-left : ∀ {F G} → Overloads F ⊂: Overloads (F ∩ G)
⊂:-overloads-left p = just (left p)

⊂:-overloads-right : ∀ {F G} → Overloads G ⊂: Overloads (F ∩ G)
⊂:-overloads-right p = just (right p)

⊂:-overloads-⋒ : ∀ {F G} → FunType F → FunType G → ∩-Lift (Overloads F) (Overloads G) ⊂: Overloads (F ⋒ G)
⊂:-overloads-⋒ (R ⇒ S) (T ⇒ U) (intersect here here) = defn here (∩-<:-∩ⁿ R T) (∩ⁿ-<:-∩ S U)
⊂:-overloads-⋒ (R ⇒ S) (G ∩ H) (intersect here (left o)) = ⊂:-overloads-⋒ (R ⇒ S) G (intersect here o) >>= ⊂:-overloads-left
⊂:-overloads-⋒ (R ⇒ S) (G ∩ H) (intersect here (right o)) = ⊂:-overloads-⋒ (R ⇒ S) H (intersect here o) >>= ⊂:-overloads-right
⊂:-overloads-⋒ (E ∩ F) G (intersect (left n) o) = ⊂:-overloads-⋒ E G (intersect n o) >>= ⊂:-overloads-left
⊂:-overloads-⋒ (E ∩ F) G (intersect (right n) o) = ⊂:-overloads-⋒ F G (intersect n o) >>= ⊂:-overloads-right

⊂:-⋒-overloads : ∀ {F G} → FunType F → FunType G → Overloads (F ⋒ G) ⊂: ∩-Lift (Overloads F) (Overloads G)
⊂:-⋒-overloads (R ⇒ S) (T ⇒ U) here = defn (intersect here here) (∩ⁿ-<:-∩ R T) (∩-<:-∩ⁿ S U)
⊂:-⋒-overloads (R ⇒ S) (G ∩ H) (left o) = ⊂:-⋒-overloads (R ⇒ S) G o >>= ⊂:-∩-lift ⊂:-refl ⊂:-overloads-left
⊂:-⋒-overloads (R ⇒ S) (G ∩ H) (right o) = ⊂:-⋒-overloads (R ⇒ S) H o >>= ⊂:-∩-lift ⊂:-refl ⊂:-overloads-right
⊂:-⋒-overloads (E ∩ F) G (left o) = ⊂:-⋒-overloads E G o >>= ⊂:-∩-lift ⊂:-overloads-left ⊂:-refl
⊂:-⋒-overloads (E ∩ F) G (right o) = ⊂:-⋒-overloads F G o >>= ⊂:-∩-lift ⊂:-overloads-right ⊂:-refl

⊂:-overloads-⋓ : ∀ {F G} → FunType F → FunType G → ∪-Lift (Overloads F) (Overloads G) ⊂: Overloads (F ⋓ G)
⊂:-overloads-⋓ (R ⇒ S) (T ⇒ U) (union here here) = defn here (∪-<:-∪ⁿ R T) (∪ⁿ-<:-∪ S U)
⊂:-overloads-⋓ (R ⇒ S) (G ∩ H) (union here (left o)) = ⊂:-overloads-⋓ (R ⇒ S) G (union here o) >>= ⊂:-overloads-left
⊂:-overloads-⋓ (R ⇒ S) (G ∩ H) (union here (right o)) = ⊂:-overloads-⋓ (R ⇒ S) H (union here o) >>= ⊂:-overloads-right
⊂:-overloads-⋓ (E ∩ F) G (union (left n) o) = ⊂:-overloads-⋓ E G (union n o) >>= ⊂:-overloads-left
⊂:-overloads-⋓ (E ∩ F) G (union (right n) o) = ⊂:-overloads-⋓ F G (union n o) >>= ⊂:-overloads-right

⊂:-⋓-overloads : ∀ {F G} → FunType F → FunType G → Overloads (F ⋓ G) ⊂: ∪-Lift (Overloads F) (Overloads G)
⊂:-⋓-overloads (R ⇒ S) (T ⇒ U) here = defn (union here here) (∪ⁿ-<:-∪ R T) (∪-<:-∪ⁿ S U)
⊂:-⋓-overloads (R ⇒ S) (G ∩ H) (left o) = ⊂:-⋓-overloads (R ⇒ S) G o >>= ⊂:-∪-lift ⊂:-refl ⊂:-overloads-left
⊂:-⋓-overloads (R ⇒ S) (G ∩ H) (right o) = ⊂:-⋓-overloads (R ⇒ S) H o >>= ⊂:-∪-lift ⊂:-refl ⊂:-overloads-right
⊂:-⋓-overloads (E ∩ F) G (left o) = ⊂:-⋓-overloads E G o >>= ⊂:-∪-lift ⊂:-overloads-left ⊂:-refl
⊂:-⋓-overloads (E ∩ F) G (right o) = ⊂:-⋓-overloads F G o >>= ⊂:-∪-lift ⊂:-overloads-right ⊂:-refl

∪-saturate-overloads : ∀ {F} → FunType F → Overloads (∪-saturate F) ⊂: ∪-Saturate (Overloads F)
∪-saturate-overloads (S ⇒ T) here = just (base here)
∪-saturate-overloads (F ∩ G) (left (left o)) = ∪-saturate-overloads F o >>= ⊂:-∪-saturate ⊂:-overloads-left
∪-saturate-overloads (F ∩ G) (left (right o)) = ∪-saturate-overloads G o >>= ⊂:-∪-saturate ⊂:-overloads-right
∪-saturate-overloads (F ∩ G) (right o) =
  ⊂:-⋓-overloads (normal-∪-saturate F) (normal-∪-saturate G) o >>=
  ⊂:-∪-lift (∪-saturate-overloads F) (∪-saturate-overloads G) >>=
  ⊂:-∪-lift (⊂:-∪-saturate ⊂:-overloads-left) (⊂:-∪-saturate ⊂:-overloads-right) >>=
  ⊂:-∪-lift-saturate

overloads-∪-saturate : ∀ {F} → FunType F → ∪-Saturate (Overloads F) ⊂: Overloads (∪-saturate F)
overloads-∪-saturate F = ⊂:-∪-saturate-indn (inj F) (step F) where

  inj : ∀ {F} → FunType F → Overloads F ⊂: Overloads (∪-saturate F)
  inj (S ⇒ T) here = just here
  inj (F ∩ G) (left p) = inj F p >>= ⊂:-overloads-left >>= ⊂:-overloads-left
  inj (F ∩ G) (right p) = inj G p >>= ⊂:-overloads-right >>= ⊂:-overloads-left

  step : ∀ {F} → FunType F → ∪-Lift (Overloads (∪-saturate F)) (Overloads (∪-saturate F)) ⊂: Overloads (∪-saturate F)
  step (S ⇒ T) (union here here) = defn here (<:-∪-lub <:-refl <:-refl) <:-∪-left
  step (F ∩ G) (union (left (left p)) (left (left q))) = step F (union p q) >>= ⊂:-overloads-left >>= ⊂:-overloads-left
  step (F ∩ G) (union (left (left p)) (left (right q))) = ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) (union p q) >>= ⊂:-overloads-right
  step (F ∩ G) (union (left (right p)) (left (left q))) = ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) (union q p) >>= ⊂:-overloads-right >>=ˡ <:-∪-symm >>=ʳ <:-∪-symm
  step (F ∩ G) (union (left (right p)) (left (right q))) = step G (union p q) >>= ⊂:-overloads-right >>= ⊂:-overloads-left
  step (F ∩ G) (union p (right q)) with ⊂:-⋓-overloads (normal-∪-saturate F) (normal-∪-saturate G) q
  step (F ∩ G) (union (left (left p)) (right q)) | defn (union q₁ q₂) q₃ q₄ =
    (step F (union p q₁) [∪] just q₂) >>=
    ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-union <:-refl q₃) <:-∪-assocl >>=ʳ
    <:-trans <:-∪-assocr (<:-union <:-refl q₄)
  step (F ∩ G) (union (left (right p)) (right q)) | defn (union q₁ q₂) q₃ q₄ =
    (just q₁ [∪] step G (union p q₂)) >>=
    ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-union <:-refl q₃) (<:-∪-lub (<:-trans <:-∪-left <:-∪-right) (<:-∪-lub <:-∪-left (<:-trans <:-∪-right <:-∪-right))) >>=ʳ
    <:-trans (<:-∪-lub (<:-trans <:-∪-left <:-∪-right) (<:-∪-lub <:-∪-left (<:-trans <:-∪-right <:-∪-right))) (<:-union <:-refl q₄)
  step (F ∩ G) (union (right p) (right q)) | defn (union q₁ q₂) q₃ q₄ with ⊂:-⋓-overloads (normal-∪-saturate F) (normal-∪-saturate G) p
  step (F ∩ G) (union (right p) (right q)) | defn (union q₁ q₂) q₃ q₄ | defn (union p₁ p₂) p₃ p₄ =
    (step F (union p₁ q₁) [∪] step G (union p₂ q₂)) >>=
    ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-union p₃ q₃) (<:-∪-lub (<:-union <:-∪-left <:-∪-left) (<:-union <:-∪-right <:-∪-right)) >>=ʳ
    <:-trans (<:-∪-lub (<:-union <:-∪-left <:-∪-left) (<:-union <:-∪-right <:-∪-right)) (<:-union p₄ q₄)
  step (F ∩ G) (union (right p) q) with ⊂:-⋓-overloads (normal-∪-saturate F) (normal-∪-saturate G) p
  step (F ∩ G) (union (right p) (left (left q))) | defn (union p₁ p₂) p₃ p₄ =
    (step F (union p₁ q) [∪] just p₂) >>=
    ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-union p₃ <:-refl) (<:-∪-lub (<:-union <:-∪-left <:-refl) (<:-trans <:-∪-right <:-∪-left)) >>=ʳ
    <:-trans (<:-∪-lub (<:-union <:-∪-left <:-refl) (<:-trans <:-∪-right <:-∪-left)) (<:-union p₄ <:-refl)
  step (F ∩ G) (union (right p) (left (right q))) | defn (union p₁ p₂) p₃ p₄ =
    (just p₁ [∪] step G (union p₂ q)) >>=
    ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-union p₃ <:-refl) <:-∪-assocr >>=ʳ
    <:-trans <:-∪-assocl (<:-union p₄ <:-refl)
  step (F ∩ G) (union (right p) (right q)) | defn (union p₁ p₂) p₃ p₄ with ⊂:-⋓-overloads (normal-∪-saturate F) (normal-∪-saturate G) q
  step (F ∩ G) (union (right p) (right q)) | defn (union p₁ p₂) p₃ p₄ | defn (union q₁ q₂) q₃ q₄ =
    (step F (union p₁ q₁) [∪] step G (union p₂ q₂)) >>=
    ⊂:-overloads-⋓ (normal-∪-saturate F) (normal-∪-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-union p₃ q₃) (<:-∪-lub (<:-union <:-∪-left <:-∪-left) (<:-union <:-∪-right <:-∪-right)) >>=ʳ
    <:-trans (<:-∪-lub (<:-union <:-∪-left <:-∪-left) (<:-union <:-∪-right <:-∪-right)) (<:-union p₄ q₄)

∪-saturated : ∀ {F} → FunType F → ∪-Lift (Overloads (∪-saturate F)) (Overloads (∪-saturate F)) ⊂: Overloads (∪-saturate F)
∪-saturated F o =
  ⊂:-∪-lift (∪-saturate-overloads F) (∪-saturate-overloads F) o >>=
  ⊂:-∪-lift-saturate >>=
  overloads-∪-saturate F

∩-saturate-overloads : ∀ {F} → FunType F → Overloads (∩-saturate F) ⊂: ∩-Saturate (Overloads F)
∩-saturate-overloads (S ⇒ T) here = just (base here)
∩-saturate-overloads (F ∩ G) (left (left o)) = ∩-saturate-overloads F o >>= ⊂:-∩-saturate ⊂:-overloads-left
∩-saturate-overloads (F ∩ G) (left (right o)) = ∩-saturate-overloads G o >>= ⊂:-∩-saturate ⊂:-overloads-right
∩-saturate-overloads (F ∩ G) (right o) =
  ⊂:-⋒-overloads (normal-∩-saturate F) (normal-∩-saturate G) o >>=
  ⊂:-∩-lift (∩-saturate-overloads F) (∩-saturate-overloads G) >>=
  ⊂:-∩-lift (⊂:-∩-saturate ⊂:-overloads-left) (⊂:-∩-saturate ⊂:-overloads-right) >>=
  ⊂:-∩-lift-saturate

overloads-∩-saturate : ∀ {F} → FunType F → ∩-Saturate (Overloads F) ⊂: Overloads (∩-saturate F)
overloads-∩-saturate F = ⊂:-∩-saturate-indn (inj F) (step F) where

  inj :  ∀ {F} → FunType F → Overloads F ⊂: Overloads (∩-saturate F)
  inj (S ⇒ T) here = just here
  inj (F ∩ G) (left p) = inj F p >>= ⊂:-overloads-left >>= ⊂:-overloads-left
  inj (F ∩ G) (right p) = inj G p >>= ⊂:-overloads-right >>= ⊂:-overloads-left

  step : ∀ {F} → FunType F → ∩-Lift (Overloads (∩-saturate F)) (Overloads (∩-saturate F)) ⊂: Overloads (∩-saturate F)
  step (S ⇒ T) (intersect here here) = defn here <:-∩-left (<:-∩-glb <:-refl <:-refl)
  step (F ∩ G) (intersect (left (left p)) (left (left q))) = step F (intersect p q) >>= ⊂:-overloads-left >>= ⊂:-overloads-left
  step (F ∩ G) (intersect (left (left p)) (left (right q))) = ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) (intersect p q) >>= ⊂:-overloads-right
  step (F ∩ G) (intersect (left (right p)) (left (left q))) = ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) (intersect q p) >>= ⊂:-overloads-right >>=ˡ <:-∩-symm >>=ʳ <:-∩-symm
  step (F ∩ G) (intersect (left (right p)) (left (right q))) = step G (intersect p q) >>= ⊂:-overloads-right >>= ⊂:-overloads-left
  step (F ∩ G) (intersect (right p) q) with ⊂:-⋒-overloads (normal-∩-saturate F) (normal-∩-saturate G) p
  step (F ∩ G) (intersect (right p) (left (left q))) | defn (intersect p₁ p₂) p₃ p₄ =
    (step F (intersect p₁ q) [∩] just p₂) >>=
    ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-intersect p₃ <:-refl) (<:-∩-glb (<:-intersect <:-∩-left <:-refl) (<:-trans <:-∩-left <:-∩-right)) >>=ʳ
    <:-trans (<:-∩-glb (<:-intersect <:-∩-left <:-refl) (<:-trans <:-∩-left <:-∩-right)) (<:-intersect p₄ <:-refl)
  step (F ∩ G) (intersect (right p) (left (right q))) | defn (intersect p₁ p₂) p₃ p₄ =
    (just p₁ [∩] step G (intersect p₂ q)) >>=
    ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-intersect p₃ <:-refl) <:-∩-assocr >>=ʳ
    <:-trans <:-∩-assocl (<:-intersect p₄ <:-refl)
  step (F ∩ G) (intersect (right p) (right q)) | defn (intersect p₁ p₂) p₃ p₄ with ⊂:-⋒-overloads (normal-∩-saturate F) (normal-∩-saturate G) q
  step (F ∩ G) (intersect (right p) (right q)) | defn (intersect p₁ p₂) p₃ p₄ | defn (intersect q₁ q₂) q₃ q₄ =
    (step F (intersect p₁ q₁) [∩] step G (intersect p₂ q₂)) >>=
    ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-intersect p₃ q₃) (<:-∩-glb (<:-intersect <:-∩-left <:-∩-left) (<:-intersect <:-∩-right <:-∩-right)) >>=ʳ
    <:-trans (<:-∩-glb (<:-intersect <:-∩-left <:-∩-left) (<:-intersect <:-∩-right <:-∩-right)) (<:-intersect p₄ q₄)
  step (F ∩ G) (intersect p (right q)) with ⊂:-⋒-overloads (normal-∩-saturate F) (normal-∩-saturate G) q
  step (F ∩ G) (intersect (left (left p)) (right q)) | defn (intersect q₁ q₂) q₃ q₄ =
    (step F (intersect p q₁) [∩] just q₂) >>=
    ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-intersect <:-refl q₃) <:-∩-assocl >>=ʳ
    <:-trans <:-∩-assocr (<:-intersect <:-refl q₄)
  step (F ∩ G) (intersect (left (right p)) (right q)) | defn (intersect q₁ q₂) q₃ q₄ =
    (just q₁ [∩] step G (intersect p q₂) ) >>=
    ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-intersect <:-refl q₃) (<:-∩-glb (<:-trans <:-∩-right <:-∩-left) (<:-∩-glb <:-∩-left (<:-trans <:-∩-right <:-∩-right))) >>=ʳ
    <:-∩-glb (<:-trans <:-∩-right <:-∩-left) (<:-trans (<:-∩-glb <:-∩-left (<:-trans <:-∩-right <:-∩-right)) q₄)
  step (F ∩ G) (intersect (right p) (right q)) | defn (intersect q₁ q₂) q₃ q₄ with ⊂:-⋒-overloads (normal-∩-saturate F) (normal-∩-saturate G) p
  step (F ∩ G) (intersect (right p) (right q)) | defn (intersect q₁ q₂) q₃ q₄ | defn (intersect p₁ p₂) p₃ p₄ =
    (step F (intersect p₁ q₁) [∩] step G (intersect p₂ q₂)) >>=
    ⊂:-overloads-⋒ (normal-∩-saturate F) (normal-∩-saturate G) >>=
    ⊂:-overloads-right >>=ˡ
    <:-trans (<:-intersect p₃ q₃) (<:-∩-glb (<:-intersect <:-∩-left <:-∩-left) (<:-intersect <:-∩-right <:-∩-right)) >>=ʳ
    <:-trans (<:-∩-glb (<:-intersect <:-∩-left <:-∩-left) (<:-intersect <:-∩-right <:-∩-right)) (<:-intersect p₄ q₄)

saturate-overloads : ∀ {F} → FunType F → Overloads (saturate F) ⊂: ∪-Saturate (∩-Saturate (Overloads F))
saturate-overloads F o = ∪-saturate-overloads (normal-∩-saturate F) o >>= (⊂:-∪-saturate (∩-saturate-overloads F))

overloads-saturate : ∀ {F} → FunType F → ∪-Saturate (∩-Saturate (Overloads F)) ⊂: Overloads (saturate F)
overloads-saturate F o = ⊂:-∪-saturate (overloads-∩-saturate F) o >>= overloads-∪-saturate (normal-∩-saturate F)

-- Saturated F whenever
-- * if F has overloads (R ⇒ S) and (T ⇒ U) then F has an overload which is a subtype of ((R ∩ T) ⇒ (S ∩ U))
-- * ditto union
data Saturated (F : Type) : Set where

  defn :

    (∀ {R S T U} → Overloads F (R ⇒ S) → Overloads F (T ⇒ U) → <:-Close (Overloads F) ((R ∩ T) ⇒ (S ∩ U))) →
    (∀ {R S T U} → Overloads F (R ⇒ S) → Overloads F (T ⇒ U) → <:-Close (Overloads F) ((R ∪ T) ⇒ (S ∪ U))) →
    -----------
    Saturated F

-- saturated F is saturated!
saturated : ∀ {F} → FunType F → Saturated (saturate F)
saturated F = defn
  (λ n o → (saturate-overloads F n [∩] saturate-overloads F o) >>= ∪-saturate-resp-∩-saturation ⊂:-∩-lift-saturate >>= overloads-saturate F)
  (λ n o → ∪-saturated (normal-∩-saturate F) (union n o))


{-# OPTIONS --without-K #-}
module well-typed-syntax where

infixl 2 _▻_
infixl 3 _‘’_
infixl 3 _‘’₁_
infixl 3 _‘’₂_
infixl 3 _‘’₃_
infixl 3 _‘’ₐ_
infixr 1 _‘→’_
infixl 3 _‘‘’’_
infixl 3 _w‘‘’’_
infixr 1 _‘‘→'’’_
infixr 1 _w‘‘→'’’_

mutual
  data Context : Set where
    ε : Context
    _▻_ : (Γ : Context) → Typ Γ → Context

  data Typ : Context → Set where
    _‘’_ : ∀ {Γ A} → Typ (Γ ▻ A) → Term {Γ} A → Typ Γ
    _‘’₁_ : ∀ {Γ A B} → (C : Typ (Γ ▻ A ▻ B)) → (a : Term {Γ} A) → Typ (Γ ▻ B ‘’ a)
    _‘’₂_ : ∀ {Γ A B C} → (D : Typ (Γ ▻ A ▻ B ▻ C)) → (a : Term {Γ} A) → Typ (Γ ▻ B ‘’ a ▻ C ‘’₁ a)
    _‘’₃_ : ∀ {Γ A B C D} → (E : Typ (Γ ▻ A ▻ B ▻ C ▻ D)) → (a : Term {Γ} A) → Typ (Γ ▻ B ‘’ a ▻ C ‘’₁ a ▻ D ‘’₂ a)
    W : ∀ {Γ A} → Typ Γ → Typ (Γ ▻ A)
    W1 : ∀ {Γ A B} → Typ (Γ ▻ B) → Typ (Γ ▻ A ▻ (W {Γ = Γ} {A = A} B))
    W2 : ∀ {Γ A B C} → Typ (Γ ▻ B ▻ C) → Typ (Γ ▻ A ▻ W B ▻ W1 C)
    _‘→’_ : ∀ {Γ} (A : Typ Γ) → Typ (Γ ▻ A) → Typ Γ
    ‘Σ’ : ∀ {Γ} (T : Typ Γ) → Typ (Γ ▻ T) → Typ Γ
    ‘Context’ : ∀ {Γ} → Typ Γ
    ‘Typ’ : ∀ {Γ} → Typ (Γ ▻ ‘Context’)
    ‘Term’ : ∀ {Γ} → Typ (Γ ▻ ‘Context’ ▻ ‘Typ’)

  data Term : ∀ {Γ} → Typ Γ → Set where
    w : ∀ {Γ A B} → Term {Γ} B → Term {Γ = Γ ▻ A} (W {Γ = Γ} {A = A} B)
    ‘λ∙’ : ∀ {Γ A B} → Term {Γ = (Γ ▻ A)} B → Term {Γ} (A ‘→’ B)
    _‘’ₐ_ : ∀ {Γ A B} → (f : Term {Γ} (A ‘→’ B)) → (x : Term {Γ} A) → Term {Γ} (B ‘’ x)
    ‘VAR₀’ : ∀ {Γ T} → Term {Γ = Γ ▻ T} (W T)
    ⌜_⌝c : ∀ {Γ} → Context → Term {Γ} ‘Context’
    ⌜_⌝T : ∀ {Γ Γ'} → Typ Γ' → Term {Γ} (‘Typ’ ‘’ ⌜ Γ' ⌝c)
    ⌜_⌝t : ∀ {Γ Γ'} {T : Typ Γ'} → Term T → Term {Γ} (‘Term’ ‘’₁ ⌜ Γ' ⌝c ‘’ ⌜ T ⌝T)
    ‘quote-term’ : ∀ {Γ Γ'} {A : Typ Γ'} → Term {Γ} (‘Term’ ‘’₁ ⌜ Γ' ⌝c ‘’ ⌜ A ⌝T ‘→’ W (‘Term’ ‘’₁ ⌜ Γ ⌝c ‘’ ⌜ ‘Term’ ‘’₁ ⌜ Γ' ⌝c ‘’ ⌜ A ⌝T ⌝T))
    ‘quote-sigma’ : ∀ {Γ Γ'} → Term {Γ} (‘Σ’ ‘Context’ ‘Typ’ ‘→’ W (‘Term’ ‘’₁ ⌜ Γ' ⌝c ‘’ ⌜ ‘Σ’ ‘Context’ ‘Typ’ ⌝T))
    {-‘substTyp’ : ∀ {Γ' Γ} {A : Typ Γ}
      → Term {Γ'} (‘Typ’ ‘’ ⌜ Γ ▻ A ⌝c
                  ‘→’ W (‘Term’ ‘’₁ ⌜ Γ ⌝c ‘’ ⌜ A ⌝T
                  ‘→’ W (‘Typ’ ‘’ ⌜ Γ ⌝c)))-}
    ‘cast’ : Term {ε} (‘Σ’ ‘Context’ ‘Typ’ ‘→’ W (‘Typ’ ‘’ ⌜ ε ▻ ‘Σ’ ‘Context’ ‘Typ’ ⌝c))
    SW : ∀ {Γ A B} {a : Term {Γ} A} → Term {Γ} (W B ‘’ a) → Term {Γ} B
    weakenTyp-substTyp-tProd : ∀ {Γ T T' A B} {a : Term {Γ} T} → Term {Γ = Γ ▻ T'} (W ((A ‘→’ B) ‘’ a)) → Term {Γ ▻ T'} (W ((A ‘’ a) ‘→’ (B ‘’₁ a)))
    substTyp-weakenTyp1-VAR₀ : ∀ {Γ A T} → Term {Γ ▻ A} (W1 T ‘’ ‘VAR₀’) → Term {Γ ▻ A} T
    weakenTyp-tProd : ∀ {Γ A B C} → Term {Γ = Γ ▻ C} (W (A ‘→’ B)) → Term {Γ = Γ ▻ C} (W A ‘→’ W1 B)
    weakenTyp-tProd-inv : ∀ {Γ A B C} → Term {Γ = Γ ▻ C} (W A ‘→’ W1 B) → Term {Γ = Γ ▻ C} (W (A ‘→’ B))
    weakenTyp-weakenTyp-tProd : ∀ {Γ A B C D} → Term {Γ ▻ C ▻ D} (W (W (A ‘→’ B))) → Term {Γ ▻ C ▻ D} (W (W A ‘→’ W1 B))
    substTyp1-tProd : ∀ {Γ T T' A B} {a : Term {Γ} T} → Term {Γ ▻ T' ‘’ a} ((A ‘→’ B) ‘’₁ a) → Term {Γ ▻ T' ‘’ a} ((A ‘’₁ a) ‘→’ (B ‘’₂ a))
    weakenTyp1-tProd : ∀ {Γ C D A B} → Term {Γ ▻ C ▻ W D} (W1 (A ‘→’ B)) → Term {Γ ▻ C ▻ W D} (W1 A ‘→’ W2 B)
    substTyp2-tProd : ∀ {Γ T T' T'' A B} {a : Term {Γ} T} → Term {Γ ▻ T' ‘’ a ▻ T'' ‘’₁ a} ((A ‘→’ B) ‘’₂ a) → Term {Γ ▻ T' ‘’ a ▻ T'' ‘’₁ a} ((A ‘’₂ a) ‘→’ (B ‘’₃ a))
    substTyp1-substTyp-weakenTyp-inv : ∀ {Γ C T A} {a : Term {Γ} C} {b : Term {Γ} (T ‘’ a)} → Term {Γ} (A ‘’ a) → Term {Γ} (W A ‘’₁ a ‘’ b)
    substTyp1-substTyp-weakenTyp : ∀ {Γ C T A} {a : Term {Γ} C} {b : Term {Γ} (T ‘’ a)} → Term {Γ} (W A ‘’₁ a ‘’ b) → Term {Γ} (A ‘’ a)
    weakenTyp-weakenTyp-substTyp1-substTyp-weakenTyp : ∀ {Γ C T A D E} {a : Term {Γ} C} {b : Term {Γ} (T ‘’ a)} → Term {Γ ▻ D ▻ E} (W (W (W A ‘’₁ a ‘’ b))) → Term {Γ ▻ D ▻ E} (W (W (A ‘’ a)))
    weakenTyp-substTyp2-substTyp1-substTyp-weakenTyp-inv : ∀ {Γ A B C T T'} {a : Term {Γ} A} {b : Term {Γ} (B ‘’ a)} {c : Term {Γ} (C ‘’₁ a ‘’ b)}
      → Term {Γ ▻ T'} (W (T ‘’₁ a ‘’ b))
      → Term {Γ ▻ T'} (W (W T ‘’₂ a ‘’₁ b ‘’ c))
    substTyp2-substTyp1-substTyp-weakenTyp : ∀ {Γ A B C T} {a : Term {Γ} A} {b : Term {Γ} (B ‘’ a)} {c : Term {Γ} (C ‘’₁ a ‘’ b)}
      → Term {Γ} (W T ‘’₂ a ‘’₁ b ‘’ c)
      → Term {Γ} (T ‘’₁ a ‘’ b)
    weakenTyp-substTyp2-substTyp1-substTyp-tProd : ∀ {Γ T T' T'' T''' A B} {a : Term {Γ} T} {b : Term {Γ} (T' ‘’ a)} {c : Term {Γ} (T'' ‘’₁ a ‘’ b)}
      → Term {Γ ▻ T'''} (W ((A ‘→’ B) ‘’₂ a ‘’₁ b ‘’ c))
      → Term {Γ ▻ T'''} ((W (A ‘’₂ a ‘’₁ b ‘’ c)) ‘→’ (W1 (B ‘’₃ a ‘’₂ b ‘’₁ c)))
    weakenTyp2-weakenTyp1 : ∀ {Γ A B C D} → Term {Γ ▻ A ▻ W B ▻ W1 C} (W2 (W D)) → Term {Γ ▻ A ▻ W B ▻ W1 C} (W (W1 D))
    weakenTyp1-weakenTyp : ∀ {Γ A B C} → Term {Γ ▻ A ▻ W B} (W1 (W C)) → Term {Γ ▻ A ▻ W B} (W (W C))
    weakenTyp1-weakenTyp-inv : ∀ {Γ A B C} → Term {Γ ▻ A ▻ W B} (W (W C)) → Term {Γ ▻ A ▻ W B} (W1 (W C))
    weakenTyp1-weakenTyp1-weakenTyp : ∀ {Γ A B C T} → Term {Γ ▻ A ▻ B ▻ W (W C)} (W1 (W1 (W T))) → Term {Γ ▻ A ▻ B ▻ W (W C)} (W1 (W (W T)))
    substTyp1-weakenTyp1 : ∀ {Γ A B C} {a : Term {Γ} A} → Term {Γ ▻ W B ‘’ a} (W1 C ‘’₁ a) → Term {Γ ▻ B} C
    weakenTyp1-substTyp-weakenTyp1-inv : ∀ {Γ A T'' T' T} {a : Term {Γ} A}
      → Term {Γ ▻ T'' ▻ W (T' ‘’ a)} (W1 (W (T ‘’ a)))
      → Term {Γ ▻ T'' ▻ W (T' ‘’ a)} (W1 (W T ‘’₁ a))
    weakenTyp1-substTyp-weakenTyp1 : ∀ {Γ A T'' T' T} {a : Term {Γ} A}
      → Term {Γ ▻ T'' ▻ W (T' ‘’ a)} (W1 (W T ‘’₁ a))
      → Term {Γ ▻ T'' ▻ W (T' ‘’ a)} (W1 (W (T ‘’ a)))
    weakenTyp-substTyp-substTyp-weakenTyp1 : ∀ {Γ T' B A} {b : Term {Γ} B} {a : Term {Γ ▻ B} (W A)} {T : Typ (Γ ▻ A)}
      → Term {Γ ▻ T'} (W (W1 T ‘’ a ‘’ b))
      → Term {Γ ▻ T'} (W (T ‘’ (SW ((‘λ∙’ a) ‘’ₐ b))))
    weakenTyp-substTyp-substTyp-weakenTyp1-inv : ∀ {Γ T' B A} {b : Term {Γ} B} {a : Term {Γ ▻ B} (W A)} {T : Typ (Γ ▻ A)}
      → Term {Γ ▻ T'} (W (T ‘’ (SW ((‘λ∙’ a) ‘’ₐ b))))
      → Term {Γ ▻ T'} (W (W1 T ‘’ a ‘’ b))
    substTyp-weakenTyp1-weakenTyp : ∀ {Γ T} {A : Typ Γ} {B : Typ Γ}
      → {a : Term {Γ = Γ ▻ T} (W {Γ = Γ} {A = T} B)}
      → Term {Γ = Γ ▻ T} (W1 (W A) ‘’ a)
      → Term {Γ = Γ ▻ T} (W A)
    substTyp3-substTyp2-substTyp1-substTyp-weakenTyp : ∀ {Γ A B C D T T'} {a : Term {Γ} A} {b : Term {Γ} (B ‘’ a)} {c : Term {Γ} (C ‘’₁ a ‘’ b)}
         {d : Term {Γ = (Γ ▻ T')} (W (D ‘’₂ a ‘’₁ b ‘’ c))}
         → Term {Γ = (Γ ▻ T')} (W1 (W T ‘’₃ a ‘’₂ b ‘’₁ c) ‘’ d)
         → Term {Γ = (Γ ▻ T')} (W (T ‘’₂ a ‘’₁ b ‘’ c))
    weakenTyp-substTyp2-substTyp1-substTyp-weakenTyp1 : ∀ {Γ A B C T T'} {a : Term {Γ} A} {b : Term (B ‘’ a)} {c : Term (C ‘’ a)}
      → Term {Γ = (Γ ▻ T')} (W (W1 T ‘’₂ a ‘’₁ b ‘’ substTyp1-substTyp-weakenTyp-inv c))
      → Term {Γ = (Γ ▻ T')} (W (T ‘’₁ a ‘’ c))
    substTyp1-substTyp-tProd : ∀ {Γ T T' A B a b} → Term ((_‘→’_ {Γ = Γ ▻ T ▻ T'} A B) ‘’₁ a ‘’ b) → Term (_‘→’_ {Γ = Γ} (A ‘’₁ a ‘’ b) (B ‘’₂ a ‘’₁ b))
    substTyp2-substTyp-substTyp-weakenTyp1-weakenTyp-weakenTyp : ∀ {Γ A} {T : Typ (Γ ▻ A)} {T' C B} {a : Term {Γ} A} {b : Term {Γ = (Γ ▻ C ‘’ a)} (B ‘’₁ a)}
         {c : Term {Γ = (Γ ▻ T')} (W (C ‘’ a))}
         → Term {Γ = (Γ ▻ T')} (W1 (W (W T) ‘’₂ a ‘’ b) ‘’ c)
         → Term {Γ = (Γ ▻ T')} (W (T ‘’ a))
    substTyp1-substTyp-weakenTyp2-weakenTyp : ∀ {Γ T' A B T} {a : Term {Γ ▻ T'} (W A)} {b : Term {Γ ▻ T'} (W1 B ‘’ a)}
      → Term {Γ ▻ T'} (W2 (W T) ‘’₁ a ‘’ b)
      → Term {Γ ▻ T'} (W1 T ‘’ a)
    weakenTyp-weakenTyp1-weakenTyp : ∀ {Γ A B C D} → Term {Γ ▻ A ▻ W B ▻ W1 C} (W (W1 (W D))) → Term {Γ ▻ A ▻ W B ▻ W1 C} (W (W (W D)))
    beta-under-subst : ∀ {Γ A B B'} {g : Term {Γ} (A ‘→’ W B)} {x : Term {Γ} A}
      → Term (B' ‘’ SW (‘λ∙’ (SW (‘λ∙’ (weakenTyp1-weakenTyp (substTyp-weakenTyp1-VAR₀ (weakenTyp-tProd (w (weakenTyp-tProd (w g))) ‘’ₐ ‘VAR₀’))) ‘’ₐ ‘VAR₀’)) ‘’ₐ x))
      → Term (B' ‘’ SW (g ‘’ₐ x))
    ‘proj₁'’ : ∀ {Γ} {T : Typ Γ} {P : Typ (Γ ▻ T)} → Term (‘Σ’ T P ‘→’ W T)
    ‘proj₂'’ : ∀ {Γ} {T : Typ Γ} {P : Typ (Γ ▻ T)} → Term {Γ ▻ ‘Σ’ T P} (W1 P ‘’ SW (‘λ∙’ (weakenTyp1-weakenTyp (substTyp-weakenTyp1-VAR₀ (weakenTyp-tProd (w (weakenTyp-tProd (w ‘proj₁'’))) ‘’ₐ ‘VAR₀’))) ‘’ₐ ‘VAR₀’))
    ‘existT’ : ∀ {Γ T P} (x : Term {Γ} T) (p : Term (P ‘’ x)) → Term (‘Σ’ T P)
    {- these are redundant, but useful for not having to normalize the subsequent ones -}
    _‘‘’’_ : ∀ {Γ} {A : Typ Γ}
      → Term {ε} (‘Typ’ ‘’ ⌜ Γ ▻ A ⌝c)
      → Term {ε} (‘Term’ ‘’₁ ⌜ Γ ⌝c ‘’ ⌜ A ⌝T)
      → Term {ε} (‘Typ’ ‘’ ⌜ Γ ⌝c)
    _w‘‘’’_ : ∀ {X Γ} {A : Typ Γ}
      → Term {ε ▻ X} (W (‘Typ’ ‘’ ⌜ Γ ▻ A ⌝c))
      → Term {ε ▻ X} (W (‘Term’ ‘’₁ ⌜ Γ ⌝c ‘’ ⌜ A ⌝T))
      → Term {ε ▻ X} (W (‘Typ’ ‘’ ⌜ Γ ⌝c))
    _‘‘→'’’_ : ∀ {Γ}
      → Term {ε} (‘Typ’ ‘’ Γ)
      → Term {ε} (‘Typ’ ‘’ Γ)
      → Term {ε} (‘Typ’ ‘’ Γ)
    _w‘‘→'’’_ : ∀ {X Γ}
      → Term {ε ▻ X} (W (‘Typ’ ‘’ Γ))
      → Term {ε ▻ X} (W (‘Typ’ ‘’ Γ))
      → Term {ε ▻ X} (W (‘Typ’ ‘’ Γ))
    w→ : ∀ {Γ A B C} → Term (A ‘→’ W B) → Term {Γ = Γ ▻ C} (W A ‘→’ W (W B))
    {- things that were postulates, but are no longer -}
    ‘‘→'’’→w‘‘→'’’ : ∀ {T'}
         {b : Term {ε} (‘Typ’ ‘’ ⌜ ε ⌝c)}
         {c : Term {ε ▻ T'} (W (‘Typ’ ‘’ ⌜ ε ⌝c))}
         {e : Term {ε} T'}
         → Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (SW (‘λ∙’ (c w‘‘→'’’ w b) ‘’ₐ e))
                    ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (SW (‘λ∙’ c ‘’ₐ e) ‘‘→'’’ b)))
    w‘‘→'’’→‘‘→'’’ : ∀ {T'}
         {b : Term {ε} (‘Typ’ ‘’ ⌜ ε ⌝c)}
         {c : Term {ε ▻ T'} (W (‘Typ’ ‘’ ⌜ ε ⌝c))}
         {e : Term {ε} T'}
         → Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (SW (‘λ∙’ c ‘’ₐ e) ‘‘→'’’ b)
                    ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (SW (‘λ∙’ (c w‘‘→'’’ w b) ‘’ₐ e))))
    ‘tApp-nd’ : ∀ {Γ} {A : Term {ε} (‘Typ’ ‘’ Γ)} {B : Term {ε} (‘Typ’ ‘’ Γ)} →
      Term {ε} (‘Term’ ‘’₁ Γ ‘’ (A ‘‘→'’’ B)
           ‘→’ W (‘Term’ ‘’₁ Γ ‘’ A
           ‘→’ W (‘Term’ ‘’₁ Γ ‘’ B)))
    ⌜←'⌝ : ∀ {H X} →
      Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (⌜ H ⌝T ‘‘→'’’ ⌜ X ⌝T)
           ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ ⌜ H ‘→’ W X ⌝T))
    ⌜→'⌝ : ∀ {H X} →
      Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ ⌜ H ‘→’ W X ⌝T
           ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (⌜ H ⌝T ‘‘→'’’ ⌜ X ⌝T)))
    ‘‘fcomp-nd’’ : ∀ {A B C} →
      Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (A ‘‘→'’’ C)
           ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (C ‘‘→'’’ B)
           ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ (A ‘‘→'’’ B))))
    ⌜‘’⌝ : ∀ {B A} {b : Term {ε} B} →
        Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’
            (⌜ A ‘’ b ⌝T ‘‘→'’’ ⌜ A ⌝T ‘‘’’ ⌜ b ⌝t))
    ⌜‘’⌝' : ∀ {B A} {b : Term {ε} B} →
        Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’
            (⌜ A ⌝T ‘‘’’ ⌜ b ⌝t ‘‘→'’’ ⌜ A ‘’ b ⌝T))
    ‘cast-refl’ : ∀ {T : Typ (ε ▻ ‘Σ’ ‘Context’ ‘Typ’)} →
        Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’
            ((⌜ T ‘’ ‘existT’ ⌜ ε ▻ ‘Σ’ ‘Context’ ‘Typ’ ⌝c ⌜ T ⌝T ⌝T)
               ‘‘→'’’
               (SW (‘cast’ ‘’ₐ ‘existT’ ⌜ ε ▻ ‘Σ’ ‘Context’ ‘Typ’ ⌝c ⌜ T ⌝T)
                 ‘‘’’ SW (‘quote-sigma’ ‘’ₐ ‘existT’ ⌜ ε ▻ ‘Σ’ ‘Context’ ‘Typ’ ⌝c ⌜ T ⌝T))))
    ‘cast-refl'’ : ∀ {T : Typ (ε ▻ ‘Σ’ ‘Context’ ‘Typ’)} →
        Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’
            ((SW (‘cast’ ‘’ₐ ‘existT’ ⌜ ε ▻ ‘Σ’ ‘Context’ ‘Typ’ ⌝c ⌜ T ⌝T)
                 ‘‘’’ SW (‘quote-sigma’ ‘’ₐ ‘existT’ ⌜ ε ▻ ‘Σ’ ‘Context’ ‘Typ’ ⌝c ⌜ T ⌝T))
               ‘‘→'’’
               (⌜ T ‘’ ‘existT’ ⌜ ε ▻ ‘Σ’ ‘Context’ ‘Typ’ ⌝c ⌜ T ⌝T ⌝T)))
    ‘s→→’ : ∀ {T B}
           {b : Term {ε} (T ‘→’ W (‘Typ’ ‘’ ⌜ ε ▻ B ⌝c))}
           {c : Term {ε} (T ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ ⌜ B ⌝T))}
           {v : Term {ε} T} →
      (Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c
           ‘’ ((SW (((‘λ∙’ (SW (w→ b ‘’ₐ ‘VAR₀’) w‘‘’’ SW (w→ c ‘’ₐ ‘VAR₀’)) ‘’ₐ v))))
                 ‘‘→'’’ (SW (b ‘’ₐ v) ‘‘’’ SW (c ‘’ₐ v)))))
    ‘s←←’ : ∀ {T B}
           {b : Term {ε} (T ‘→’ W (‘Typ’ ‘’ ⌜ ε ▻ B ⌝c))}
           {c : Term {ε} (T ‘→’ W (‘Term’ ‘’₁ ⌜ ε ⌝c ‘’ ⌜ B ⌝T))}
           {v : Term {ε} T} →
      (Term {ε} (‘Term’ ‘’₁ ⌜ ε ⌝c
           ‘’ ((SW (b ‘’ₐ v) ‘‘’’ SW (c ‘’ₐ v))
                 ‘‘→'’’ (SW (((‘λ∙’ (SW (w→ b ‘’ₐ ‘VAR₀’) w‘‘’’ SW (w→ c ‘’ₐ ‘VAR₀’)) ‘’ₐ v)))))))


module PatternShadowsConstructor where

module A where

  data B : Set where
    x : B

  data C : Set where
    c : B → C

open A using (C; c)

f : C → C
f (c x) = x