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

open import HoTT
open import homotopy.HSpace renaming (HSpaceStructure to HSS)
open import homotopy.Pi2HSusp
open import homotopy.WedgeExtension
open import lib.types.TwoSemiCategory
open import lib.two-semi-categories.FundamentalCategory

module homotopy.Pi2HSuspCompose {i} {X : Ptd i} {{_ : has-level 1 (de⊙ X)}}
  {{is-0-connected : is-connected 0 (de⊙ X)}} (H-X : HSS X)
  (H-X-assoc : associator H-X)
  (coh-assoc-unit-l-r-pentagon : coh-unit-l-r-pentagon H-X H-X-assoc)
  where

  private
    A = de⊙ X
    e = pt X

  open Pi2HSusp H-X public

  infixr 80 _∙₁_
  _∙₁_ : {x y z : Susp A} → Trunc 1 (x == y) → Trunc 1 (y == z) → Trunc 1 (x == z)
  _∙₁_ {x} {y} {z} p q = _∙ₜ_ {A = Susp A} {ta = [ x ]} {tb = [ y ]} {tc = [ z ]} p q

  module _ {k} {B : Type k} where

    add-path-inverse-l : {x y z : B}
      → (p : x == y) (q : x == z)
      → p == (q ∙ ! q) ∙ p
    add-path-inverse-l p q = ap (_∙ p) (! (!-inv-r q))

    add-path-inverse-r : {x y z : B}
      → (p : x == y) (r : y == z)
      → p == p ∙ (r ∙ ! r)
    add-path-inverse-r p r =
      ! (∙-unit-r p) ∙ ap (p ∙_) (! (!-inv-r r))

    abstract
      add-path-inverse-coh : {x y : B} (p : x == x) (q : x == y)
        → add-path-inverse-r p q ◃∙
          ap (_∙ (q ∙ ! q)) (add-path-inverse-l p q) ◃∙
          ∙-assoc (q ∙ ! q) p (q ∙ ! q) ◃∎
          =ₛ
          add-path-inverse-l p q ◃∙
          ap ((q ∙ ! q) ∙_) (add-path-inverse-r p q) ◃∎
      add-path-inverse-coh p idp =
        add-path-inverse-r p idp ◃∙
        idp ◃∙
        idp ◃∎
          =ₛ⟨ 1 & 1 & expand [] ⟩
        add-path-inverse-r p idp ◃∙
        idp ◃∎
          =ₛ⟨ 1 & 1 & expand [] ⟩
        add-path-inverse-r p idp ◃∎
          =ₛ₁⟨ ! (ap-idf (add-path-inverse-r p idp)) ⟩
        ap (λ q → q) (add-path-inverse-r p idp) ◃∎
          =ₛ⟨ 0 & 0 & contract ⟩
        add-path-inverse-l p idp ◃∙
        ap (λ q → q) (add-path-inverse-r p idp) ◃∎ ∎ₛ

  comp-l-seq : (a' : A) → η (μ e a') =-= η e ∙ η a'
  comp-l-seq a' =
    η (μ e a')
      =⟪ ap η (μ.unit-l a') ⟫
    η a'
      =⟪ add-path-inverse-l (η a') (merid e) ⟫
    η e ∙ η a' ∎∎

  comp-l : (a' : A) → η (μ e a') == η e ∙ η a'
  comp-l a' = ↯ (comp-l-seq a')

  comp-r-seq : (a : A) → η (μ a e) =-= η a ∙ η e
  comp-r-seq a =
    η (μ a e)
      =⟪ ap η (μ.unit-r a) ⟫
    η a
      =⟪ add-path-inverse-r (η a) (merid e) ⟫
    η a ∙ η e ∎∎

  comp-r : (a : A) → η (μ a e) == η a ∙ η e
  comp-r a = ↯ (comp-r-seq a)

  comp-lr-coh : comp-l e == comp-r e
  comp-lr-coh =
    ap2 (λ p₁ p₂ → ap η p₁ ∙ p₂)
        μ.coh
        (add-path-inverse-lr-coh (merid e))
    where
    add-path-inverse-lr-coh : {B : Type i} {b b' : B} (p : b == b')
      → add-path-inverse-l (p ∙ ! p) p == add-path-inverse-r (p ∙ ! p) p
    add-path-inverse-lr-coh idp = idp

  comp-l₁ : (a' : A) → [ η (μ e a') ]₁ == [ η e ∙ η a' ]₁
  comp-l₁ = ap [_]₁ ∘ comp-l

  comp-r₁ : (a : A) → [ η (μ a e) ]₁ == [ η a ∙ η e ]₁
  comp-r₁ = ap [_]₁ ∘ comp-r

  comp-args : args {i} {i} {A} {e} {A} {e}
  comp-args =
    record {
      m = -1; n = -1;
      P = λ a a' → (Q a a' , ⟨⟩);
      f = comp-r₁;
      g = comp-l₁;
      p = ap (ap [_]₁) (! comp-lr-coh)
    }
    where
    Q : A → A → Type i
    Q a a' = [ η (μ a a' ) ]₁ == [ η a ∙ η a' ]₁

  module Comp = WedgeExt {i} {i} {A} {e} {A} {e} comp-args

  comp : (a a' : A) → [ η (μ a a') ]₁ == [ η a ]₁ ∙₁ [ η a' ]₁
  comp = Comp.ext

  comp-unit-l : (a' : A) → comp e a' == comp-l₁ a'
  comp-unit-l a' = Comp.β-r a'

  comp-unit-r : (a : A) → comp a e == comp-r₁ a
  comp-unit-r a = Comp.β-l a

  module CoherenceProof (a' : A) where

    P : A → A → Type i
    P a a'' =
      comp (μ a a') a'' ◃∙
      ap (_∙₁ [ η a'' ]₁) (comp a a') ◃∙
      ap [_]₁ (∙-assoc (η a) (η a') (η a'')) ◃∎
      =ₛ
      ap ([_]₁ ∘ η) (H-X-assoc a a' a'') ◃∙
      comp a (μ a' a'') ◃∙
      ap ([ η a ]₁ ∙₁_) (comp a' a'') ◃∎

    P-is-prop : ∀ a a'' → is-prop (P a a'')
    P-is-prop a a'' = =ₛ-level (Trunc-level {n = 1})

    Q  : A → A → hProp i
    Q a a'' = P a a'' , P-is-prop a a''

    inner-coh :
      comp-r (μ e a') ◃∙
      ap (_∙ η e) (comp-l a') ◃∙
      ∙-assoc (η e) (η a') (η e) ◃∎
      =ₛ
      ap η (H-X-assoc e a' e) ◃∙
      comp-l (μ a' e) ◃∙
      ap (η e ∙_) (comp-r a') ◃∎
    inner-coh =
      comp-r (μ e a') ◃∙
      ap (_∙ η e) (comp-l a') ◃∙
      ∙-assoc (η e) (η a') (η e) ◃∎
        =ₛ⟨ 0 & 1 & expand (comp-r-seq (μ e a')) ⟩
      ap η (μ.unit-r (μ e a')) ◃∙
      add-path-inverse-r (η (μ e a')) (merid e) ◃∙
      ap (_∙ η e) (comp-l a') ◃∙
      ∙-assoc (η e) (η a') (η e) ◃∎
        =ₛ⟨ 2 & 1 & ap-seq-∙ (_∙ η e) (comp-l-seq a') ⟩
      ap η (μ.unit-r (μ e a')) ◃∙
      add-path-inverse-r (η (μ e a')) (merid e) ◃∙
      ap (_∙ η e) (ap η (μ.unit-l a')) ◃∙
      ap (_∙ η e) (add-path-inverse-l (η a') (merid e)) ◃∙
      ∙-assoc (η e) (η a') (η e) ◃∎
        =ₛ⟨ 1 & 2 & !ₛ $
            homotopy-naturality-from-idf (_∙ η e)
                                         (λ r → add-path-inverse-r r (merid e))
                                         (ap η (μ.unit-l a')) ⟩
      ap η (μ.unit-r (μ e a')) ◃∙
      ap η (μ.unit-l a') ◃∙
      add-path-inverse-r (η a') (merid e) ◃∙
      ap (_∙ η e) (add-path-inverse-l (η a') (merid e)) ◃∙
      ∙-assoc (η e) (η a') (η e) ◃∎
        =ₛ⟨ 2 & 3 & add-path-inverse-coh (η a') (merid e) ⟩
      ap η (μ.unit-r (μ e a')) ◃∙
      ap η (μ.unit-l a') ◃∙
      add-path-inverse-l (η a') (merid e) ◃∙
      ap (η e ∙_) (add-path-inverse-r (η a') (merid e)) ◃∎
        =ₛ⟨ 0 & 2 & ap-seq-=ₛ η (coh-assoc-unit-l-r-pentagon a') ⟩
      ap η (H-X-assoc e a' e) ◃∙
      ap η (μ.unit-l (μ a' e)) ◃∙
      ap η (μ.unit-r a') ◃∙
      add-path-inverse-l (η a') (merid e) ◃∙
      ap (η e ∙_) (add-path-inverse-r (η a') (merid e)) ◃∎
        =ₛ⟨ 2 & 2 &
            homotopy-naturality-from-idf (η e ∙_)
                                         (λ v → add-path-inverse-l v (merid e))
                                         (ap η (μ.unit-r a')) ⟩
      ap η (H-X-assoc e a' e) ◃∙
      ap η (μ.unit-l (μ a' e)) ◃∙
      add-path-inverse-l (η (μ a' e)) (merid e) ◃∙
      ap (η e ∙_) (ap η (μ.unit-r a')) ◃∙
      ap (η e ∙_) (add-path-inverse-r (η a') (merid e)) ◃∎
        =ₛ⟨ 3 & 2 & ∙-ap-seq (η e ∙_) (comp-r-seq a')⟩
      ap η (H-X-assoc e a' e) ◃∙
      ap η (μ.unit-l (μ a' e)) ◃∙
      add-path-inverse-l (η (μ a' e)) (merid e) ◃∙
      ap (η e ∙_) (comp-r a') ◃∎
        =ₛ⟨ 1 & 2 & contract ⟩
      ap η (H-X-assoc e a' e) ◃∙
      comp-l (μ a' e) ◃∙
      ap (η e ∙_) (comp-r a') ◃∎ ∎ₛ

    coh : P e e
    coh =
      comp (μ e a') e ◃∙
      ap (_∙₁ [ η e ]₁) (comp e a') ◃∙
      ap [_]₁ (∙-assoc (η e) (η a') (η e)) ◃∎
        =ₛ₁⟨ 0 & 1 & comp-unit-r (μ e a') ⟩
      comp-r₁ (μ e a') ◃∙
      ap (_∙₁ [ η e ]₁) (comp e a') ◃∙
      ap [_]₁ (∙-assoc (η e) (η a') (η e)) ◃∎
        =ₛ₁⟨ 1 & 1 & step₂ ⟩
      comp-r₁ (μ e a') ◃∙
      ap [_]₁ (ap (_∙ η e) (comp-l a')) ◃∙
      ap [_]₁ (∙-assoc (η e) (η a') (η e)) ◃∎
        =ₛ⟨ 0 & 3 & ap-seq-=ₛ [_]₁ inner-coh ⟩
      ap [_]₁ (ap η (H-X-assoc e a' e)) ◃∙
      comp-l₁ (μ a' e) ◃∙
      ap [_]₁ (ap (η e ∙_) (comp-r a')) ◃∎
        =ₛ₁⟨ 0 & 1 & ∘-ap [_]₁ η (H-X-assoc e a' e) ⟩
      ap ([_]₁ ∘ η) (H-X-assoc e a' e) ◃∙
      comp-l₁ (μ a' e) ◃∙
      ap [_]₁ (ap (η e ∙_) (comp-r a')) ◃∎
        =ₛ₁⟨ 1 & 1 & ! (comp-unit-l (μ a' e)) ⟩
      ap ([_]₁ ∘ η) (H-X-assoc e a' e) ◃∙
      comp e (μ a' e) ◃∙
      ap [_]₁ (ap (η e ∙_) (comp-r a')) ◃∎
        =ₛ₁⟨ 2 & 1 & step₈ ⟩
      ap ([_]₁ ∘ η) (H-X-assoc e a' e) ◃∙
      comp e (μ a' e) ◃∙
      ap ([ η e ]₁ ∙₁_) (comp a' e) ◃∎ ∎ₛ
      where
      step₂ : ap (_∙₁ [ η e ]₁) (comp e a') == ap [_]₁ (ap (_∙ η e) (comp-l a'))
      step₂ =
        ap (_∙₁ [ η e ]₁) (comp e a')
          =⟨ ap (ap (_∙₁ [ η e ]₁)) (comp-unit-l a') ⟩
        ap (_∙₁ [ η e ]₁) (comp-l₁ a')
          =⟨ ∘-ap (_∙₁ [ η e ]₁) [_]₁ (comp-l a') ⟩
        ap ([_]₁ ∘ (_∙ η e)) (comp-l a')
          =⟨ ap-∘ [_]₁ (_∙ η e) (comp-l a') ⟩
        ap [_]₁ (ap (_∙ η e) (comp-l a')) =∎
      step₈ : ap [_]₁ (ap (η e ∙_) (comp-r a')) == ap ([ η e ]₁ ∙₁_) (comp a' e)
      step₈ =
        ap [_]₁ (ap (η e ∙_) (comp-r a'))
          =⟨ ∘-ap [_]₁ (η e ∙_) (comp-r a') ⟩
        ap (λ v → [ η e ∙ v ]₁) (comp-r a')
          =⟨ ap-∘ ([ η e ]₁ ∙₁_) [_]₁ (comp-r a') ⟩
        ap ([ η e ]₁ ∙₁_) (comp-r₁ a')
          =⟨ ! (ap (ap ([ η e ]₁ ∙₁_)) (comp-unit-r a')) ⟩
        ap ([ η e ]₁ ∙₁_) (comp a' e) =∎

  abstract
    comp-coh : (a a' a'' : A)
      → comp (μ a a') a'' ◃∙
        ap (λ v → v ∙₁ [ η a'' ]₁) (comp a a') ◃∙
        ap [_]₁ (∙-assoc (η a) (η a') (η a'')) ◃∎
        =ₛ
        ap ([_]₁ ∘ η) (H-X-assoc a a' a'') ◃∙
        comp a (μ a' a'') ◃∙
        ap (λ v → [ η a ] ∙₁ v) (comp a' a'') ◃∎
    comp-coh a a' a'' =
      prop-over-connected {A = A} {a = e} {{is-0-connected}}
                          (λ a → CoherenceProof.Q a' a a'')
                          (prop-over-connected {A = A} {a = e} {{is-0-connected}}
                                              (λ a'' → CoherenceProof.Q a' e a'')
                                              (CoherenceProof.coh a')
                                              a'')
                          a

  comp-functor : (pentagon : coh-assoc-pentagon H-X H-X-assoc)
    → TwoSemiFunctor
        (HSpace-2-semi-category H-X {{⟨⟩}} H-X-assoc pentagon)
        (=ₜ-fundamental-cat (Susp (de⊙ X)))
  comp-functor _ =
    record
    { F₀ = λ _ → [ north ]
    ; F₁ = λ x → [ η x ]
    ; pres-comp = comp
    ; pres-comp-coh = comp-coh
    }


module SystemF.BigStep.Extrinsic.Terms where

open import Prelude
open import SystemF.BigStep.Types
open import Data.List
open import Data.Fin.Substitution

-- erased (type-free) System F syntax
data Term : Set where
  unit : Term
  ƛ : Term → Term
  Λ : Term → Term
  _·_ : Term → Term → Term
  _[-] : Term → Term
  var : ℕ → Term


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.EquivCarac.An[Am[X]]-Anm[X] where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Nat renaming (_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat
open import Cubical.Data.Sigma

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Polynomials.Univariate.Base

open import Cubical.Algebra.Polynomials.Multivariate.Base
open import Cubical.Algebra.Polynomials.Multivariate.Properties
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly

private variable
  ℓ ℓ' : Level

module Comp-Poly-nm (A' : CommRing ℓ) (n m : ℕ) where
  private
    A = fst A'
  open CommRingStr (snd A')

  module Mr  = Nth-Poly-structure A' m
  module N+Mr = Nth-Poly-structure A' (n +n m)
  module N∘Mr  = Nth-Poly-structure (PolyCommRing A' m) n

-----------------------------------------------------------------------------
-- direct sens

  N∘M→N+M-b : (v : Vec ℕ n) → Poly A' m → Poly A' (n +n m)
  N∘M→N+M-b v = Poly-Rec-Set.f A' m (Poly A' (n +n m)) trunc
                0P
                (λ v' a → base (v ++ v') a)
                _poly+_
                poly+Assoc
                poly+IdR
                poly+Comm
                (λ v' → base-0P (v ++ v'))
                (λ v' a b → base-poly+ (v ++ v') a b)

  N∘M→N+M : Poly (PolyCommRing A' m) n → Poly A' (n +n m)
  N∘M→N+M = Poly-Rec-Set.f (PolyCommRing A' m) n (Poly A' (n +n m)) trunc
           0P
           N∘M→N+M-b
           _poly+_
           poly+Assoc
           poly+IdR
           poly+Comm
           (λ _ → refl)
           (λ v a b → refl)

-- -----------------------------------------------------------------------------
-- -- Converse sens

  N+M→N∘M : Poly A' (n +n m) → Poly (PolyCommRing A' m) n
  N+M→N∘M = Poly-Rec-Set.f A' (n +n m) (Poly (PolyCommRing A' m) n) trunc
            0P
            (λ v a → let v , v'  = sep-vec n m v in
                      base v (base v' a))
            _poly+_
            poly+Assoc
            poly+IdR
            poly+Comm
            (λ v → (cong (base (fst (sep-vec n m v))) (base-0P (snd (sep-vec n m v)))) ∙ (base-0P (fst (sep-vec n m v))))
            λ v a b → base-poly+ (fst (sep-vec n m v)) (base (snd (sep-vec n m v)) a) (base (snd (sep-vec n m v)) b)
                       ∙ cong (base (fst (sep-vec n m v))) (base-poly+ (snd (sep-vec n m v)) a b)

-----------------------------------------------------------------------------
-- Section

  e-sect : (P : Poly A' (n +n m)) → N∘M→N+M (N+M→N∘M P) ≡ P
  e-sect = Poly-Ind-Prop.f A' (n +n m)
           (λ P → N∘M→N+M (N+M→N∘M P) ≡ P)
           (λ _ → trunc _ _)
           refl
           (λ v a → cong (λ X → base X a) (sep-vec-id n m v))
           (λ {U V} ind-U ind-V → cong₂ _poly+_ ind-U ind-V)

-----------------------------------------------------------------------------
-- Retraction

  e-retr : (P : Poly (PolyCommRing A' m) n) → N+M→N∘M (N∘M→N+M P) ≡ P
  e-retr = Poly-Ind-Prop.f (PolyCommRing A' m) n
           (λ P → N+M→N∘M (N∘M→N+M P) ≡ P)
           (λ _ → trunc _ _)
           refl
           (λ v → Poly-Ind-Prop.f A' m
                   (λ P → N+M→N∘M (N∘M→N+M (base v P)) ≡ base v P)
                   (λ _ → trunc _ _)
                   (sym (base-0P v))
                   (λ v' a → cong₂ base (sep-vec-fst n m v v') (cong (λ X → base X a) (sep-vec-snd n m v v')))
                   (λ {U V} ind-U ind-V → (cong₂ _poly+_ ind-U ind-V) ∙ (base-poly+ v U V)))
           (λ {U V} ind-U ind-V → cong₂ _poly+_ ind-U ind-V )

-----------------------------------------------------------------------------
-- Morphism of ring

  map-0P : N∘M→N+M (0P) ≡ 0P
  map-0P = refl

  N∘M→N+M-gmorph : (P Q : Poly (PolyCommRing A' m) n) → N∘M→N+M ( P poly+ Q) ≡ N∘M→N+M P poly+ N∘M→N+M Q
  N∘M→N+M-gmorph = λ P Q → refl

  map-1P : N∘M→N+M (N∘Mr.1P) ≡ N+Mr.1P
  map-1P = cong (λ X → base X 1r) (rep-concat n m 0 )

  N∘M→N+M-rmorph : (P Q : Poly (PolyCommRing A' m) n) → N∘M→N+M ( P N∘Mr.poly* Q) ≡ N∘M→N+M P N+Mr.poly* N∘M→N+M Q
  N∘M→N+M-rmorph =
    -- Ind P
    Poly-Ind-Prop.f (PolyCommRing A' m) n
    (λ P → (Q : Poly (PolyCommRing A' m) n) → N∘M→N+M (P N∘Mr.poly* Q) ≡ (N∘M→N+M P N+Mr.poly* N∘M→N+M Q))
    (λ P p q i Q j → trunc _ _ (p Q) (q Q) i j)
    (λ Q → refl)
    (λ v → -- Ind Base P
           Poly-Ind-Prop.f A' m
           (λ P → (Q : Poly (PolyCommRing A' m) n) → N∘M→N+M (base v P N∘Mr.poly* Q) ≡ (N∘M→N+M (base v P) N+Mr.poly* N∘M→N+M Q))
           (λ P p q i Q j → trunc _ _ (p Q) (q Q) i j)
           (λ Q → cong (λ X → N∘M→N+M (X N∘Mr.poly* Q)) (base-0P v))
           (λ v' a → -- Ind Q
                      Poly-Ind-Prop.f (PolyCommRing A' m) n
                      (λ Q → N∘M→N+M (base v (base v' a) N∘Mr.poly* Q) ≡ (N∘M→N+M (base v (base v' a)) N+Mr.poly* N∘M→N+M Q))
                      (λ _ → trunc _ _)
                      (sym (N+Mr.poly*AnnihilR (N∘M→N+M (base v (base v' a)))))
                      (λ w → -- Ind base Q
                              Poly-Ind-Prop.f A' m
                              _
                              (λ _ → trunc _ _)
                              (sym (N+Mr.poly*AnnihilR (N∘M→N+M (base v (base v' a)))))
                              (λ w' b → cong (λ X → base X (a · b)) (+n-vec-concat n m v w v' w'))
                              λ {U V} ind-U ind-V → cong (λ X → N∘M→N+M (base v (base v' a) N∘Mr.poly* X)) (sym (base-poly+ w U V))
                                                     ∙ cong₂ (_poly+_ ) ind-U ind-V
                                                     ∙ sym (cong (λ X → N∘M→N+M (base v (base v' a)) N+Mr.poly* N∘M→N+M X) (base-poly+ w U V)) )
                              -- End Ind base Q
                      λ {U V} ind-U ind-V → cong₂ _poly+_ ind-U ind-V)
                      -- End Ind Q
           λ {U V} ind-U ind-V Q → cong (λ X → N∘M→N+M (X N∘Mr.poly* Q)) (sym (base-poly+ v U V))
                                    ∙ cong₂ _poly+_ (ind-U Q) (ind-V Q)
                                    ∙ sym (cong (λ X → (N∘M→N+M X) N+Mr.poly* (N∘M→N+M Q)) (sym (base-poly+ v U V)) ))
           -- End Ind base P
     λ {U V} ind-U ind-V Q → cong₂ _poly+_ (ind-U Q) (ind-V Q)
     -- End Ind P

-----------------------------------------------------------------------------
-- Ring Equivalence

module _ (A' : CommRing ℓ) (n m : ℕ) where

  open Comp-Poly-nm A' n m

  CRE-PolyN∘M-PolyN+M : CommRingEquiv (PolyCommRing (PolyCommRing A' m) n) (PolyCommRing A' (n +n m))
  fst CRE-PolyN∘M-PolyN+M = isoToEquiv is
    where
    is : Iso _ _
    Iso.fun is = N∘M→N+M
    Iso.inv is = N+M→N∘M
    Iso.rightInv is = e-sect
    Iso.leftInv is = e-retr

  snd CRE-PolyN∘M-PolyN+M = makeIsRingHom map-1P N∘M→N+M-gmorph N∘M→N+M-rmorph


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

open import HoTT

open import stash.modalities.Orthogonality

module stash.modalities.Nullification where

module _ {i} where

  postulate -- HIT
    P⟨_⟩ : (A X : Type i) → Type i
    p[_] : {A X : Type i} → X → P⟨ A ⟩ X
    is-orth : {A X : Type i} → ⟦ A ⊥ P⟨ A ⟩ X ⟧

  module NullElim {A X : Type i} {Q : P⟨ A ⟩ X → Type i}
    (p : (x : P⟨ A ⟩ X) → ⟦ A ⊥ Q x ⟧) (d : (x : X) → Q p[ x ]) where

    postulate
      f : Π (P⟨ A ⟩ X) Q
      p[_]-β : ∀ x → f p[ x ] ↦ d x
    {-# REWRITE p[_]-β #-}

open NullElim public renaming (f to Null-elim)

module _ {i} (A : Type i) where

  NullModality : Modality i
  Modality.is-local NullModality X = ⟦ A ⊥ X ⟧
  Modality.is-local-is-prop NullModality = is-equiv-is-prop
  Modality.◯ NullModality = P⟨ A ⟩
  Modality.◯-is-local NullModality = is-orth
  Modality.η NullModality = p[_]
  Modality.◯-elim NullModality = Null-elim
  Modality.◯-elim-β NullModality _ _ _ = idp
  Modality.◯-=-is-local NullModality x y = pths-orth is-orth

module _ {i} (A X : Type i) where

  f-aux : (x : P⟨ Susp A ⟩ X) → P⟨ A ⟩ (x == x)
  f-aux = Null-elim (λ x → susp-≻ A (P⟨ A ⟩ (x == x)) is-orth) (λ x → p[ idp ])

  f : (x y : P⟨ Susp A ⟩ X) → x == y → P⟨ A ⟩ (x == y)
  f x .x idp = f-aux x

module _ {i} {A B : Type i} (f : A → B) where

  ap-fib-to : {a₀ a₁ : A} (p : f a₀ == f a₁) → hfiber (ap f) p
    → Σ (hfiber f (f a₀)) (λ α →
       Σ (hfiber f (f a₁)) (λ β →
       Σ (fst α == fst β) (λ q →
       ap f q == snd α ∙ p ∙ ! (snd β))))
  ap-fib-to {a₀} {a₁} .(ap f q) (q , idp) = (a₀ , idp) , (a₁ , idp) , q , ! (∙-unit-r (ap f q))

  postulate
    ap-fib : {a₀ a₁ : A} (p : f a₀ == f a₁) → is-equiv (ap-fib-to p)

  new-ap-fib : {a₀ a₁ : A} (p : f a₀ == f a₁) → hfiber (ap f) p
    → Σ (hfiber f (f a₀)) (λ α →
       Σ (hfiber f (f a₁)) (λ β →
       α == β [ (λ z → hfiber f z) ↓ p ]))
  new-ap-fib = {!!}

module _ {i} (A X : Type i) (x y : X) where

  module NMA = Modality (NullModality A)
  module NMSA = Modality (NullModality (Susp A))

  -- Okay.  Here is the map in question:
  pΣ : x == y → Path {A = P⟨ Susp A ⟩ X} p[ x ] p[ y ]
  pΣ = ap p[_]

  lemma : NMSA.is-◯-equiv pΣ
  lemma p = NMSA.equiv-preserves-◯-conn ((ap-fib-to p[_] p , ap-fib p[_] p) ⁻¹)
              {!!}

  thm : NMA.is-◯-equiv pΣ
  thm p = {!!}

  -- equiv-preserves-◯-conn : {A B : Type ℓ} → A ≃ B → is-◯-connected A → is-◯-connected B
  -- equiv-preserves-◯-conn e c = equiv-preserves-level (◯-emap e) c

  -- Okay, here's a better explanation: you are simply applying the
  -- full fledged join adjunction formula to the p[_].  I think
  -- the diagonal of this map will have fibers which are exactly
  -- the PathOver description you give above.  Or something
  -- very close to this.  That's the main idea.

  -- Theorem 19.1 of CwA and PA asserts that this map
  -- is A-connected.  Have to trace through the argument.
  -- So we don't contruct a direct inverse ...

  -- He starts by observing that it is ΣA-connected.
  -- Do you have a proof of this?  It should be obvious ...

  -- So by adjuction, loops on this fiber is A-connected.

  -- Then the claim is that you can commute with limits, i.e.
  -- that this is the fiber on loops of the canoncial map.

  -- Right.  This is much clearer.  We'll need some preparation,
  -- but I think this should be quite doable.

  -- this map is fairly easy by adjunction ...
  to : P⟨ A ⟩ (x == y) → (Path {A = P⟨ Susp A ⟩ X} p[ x ] p[ y ])
  to = Null-elim (λ p → adj-orth A (P⟨ Susp A ⟩ X) is-orth p[ x ] p[ y ]) (λ p → ap p[_] p)


module _ where

postulate
  A : Set

data Box : Set where
  box : A → Box

unbox : Box → A
unbox (box {x}) = x


-- 2010-10-01 Issue 342
module NonDependentConstructorType where

data Wrap : Set1 where
  wrap : Set -> Wrap

bla : Set
bla = wrap
-- 2010-10-01 error is printed as (_ : Set) -> Wrap !=< Set
-- error should be printed as Set -> Wrap !=< Set


{-# OPTIONS --universe-polymorphism #-}
module Categories.Agda.ISetoids.Cocomplete.Helpers where

open import Level
open import Relation.Binary using (Setoid; module Setoid; Preorder; module Preorder; Rel; _=[_]⇒_)
open import Data.Product using (Σ; _,_; Σ-syntax)
-- import Relation.Binary.EqReasoning as EqReasoning

open import Categories.Support.Equivalence using (module I→R-Wrapper; setoid-i→r; squash) renaming (Setoid to ISetoid; module Setoid to ISetoid)
open import Categories.Support.SetoidFunctions using (module _⟶_)
open import Categories.Support.PropositionalEquality
import Categories.Support.ZigZag as ZigZag

open import Categories.Category
open import Categories.Functor
open import Categories.Agda
open import Categories.Colimit
open import Categories.Object.Initial
open import Categories.Cocones
open import Categories.Cocone

open I→R-Wrapper

ding : Level → Level
ding ℓ = ℓ

module ColimitCocone {o ℓ e c ℓ′} {J : Category o ℓ e} (F : Functor J (ISetoids (c ⊔ ding (o ⊔ ℓ ⊔ e)) (c ⊔ ℓ′ ⊔ ding (o ⊔ ℓ ⊔ e)))) where
  c′ = c ⊔ ding (o ⊔ ℓ ⊔ e)
  ℓ″ = c ⊔ ℓ′ ⊔ ding (o ⊔ ℓ ⊔ e)
  C = ISetoids c′ ℓ″
  D = Cocones F
  module J = Category J
  open Functor F
  open ISetoid
  open _⟶_

  vertex-carrier = Σ[ x ∈ J.Obj ] Carrier (F₀ x)

  -- this lets us build a preorder out of an irrelevant setoid, since there
  -- are no irrelevant preorders
  dot-setoid : (j : J.Obj) → Setoid c′ ℓ″
  dot-setoid j = setoid-i→r (F₀ j)
  module DotSetoid (j : J.Obj) = Setoid (dot-setoid j)
  open DotSetoid using () renaming (_≈_ to _[_≈_])

  -- _↝_ means that an arrow in the diagram directly constrains the two
  -- objects of vertex-carrier to be equal.  completing this to an
  -- equivalence relation gives us the setoid we need
  _↝_ : (x y : vertex-carrier) → Set ℓ″
  (X , x) ↝ (Y , y) = Σ[ f ∈ J [ X , Y ] ] (Y [ (F₁ f ⟨$⟩ x) ≈ y ])

  ↝-preorder : Preorder c′ c′ ℓ″
  ↝-preorder = record
    { Carrier = vertex-carrier
    ; _≈_ = _≣_
    ; _∼_ = _↝_
    ; isPreorder = record
      { isEquivalence = ≣-isEquivalence
      ; reflexive = ↝-reflexive
      ; trans = ↝-trans
      }
    }
    where
    ↝-refl : ∀ {i} → (i ↝ i)
    ↝-refl {X , x} = J.id , squash (identity (refl (F₀ X)))

    ↝-reflexive : ∀ {i j} → (i ≣ j) → (i ↝ j)
    ↝-reflexive ≣-refl = ↝-refl

    -- the nice proof.  pretty proof!
    {-
    ↝-trans : ∀ {i j k} → (i ↝ j) → (j ↝ k) → (i ↝ k)
    ↝-trans {_ , i} {_ , j} {k₁ , k} (f , squash fi≈j) (g , gj≈k) =
      J [ g ∘ f ] , (
        begin
          F₁ (J [ g ∘ f ]) ⟨$⟩ i
        ≈⟨ squash homomorphism ⟩
          F₁ g ⟨$⟩ (F₁ f ⟨$⟩ i)
        ≈⟨ squash (cong (F₁ g) fi≈j) ⟩
          F₁ g ⟨$⟩ j
        ≈⟨ gj≈k ⟩
          k
        ∎ )
      where
      open EqReasoning (dot-setoid k₁)
    -}

    -- the ugly proof that loads before the sun burns out.
    ↝-trans : ∀ {i j k} → (i ↝ j) → (j ↝ k) → (i ↝ k)
    ↝-trans {X , _} {k = Z , _} (f , squash fx≈y) (g , gy≈z) =
      J [ g ∘ f ] , DotSetoid.trans Z (squash (trans (F₀ Z) (homomorphism (refl (F₀ X))) (cong (F₁ g) fx≈y))) gy≈z

  vertex = ZigZag.isetoid ↝-preorder

  ⊥ : Cocone F
  ⊥ = record
    { N = vertex
    ; ψ = λ X → record
      { _⟨$⟩_ = _,_ X
      ; cong = λ pf → ZigZag.disorient (ZigZag.slish (J.id , squash (identity pf)))
    -- cong would be easier if i'd used the proper dotwise equality for
    -- ↝-preorder above ... since this is basically the proof ↝ respects it
    }
    ; commute = λ {X Y} f {x : _} {y : _} (x≈y : _) → ZigZag.disorient (ZigZag.slish (f , (squash (cong (F₁ f) x≈y))))
    }

  ! : {A : Cocone F} → CoconeMorphism {F = F} ⊥ A
  ! {A} = record
    { f = record
      { _⟨$⟩_ = my-f
      ; cong = ZigZag.iminimal ↝-preorder A.N my-f my-precong
      }
    ; commute = λ {X x y} x≈y → cong (A.ψ X) x≈y
    }
    where
    module A = Cocone A
    my-f : vertex-carrier → Carrier A.N
    my-f (X , x) = A.ψ X ⟨$⟩ x

    .my-precong : _↝_ =[ my-f ]⇒ (_≈_ A.N)
    my-precong {X , x} {Y , y} (f , squash fx≈y) = trans A.N (A.commute f (refl (F₀ X))) (cong (A.ψ Y) (irr fx≈y))


module SystemF.BigStep.Types where

open import Prelude
open import Data.List as List

-- types are indexed by the number of open tvars
infixl 10 _⇒_
data Type (n : ℕ) : Set where
  Unit : Type n
  ν    : (i : Fin n) → Type n
  _⇒_  : Type n → Type n → Type n
  ∀'   : Type (suc n) → Type n

open import Data.Fin.Substitution
open import Data.Vec hiding (_∈_; map)

module App {T} (l : Lift T Type )where

  open Lift l hiding (var)
  _/_  : ∀ {m n} → Type m → Sub T m n → Type n
  Unit / s = Unit
  ν i / s = lift (lookup i s)
  (a ⇒ b) / s = (a / s) ⇒ (b / s)
  ∀' x / s = ∀' (x / (s ↑))

  open Application (record { _/_ = _/_ }) using (_/✶_)

  open import Data.Star

  Unit-/✶-↑✶ : ∀ k {m n} (ρs : Subs T m n) → Unit /✶ ρs ↑✶ k ≡ Unit
  Unit-/✶-↑✶ k ε = refl
  Unit-/✶-↑✶ k (x ◅ ρs) = cong₂ _/_ (Unit-/✶-↑✶ k ρs) refl

  ∀-/✶-↑✶ : ∀ k {m n t} (ρs : Subs T m n) →
            ∀' t /✶ ρs ↑✶ k ≡ ∀' (t /✶ ρs ↑✶ suc k)
  ∀-/✶-↑✶ k ε        = refl
  ∀-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (∀-/✶-↑✶ k ρs) refl

  ⇒-/✶-↑✶ : ∀ k {m n t₁ t₂} (ρs : Subs T m n) →
            t₁ ⇒ t₂ /✶ ρs ↑✶ k ≡ (t₁ /✶ ρs ↑✶ k) ⇒ (t₂ /✶ ρs ↑✶ k)
  ⇒-/✶-↑✶ k ε        = refl
  ⇒-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (⇒-/✶-↑✶ k ρs) refl

tmSubst : TermSubst Type
tmSubst = record { var = ν; app = App._/_ }

open TermSubst tmSubst hiding (var; subst) public

-- typing context
Ctx : ℕ → Set
Ctx n = List (Type n)

_+tm_ : ∀ {n} → Ctx n → Type n → Ctx n
Γ +tm a = a ∷ Γ

Var : ∀ {n} → Ctx n → Type n → Set
Var Γ a = a ∈ Γ
  where
    open import Data.List.Any
    open Membership-≡

infixl 30 _ctx/_
_ctx/_ : ∀ {n m} → Ctx n → Sub Type n m → Ctx m
Γ ctx/ ρ = List.map (flip _/_ ρ) Γ

_+ty  : ∀ {n} → Ctx n → Ctx (suc n)
Γ +ty = Γ ctx/ wk

module Lemmas where

  open import Data.Fin.Substitution.Lemmas

  tyLemmas : TermLemmas Type
  tyLemmas = record
    { termSubst = tmSubst
    ; app-var   = refl
    ; /✶-↑✶     = Lemma./✶-↑✶
    }
    where
    module Lemma {T₁ T₂} {lift₁ : Lift T₁ Type} {lift₂ : Lift T₂ Type} where

      open Lifted lift₁ using () renaming (_↑✶_ to _↑✶₁_; _/✶_ to _/✶₁_)
      open Lifted lift₂ using () renaming (_↑✶_ to _↑✶₂_; _/✶_ to _/✶₂_)

      /✶-↑✶ : ∀ {m n} (ρs₁ : Subs T₁ m n) (ρs₂ : Subs T₂ m n) →
              (∀ k x → ν x /✶₁ ρs₁ ↑✶₁ k ≡ ν x /✶₂ ρs₂ ↑✶₂ k) →
              ∀ k t → t /✶₁ ρs₁ ↑✶₁ k ≡ t /✶₂ ρs₂ ↑✶₂ k
      /✶-↑✶ ρs₁ ρs₂ hyp k Unit =
        begin _ ≡⟨ App.Unit-/✶-↑✶ _ k ρs₁ ⟩ Unit ≡⟨ sym $ App.Unit-/✶-↑✶ _ k ρs₂ ⟩ _ ∎
      /✶-↑✶ ρs₁ ρs₂ hyp k (ν i) = hyp k i
      /✶-↑✶ ρs₁ ρs₂ hyp k (a ⇒ b) = begin
        _ ≡⟨ App.⇒-/✶-↑✶ _ k ρs₁ ⟩
        (a /✶₁ ρs₁ ↑✶₁ k) ⇒ (b /✶₁ ρs₁ ↑✶₁ k) ≡⟨ cong₂ _⇒_ (/✶-↑✶ ρs₁ ρs₂ hyp k a)
                                                           ((/✶-↑✶ ρs₁ ρs₂ hyp k b)) ⟩
        (a /✶₂ ρs₂ ↑✶₂ k) ⇒ (b /✶₂ ρs₂ ↑✶₂ k) ≡⟨ sym $ App.⇒-/✶-↑✶ _ k ρs₂ ⟩
        _ ∎
      /✶-↑✶ ρs₁ ρs₂ hyp k (∀' x) = begin
        _ ≡⟨ App.∀-/✶-↑✶ _ k ρs₁ ⟩
          ∀' (x /✶₁ ρs₁ ↑✶₁ (suc k)) ≡⟨ cong ∀' (/✶-↑✶ ρs₁ ρs₂ hyp (suc k) x) ⟩
        ∀' (x /✶₂ ρs₂ ↑✶₂ (suc k)) ≡⟨ sym $ App.∀-/✶-↑✶ _ k ρs₂ ⟩
        _ ∎

  open TermLemmas tyLemmas public hiding (var)

module CtxLemmas where

  open import Data.List.Properties as ListProp using ()
  open import Function as Fun

  -- weakening followed by sub disappears on contexts
  ctx/-wk-sub≡id : ∀ {n} (Γ : Ctx n) a → (Γ ctx/ wk) ctx/ (sub a) ≡ Γ
  ctx/-wk-sub≡id Γ a = begin
    _ ≡⟨ sym (ListProp.map-compose Γ) ⟩
    map (λ x → x / wk / (sub a)) Γ ≡⟨ ListProp.map-cong Lemmas.wk-sub-vanishes Γ ⟩
    map Fun.id Γ ≡⟨ ListProp.map-id Γ ⟩
    _ ∎

  -- weakening commutes with other substitutions on contexts
  ctx/-wk-comm : ∀ {n m} (Γ : Ctx n) (ρ : Sub Type n m) → (Γ ctx/ ρ) ctx/ wk ≡ Γ ctx/ wk ctx/ (ρ ↑)
  ctx/-wk-comm Γ ρ = begin
    _ ≡⟨ sym $ ListProp.map-compose Γ ⟩
    map (λ x → x / ρ / wk) Γ ≡⟨ ListProp.map-cong Lemmas.wk-commutes Γ ⟩
    map (λ x → x / wk / ρ ↑) Γ ≡⟨ ListProp.map-compose Γ ⟩
    _ ∎


{-# OPTIONS --prop --rewriting #-}

module Examples.Sorting where

import Examples.Sorting.Sequential
import Examples.Sorting.Parallel


module Data.List.Instance where

open import Class.Equality
open import Class.Monad
open import Class.Monoid
open import Class.Show
open import Class.Traversable
open import Data.Bool using (Bool; _∧_; true; false)
open import Data.List hiding (concat)
open import Data.List.Properties
open import Data.String using (String)
open import Data.String.Instance
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

instance
  List-Eq : ∀ {A} {{_ : Eq A}} -> Eq (List A)
  List-Eq {A} = record { _≟_ = ≡-dec _≟_ }

  List-EqB : ∀ {A} {{_ : EqB A}} -> EqB (List A)
  List-EqB {A} = record { _≣_ = helper }
    where
      helper : (l l' : List A) -> Bool
      helper [] [] = true
      helper [] (x ∷ l') = false
      helper (x ∷ l) [] = false
      helper (x ∷ l) (x₁ ∷ l') = x ≣ x₁ ∧ helper l l'

  List-Monoid : ∀ {a} {A : Set a} -> Monoid (List A)
  List-Monoid = record { mzero = [] ; _+_ = _++_ }

  List-Traversable : ∀ {a} -> Traversable {a} (List {a})
  List-Traversable = record { sequence = helper }
    where
      helper : ∀ {a} {M : Set a → Set a} ⦃ _ : Monad M ⦄ {A : Set a} → List (M A) → M (List A)
      helper [] = return []
      helper (x ∷ xs) = do
        x' <- x
        xs' <- helper xs
        return (x' ∷ xs')

  List-Show : ∀ {a} {A : Set a} {{_ : Show A}} -> Show (List A)
  List-Show = record { show = showList show }
    where
      showList : ∀ {a} {A : Set a} -> (A -> String) -> List A -> String
      showList showA l = "[" + concat (intersperse "," (map showA l)) + "]"

  List-Monad : ∀ {a} -> Monad {a} List
  List-Monad = record { _>>=_ = λ l f -> concat (map f l) ; return = λ a -> Data.List.[ a ] }


------------------------------------------------------------------------
-- Untyped kind/type/term equality in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Syntax.WeakEquality where

open import Data.Fin using (Fin; zero; suc; raise)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Fin.Substitution.Relation
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.List using ([]; _∷_; _++_)
open import Data.Vec as Vec using ([])
open import Relation.Binary using (IsEquivalence; Setoid)
import Relation.Binary.Reasoning.Setoid as SetoidReasoning
open import Relation.Binary.PropositionalEquality as P

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization

------------------------------------------------------------------------
-- Weak untyped kind/type/term equality.
--
-- A "weak" equality that identifies syntactically equal terms and
-- types in elimination form up to type/kind ascriptions in
-- abstractions (lambdas).
--
-- Certain commutation lemmas about hereditary substitution,
-- η-expansion and normalization of raw types do not hold on the nose
-- (i.e. up to α-equivalence) because type-directed η-expansion can
-- change domain annotations in type operator abstractions.  Since
-- untyped normalization involves some degree of η-expansion, the
-- order in which these operations are performed can affect the domain
-- annotations in the resulting raw type expressions.  This is not a
-- problem semantically because the two type expressions are
-- considered equal as types (by the type equality judgment).  But
-- proving the relevant commutation lemmas directly w.r.t. to type
-- equality is difficult because of the complexity of that judgment.
-- Instead, we introduce a separate equivalence relation, called "weak
-- equality", that is essentially α-equivalence modulo shape-equal
-- domain annotations.  The problematic commutation lemmas then all
-- hold weakly (i.e. up to weak equality, see the nf-/⟨⟩ lemma in the
-- FOmegaInt.Kinding.Simple.Normalization for example).  Weak equality
-- is much easier to work with and can be embedded into (canonical)
-- type equivalence (see the FOmegaInt.Kinding.Canonical.WeakEquality
-- module).

open Syntax

infix 4 _≋_ _≈_ _≈Hd_ _≈Sp_ _≈Asc_ _≈Ctx_ _⟨≈⟩_ _≈?_

mutual

  data _≋_ {n} : Kind Elim n → Kind Elim n → Set where
    ≋-Π : ∀ {j₁ j₂ k₁ k₂} → j₁ ≋ j₂ → k₁ ≋ k₂ → Π j₁ k₁ ≋ Π j₂ k₂
    ≋-⋯ : ∀ {a₁ a₂ b₁ b₂} → a₁ ≈ a₂ → b₁ ≈ b₂ → a₁ ⋯ b₁ ≋ a₂ ⋯ b₂

  data _≈_ {n} : Elim n → Elim n → Set where
    ≈-∙ : ∀ {a₁ a₂ bs₁ bs₂} → a₁ ≈Hd a₂ → bs₁ ≈Sp bs₂ → a₁ ∙ bs₁ ≈ a₂ ∙ bs₂

  data _≈Hd_ {n} : Head n → Head n → Set where
    ≈-var : ∀ x →                                           var x ≈Hd var x
    ≈-⊥   :                                                     ⊥ ≈Hd ⊥
    ≈-⊤   :                                                     ⊤ ≈Hd ⊤
    ≈-∀   : ∀ {k₁ k₂ a₁ a₂} → k₁ ≋ k₂         → a₁ ≈ a₂ → Π k₁ a₁ ≈Hd Π k₂ a₂
    ≈-→   : ∀ {a₁ a₂ b₁ b₂} → a₁ ≈ a₂         → b₁ ≈ b₂ → a₁ ⇒ b₁ ≈Hd a₂ ⇒ b₂
    ≈-Λ   : ∀ {k₁ k₂ a₁ a₂} → ⌊ k₁ ⌋ ≡ ⌊ k₂ ⌋ → a₁ ≈ a₂ → Λ k₁ a₁ ≈Hd Λ k₂ a₂
    ≈-λ   : ∀ {a₁ a₂ b₁ b₂}                   → b₁ ≈ b₂ → ƛ a₁ b₁ ≈Hd ƛ a₂ b₂
    ≈-⊡   : ∀ {a₁ a₂ b₁ b₂} → a₁ ≈ a₂         → b₁ ≈ b₂ → a₁ ⊡ b₁ ≈Hd a₂ ⊡ b₂

  data _≈Sp_ {n} : Spine n → Spine n → Set where
    ≈-[] :                                                   [] ≈Sp []
    ≈-∷  : ∀ {a₁ a₂ bs₁ bs₂} → a₁ ≈ a₂ → bs₁ ≈Sp bs₂ → a₁ ∷ bs₁ ≈Sp a₂ ∷ bs₂

data _≈Asc_ {n} : ElimAsc n → ElimAsc n → Set where
  ≈-kd : ∀ {k₁ k₂} → k₁ ≋ k₂ → kd k₁ ≈Asc kd k₂
  ≈-tp : ∀ {a₁ a₂} → a₁ ≈ a₂ → tp a₁ ≈Asc tp a₂

open ElimCtx hiding (_++_)

data _≈Ctx_ : ∀ {n} → Ctx n → Ctx n → Set where
  ≈-[] : [] ≈Ctx []
  ≈-∷  : ∀ {n a₁ a₂} {Γ₁ Γ₂ : Ctx n} →
         a₁ ≈Asc a₂ → Γ₁ ≈Ctx Γ₂ → a₁ ∷ Γ₁ ≈Ctx a₂ ∷ Γ₂

-- Weak equality of single-variable substations and results.

data _⟨≈⟩_ : ∀ {m n} → SVSub m n → SVSub m n → Set where
  ≈-sub : ∀ {n}   {a b : Elim n}    →  a ≈ b  → sub a ⟨≈⟩ sub b
  ≈-↑   : ∀ {m n} {σ τ : SVSub m n} → σ ⟨≈⟩ τ →   σ ↑ ⟨≈⟩ τ ↑

data _≈?_ {n} : SVRes n → SVRes n → Set where
  ≈-hit  : ∀ {a b : Elim n} → a ≈ b →  hit a ≈? hit b
  ≈-miss : ∀ (x : Fin n)            → miss x ≈? miss x

-- Shorthands.

≈-var∙ : ∀ {n} (x : Fin n) → var∙ x ≈ var∙ x
≈-var∙ x = ≈-∙ (≈-var x) ≈-[]

≈-⊥∙ : ∀ {n} → _≈_ {n = n} ⊥∙ ⊥∙
≈-⊥∙ = ≈-∙ (≈-⊥) ≈-[]

≈-⊤∙ : ∀ {n} → _≈_ {n = n} ⊤∙ ⊤∙
≈-⊤∙ = ≈-∙ (≈-⊤) ≈-[]

≈-∀∙ : ∀ {n} {k₁ k₂ : Kind Elim n} {a₁ a₂} →
       k₁ ≋ k₂ → a₁ ≈ a₂ → ∀∙ k₁ a₁ ≈ ∀∙ k₂ a₂
≈-∀∙ k₁≋k₂ a₁≈a₂ = ≈-∙ (≈-∀ k₁≋k₂ a₁≈a₂) ≈-[]

≈-⇒∙ : ∀ {n} {a₁ a₂ : Elim n} {b₁ b₂} →
       a₁ ≈ a₂ → b₁ ≈ b₂ → a₁ ⇒∙ b₁ ≈ a₂ ⇒∙ b₂
≈-⇒∙ a₁≈a₂ b₁≈b₂ = ≈-∙ (≈-→ a₁≈a₂ b₁≈b₂) ≈-[]

≈-Λ∙ : ∀ {n} {k₁ k₂ : Kind Elim n} {a₁ a₂} → ⌊ k₁ ⌋ ≡ ⌊ k₂ ⌋ → a₁ ≈ a₂ →
       Λ∙ k₁ a₁ ≈ Λ∙ k₂ a₂
≈-Λ∙ ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂ = ≈-∙ (≈-Λ ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂) ≈-[]

≈-λ∙ : ∀ {n} {a₁ a₂ : Elim n} {b₁ b₂} → b₁ ≈ b₂ → ƛ∙ a₁ b₁ ≈ ƛ∙ a₂ b₂
≈-λ∙ a₁≈a₂ = ≈-∙ (≈-λ a₁≈a₂) ≈-[]

≈-⊡∙ : ∀ {n} {a₁ a₂ : Elim n} {b₁ b₂} →
       a₁ ≈ a₂ → b₁ ≈ b₂ → a₁ ⊡∙ b₁ ≈ a₂ ⊡∙ b₂
≈-⊡∙ a₁≈a₂ b₁≈b₂ = ≈-∙ (≈-⊡ a₁≈a₂ b₁≈b₂) ≈-[]

------------------------------------------------------------------------
-- Simple properties of weake equality.

-- Some simple congruence rules w.r.t. operations on spines and
-- eliminations.

≈-++ : ∀ {n} {as₁ as₂ : Spine n} {bs₁ bs₂} →
       as₁ ≈Sp as₂ → bs₁ ≈Sp bs₂ → as₁ ++ bs₁ ≈Sp as₂ ++ bs₂
≈-++ ≈-[]                bs₁≈bs₂ = bs₁≈bs₂
≈-++ (≈-∷ a₁≈a₂ as₁≈as₂) bs₁≈bs₂ = ≈-∷ a₁≈a₂ (≈-++ as₁≈as₂ bs₁≈bs₂)

≈-∙∙ : ∀ {n} {a₁ a₂ : Elim n} {bs₁ bs₂} →
       a₁ ≈ a₂ → bs₁ ≈Sp bs₂ → a₁ ∙∙ bs₁ ≈ a₂ ∙∙ bs₂
≈-∙∙ (≈-∙ a₁≈a₂ as₁≈as₂) bs₁≈bs₂ = ≈-∙ a₁≈a₂ (≈-++ as₁≈as₂ bs₁≈bs₂)

≈-⌜·⌝ : ∀ {n} {a₁ a₂ : Elim n} {b₁ b₂} →
        a₁ ≈ a₂ → b₁ ≈ b₂ → a₁ ⌜·⌝ b₁ ≈ a₂ ⌜·⌝ b₂
≈-⌜·⌝ a₁≈a₂ b₁≈b₂ = ≈-∙∙ a₁≈a₂ (≈-∷ b₁≈b₂ ≈-[])

-- Weakly equal kinds have equal shapes.

≋-⌊⌋ : ∀ {n} {k₁ k₂ : Kind Elim n} → k₁ ≋ k₂ → ⌊ k₁ ⌋ ≡ ⌊ k₂ ⌋
≋-⌊⌋ (≋-Π j₁≋j₂ k₁≋k₂) = cong₂ _⇒_ (≋-⌊⌋ j₁≋j₂) (≋-⌊⌋ k₁≋k₂)
≋-⌊⌋ (≋-⋯ a₁≈a₂ b₁≈b₂) = refl

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

  -- Weakly equal ascriptions and contexts have equal shapes.

  ≈Asc-⌊⌋ : ∀ {n} {a₁ a₂ : ElimAsc n} → a₁ ≈Asc a₂ → ⌊ a₁ ⌋Asc ≡ ⌊ a₂ ⌋Asc
  ≈Asc-⌊⌋ (≈-kd k₁≋k₂) = cong kd (≋-⌊⌋ k₁≋k₂)
  ≈Asc-⌊⌋ (≈-tp a₁≈a₂) = refl

  ≈Ctx-⌊⌋ : ∀ {n} {Γ₁ Γ₂ : Ctx n} → Γ₁ ≈Ctx Γ₂ → ⌊ Γ₁ ⌋Ctx ≡ ⌊ Γ₂ ⌋Ctx
  ≈Ctx-⌊⌋ ≈-[]              = refl
  ≈Ctx-⌊⌋ (≈-∷ a₁≈a₂ Γ₁≈Γ₂) = cong₂ _∷_ (≈Asc-⌊⌋ a₁≈a₂) (≈Ctx-⌊⌋ Γ₁≈Γ₂)

-- Reflexivity of weak equality.

mutual

  ≋-refl : ∀ {n} (k : Kind Elim n) → k ≋ k
  ≋-refl (a ⋯ b) = ≋-⋯ (≈-refl a) (≈-refl b)
  ≋-refl (Π j k) = ≋-Π (≋-refl j) (≋-refl k)

  ≈-refl : ∀ {n} (a : Elim n) → a ≈ a
  ≈-refl (a ∙ as) = ≈-∙ (≈Hd-refl a) (≈Sp-refl as)

  ≈Hd-refl : ∀ {n} (a : Head n) → a ≈Hd a
  ≈Hd-refl (var x) = ≈-var x
  ≈Hd-refl ⊥       = ≈-⊥
  ≈Hd-refl ⊤       = ≈-⊤
  ≈Hd-refl (Π k a) = ≈-∀ (≋-refl k) (≈-refl a)
  ≈Hd-refl (a ⇒ b) = ≈-→ (≈-refl a) (≈-refl b)
  ≈Hd-refl (Λ k a) = ≈-Λ refl (≈-refl a)
  ≈Hd-refl (ƛ a b) = ≈-λ (≈-refl b)
  ≈Hd-refl (a ⊡ b) = ≈-⊡ (≈-refl a) (≈-refl b)

  ≈Sp-refl : ∀ {n} (as : Spine n) → as ≈Sp as
  ≈Sp-refl []       = ≈-[]
  ≈Sp-refl (a ∷ as) = ≈-∷ (≈-refl a) (≈Sp-refl as)

≈Asc-refl : ∀ {n} (a : ElimAsc n) → a ≈Asc a
≈Asc-refl (kd k) = ≈-kd (≋-refl k)
≈Asc-refl (tp a) = ≈-tp (≈-refl a)

≈Ctx-refl : ∀ {n} (Γ : Ctx n) → Γ ≈Ctx Γ
≈Ctx-refl []      = ≈-[]
≈Ctx-refl (a ∷ Γ) = ≈-∷ (≈Asc-refl a) (≈Ctx-refl Γ)

-- Transitivity of weak equality.

mutual

  ≋-trans : ∀ {n} {j k l : Kind Elim n} → j ≋ k → k ≋ l → j ≋ l
  ≋-trans (≋-Π j₁≋j₂ k₁≋k₂) (≋-Π j₂≋j₃ k₂≋k₃) =
    ≋-Π (≋-trans j₁≋j₂ j₂≋j₃) (≋-trans k₁≋k₂ k₂≋k₃)
  ≋-trans (≋-⋯ a₁≈a₂ b₁≈b₂) (≋-⋯ a₂≈a₃ b₂≈b₃) =
    ≋-⋯ (≈-trans a₁≈a₂ a₂≈a₃) (≈-trans b₁≈b₂ b₂≈b₃)

  ≈-trans : ∀ {n} {a b c : Elim n} → a ≈ b → b ≈ c → a ≈ c
  ≈-trans (≈-∙ a₁≈a₂ bs₁≈bs₂) (≈-∙ a₂≈a₃ bs₂≈bs₃) =
    ≈-∙ (≈Hd-trans a₁≈a₂ a₂≈a₃) (≈Sp-trans bs₁≈bs₂ bs₂≈bs₃)

  ≈Hd-trans : ∀ {n} {a b c : Head n} → a ≈Hd b → b ≈Hd c → a ≈Hd c
  ≈Hd-trans (≈-var x)         (≈-var .x)        = ≈-var x
  ≈Hd-trans ≈-⊥               ≈-⊥               = ≈-⊥
  ≈Hd-trans ≈-⊤               ≈-⊤               = ≈-⊤
  ≈Hd-trans (≈-∀ k₁≋k₂ a₁≈a₂) (≈-∀ k₂≋k₃ a₂≈a₃) =
    ≈-∀ (≋-trans k₁≋k₂ k₂≋k₃) (≈-trans a₁≈a₂ a₂≈a₃)
  ≈Hd-trans (≈-→ a₁≈a₂ b₁≈b₂) (≈-→ a₂≈a₃ b₂≈b₃) =
    ≈-→ (≈-trans a₁≈a₂ a₂≈a₃) (≈-trans b₁≈b₂ b₂≈b₃)
  ≈Hd-trans (≈-Λ ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂) (≈-Λ ⌊k₂⌋≡⌊k₃⌋ a₂≈a₃) =
    ≈-Λ (trans ⌊k₁⌋≡⌊k₂⌋ ⌊k₂⌋≡⌊k₃⌋) (≈-trans a₁≈a₂ a₂≈a₃)
  ≈Hd-trans (≈-λ a₁≈a₂)       (≈-λ a₂≈a₃)       = ≈-λ (≈-trans a₁≈a₂ a₂≈a₃)
  ≈Hd-trans (≈-⊡ a₁≈a₂ b₁≈b₂) (≈-⊡ a₂≈a₃ b₂≈b₃) =
    ≈-⊡ (≈-trans a₁≈a₂ a₂≈a₃) (≈-trans b₁≈b₂ b₂≈b₃)

  ≈Sp-trans : ∀ {n} {as bs cs : Spine n} → as ≈Sp bs → bs ≈Sp cs → as ≈Sp cs
  ≈Sp-trans ≈-[]                ≈-[]                = ≈-[]
  ≈Sp-trans (≈-∷ a₁≈a₂ bs₁≈bs₂) (≈-∷ a₂≈a₃ bs₂≈bs₃) =
    ≈-∷ (≈-trans a₁≈a₂ a₂≈a₃) (≈Sp-trans bs₁≈bs₂ bs₂≈bs₃)

≈Asc-trans : ∀ {n} {a b c : ElimAsc n} → a ≈Asc b → b ≈Asc c → a ≈Asc c
≈Asc-trans (≈-kd k₁≋k₂) (≈-kd k₂≋k₃) = ≈-kd (≋-trans k₁≋k₂ k₂≋k₃)
≈Asc-trans (≈-tp a₁≈a₂) (≈-tp a₂≈a₃) = ≈-tp (≈-trans a₁≈a₂ a₂≈a₃)

≈Ctx-trans : ∀ {n} {Γ Δ E : Ctx n} → Γ ≈Ctx Δ → Δ ≈Ctx E → Γ ≈Ctx E
≈Ctx-trans ≈-[]              ≈-[]                = ≈-[]
≈Ctx-trans (≈-∷ a₁≈a₂ Γ₁≈Γ₂) (≈-∷ a₂≈a₃ Γ₂≈Γ₃) =
  ≈-∷ (≈Asc-trans a₁≈a₂ a₂≈a₃) (≈Ctx-trans Γ₁≈Γ₂ Γ₂≈Γ₃)

-- Symmetry of weak equality.

mutual

  ≋-sym : ∀ {n} {j k : Kind Elim n} → j ≋ k → k ≋ j
  ≋-sym (≋-⋯ a₁≈a₂ b₁≈b₂) = ≋-⋯ (≈-sym a₁≈a₂) (≈-sym b₁≈b₂)
  ≋-sym (≋-Π j₁≋j₂ k₁≋k₂) = ≋-Π (≋-sym j₁≋j₂) (≋-sym k₁≋k₂)

  ≈-sym : ∀ {n} {a b : Elim n} → a ≈ b → b ≈ a
  ≈-sym (≈-∙ a≈b as≈bs) = ≈-∙ (≈Hd-sym a≈b) (≈Sp-sym as≈bs)

  ≈Hd-sym : ∀ {n} {a b : Head n} → a ≈Hd b → b ≈Hd a
  ≈Hd-sym (≈-var x)             = ≈-var x
  ≈Hd-sym ≈-⊥                   = ≈-⊥
  ≈Hd-sym ≈-⊤                   = ≈-⊤
  ≈Hd-sym (≈-∀ k₁≋k₂ a₁≈a₂)     = ≈-∀ (≋-sym k₁≋k₂) (≈-sym a₁≈a₂)
  ≈Hd-sym (≈-→ a₁≈a₂ b₁≈b₂)     = ≈-→ (≈-sym a₁≈a₂) (≈-sym b₁≈b₂)
  ≈Hd-sym (≈-Λ ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂) = ≈-Λ (sym ⌊k₁⌋≡⌊k₂⌋) (≈-sym a₁≈a₂)
  ≈Hd-sym (≈-λ a₁≈a₂)           = ≈-λ (≈-sym a₁≈a₂)
  ≈Hd-sym (≈-⊡ a₁≈a₂ b₁≈b₂)     = ≈-⊡ (≈-sym a₁≈a₂) (≈-sym b₁≈b₂)

  ≈Sp-sym : ∀ {n} {as bs : Spine n} → as ≈Sp bs → bs ≈Sp as
  ≈Sp-sym ≈-[]                = ≈-[]
  ≈Sp-sym (≈-∷ a₁≈a₂ as₁≈as₂) = ≈-∷ (≈-sym a₁≈a₂) (≈Sp-sym as₁≈as₂)

≈Asc-sym : ∀ {n} {a b : ElimAsc n} → a ≈Asc b → b ≈Asc a
≈Asc-sym (≈-kd j≋k) = ≈-kd (≋-sym j≋k)
≈Asc-sym (≈-tp a≈b) = ≈-tp (≈-sym a≈b)

≈Ctx-sym : ∀ {n} {Γ Δ : Ctx n} → Γ ≈Ctx Δ → Δ ≈Ctx Γ
≈Ctx-sym ≈-[]              = ≈-[]
≈Ctx-sym (≈-∷ a₁≈a₂ Γ₁≈Γ₂) = ≈-∷ (≈Asc-sym a₁≈a₂) (≈Ctx-sym Γ₁≈Γ₂)

-- Weak equality is an equivalence relation.

≋-isEquivalence : (n : ℕ) → IsEquivalence (_≋_ {n})
≋-isEquivalence n = record
  { refl  = λ {k} → ≋-refl k
  ; sym   = ≋-sym
  ; trans = ≋-trans
  }

≈-isEquivalence : (n : ℕ) → IsEquivalence (_≈_ {n})
≈-isEquivalence n = record
  { refl  = λ {k} → ≈-refl k
  ; sym   = ≈-sym
  ; trans = ≈-trans
  }

≈Hd-isEquivalence : (n : ℕ) → IsEquivalence (_≈Hd_ {n})
≈Hd-isEquivalence n = record
  { refl  = λ {k} → ≈Hd-refl k
  ; sym   = ≈Hd-sym
  ; trans = ≈Hd-trans
  }

≈Sp-isEquivalence : (n : ℕ) → IsEquivalence (_≈Sp_ {n})
≈Sp-isEquivalence n = record
  { refl  = λ {k} → ≈Sp-refl k
  ; sym   = ≈Sp-sym
  ; trans = ≈Sp-trans
  }

≈Asc-isEquivalence : (n : ℕ) → IsEquivalence (_≈Asc_ {n})
≈Asc-isEquivalence n = record
  { refl  = λ {k} → ≈Asc-refl k
  ; sym   = ≈Asc-sym
  ; trans = ≈Asc-trans
  }

≈Ctx-isEquivalence : (n : ℕ) → IsEquivalence (_≈Ctx_ {n})
≈Ctx-isEquivalence n = record
  { refl  = λ {k} → ≈Ctx-refl k
  ; sym   = ≈Ctx-sym
  ; trans = ≈Ctx-trans
  }

-- Kinds together with weak equality form a setoid.
≋-setoid : ℕ → Setoid _ _
≋-setoid n = record
  { Carrier       = Kind Elim n
  ; _≈_           = _≋_
  ; isEquivalence = ≋-isEquivalence n
  }

-- Types and terms together with weak equality form a setoid.

≈-setoid : ℕ → Setoid _ _
≈-setoid n = record
  { Carrier       = Elim n
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence n
  }

≈Hd-setoid : ℕ → Setoid _ _
≈Hd-setoid n = record
  { Carrier       = Head n
  ; _≈_           = _≈Hd_
  ; isEquivalence = ≈Hd-isEquivalence n
  }

≈Sp-setoid : ℕ → Setoid _ _
≈Sp-setoid n = record
  { Carrier       = Spine n
  ; _≈_           = _≈Sp_
  ; isEquivalence = ≈Sp-isEquivalence n
  }

≈Asc-setoid : ℕ → Setoid _ _
≈Asc-setoid n = record
  { Carrier       = ElimAsc n
  ; _≈_           = _≈Asc_
  ; isEquivalence = ≈Asc-isEquivalence n
  }

≈Ctx-setoid : ℕ → Setoid _ _
≈Ctx-setoid n = record
  { Carrier       = Ctx n
  ; _≈_           = _≈Ctx_
  ; isEquivalence = ≈Ctx-isEquivalence n
  }

-- Equational reasoning for weak equality.
module ≈-Reasoning {n : ℕ} where
  open SetoidReasoning (≈-setoid n) public
  module Kd = SetoidReasoning (≋-setoid n)
  module Hd = SetoidReasoning (≈Hd-setoid n)
  module Sp = SetoidReasoning (≈Sp-setoid n)
  module Asc = SetoidReasoning (≈Asc-setoid n)
  module Ctx = SetoidReasoning (≈Ctx-setoid n)

------------------------------------------------------------------------
-- Substitution lemmas for weak equality.

-- Renamings in weakly equal terms.
--
-- The substitution lemmas below establishe that renamings of
-- variables in kinds, heads, eliminations and spines preserve weak
-- equality:
--
--                                ≈
--                           a ------→ b
--                           |         |
--                       -/ρ |         | -/ρ
--                           ↓    ≈    ↓
--                          a/ρ ····→ b/ρ
--
-- where ρ is a renaming.
module Renaming where
  open Substitution
  module V = VarSubst

  mutual

    -- Renamings preserve weak equality.

    ≋-/Var : ∀ {m n k₁ k₂} →
             k₁ ≋ k₂ → (ρ : Sub Fin m n) → k₁ Kind′/Var ρ ≋ k₂ Kind′/Var ρ
    ≋-/Var (≋-Π j₁≋j₂ k₁≋k₂) ρ =
      ≋-Π (≋-/Var j₁≋j₂ ρ) (≋-/Var k₁≋k₂ (ρ V.↑))
    ≋-/Var (≋-⋯ a₁≈a₂ b₁≈b₂) ρ =
      ≋-⋯ (≈-/Var a₁≈a₂ ρ) (≈-/Var b₁≈b₂ ρ)

    ≈-/Var : ∀ {m n a₁ a₂} →
             a₁ ≈ a₂ → (ρ : Sub Fin m n) → a₁ Elim/Var ρ ≈ a₂ Elim/Var ρ
    ≈-/Var (≈-∙ a₁≈a₂ bs₁≈bs₂) ρ =
      ≈-∙∙ (≈Hd-/Var a₁≈a₂ ρ) (≈Sp-/Var bs₁≈bs₂ ρ)

    ≈Hd-/Var : ∀ {m n a₁ a₂} →
               a₁ ≈Hd a₂ → (ρ : Sub Fin m n) → a₁ Head/Var′ ρ ≈ a₂ Head/Var′ ρ
    ≈Hd-/Var (≈-var x)             ρ = ≈-var∙ (Vec.lookup ρ x)
    ≈Hd-/Var ≈-⊥                   ρ = ≈-⊥∙
    ≈Hd-/Var ≈-⊤                   ρ = ≈-⊤∙
    ≈Hd-/Var (≈-∀ k₁≋k₂ a₁≈a₂)     ρ =
      ≈-∀∙ (≋-/Var k₁≋k₂ ρ) (≈-/Var a₁≈a₂ (ρ V.↑))
    ≈Hd-/Var (≈-→ a₁≈a₂ b₁≈b₂)     ρ =
      ≈-⇒∙ (≈-/Var a₁≈a₂ ρ) (≈-/Var b₁≈b₂ ρ)
    ≈Hd-/Var (≈-Λ {k₁} {k₂} ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂) ρ =
      ≈-Λ∙ (begin
             ⌊ k₁ Kind′/Var _ ⌋   ≡⟨ ⌊⌋-Kind′/Var k₁ ⟩
             ⌊ k₁ ⌋               ≡⟨ ⌊k₁⌋≡⌊k₂⌋ ⟩
             ⌊ k₂ ⌋               ≡⟨ sym (⌊⌋-Kind′/Var k₂) ⟩
             ⌊ k₂ Kind′/Var _ ⌋   ∎)
           (≈-/Var a₁≈a₂ (ρ V.↑))
      where open ≡-Reasoning
    ≈Hd-/Var (≈-λ a₁≈a₂)           ρ = ≈-λ∙ (≈-/Var a₁≈a₂ (ρ V.↑))
    ≈Hd-/Var (≈-⊡ a₁≈a₂ b₁≈b₂)     ρ =
      ≈-⊡∙ (≈-/Var a₁≈a₂ ρ) (≈-/Var b₁≈b₂ ρ)

    ≈Sp-/Var : ∀ {m n as₁ as₂} →
               as₁ ≈Sp as₂ → (ρ : Sub Fin m n) → as₁ //Var ρ ≈Sp as₂ //Var ρ
    ≈Sp-/Var ≈-[]                ρ = ≈-[]
    ≈Sp-/Var (≈-∷ a₁≈a₂ as₁≈as₂) ρ =
      ≈-∷ (≈-/Var a₁≈a₂ ρ) (≈Sp-/Var as₁≈as₂ ρ)

  ≈?-/Var : ∀ {m n r₁ r₂} →
            r₁ ≈? r₂ → (ρ : Sub Fin m n) → r₁ ?/Var ρ ≈? r₂ ?/Var ρ
  ≈?-/Var (≈-hit a₁≈a₂) ρ = ≈-hit (≈-/Var a₁≈a₂ ρ)
  ≈?-/Var (≈-miss x)    ρ = ≈-miss (Vec.lookup ρ x)

  ≈-weakenElim : ∀ {n} {a₁ a₂ : Elim n} →
                 a₁ ≈ a₂ → weakenElim a₁ ≈ weakenElim a₂
  ≈-weakenElim a₁≈a₂ = ≈-/Var a₁≈a₂ V.wk

  ≈-weakenSVRes : ∀ {n} {r₁ r₂ : SVRes n} →
                  r₁ ≈? r₂ → weakenSVRes r₁ ≈? weakenSVRes r₂
  ≈-weakenSVRes r₁≈r₂ = ≈?-/Var r₁≈r₂ V.wk

open Renaming

-- Look up a weak equation in a pair of pointwise weakly equal
-- single-variable substitutions.

⟨≈⟩-lookup : ∀ {m n σ₁} {σ₂ : SVSub m n} →
             σ₁ ⟨≈⟩ σ₂ → (x : Fin m) → lookupSV σ₁ x ≈? lookupSV σ₂ x
⟨≈⟩-lookup (≈-sub a₁≈a₂) zero    = ≈-hit a₁≈a₂
⟨≈⟩-lookup (≈-sub a₁≈a₂) (suc x) = ≈-miss x
⟨≈⟩-lookup (≈-↑ σ₁≈σ₂)   zero    = ≈-miss zero
⟨≈⟩-lookup (≈-↑ σ₁≈σ₂)   (suc x) = ≈-weakenSVRes (⟨≈⟩-lookup σ₁≈σ₂ x)

-- Weak equality lifted to hereditary substitutions.
--
-- The substitution lemmas below establishe that simoultaneous
-- hereditary substitutions of weakly equal types or terms in kinds,
-- heads, eliminations and spines preserve weak equality:
--
--                                ≈
--                           a ------- b
--                           |         |
--                      -/σ₁ |         | -/σ₂
--                           ↓    ≈    ↓
--                          a/σ₁ ···· b/σ₂
--
-- where σ₁ and σ₁ are weakly equal hereditary substitutions.

module WeakHereditarySubstitutionEquality where
  open Substitution hiding (_↑; sub)

  mutual

    -- Point-wise weakly equal hereditary substitutions preserve weak
    -- equality.

    ≋-/⟨⟩ : ∀ {k m n j₁ j₂} {σ₁ σ₂ : SVSub m n} →
            j₁ ≋ j₂ → σ₁ ⟨≈⟩ σ₂ → j₁ Kind/⟨ k ⟩ σ₁ ≋ j₂ Kind/⟨ k ⟩ σ₂
    ≋-/⟨⟩ (≋-Π j₁≋j₂ k₁≋k₂) σ₁≈σ₂ =
      ≋-Π (≋-/⟨⟩ j₁≋j₂ σ₁≈σ₂) (≋-/⟨⟩ k₁≋k₂ (≈-↑ σ₁≈σ₂))
    ≋-/⟨⟩ (≋-⋯ a₁≈a₂ b₁≈b₂) σ₁≈σ₂ =
      ≋-⋯ (≈-/⟨⟩ a₁≈a₂ σ₁≈σ₂) (≈-/⟨⟩ b₁≈b₂ σ₁≈σ₂)

    ≈-/⟨⟩ : ∀ {k m n a₁ a₂} {σ₁ σ₂ : SVSub m n} →
            a₁ ≈ a₂ → σ₁ ⟨≈⟩ σ₂ → a₁ /⟨ k ⟩ σ₁ ≈ a₂ /⟨ k ⟩ σ₂
    ≈-/⟨⟩ (≈-∙ (≈-var x) bs₁≈bs₂) σ₁≈σ₂ =
      ≈-?∙∙⟨⟩ _ (⟨≈⟩-lookup σ₁≈σ₂ x) (≈Sp-/⟨⟩ bs₁≈bs₂ σ₁≈σ₂)
    ≈-/⟨⟩ (≈-∙ ≈-⊥ bs₁≈bs₂) σ₁≈σ₂ = ≈-∙ ≈-⊥ (≈Sp-/⟨⟩ bs₁≈bs₂ σ₁≈σ₂)
    ≈-/⟨⟩ (≈-∙ ≈-⊤ bs₁≈bs₂) σ₁≈σ₂ = ≈-∙ ≈-⊤ (≈Sp-/⟨⟩ bs₁≈bs₂ σ₁≈σ₂)
    ≈-/⟨⟩ (≈-∙ (≈-∀ k₁≋k₂ a₁≈a₂) bs₁≈bs₂) σ₁≈σ₂ =
      ≈-∙ (≈-∀ (≋-/⟨⟩ k₁≋k₂ σ₁≈σ₂) (≈-/⟨⟩ a₁≈a₂ (≈-↑ σ₁≈σ₂)))
          (≈Sp-/⟨⟩ bs₁≈bs₂ σ₁≈σ₂)
    ≈-/⟨⟩ (≈-∙ (≈-→ a₁≈a₂ b₁≈b₂) cs₁≈cs₂) σ₁≈σ₂ =
      ≈-∙ (≈-→ (≈-/⟨⟩ a₁≈a₂ σ₁≈σ₂) (≈-/⟨⟩ b₁≈b₂ σ₁≈σ₂))
          (≈Sp-/⟨⟩ cs₁≈cs₂ σ₁≈σ₂)
    ≈-/⟨⟩ (≈-∙ (≈-Λ {k₁} {k₂} ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂) bs₁≈bs₂) σ₁≈σ₂ =
      ≈-∙ (≈-Λ (begin
                 ⌊ k₁ Kind/⟨ _ ⟩ _ ⌋   ≡⟨ ⌊⌋-Kind/⟨⟩ k₁ ⟩
                 ⌊ k₁ ⌋                ≡⟨ ⌊k₁⌋≡⌊k₂⌋ ⟩
                 ⌊ k₂ ⌋                ≡⟨ sym (⌊⌋-Kind/⟨⟩ k₂) ⟩
                 ⌊ k₂ Kind/⟨ _ ⟩ _ ⌋   ∎)
               (≈-/⟨⟩ a₁≈a₂ (≈-↑ σ₁≈σ₂)))
          (≈Sp-/⟨⟩ bs₁≈bs₂ σ₁≈σ₂)
      where open ≡-Reasoning
    ≈-/⟨⟩ (≈-∙ (≈-λ a₁≈a₂) bs₁≈bs₂) σ₁≈σ₂ =
      ≈-∙ (≈-λ (≈-/⟨⟩ a₁≈a₂ (≈-↑ σ₁≈σ₂))) (≈Sp-/⟨⟩ bs₁≈bs₂ σ₁≈σ₂)
    ≈-/⟨⟩ (≈-∙ (≈-⊡ a₁≈a₂ b₁≈b₂) cs₁≈cs₂) σ₁≈σ₂ =
      ≈-∙ (≈-⊡ (≈-/⟨⟩ a₁≈a₂ σ₁≈σ₂) (≈-/⟨⟩ b₁≈b₂ σ₁≈σ₂))
          (≈Sp-/⟨⟩ cs₁≈cs₂ σ₁≈σ₂)

    ≈Sp-/⟨⟩ : ∀ {k m n as₁ as₂} {σ₁ σ₂ : SVSub m n} →
              as₁ ≈Sp as₂ → σ₁ ⟨≈⟩ σ₂ → as₁ //⟨ k ⟩ σ₁ ≈Sp as₂ //⟨ k ⟩ σ₂
    ≈Sp-/⟨⟩ ≈-[]                σ₁≈σ₂ = ≈-[]
    ≈Sp-/⟨⟩ (≈-∷ a₁≈a₂ as₁≈as₂) σ₁≈σ₂ =
      ≈-∷ (≈-/⟨⟩ a₁≈a₂ σ₁≈σ₂) (≈Sp-/⟨⟩ as₁≈as₂ σ₁≈σ₂)

    -- Weak equality is a congruence w.r.t reducing applications.

    ≈-?∙∙⟨⟩ : ∀ k {n} {r₁ r₂ : SVRes n} {as₁ as₂} →
              r₁ ≈? r₂ → as₁ ≈Sp as₂ → r₁ ?∙∙⟨ k ⟩ as₁ ≈ r₂ ?∙∙⟨ k ⟩ as₂
    ≈-?∙∙⟨⟩ k (≈-hit a₁≈a₂) as₁≈as₂ = ≈-∙∙⟨⟩ k a₁≈a₂ as₁≈as₂
    ≈-?∙∙⟨⟩ k (≈-miss x)    as₁≈as₂ = ≈-∙ (≈-var x) as₁≈as₂

    ≈-∙∙⟨⟩ : ∀ k {n} {a₁ a₂ : Elim n} {bs₁ bs₂} →
             a₁ ≈ a₂ → bs₁ ≈Sp bs₂ → a₁ ∙∙⟨ k ⟩ bs₁ ≈ a₂ ∙∙⟨ k ⟩ bs₂
    ≈-∙∙⟨⟩ k         a₁≈a₂ ≈-[]                = a₁≈a₂
    ≈-∙∙⟨⟩ ★         a₁≈a₂ (≈-∷ b₁≈b₂ bs₁≈bs₂) = ≈-∙∙ a₁≈a₂ (≈-∷ b₁≈b₂ bs₁≈bs₂)
    ≈-∙∙⟨⟩ (k₁ ⇒ k₂) a₁≈a₂ (≈-∷ b₁≈b₂ bs₁≈bs₂) =
      ≈-∙∙⟨⟩ k₂ (≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) a₁≈a₂ b₁≈b₂) bs₁≈bs₂

    ≈-⌜·⌝⟨⟩ : ∀ k {n} {a₁ a₂ : Elim n} {b₁ b₂} →
              a₁ ≈ a₂ → b₁ ≈ b₂ → a₁ ⌜·⌝⟨ k ⟩ b₁ ≈ a₂ ⌜·⌝⟨ k ⟩ b₂
    ≈-⌜·⌝⟨⟩ ★         a₁≈a₂                            b₁≈b₂ = ≈-⌜·⌝ a₁≈a₂ b₁≈b₂
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ a₁≈a₂ (≈-∷ b₁≈b₂ bs₁≈bs₂))  c₁≈c₂ =
      ≈-⌜·⌝ (≈-∙ a₁≈a₂ (≈-∷ b₁≈b₂ bs₁≈bs₂)) c₁≈c₂
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ (≈-Λ ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂) ≈-[]) c₁≈c₂ =
      ≈-/⟨⟩ a₁≈a₂ (≈-sub c₁≈c₂)
    -- Degenerate cases.
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ ≈-⊥ ≈-[]) c₁≈c₂ = ≈-∙ ≈-⊥ (≈-∷ c₁≈c₂ ≈-[])
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ ≈-⊤ ≈-[]) c₁≈c₂ = ≈-∙ ≈-⊤ (≈-∷ c₁≈c₂ ≈-[])
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ (≈-var x) ≈-[])         c₁≈c₂ =
      ≈-∙ (≈-var x) (≈-∷ c₁≈c₂ ≈-[])
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ (≈-∀ j₁≋j₂ a₁≈a₂) ≈-[]) c₁≈c₂ =
      ≈-∙ (≈-∀ j₁≋j₂ a₁≈a₂) (≈-∷ c₁≈c₂ ≈-[])
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ (≈-→ a₁≈a₂ b₁≈b₂) ≈-[]) c₁≈c₂ =
      ≈-∙ (≈-→ a₁≈a₂ b₁≈b₂) (≈-∷ c₁≈c₂ ≈-[])
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ (≈-λ a₁≈a₂) ≈-[])       c₁≈c₂ =
      ≈-∙ (≈-λ a₁≈a₂) (≈-∷ c₁≈c₂ ≈-[])
    ≈-⌜·⌝⟨⟩ (k₁ ⇒ k₂) (≈-∙ (≈-⊡ a₁≈a₂ b₁≈b₂) ≈-[]) c₁≈c₂ =
      ≈-∙ (≈-⊡ a₁≈a₂ b₁≈b₂) (≈-∷ c₁≈c₂ ≈-[])

  -- A corollary.
  ≈-[∈] : ∀ {k n a₁ a₂} {b₁ b₂ : Elim n} →
          a₁ ≈ a₂ → b₁ ≈ b₂ → a₁ [ b₁ ∈ k ] ≈ a₂ [ b₂ ∈ k ]
  ≈-[∈] a₁≈a₂ b₁≈b₂ = ≈-/⟨⟩ a₁≈a₂ (≈-sub b₁≈b₂)

  -- Weak equality is a congruence w.r.t potentially reducing
  -- applications.
  ≈-↓⌜·⌝ : ∀ {n} {a₁ a₂ : Elim n} {b₁ b₂} → a₁ ≈ a₂ → b₁ ≈ b₂ →
                  a₁ ↓⌜·⌝ b₁ ≈ a₂ ↓⌜·⌝ b₂
  ≈-↓⌜·⌝ (≈-∙ a₁≈a₂ (≈-∷ b₁≈b₂ bs₁≈bs₂))  c₁≈c₂ =
    ≈-⌜·⌝ (≈-∙ a₁≈a₂ (≈-∷ b₁≈b₂ bs₁≈bs₂)) c₁≈c₂
  ≈-↓⌜·⌝ {_} {_} {_} {b₁} {b₂}
         (≈-∙ (≈-Λ {k₁} {k₂} {a₁} {a₂} ⌊k₁⌋≡⌊k₂⌋ a₁≈a₂) ≈-[]) c₁≈c₂ =
    begin
      a₁ [ b₁ ∈ ⌊ k₁ ⌋ ]   ≈⟨ ≈-/⟨⟩ a₁≈a₂ (≈-sub c₁≈c₂) ⟩
      a₂ [ b₂ ∈ ⌊ k₁ ⌋ ]   ≡⟨ cong (a₂ [ b₂ ∈_]) ⌊k₁⌋≡⌊k₂⌋ ⟩
      a₂ [ b₂ ∈ ⌊ k₂ ⌋ ]   ∎
    where open ≈-Reasoning
  -- Degenerate cases.
  ≈-↓⌜·⌝ (≈-∙ ≈-⊥ ≈-[]) c₁≈c₂ = ≈-∙ ≈-⊥ (≈-∷ c₁≈c₂ ≈-[])
  ≈-↓⌜·⌝ (≈-∙ ≈-⊤ ≈-[]) c₁≈c₂ = ≈-∙ ≈-⊤ (≈-∷ c₁≈c₂ ≈-[])
  ≈-↓⌜·⌝ (≈-∙ (≈-var x) ≈-[])         c₁≈c₂ =
    ≈-∙ (≈-var x) (≈-∷ c₁≈c₂ ≈-[])
  ≈-↓⌜·⌝ (≈-∙ (≈-∀ j₁≋j₂ a₁≈a₂) ≈-[]) c₁≈c₂ =
    ≈-∙ (≈-∀ j₁≋j₂ a₁≈a₂) (≈-∷ c₁≈c₂ ≈-[])
  ≈-↓⌜·⌝ (≈-∙ (≈-→ a₁≈a₂ b₁≈b₂) ≈-[]) c₁≈c₂ =
    ≈-∙ (≈-→ a₁≈a₂ b₁≈b₂) (≈-∷ c₁≈c₂ ≈-[])
  ≈-↓⌜·⌝ (≈-∙ (≈-λ a₁≈a₂) ≈-[])       c₁≈c₂ =
    ≈-∙ (≈-λ a₁≈a₂) (≈-∷ c₁≈c₂ ≈-[])
  ≈-↓⌜·⌝ (≈-∙ (≈-⊡ a₁≈a₂ b₁≈b₂) ≈-[]) c₁≈c₂ =
    ≈-∙ (≈-⊡ a₁≈a₂ b₁≈b₂) (≈-∷ c₁≈c₂ ≈-[])

open WeakHereditarySubstitutionEquality

module WeakEqEtaExpansion where
  private module TK = TrackSimpleKindsEtaExp
  open Substitution
  open SimpHSubstLemmas
  open ≈-Reasoning

  -- NOTE. The definition of the function ≈-η-exp′ in this module is
  -- structurally recursive in the *shape* parameter k, but *not* in
  -- the kinds (j₁ j₂ : Kind Elim n) because we need to weaken the
  -- domains j₁₁ and j₂₁ of the dependent kinds (j₁ = Π j₁₁ j₁₂) and
  -- (j₂ = Π j₂₁ j₂₂) in the arrow case.  The additional premises ⌊ j₁
  -- ⌋≡ k and ⌊ j₂ ⌋≡ k ensure that k is indeed the shape of the kinds
  -- j₁ and j₂.

  -- Weak equality is a congruence w.r.t. untyped η-expansion.
  --
  -- NOTE. We do *not* require the kinds j₁ and j₂ to be (weakly)
  -- equal, we only require them to have the same shape.

  ≈-η-exp′ : ∀ {n k j₁ j₂} {a₁ a₂ : Elim n}
             (hyp₁ : ⌊ j₁ ⌋≡ k) (hyp₂ : ⌊ j₂ ⌋≡ k) → a₁ ≈ a₂ →
             TK.η-exp j₁ hyp₁ a₁ ≈ TK.η-exp j₂ hyp₂ a₂
  ≈-η-exp′ (is-★) (is-★) a₁≈a₂ = a₁≈a₂
  ≈-η-exp′ (is-⇒ ⌊j₁⌋≡l₁ ⌊k₁⌋≡l₂) (is-⇒ ⌊j₂⌋≡l₁ ⌊k₂⌋≡l₂) a₁≈a₂ =
    ≈-Λ∙ ⌊j₁⌋≡⌊j₂⌋ (≈-η-exp′ ⌊k₁⌋≡l₂ ⌊k₂⌋≡l₂ a₁·ηz≈a₂·ηz)
    where
      ⌊j₁⌋≡⌊j₂⌋   = trans (⌊⌋≡⇒⌊⌋-≡ ⌊j₁⌋≡l₁) (sym (⌊⌋≡⇒⌊⌋-≡ ⌊j₂⌋≡l₁))
      a₁·ηz≈a₂·ηz =
        ≈-⌜·⌝ (≈-weakenElim a₁≈a₂)
              (≈-η-exp′ (⌊⌋≡-weaken ⌊j₁⌋≡l₁) (⌊⌋≡-weaken ⌊j₂⌋≡l₁) (≈-var∙ zero))

  ≈-η-exp : ∀ {n} {j₁ j₂ : Kind Elim n} {a₁ a₂} →
            ⌊ j₁ ⌋ ≡ ⌊ j₂ ⌋ → a₁ ≈ a₂ → η-exp j₁ a₁ ≈ η-exp j₂ a₂
  ≈-η-exp {_} {j₁} {j₂} {a₁} {a₂} ⌊j₁⌋≡⌊j₂⌋ a₁≈a₂ = begin
      η-exp j₁ a₁
    ≡⟨ TK.η-exp-⌊⌋≡ (⌊⌋-⌊⌋≡ j₁) (⌊⌋≡-trans ⌊j₁⌋≡⌊j₂⌋ (⌊⌋-⌊⌋≡ j₂))
                    refl ⌊j₁⌋≡⌊j₂⌋ ⟩
      TK.η-exp j₁ _ a₁
    ≈⟨ ≈-η-exp′ (⌊⌋≡-trans ⌊j₁⌋≡⌊j₂⌋ (⌊⌋-⌊⌋≡ j₂)) (⌊⌋-⌊⌋≡ j₂) a₁≈a₂ ⟩
      η-exp j₂ a₂
    ∎

  open SimpleCtx using (kd; ⌊_⌋Asc; kd-inj′)
  open ContextConversions using (⌊_⌋Ctx)

  -- A variant of `nf-var-kd' that is a corollary of the above.

  nf-var-kd-⌊⌋ : ∀ {n} (Γ : Ctx n) {k} x →
                 ⌊ lookup Γ x ⌋Asc ≡ kd ⌊ k ⌋ → nf Γ (var x) ≈ η-exp k (var∙ x)
  nf-var-kd-⌊⌋ Γ x hyp with lookup Γ x
  nf-var-kd-⌊⌋ Γ x hyp | kd j = ≈-η-exp (kd-inj′ hyp) (≈-var∙ x)
  nf-var-kd-⌊⌋ Γ x ()  | tp _

open WeakEqEtaExpansion

module WeakEqNormalization where
  open SimpleCtx using (kd; ⌊_⌋Asc; ⌊⌋-ElimAsc/Var; kd-inj′)
  open ContextConversions

  -- A helper lemma.

  ⌊⌋≡⌊⌋-lookup : ∀ {n} (Γ₁ Γ₂ : Ctx n) x → ⌊ Γ₁ ⌋Ctx ≡ ⌊ Γ₂ ⌋Ctx →
                 ⌊ lookup Γ₁ x ⌋Asc ≡ ⌊ lookup Γ₂ x ⌋Asc
  ⌊⌋≡⌊⌋-lookup Γ₁ Γ₂ x ⌊Γ₁⌋≡⌊Γ₂⌋ = begin
      ⌊ lookup Γ₁ x ⌋Asc
    ≡˘⟨ ⌊⌋Asc-lookup Γ₁ x ⟩
      SimpleCtx.lookup ⌊ Γ₁ ⌋Ctx x
    ≡⟨ cong (λ Δ → SimpleCtx.lookup Δ x) ⌊Γ₁⌋≡⌊Γ₂⌋ ⟩
      SimpleCtx.lookup ⌊ Γ₂ ⌋Ctx x
    ≡⟨ ⌊⌋Asc-lookup Γ₂ x ⟩
      ⌊ lookup Γ₂ x ⌋Asc
    ∎
    where open ≡-Reasoning

  -- If two contexts have the same shape, then kinds, types and terms
  -- normalize weakly equally in these contexts.

  mutual

    ≈-nf : ∀ {n} {Γ₁ Γ₂ : Ctx n} →
           ⌊ Γ₁ ⌋Ctx ≡ ⌊ Γ₂ ⌋Ctx → ∀ a → nf Γ₁ a ≈ nf Γ₂ a
    ≈-nf {_} {Γ₁} {Γ₂} ⌊Γ₁⌋≡⌊Γ₂⌋ (var x)
      with lookup Γ₁ x | lookup Γ₂ x | ⌊⌋≡⌊⌋-lookup Γ₁ Γ₂ x ⌊Γ₁⌋≡⌊Γ₂⌋
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (var x) | kd k₁ | kd k₂ | ⌊kd-k₁⌋≡⌊kd-k₂⌋ =
      ≈-η-exp (kd-inj′ ⌊kd-k₁⌋≡⌊kd-k₂⌋) (≈-var∙ x)
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (var x) | kd _  | tp _  | ()
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (var x) | tp _  | kd _  | ()
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (var x) | tp a₁ | tp a₂ | refl = ≈-var∙ x
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ ⊥       = ≈-⊥∙
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ ⊤       = ≈-⊤∙
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (Π k a) =
      let k≋k′ = ≋-nfKind ⌊Γ₁⌋≡⌊Γ₂⌋ k
      in ≈-∀∙ k≋k′ (≈-nf (cong₂ _∷_ (cong kd (≋-⌊⌋ k≋k′)) ⌊Γ₁⌋≡⌊Γ₂⌋) a)
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (a ⇒ b) = ≈-⇒∙ (≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ a) (≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ b)
    ≈-nf {_} {Γ₁} ⌊Γ₁⌋≡⌊Γ₂⌋ (Λ k a) =
      let k≋k′ = ≋-nfKind ⌊Γ₁⌋≡⌊Γ₂⌋ k
      in ≈-Λ∙ (≋-⌊⌋ k≋k′) (≈-nf (cong₂ _∷_ (cong kd (≋-⌊⌋ k≋k′)) ⌊Γ₁⌋≡⌊Γ₂⌋) a)
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (ƛ a b) = ≈-λ∙ (≈-refl ⌜ b ⌝)
    ≈-nf {_} {Γ₁} {Γ₂} ⌊Γ₁⌋≡⌊Γ₂⌋ (a · b) =
      ≈-↓⌜·⌝ (≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ a) (≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ b)
    ≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ (a ⊡ b) = ≈-⊡∙ (≈-refl ⌜ a ⌝) (≈-refl ⌜ b ⌝)

    ≋-nfKind : ∀ {n} {Γ₁ Γ₂ : Ctx n} →
               ⌊ Γ₁ ⌋Ctx ≡ ⌊ Γ₂ ⌋Ctx → ∀ k → nfKind Γ₁ k ≋ nfKind Γ₂ k
    ≋-nfKind ⌊Γ₁⌋≡⌊Γ₂⌋ (a ⋯ b) = ≋-⋯ (≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ a) (≈-nf ⌊Γ₁⌋≡⌊Γ₂⌋ b)
    ≋-nfKind ⌊Γ₁⌋≡⌊Γ₂⌋ (Π j k) =
      let j≋j′ = ≋-nfKind ⌊Γ₁⌋≡⌊Γ₂⌋ j
      in ≋-Π j≋j′ (≋-nfKind (cong₂ _∷_ (cong kd (≋-⌊⌋ j≋j′)) ⌊Γ₁⌋≡⌊Γ₂⌋) k)


postulate
  A : Set
  a : A

record B : Set where
  constructor i
  field b : A
open B

data D : (X : Set) → X → Set where
  c : D B (record { b = a })

accepted : (X : Set) (x : X) → D X x → Set
accepted .B (i a) c = A

rejected : (X : Set) (x : X) → D X x → Set
rejected .B (record { b = a }) c = A

-- WAS:
-- I'm not sure if there should be a case for the constructor c,
-- because I get stuck when trying to solve the following unification
-- problems (inferred index ≟ expected index):
--   B ≟ X
--   record { b = a } ≟ x
-- when checking that the pattern c has type D X x

-- SHOULD: succeed


open import Agda.Builtin.Sigma

dup : ∀ {A : Set} → A → Σ A λ _ → A
dup x = x , x

postulate
  A : Set

module M {x : A} where
  y = x

data X : Set where
  mkX : ∀ {x : A}
    → let
        (_ , _) = dup x
        open M {x}
      in
      X


------------------------------------------------------------------------
-- Virtual machine instructions, state etc.
------------------------------------------------------------------------

open import Prelude

module Lambda.Virtual-machine.Instructions (Name : Type) where

open import Equality.Propositional

open import Lambda.Syntax Name

------------------------------------------------------------------------
-- Instruction set

mutual

  -- Instructions.

  data Instr (n : ℕ) : Type where
    var     : Fin n → Instr n
    clo     : Code (suc n) → Instr n
    app ret : Instr n
    cal tcl : Name → Instr n  -- Calls and tail calls.
    con     : Bool → Instr n
    bra     : Code n → Code n → Instr n

  -- Code.

  Code : ℕ → Type
  Code n = List (Instr n)

-- Environments and values.

open Closure Code

------------------------------------------------------------------------
-- Stacks and states

-- Stacks.

data Stack-element : Type where
  val : Value → Stack-element
  ret : ∀ {n} → Code n → Env n → Stack-element

Stack : Type
Stack = List Stack-element

-- States.

data State : Type where
  ⟨_,_,_⟩ : ∀ {n} → Code n → Stack → Env n → State

------------------------------------------------------------------------
-- Results

-- The result of running the VM one step.

data Result : Type where
  continue : State → Result
  done     : Value → Result
  crash    : Result


------------------------------------------------------------------------
-- Isomorphism of monoids on sets coincides with equality (assuming
-- univalence)
------------------------------------------------------------------------

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

-- This module has been developed in collaboration with Thierry
-- Coquand.

open import Equality

module Univalence-axiom.Isomorphism-is-equality.Monoid
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Bijection eq using (_↔_; Σ-≡,≡↔≡; ↑↔)
open Derived-definitions-and-properties eq
open import Equivalence eq as Eq using (_≃_)
open import Function-universe eq hiding (id)
open import H-level eq
open import H-level.Closure eq
open import Prelude hiding (id)
open import Univalence-axiom eq

-- Monoid laws (including the assumption that the carrier type is a
-- set).

Is-monoid : (C : Type) → (C → C → C) → C → Type
Is-monoid C _∙_ id =

  -- C is a set.
  Is-set C ×

  -- Left and right identity laws.
  (∀ x → (id ∙ x) ≡ x) ×
  (∀ x → (x ∙ id) ≡ x) ×

  -- Associativity.
  (∀ x y z → (x ∙ (y ∙ z)) ≡ ((x ∙ y) ∙ z))

-- Monoids (on sets).

Monoid : Type₁
Monoid =
  -- Carrier.
  Σ Type λ C →

  -- Binary operation.
  Σ (C → C → C) λ _∙_ →

  -- Identity.
  Σ C λ id →

  -- Laws.
  Is-monoid C _∙_ id

-- The carrier type.

Carrier : Monoid → Type
Carrier M = proj₁ M

-- The binary operation.

op : (M : Monoid) → Carrier M → Carrier M → Carrier M
op M = proj₁ (proj₂ M)

-- The identity element.

id : (M : Monoid) → Carrier M
id M = proj₁ (proj₂ (proj₂ M))

-- The monoid laws.

laws : (M : Monoid) → Is-monoid (Carrier M) (op M) (id M)
laws M = proj₂ (proj₂ (proj₂ M))

-- Monoid morphisms.

Is-homomorphism :
  (M₁ M₂ : Monoid) → (Carrier M₁ → Carrier M₂) → Type
Is-homomorphism M₁ M₂ f =
  (∀ x y → f (op M₁ x y) ≡ op M₂ (f x) (f y)) ×
  (f (id M₁) ≡ id M₂)

-- Monoid isomorphisms.

_≅_ : Monoid → Monoid → Type
M₁ ≅ M₂ =
  Σ (Carrier M₁ ↔ Carrier M₂) λ f →
  Is-homomorphism M₁ M₂ (_↔_.to f)

-- The monoid laws are propositional (assuming extensionality).

laws-propositional :
  Extensionality (# 0) (# 0) →
  (M : Monoid) →
  Is-proposition (Is-monoid (Carrier M) (op M) (id M))
laws-propositional ext M =
  ×-closure 1 (H-level-propositional ext 2)
  (×-closure 1 (Π-closure ext 1 λ _ →
                is-set)
  (×-closure 1 (Π-closure ext 1 λ _ →
                is-set)
               (Π-closure ext 1 λ _ →
                Π-closure ext 1 λ _ →
                Π-closure ext 1 λ _ →
                is-set)))
  where is-set = proj₁ (laws M)

-- Monoid equality is isomorphic to equality of the carrier sets,
-- binary operations and identity elements, suitably transported
-- (assuming extensionality).

equality-triple-lemma :
  Extensionality (# 0) (# 0) →
  (M₁ M₂ : Monoid) →
  M₁ ≡ M₂ ↔
  Σ (Carrier M₁ ≡ Carrier M₂) λ C-eq →
    subst (λ C → C → C → C) C-eq (op M₁) ≡ op M₂ ×
    subst (λ C → C) C-eq (id M₁) ≡ id M₂
equality-triple-lemma
  ext (C₁ , op₁ , id₁ , laws₁) (C₂ , op₂ , id₂ , laws₂) =

  ((C₁ , op₁ , id₁ , laws₁) ≡ (C₂ , op₂ , id₂ , laws₂))               ↔⟨ inverse $ Eq.≃-≡ $ Eq.↔⇒≃ bij ⟩

  (((C₁ , op₁ , id₁) , laws₁) ≡ ((C₂ , op₂ , id₂) , laws₂))           ↝⟨ inverse $ ignore-propositional-component $
                                                                           laws-propositional ext (C₂ , op₂ , id₂ , laws₂) ⟩

  ((C₁ , op₁ , id₁) ≡ (C₂ , op₂ , id₂))                               ↝⟨ inverse Σ-≡,≡↔≡ ⟩

  (Σ (C₁ ≡ C₂) λ C-eq →
     subst (λ C → (C → C → C) × C) C-eq (op₁ , id₁) ≡ (op₂ , id₂))    ↝⟨ ∃-cong (λ _ → ≡⇒↝ _ $ cong (λ x → x ≡ _) $
                                                                             push-subst-, (λ C → C → C → C) (λ C → C)) ⟩
  (Σ (C₁ ≡ C₂) λ C-eq →
     (subst (λ C → C → C → C) C-eq op₁ , subst (λ C → C) C-eq id₁) ≡
     (op₂ , id₂))                                                     ↝⟨ ∃-cong (λ _ → inverse ≡×≡↔≡) ⟩□

  (Σ (C₁ ≡ C₂) λ C-eq →
     subst (λ C → C → C → C) C-eq op₁ ≡ op₂ ×
     subst (λ C → C) C-eq id₁ ≡ id₂)                                  □

  where
  bij =

    (Σ Type λ C → Σ (C → C → C) λ op → Σ C λ id → Is-monoid C op id)  ↝⟨ ∃-cong (λ _ → Σ-assoc) ⟩

    (Σ Type λ C → Σ ((C → C → C) × C) λ { (op , id) →
     Is-monoid C op id })                                             ↝⟨ Σ-assoc ⟩□

    (Σ (Σ Type λ C → (C → C → C) × C) λ { (C , op , id) →
     Is-monoid C op id })                                             □

-- If two monoids are isomorphic, then they are equal (assuming
-- univalence).

isomorphic-equal :
  Univalence (# 0) →
  Univalence (# 1) →
  (M₁ M₂ : Monoid) → M₁ ≅ M₂ → M₁ ≡ M₂
isomorphic-equal univ univ₁ M₁ M₂ (bij , bij-op , bij-id) = goal
  where
  open _≃_

  -- Our goal:

  goal : M₁ ≡ M₂

  -- Extensionality follows from univalence.

  ext : Extensionality (# 0) (# 0)
  ext = dependent-extensionality univ₁ univ

  -- Hence the goal follows from monoids-equal-if, if we can prove
  -- three equalities.

  C-eq  : Carrier M₁ ≡ Carrier M₂
  op-eq : subst (λ A → A → A → A) C-eq (op M₁) ≡ op M₂
  id-eq : subst (λ A → A) C-eq (id M₁) ≡ id M₂

  goal = _↔_.from (equality-triple-lemma ext M₁ M₂)
                  (C-eq , op-eq , id-eq)

  -- Our bijection can be converted into an equivalence.

  equiv : Carrier M₁ ≃ Carrier M₂
  equiv = Eq.↔⇒≃ bij

  -- Hence the first equality follows directly from univalence.

  C-eq = ≃⇒≡ univ equiv

  -- For the second equality, let us first define a "cast" operator.

  cast₂ : {A B : Type} → A ≃ B → (A → A → A) → (B → B → B)
  cast₂ eq f = λ x y → to eq (f (from eq x) (from eq y))

  -- The transport theorem implies that cast₂ equiv can be expressed
  -- using subst.

  cast₂-equiv-is-subst :
    ∀ f → cast₂ equiv f ≡ subst (λ A → A → A → A) C-eq f
  cast₂-equiv-is-subst f =
    transport-theorem (λ A → A → A → A) cast₂ refl univ equiv f

  -- The second equality op-eq follows from extensionality,
  -- cast₂-equiv-is-subst, and the fact that the bijection is a
  -- monoid homomorphism.

  op-eq = apply-ext ext λ x → apply-ext ext λ y →
    subst (λ A → A → A → A) C-eq (op M₁) x y                   ≡⟨ cong (λ f → f x y) $ sym $ cast₂-equiv-is-subst (op M₁) ⟩
    to equiv (op M₁ (from equiv x) (from equiv y))             ≡⟨ bij-op (from equiv x) (from equiv y) ⟩
    op M₂ (to equiv (from equiv x)) (to equiv (from equiv y))  ≡⟨ cong₂ (op M₂) (right-inverse-of equiv x) (right-inverse-of equiv y) ⟩∎
    op M₂ x y                                                  ∎

  -- The development above can be repeated for the identity
  -- elements.

  cast₀ : {A B : Type} → A ≃ B → A → B
  cast₀ eq x = to eq x

  cast₀-equiv-is-subst : ∀ x → cast₀ equiv x ≡ subst (λ A → A) C-eq x
  cast₀-equiv-is-subst x =
    transport-theorem (λ A → A) cast₀ refl univ equiv x

  id-eq =
    subst (λ A → A) C-eq (id M₁)  ≡⟨ sym $ cast₀-equiv-is-subst (id M₁) ⟩
    to equiv (id M₁)              ≡⟨ bij-id ⟩∎
    id M₂                         ∎

-- Equality of monoids is in fact in bijective correspondence with
-- isomorphism of monoids (assuming univalence).

isomorphism-is-equality :
  Univalence (# 0) →
  Univalence (# 1) →
  (M₁ M₂ : Monoid) → (M₁ ≅ M₂) ↔ (M₁ ≡ M₂)
isomorphism-is-equality univ univ₁
  (C₁ , op₁ , id₁ , laws₁) (C₂ , op₂ , id₂ , laws₂) =

  (Σ (C₁ ↔ C₂) λ f → Is-homomorphism M₁ M₂ (_↔_.to f))          ↝⟨ Σ-cong (Eq.↔↔≃ ext C₁-set) (λ _ → _ □) ⟩

  (Σ (C₁ ≃ C₂) λ C-eq → Is-homomorphism M₁ M₂ (_≃_.to C-eq))    ↝⟨ ∃-cong (λ C-eq → op-lemma C-eq ×-cong id-lemma C-eq) ⟩

  (Σ (C₁ ≃ C₂) λ C-eq →
     subst (λ C → C → C → C) (≃⇒≡ univ C-eq) op₁ ≡ op₂ ×
     subst (λ C → C) (≃⇒≡ univ C-eq) id₁ ≡ id₂)                 ↝⟨ inverse $ Σ-cong (≡≃≃ univ) (λ C-eq → ≡⇒↝ _ $
                                                                     cong (λ eq → subst (λ C → C → C → C) eq op₁ ≡ op₂ ×
                                                                                subst (λ C → C) eq id₁ ≡ id₂) $ sym $
                                                                       _≃_.left-inverse-of (≡≃≃ univ) C-eq) ⟩
  (Σ (C₁ ≡ C₂) λ C-eq →
     subst (λ C → C → C → C) C-eq op₁ ≡ op₂ ×
     subst (λ C → C) C-eq id₁ ≡ id₂)                            ↝⟨ inverse $ equality-triple-lemma ext M₁ M₂ ⟩

  ((C₁ , op₁ , id₁ , laws₁) ≡ (C₂ , op₂ , id₂ , laws₂))         □

  where

  -- The two monoids.

  M₁ = (C₁ , op₁ , id₁ , laws₁)
  M₂ = (C₂ , op₂ , id₂ , laws₂)

  -- Extensionality follows from univalence.

  ext : Extensionality (# 0) (# 0)
  ext = dependent-extensionality univ₁ univ

  -- C₁ is a set.

  C₁-set : Is-set C₁
  C₁-set = proj₁ laws₁

  module _ (C-eq : C₁ ≃ C₂) where

    open _≃_ C-eq

    -- Two component lemmas.

    op-lemma :
      (∀ x y → to (op₁ x y) ≡ op₂ (to x) (to y)) ↔
      subst (λ C → C → C → C) (≃⇒≡ univ C-eq) op₁ ≡ op₂
    op-lemma =
      (∀ x y → to (op₁ x y) ≡ op₂ (to x) (to y))                  ↔⟨ ∀-cong ext (λ _ → Eq.extensionality-isomorphism ext) ⟩

      (∀ x → (λ y → to (op₁ x y)) ≡ (λ y → op₂ (to x) (to y)))    ↝⟨ ∀-cong ext (λ _ → inverse $ ∘from≡↔≡∘to ext C-eq) ⟩

      (∀ x → (λ y → to (op₁ x (from y))) ≡ (λ y → op₂ (to x) y))  ↔⟨ Eq.extensionality-isomorphism ext ⟩

      ((λ x y → to (op₁ x (from y))) ≡ (λ x y → op₂ (to x) y))    ↝⟨ inverse $ ∘from≡↔≡∘to ext C-eq ⟩

      ((λ x y → to (op₁ (from x) (from y))) ≡ (λ x y → op₂ x y))  ↝⟨ ≡⇒↝ _ $ cong (λ o → o ≡ op₂) $
                                                                       transport-theorem
                                                                         (λ C → C → C → C)
                                                                         (λ eq f x y → _≃_.to eq (f (_≃_.from eq x) (_≃_.from eq y)))
                                                                         refl univ C-eq op₁ ⟩
      (subst (λ C → C → C → C) (≃⇒≡ univ C-eq) op₁ ≡ op₂)         □

    id-lemma : (to id₁ ≡ id₂) ↔
               (subst (λ C → C) (≃⇒≡ univ C-eq) id₁ ≡ id₂)
    id-lemma =
      (to id₁ ≡ id₂)                               ↝⟨ ≡⇒↝ _ $ cong (λ i → i ≡ id₂) $
                                                        transport-theorem (λ C → C) _≃_.to refl univ C-eq id₁ ⟩□
      (subst (λ C → C) (≃⇒≡ univ C-eq) id₁ ≡ id₂)  □

-- Equality of monoids is thus equal to equality (assuming
-- univalence).

isomorphism-is-equal-to-equality :
  Univalence (# 0) →
  Univalence (# 1) →
  (M₁ M₂ : Monoid) → ↑ _ (M₁ ≅ M₂) ≡ (M₁ ≡ M₂)
isomorphism-is-equal-to-equality univ univ₁ M₁ M₂ =
  ≃⇒≡ univ₁ $ Eq.↔⇒≃ (
    ↑ _ (M₁ ≅ M₂)  ↝⟨ ↑↔ ⟩
    (M₁ ≅ M₂)      ↝⟨ isomorphism-is-equality univ univ₁ M₁ M₂ ⟩□
    (M₁ ≡ M₂)      □)


{-# OPTIONS --rewriting #-}

module Properties.TypeNormalization where

open import Luau.Type using (Type; Scalar; nil; number; string; boolean; never; unknown; _⇒_; _∪_; _∩_)
open import Luau.Subtyping using (Tree; Language; ¬Language; function; scalar; unknown; left; right; function-ok₁; function-ok₂; function-err; function-tgt; scalar-function; scalar-function-ok; scalar-function-err; scalar-function-tgt; function-scalar; _,_)
open import Luau.TypeNormalization using (_∪ⁿ_; _∩ⁿ_; _∪ᶠ_; _∪ⁿˢ_; _∩ⁿˢ_; normalize)
open import Luau.Subtyping using (_<:_; _≮:_; witness; never)
open import Properties.Subtyping using (<:-trans; <:-refl; <:-unknown; <:-never; <:-∪-left; <:-∪-right; <:-∪-lub; <:-∩-left; <:-∩-right; <:-∩-glb; <:-∩-symm; <:-function; <:-function-∪-∩; <:-function-∩-∪; <:-function-∪; <:-everything; <:-union; <:-∪-assocl; <:-∪-assocr; <:-∪-symm; <:-intersect;  ∪-distl-∩-<:; ∪-distr-∩-<:; <:-∪-distr-∩; <:-∪-distl-∩; ∩-distl-∪-<:; <:-∩-distl-∪; <:-∩-distr-∪; scalar-∩-function-<:-never; scalar-≢-∩-<:-never)

-- Normal forms for types
data FunType : Type → Set
data Normal : Type → Set

data FunType where
  _⇒_ : ∀ {S T} → Normal S → Normal T → FunType (S ⇒ T)
  _∩_ : ∀ {F G} → FunType F → FunType G → FunType (F ∩ G)

data Normal where
  _⇒_ : ∀ {S T} → Normal S → Normal T → Normal (S ⇒ T)
  _∩_ : ∀ {F G} → FunType F → FunType G → Normal (F ∩ G)
  _∪_ : ∀ {S T} → Normal S → Scalar T → Normal (S ∪ T)
  never : Normal never
  unknown : Normal unknown

data OptScalar : Type → Set where
  never : OptScalar never
  number : OptScalar number
  boolean : OptScalar boolean
  string : OptScalar string
  nil : OptScalar nil

-- Top function type
fun-top : ∀ {F} → (FunType F) → (F <: (never ⇒ unknown))
fun-top (S ⇒ T) = <:-function <:-never <:-unknown
fun-top (F ∩ G) = <:-trans <:-∩-left (fun-top F)

-- function types are inhabited
fun-function : ∀ {F} → FunType F → Language F function
fun-function (S ⇒ T) = function
fun-function (F ∩ G) = (fun-function F , fun-function G)

fun-≮:-never : ∀ {F} → FunType F → (F ≮: never)
fun-≮:-never F = witness function (fun-function F) never

-- function types aren't scalars
fun-¬scalar : ∀ {F S t} → (s : Scalar S) → FunType F → Language F t → ¬Language S t
fun-¬scalar s (S ⇒ T) function = scalar-function s
fun-¬scalar s (S ⇒ T) (function-ok₁ p) = scalar-function-ok s
fun-¬scalar s (S ⇒ T) (function-ok₂ p) = scalar-function-ok s
fun-¬scalar s (S ⇒ T) (function-err p) = scalar-function-err s
fun-¬scalar s (S ⇒ T) (function-tgt p) = scalar-function-tgt s
fun-¬scalar s (F ∩ G) (p₁ , p₂) = fun-¬scalar s G p₂

¬scalar-fun : ∀ {F S} → FunType F → (s : Scalar S) → ¬Language F (scalar s)
¬scalar-fun (S ⇒ T) s = function-scalar s
¬scalar-fun (F ∩ G) s = left (¬scalar-fun F s)

scalar-≮:-fun : ∀ {F S} → FunType F → Scalar S → S ≮: F
scalar-≮:-fun F s = witness (scalar s) (scalar s) (¬scalar-fun F s)

unknown-≮:-fun : ∀ {F} → FunType F → unknown ≮: F
unknown-≮:-fun F = witness (scalar nil) unknown (¬scalar-fun F nil)

-- Normalization produces normal types
normal : ∀ T → Normal (normalize T)
normalᶠ : ∀ {F} → FunType F → Normal F
normal-∪ⁿ : ∀ {S T} → Normal S → Normal T → Normal (S ∪ⁿ T)
normal-∩ⁿ : ∀ {S T} → Normal S → Normal T → Normal (S ∩ⁿ T)
normal-∪ⁿˢ : ∀ {S T} → Normal S → OptScalar T → Normal (S ∪ⁿˢ T)
normal-∩ⁿˢ : ∀ {S T} → Normal S → Scalar T → OptScalar (S ∩ⁿˢ T)
normal-∪ᶠ : ∀ {F G} → FunType F → FunType G → FunType (F ∪ᶠ G)

normal nil = never ∪ nil
normal (S ⇒ T) = (normal S) ⇒ (normal T)
normal never = never
normal unknown = unknown
normal boolean = never ∪ boolean
normal number = never ∪ number
normal string = never ∪ string
normal (S ∪ T) = normal-∪ⁿ (normal S) (normal T)
normal (S ∩ T) = normal-∩ⁿ (normal S) (normal T)

normalᶠ (S ⇒ T) = S ⇒ T
normalᶠ (F ∩ G) = F ∩ G

normal-∪ⁿ S (T₁ ∪ T₂) = (normal-∪ⁿ S T₁) ∪ T₂
normal-∪ⁿ S never = S
normal-∪ⁿ S unknown = unknown
normal-∪ⁿ never (T ⇒ U) = T ⇒ U
normal-∪ⁿ never (G₁ ∩ G₂) = G₁ ∩ G₂
normal-∪ⁿ unknown (T ⇒ U) = unknown
normal-∪ⁿ unknown (G₁ ∩ G₂) = unknown
normal-∪ⁿ (R ⇒ S) (T ⇒ U) = normalᶠ (normal-∪ᶠ (R ⇒ S) (T ⇒ U))
normal-∪ⁿ (R ⇒ S) (G₁ ∩ G₂) = normalᶠ (normal-∪ᶠ (R ⇒ S) (G₁ ∩ G₂))
normal-∪ⁿ (F₁ ∩ F₂) (T ⇒ U) = normalᶠ (normal-∪ᶠ (F₁ ∩ F₂) (T ⇒ U))
normal-∪ⁿ (F₁ ∩ F₂) (G₁ ∩ G₂) = normalᶠ (normal-∪ᶠ (F₁ ∩ F₂) (G₁ ∩ G₂))
normal-∪ⁿ (S₁ ∪ S₂) (T₁ ⇒ T₂) = normal-∪ⁿ S₁ (T₁ ⇒ T₂) ∪ S₂
normal-∪ⁿ (S₁ ∪ S₂) (G₁ ∩ G₂) = normal-∪ⁿ S₁ (G₁ ∩ G₂) ∪ S₂

normal-∩ⁿ S never = never
normal-∩ⁿ S unknown = S
normal-∩ⁿ S (T ∪ U) = normal-∪ⁿˢ (normal-∩ⁿ S T) (normal-∩ⁿˢ S U )
normal-∩ⁿ never (T ⇒ U) = never
normal-∩ⁿ unknown (T ⇒ U) = T ⇒ U
normal-∩ⁿ (R ⇒ S) (T ⇒ U) = (R ⇒ S) ∩ (T ⇒ U)
normal-∩ⁿ (R ∩ S) (T ⇒ U) = (R ∩ S) ∩ (T ⇒ U)
normal-∩ⁿ (R ∪ S) (T ⇒ U) = normal-∩ⁿ R (T ⇒ U)
normal-∩ⁿ never (T ∩ U) = never
normal-∩ⁿ unknown (T ∩ U) = T ∩ U
normal-∩ⁿ (R ⇒ S) (T ∩ U) = (R ⇒ S) ∩ (T ∩ U)
normal-∩ⁿ (R ∩ S) (T ∩ U) = (R ∩ S) ∩ (T ∩ U)
normal-∩ⁿ (R ∪ S) (T ∩ U) = normal-∩ⁿ R (T ∩ U)

normal-∪ⁿˢ S never = S
normal-∪ⁿˢ never number = never ∪ number
normal-∪ⁿˢ unknown number = unknown
normal-∪ⁿˢ (R ⇒ S) number = (R ⇒ S) ∪ number
normal-∪ⁿˢ (R ∩ S) number = (R ∩ S) ∪ number
normal-∪ⁿˢ (R ∪ number) number = R ∪ number
normal-∪ⁿˢ (R ∪ boolean) number = normal-∪ⁿˢ R number ∪ boolean
normal-∪ⁿˢ (R ∪ string) number = normal-∪ⁿˢ R number ∪ string
normal-∪ⁿˢ (R ∪ nil) number = normal-∪ⁿˢ R number ∪ nil
normal-∪ⁿˢ never boolean = never ∪ boolean
normal-∪ⁿˢ unknown boolean = unknown
normal-∪ⁿˢ (R ⇒ S) boolean = (R ⇒ S) ∪ boolean
normal-∪ⁿˢ (R ∩ S) boolean = (R ∩ S) ∪ boolean
normal-∪ⁿˢ (R ∪ number) boolean = normal-∪ⁿˢ R boolean ∪ number
normal-∪ⁿˢ (R ∪ boolean) boolean = R ∪ boolean
normal-∪ⁿˢ (R ∪ string) boolean = normal-∪ⁿˢ R boolean ∪ string
normal-∪ⁿˢ (R ∪ nil) boolean = normal-∪ⁿˢ R boolean ∪ nil
normal-∪ⁿˢ never string = never ∪ string
normal-∪ⁿˢ unknown string = unknown
normal-∪ⁿˢ (R ⇒ S) string = (R ⇒ S) ∪ string
normal-∪ⁿˢ (R ∩ S) string = (R ∩ S) ∪ string
normal-∪ⁿˢ (R ∪ number) string = normal-∪ⁿˢ R string ∪ number
normal-∪ⁿˢ (R ∪ boolean) string = normal-∪ⁿˢ R string ∪ boolean
normal-∪ⁿˢ (R ∪ string) string = R ∪ string
normal-∪ⁿˢ (R ∪ nil) string = normal-∪ⁿˢ R string ∪ nil
normal-∪ⁿˢ never nil = never ∪ nil
normal-∪ⁿˢ unknown nil = unknown
normal-∪ⁿˢ (R ⇒ S) nil = (R ⇒ S) ∪ nil
normal-∪ⁿˢ (R ∩ S) nil = (R ∩ S) ∪ nil
normal-∪ⁿˢ (R ∪ number) nil = normal-∪ⁿˢ R nil ∪ number
normal-∪ⁿˢ (R ∪ boolean) nil = normal-∪ⁿˢ R nil ∪ boolean
normal-∪ⁿˢ (R ∪ string) nil = normal-∪ⁿˢ R nil ∪ string
normal-∪ⁿˢ (R ∪ nil) nil = R ∪ nil

normal-∩ⁿˢ never number = never
normal-∩ⁿˢ never boolean = never
normal-∩ⁿˢ never string = never
normal-∩ⁿˢ never nil = never
normal-∩ⁿˢ unknown number = number
normal-∩ⁿˢ unknown boolean = boolean
normal-∩ⁿˢ unknown string = string
normal-∩ⁿˢ unknown nil = nil
normal-∩ⁿˢ (R ⇒ S) number = never
normal-∩ⁿˢ (R ⇒ S) boolean = never
normal-∩ⁿˢ (R ⇒ S) string = never
normal-∩ⁿˢ (R ⇒ S) nil = never
normal-∩ⁿˢ (R ∩ S) number = never
normal-∩ⁿˢ (R ∩ S) boolean = never
normal-∩ⁿˢ (R ∩ S) string = never
normal-∩ⁿˢ (R ∩ S) nil = never
normal-∩ⁿˢ (R ∪ number) number = number
normal-∩ⁿˢ (R ∪ boolean) number = normal-∩ⁿˢ R number
normal-∩ⁿˢ (R ∪ string) number = normal-∩ⁿˢ R number
normal-∩ⁿˢ (R ∪ nil) number = normal-∩ⁿˢ R number
normal-∩ⁿˢ (R ∪ number) boolean = normal-∩ⁿˢ R boolean
normal-∩ⁿˢ (R ∪ boolean) boolean = boolean
normal-∩ⁿˢ (R ∪ string) boolean = normal-∩ⁿˢ R boolean
normal-∩ⁿˢ (R ∪ nil) boolean = normal-∩ⁿˢ R boolean
normal-∩ⁿˢ (R ∪ number) string = normal-∩ⁿˢ R string
normal-∩ⁿˢ (R ∪ boolean) string = normal-∩ⁿˢ R string
normal-∩ⁿˢ (R ∪ string) string = string
normal-∩ⁿˢ (R ∪ nil) string = normal-∩ⁿˢ R string
normal-∩ⁿˢ (R ∪ number) nil = normal-∩ⁿˢ R nil
normal-∩ⁿˢ (R ∪ boolean) nil = normal-∩ⁿˢ R nil
normal-∩ⁿˢ (R ∪ string) nil = normal-∩ⁿˢ R nil
normal-∩ⁿˢ (R ∪ nil) nil = nil

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

scalar-∩-fun-<:-never : ∀ {F S} → FunType F → Scalar S → (F ∩ S) <: never
scalar-∩-fun-<:-never (T ⇒ U) S = scalar-∩-function-<:-never S
scalar-∩-fun-<:-never (F ∩ G) S = <:-trans (<:-intersect <:-∩-left <:-refl) (scalar-∩-fun-<:-never F S)

flipper : ∀ {S T U} → ((S ∪ T) ∪ U) <: ((S ∪ U) ∪ T)
flipper = <:-trans <:-∪-assocr (<:-trans (<:-union <:-refl <:-∪-symm) <:-∪-assocl)

∩-<:-∩ⁿ :  ∀ {S T} → Normal S → Normal T → (S ∩ T) <: (S ∩ⁿ T)
∩ⁿ-<:-∩ :  ∀ {S T} → Normal S → Normal T → (S ∩ⁿ T) <: (S ∩ T)
∩-<:-∩ⁿˢ :  ∀ {S T} → Normal S → Scalar T → (S ∩ T) <: (S ∩ⁿˢ T)
∩ⁿˢ-<:-∩ :  ∀ {S T} → Normal S → Scalar T → (S ∩ⁿˢ T) <: (S ∩ T)
∪ᶠ-<:-∪ : ∀ {F G} → FunType F → FunType G → (F ∪ᶠ G) <: (F ∪ G)
∪ⁿ-<:-∪ : ∀ {S T} → Normal S → Normal T → (S ∪ⁿ T) <: (S ∪ T)
∪-<:-∪ⁿ : ∀ {S T} → Normal S → Normal T → (S ∪ T) <: (S ∪ⁿ T)
∪ⁿˢ-<:-∪ : ∀ {S T} → Normal S → OptScalar T → (S ∪ⁿˢ T) <: (S ∪ T)
∪-<:-∪ⁿˢ : ∀ {S T} → Normal S → OptScalar T → (S ∪ T) <: (S ∪ⁿˢ T)

∩-<:-∩ⁿ S never = <:-∩-right
∩-<:-∩ⁿ S unknown = <:-∩-left
∩-<:-∩ⁿ S (T ∪ U) = <:-trans <:-∩-distl-∪ (<:-trans (<:-union (∩-<:-∩ⁿ S T) (∩-<:-∩ⁿˢ S U)) (∪-<:-∪ⁿˢ (normal-∩ⁿ S T) (normal-∩ⁿˢ S U)) )
∩-<:-∩ⁿ never (T ⇒ U) = <:-∩-left
∩-<:-∩ⁿ unknown (T ⇒ U) = <:-∩-right
∩-<:-∩ⁿ (R ⇒ S) (T ⇒ U) = <:-refl
∩-<:-∩ⁿ (R ∩ S) (T ⇒ U) = <:-refl
∩-<:-∩ⁿ (R ∪ S) (T ⇒ U) = <:-trans <:-∩-distr-∪ (<:-trans (<:-union (∩-<:-∩ⁿ R (T ⇒ U)) (<:-trans <:-∩-symm (∩-<:-∩ⁿˢ (T ⇒ U) S))) (<:-∪-lub <:-refl <:-never))
∩-<:-∩ⁿ never (T ∩ U) = <:-∩-left
∩-<:-∩ⁿ unknown (T ∩ U) = <:-∩-right
∩-<:-∩ⁿ (R ⇒ S) (T ∩ U) = <:-refl
∩-<:-∩ⁿ (R ∩ S) (T ∩ U) = <:-refl
∩-<:-∩ⁿ (R ∪ S) (T ∩ U) = <:-trans <:-∩-distr-∪ (<:-trans (<:-union (∩-<:-∩ⁿ R (T ∩ U)) (<:-trans <:-∩-symm (∩-<:-∩ⁿˢ (T ∩ U) S))) (<:-∪-lub <:-refl <:-never))

∩ⁿ-<:-∩ S never = <:-never
∩ⁿ-<:-∩ S unknown = <:-∩-glb <:-refl <:-unknown
∩ⁿ-<:-∩ S (T ∪ U) = <:-trans (∪ⁿˢ-<:-∪ (normal-∩ⁿ S T) (normal-∩ⁿˢ S U)) (<:-trans (<:-union (∩ⁿ-<:-∩ S T) (∩ⁿˢ-<:-∩ S U)) ∩-distl-∪-<:)
∩ⁿ-<:-∩ never (T ⇒ U) = <:-never
∩ⁿ-<:-∩ unknown (T ⇒ U) = <:-∩-glb <:-unknown <:-refl
∩ⁿ-<:-∩ (R ⇒ S) (T ⇒ U) = <:-refl
∩ⁿ-<:-∩ (R ∩ S) (T ⇒ U) = <:-refl
∩ⁿ-<:-∩ (R ∪ S) (T ⇒ U) = <:-trans (∩ⁿ-<:-∩ R (T ⇒ U)) (<:-∩-glb (<:-trans <:-∩-left <:-∪-left) <:-∩-right)
∩ⁿ-<:-∩ never (T ∩ U) = <:-never
∩ⁿ-<:-∩ unknown (T ∩ U) = <:-∩-glb <:-unknown <:-refl
∩ⁿ-<:-∩ (R ⇒ S) (T ∩ U) = <:-refl
∩ⁿ-<:-∩ (R ∩ S) (T ∩ U) = <:-refl
∩ⁿ-<:-∩ (R ∪ S) (T ∩ U) = <:-trans (∩ⁿ-<:-∩ R (T ∩ U)) (<:-∩-glb (<:-trans <:-∩-left <:-∪-left) <:-∩-right)

∩-<:-∩ⁿˢ never number = <:-∩-left
∩-<:-∩ⁿˢ never boolean = <:-∩-left
∩-<:-∩ⁿˢ never string = <:-∩-left
∩-<:-∩ⁿˢ never nil = <:-∩-left
∩-<:-∩ⁿˢ unknown T = <:-∩-right
∩-<:-∩ⁿˢ (R ⇒ S) T = scalar-∩-fun-<:-never (R ⇒ S) T
∩-<:-∩ⁿˢ (F ∩ G) T = scalar-∩-fun-<:-never (F ∩ G) T
∩-<:-∩ⁿˢ (R ∪ number) number = <:-∩-right
∩-<:-∩ⁿˢ (R ∪ boolean) number = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R number) (scalar-≢-∩-<:-never boolean number (λ ())))
∩-<:-∩ⁿˢ (R ∪ string) number = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R number) (scalar-≢-∩-<:-never string number (λ ())))
∩-<:-∩ⁿˢ (R ∪ nil) number = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R number) (scalar-≢-∩-<:-never nil number (λ ())))
∩-<:-∩ⁿˢ (R ∪ number) boolean = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R boolean) (scalar-≢-∩-<:-never number boolean (λ ())))
∩-<:-∩ⁿˢ (R ∪ boolean) boolean = <:-∩-right
∩-<:-∩ⁿˢ (R ∪ string) boolean = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R boolean) (scalar-≢-∩-<:-never string boolean (λ ())))
∩-<:-∩ⁿˢ (R ∪ nil) boolean = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R boolean) (scalar-≢-∩-<:-never nil boolean (λ ())))
∩-<:-∩ⁿˢ (R ∪ number) string = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R string) (scalar-≢-∩-<:-never number string (λ ())))
∩-<:-∩ⁿˢ (R ∪ boolean) string = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R string) (scalar-≢-∩-<:-never boolean string (λ ())))
∩-<:-∩ⁿˢ (R ∪ string) string = <:-∩-right
∩-<:-∩ⁿˢ (R ∪ nil) string = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R string) (scalar-≢-∩-<:-never nil string (λ ())))
∩-<:-∩ⁿˢ (R ∪ number) nil = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R nil) (scalar-≢-∩-<:-never number nil (λ ())))
∩-<:-∩ⁿˢ (R ∪ boolean) nil = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R nil) (scalar-≢-∩-<:-never boolean nil (λ ())))
∩-<:-∩ⁿˢ (R ∪ string) nil = <:-trans <:-∩-distr-∪ (<:-∪-lub (∩-<:-∩ⁿˢ R nil) (scalar-≢-∩-<:-never string nil (λ ())))
∩-<:-∩ⁿˢ (R ∪ nil) nil = <:-∩-right

∩ⁿˢ-<:-∩ never T = <:-never
∩ⁿˢ-<:-∩ unknown T = <:-∩-glb <:-unknown <:-refl
∩ⁿˢ-<:-∩ (R ⇒ S) T = <:-never
∩ⁿˢ-<:-∩ (F ∩ G) T = <:-never
∩ⁿˢ-<:-∩ (R ∪ number) number = <:-∩-glb <:-∪-right <:-refl
∩ⁿˢ-<:-∩ (R ∪ boolean) number = <:-trans (∩ⁿˢ-<:-∩ R number) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ string) number = <:-trans (∩ⁿˢ-<:-∩ R number) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ nil) number = <:-trans (∩ⁿˢ-<:-∩ R number) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ number) boolean = <:-trans (∩ⁿˢ-<:-∩ R boolean) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ boolean) boolean = <:-∩-glb <:-∪-right <:-refl
∩ⁿˢ-<:-∩ (R ∪ string) boolean = <:-trans (∩ⁿˢ-<:-∩ R boolean) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ nil) boolean = <:-trans (∩ⁿˢ-<:-∩ R boolean) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ number) string = <:-trans (∩ⁿˢ-<:-∩ R string) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ boolean) string = <:-trans (∩ⁿˢ-<:-∩ R string) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ string) string = <:-∩-glb <:-∪-right <:-refl
∩ⁿˢ-<:-∩ (R ∪ nil) string = <:-trans (∩ⁿˢ-<:-∩ R string) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ number) nil = <:-trans (∩ⁿˢ-<:-∩ R nil) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ boolean) nil = <:-trans (∩ⁿˢ-<:-∩ R nil) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ string) nil = <:-trans (∩ⁿˢ-<:-∩ R nil) (<:-intersect <:-∪-left <:-refl)
∩ⁿˢ-<:-∩ (R ∪ nil) nil = <:-∩-glb <:-∪-right <:-refl

∪ᶠ-<:-∪ (R ⇒ S) (T ⇒ U) = <:-trans (<:-function (∩-<:-∩ⁿ R T) (∪ⁿ-<:-∪ S U)) <:-function-∪-∩
∪ᶠ-<:-∪ (R ⇒ S) (G ∩ H) = <:-trans (<:-intersect (∪ᶠ-<:-∪ (R ⇒ S) G) (∪ᶠ-<:-∪ (R ⇒ S) H)) ∪-distl-∩-<:
∪ᶠ-<:-∪ (E ∩ F) G = <:-trans (<:-intersect (∪ᶠ-<:-∪ E G) (∪ᶠ-<:-∪ F G)) ∪-distr-∩-<:

∪-<:-∪ᶠ : ∀ {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 <:-∪-distl-∩ (<:-intersect (∪-<:-∪ᶠ (R ⇒ S) G) (∪-<:-∪ᶠ (R ⇒ S) H))
∪-<:-∪ᶠ (E ∩ F) G = <:-trans <:-∪-distr-∩ (<:-intersect (∪-<:-∪ᶠ E G) (∪-<:-∪ᶠ F G))

∪ⁿˢ-<:-∪ S never = <:-∪-left
∪ⁿˢ-<:-∪ never number = <:-refl
∪ⁿˢ-<:-∪ never boolean = <:-refl
∪ⁿˢ-<:-∪ never string = <:-refl
∪ⁿˢ-<:-∪ never nil = <:-refl
∪ⁿˢ-<:-∪ unknown number = <:-∪-left
∪ⁿˢ-<:-∪ unknown boolean = <:-∪-left
∪ⁿˢ-<:-∪ unknown string = <:-∪-left
∪ⁿˢ-<:-∪ unknown nil = <:-∪-left
∪ⁿˢ-<:-∪ (R ⇒ S) number = <:-refl
∪ⁿˢ-<:-∪ (R ⇒ S) boolean = <:-refl
∪ⁿˢ-<:-∪ (R ⇒ S) string = <:-refl
∪ⁿˢ-<:-∪ (R ⇒ S) nil = <:-refl
∪ⁿˢ-<:-∪ (R ∩ S) number = <:-refl
∪ⁿˢ-<:-∪ (R ∩ S) boolean = <:-refl
∪ⁿˢ-<:-∪ (R ∩ S) string = <:-refl
∪ⁿˢ-<:-∪ (R ∩ S) nil = <:-refl
∪ⁿˢ-<:-∪ (R ∪ number) number = <:-union <:-∪-left <:-refl
∪ⁿˢ-<:-∪ (R ∪ boolean) number = <:-trans (<:-union (∪ⁿˢ-<:-∪ R number) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ string) number = <:-trans (<:-union (∪ⁿˢ-<:-∪ R number) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ nil) number = <:-trans (<:-union (∪ⁿˢ-<:-∪ R number) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ number) boolean = <:-trans (<:-union (∪ⁿˢ-<:-∪ R boolean) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ boolean) boolean = <:-union <:-∪-left <:-refl
∪ⁿˢ-<:-∪ (R ∪ string) boolean = <:-trans (<:-union (∪ⁿˢ-<:-∪ R boolean) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ nil) boolean = <:-trans (<:-union (∪ⁿˢ-<:-∪ R boolean) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ number) string = <:-trans (<:-union (∪ⁿˢ-<:-∪ R string) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ boolean) string = <:-trans (<:-union (∪ⁿˢ-<:-∪ R string) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ string) string = <:-union <:-∪-left <:-refl
∪ⁿˢ-<:-∪ (R ∪ nil) string = <:-trans (<:-union (∪ⁿˢ-<:-∪ R string) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ number) nil = <:-trans (<:-union (∪ⁿˢ-<:-∪ R nil) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ boolean) nil = <:-trans (<:-union (∪ⁿˢ-<:-∪ R nil) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ string) nil = <:-trans (<:-union (∪ⁿˢ-<:-∪ R nil) <:-refl) flipper
∪ⁿˢ-<:-∪ (R ∪ nil) nil = <:-union <:-∪-left <:-refl

∪-<:-∪ⁿˢ T never = <:-∪-lub <:-refl <:-never
∪-<:-∪ⁿˢ never number = <:-refl
∪-<:-∪ⁿˢ never boolean = <:-refl
∪-<:-∪ⁿˢ never string = <:-refl
∪-<:-∪ⁿˢ never nil = <:-refl
∪-<:-∪ⁿˢ unknown number = <:-unknown
∪-<:-∪ⁿˢ unknown boolean = <:-unknown
∪-<:-∪ⁿˢ unknown string = <:-unknown
∪-<:-∪ⁿˢ unknown nil = <:-unknown
∪-<:-∪ⁿˢ (R ⇒ S) number = <:-refl
∪-<:-∪ⁿˢ (R ⇒ S) boolean = <:-refl
∪-<:-∪ⁿˢ (R ⇒ S) string = <:-refl
∪-<:-∪ⁿˢ (R ⇒ S) nil = <:-refl
∪-<:-∪ⁿˢ (R ∩ S) number = <:-refl
∪-<:-∪ⁿˢ (R ∩ S) boolean = <:-refl
∪-<:-∪ⁿˢ (R ∩ S) string = <:-refl
∪-<:-∪ⁿˢ (R ∩ S) nil = <:-refl
∪-<:-∪ⁿˢ (R ∪ number) number = <:-∪-lub <:-refl <:-∪-right
∪-<:-∪ⁿˢ (R ∪ boolean) number = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R number) <:-refl)
∪-<:-∪ⁿˢ (R ∪ string) number = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R number) <:-refl)
∪-<:-∪ⁿˢ (R ∪ nil) number = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R number) <:-refl)
∪-<:-∪ⁿˢ (R ∪ number) boolean = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R boolean) <:-refl)
∪-<:-∪ⁿˢ (R ∪ boolean) boolean = <:-∪-lub <:-refl <:-∪-right
∪-<:-∪ⁿˢ (R ∪ string) boolean = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R boolean) <:-refl)
∪-<:-∪ⁿˢ (R ∪ nil) boolean = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R boolean) <:-refl)
∪-<:-∪ⁿˢ (R ∪ number) string = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R string) <:-refl)
∪-<:-∪ⁿˢ (R ∪ boolean) string = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R string) <:-refl)
∪-<:-∪ⁿˢ (R ∪ string) string = <:-∪-lub <:-refl <:-∪-right
∪-<:-∪ⁿˢ (R ∪ nil) string = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R string) <:-refl)
∪-<:-∪ⁿˢ (R ∪ number) nil = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R nil) <:-refl)
∪-<:-∪ⁿˢ (R ∪ boolean) nil = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R nil) <:-refl)
∪-<:-∪ⁿˢ (R ∪ string) nil = <:-trans flipper (<:-union (∪-<:-∪ⁿˢ R nil) <:-refl)
∪-<:-∪ⁿˢ (R ∪ nil) nil = <:-∪-lub <:-refl <:-∪-right

∪ⁿ-<:-∪ S never = <:-∪-left
∪ⁿ-<:-∪ S unknown = <:-∪-right
∪ⁿ-<:-∪ never (T ⇒ U) = <:-∪-right
∪ⁿ-<:-∪ unknown (T ⇒ U) = <:-∪-left
∪ⁿ-<:-∪ (R ⇒ S) (T ⇒ U) = ∪ᶠ-<:-∪ (R ⇒ S) (T ⇒ U)
∪ⁿ-<:-∪ (R ∩ S) (T ⇒ U) = ∪ᶠ-<:-∪ (R ∩ S) (T ⇒ U)
∪ⁿ-<:-∪ (R ∪ S) (T ⇒ U) = <:-trans (<:-union (∪ⁿ-<:-∪ R (T ⇒ U)) <:-refl) (<:-∪-lub (<:-∪-lub (<:-trans <:-∪-left <:-∪-left) <:-∪-right) (<:-trans <:-∪-right <:-∪-left))
∪ⁿ-<:-∪ never (T ∩ U) = <:-∪-right
∪ⁿ-<:-∪ unknown (T ∩ U) = <:-∪-left
∪ⁿ-<:-∪ (R ⇒ S) (T ∩ U) = ∪ᶠ-<:-∪ (R ⇒ S) (T ∩ U)
∪ⁿ-<:-∪ (R ∩ S) (T ∩ U) = ∪ᶠ-<:-∪ (R ∩ S) (T ∩ U)
∪ⁿ-<:-∪ (R ∪ S) (T ∩ U) = <:-trans (<:-union (∪ⁿ-<:-∪ R (T ∩ U)) <:-refl) (<:-∪-lub (<:-∪-lub (<:-trans <:-∪-left <:-∪-left) <:-∪-right) (<:-trans <:-∪-right <:-∪-left))
∪ⁿ-<:-∪ S (T ∪ U) = <:-∪-lub (<:-trans (∪ⁿ-<:-∪ S T) (<:-union <:-refl <:-∪-left)) (<:-trans <:-∪-right <:-∪-right)

∪-<:-∪ⁿ S never = <:-∪-lub <:-refl <:-never
∪-<:-∪ⁿ S unknown = <:-unknown
∪-<:-∪ⁿ never (T ⇒ U) = <:-∪-lub <:-never <:-refl
∪-<:-∪ⁿ unknown (T ⇒ U) = <:-unknown
∪-<:-∪ⁿ (R ⇒ S) (T ⇒ U) = ∪-<:-∪ᶠ (R ⇒ S) (T ⇒ U)
∪-<:-∪ⁿ (R ∩ S) (T ⇒ U) = ∪-<:-∪ᶠ (R ∩ S) (T ⇒ U)
∪-<:-∪ⁿ (R ∪ S) (T ⇒ U) = <:-trans <:-∪-assocr (<:-trans (<:-union <:-refl <:-∪-symm) (<:-trans <:-∪-assocl (<:-union (∪-<:-∪ⁿ R (T ⇒ U)) <:-refl)))
∪-<:-∪ⁿ never (T ∩ U) = <:-∪-lub <:-never <:-refl
∪-<:-∪ⁿ unknown (T ∩ U) = <:-unknown
∪-<:-∪ⁿ (R ⇒ S) (T ∩ U) = ∪-<:-∪ᶠ (R ⇒ S) (T ∩ U)
∪-<:-∪ⁿ (R ∩ S) (T ∩ U) = ∪-<:-∪ᶠ (R ∩ S) (T ∩ U)
∪-<:-∪ⁿ (R ∪ S) (T ∩ U) = <:-trans <:-∪-assocr (<:-trans (<:-union <:-refl <:-∪-symm) (<:-trans <:-∪-assocl (<:-union (∪-<:-∪ⁿ R (T ∩ U)) <:-refl)))
∪-<:-∪ⁿ never (T ∪ U) = <:-trans <:-∪-assocl (<:-union (∪-<:-∪ⁿ never T) <:-refl)
∪-<:-∪ⁿ unknown (T ∪ U) = <:-trans <:-∪-assocl (<:-union (∪-<:-∪ⁿ unknown T) <:-refl)
∪-<:-∪ⁿ (R ⇒ S) (T ∪ U) = <:-trans <:-∪-assocl (<:-union (∪-<:-∪ⁿ (R ⇒ S) T) <:-refl)
∪-<:-∪ⁿ (R ∩ S) (T ∪ U) = <:-trans <:-∪-assocl (<:-union (∪-<:-∪ⁿ (R ∩ S) T) <:-refl)
∪-<:-∪ⁿ (R ∪ S) (T ∪ U) = <:-trans <:-∪-assocl (<:-union (∪-<:-∪ⁿ (R ∪ S) T) <:-refl)

normalize-<: : ∀ T → normalize T <: T
<:-normalize : ∀ T → T <: normalize T

<:-normalize nil = <:-∪-right
<:-normalize (S ⇒ T) = <:-function (normalize-<: S) (<:-normalize T)
<:-normalize never = <:-refl
<:-normalize unknown = <:-refl
<:-normalize boolean = <:-∪-right
<:-normalize number = <:-∪-right
<:-normalize string = <:-∪-right
<:-normalize (S ∪ T) = <:-trans (<:-union (<:-normalize S) (<:-normalize T)) (∪-<:-∪ⁿ (normal S) (normal T))
<:-normalize (S ∩ T) = <:-trans (<:-intersect (<:-normalize S) (<:-normalize T)) (∩-<:-∩ⁿ (normal S) (normal T))

normalize-<: nil = <:-∪-lub <:-never <:-refl
normalize-<: (S ⇒ T) = <:-function (<:-normalize S) (normalize-<: T)
normalize-<: never = <:-refl
normalize-<: unknown = <:-refl
normalize-<: boolean = <:-∪-lub <:-never <:-refl
normalize-<: number = <:-∪-lub <:-never <:-refl
normalize-<: string = <:-∪-lub <:-never <:-refl
normalize-<: (S ∪ T) = <:-trans (∪ⁿ-<:-∪ (normal S) (normal T)) (<:-union (normalize-<: S) (normalize-<: T))
normalize-<: (S ∩ T) = <:-trans (∩ⁿ-<:-∩ (normal S) (normal T)) (<:-intersect (normalize-<: S) (normalize-<: T))


------------------------------------------------------------------------
-- Functors
------------------------------------------------------------------------

-- Note that currently the functor laws are not included here.

module Category.Functor where

open import Data.Function

record RawFunctor (f : Set → Set) : Set₁ where
  infixl 4 _<$>_ _<$_

  field
    _<$>_ : ∀ {a b} → (a → b) → f a → f b

  _<$_ : ∀ {a b} → a → f b → f a
  x <$ y = const x <$> y


------------------------------------------------------------------------
-- Adjunctions and monads (for 1-categories)
------------------------------------------------------------------------

-- The code is based on the presentation in the HoTT book (but might
-- not follow it exactly).

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

open import Equality

module Adjunction
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Prelude hiding (id)

open import Category eq
open Derived-definitions-and-properties eq
open import Functor eq

------------------------------------------------------------------------
-- Adjunctions

private

  -- Is-left-adjoint-of ext F G means that F is a left adjoint of G.
  -- This definition tries to follow the HoTT book closely.

  Is-left-adjoint-of :
    ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
      {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄} →
    Extensionality (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) →
    C ⇨ D → D ⇨ C → Type _
  Is-left-adjoint-of {ℓ₁} {ℓ₂} {C} {ℓ₃} {ℓ₄} {D} ext F G =
    ∃ λ (η : id⇨ ⇾ G ∙⇨ F) →
    ∃ λ (ε : F ∙⇨ G ⇾ id⇨) →
    subst ((F ∙⇨ G) ∙⇨ F ⇾_) (id⇨∙⇨ ext₁) (ε ⇾∙⇨ F) ∙⇾
      subst (_⇾ (F ∙⇨ G) ∙⇨ F) (∙⇨id⇨ ext₁)
        (subst (F ∙⇨ id⇨ ⇾_) (∙⇨-assoc ext₁ F G) (F ⇨∙⇾ η))
      ≡
    id⇾ F
      ×
    subst (G ∙⇨ F ∙⇨ G ⇾_) (∙⇨id⇨ ext₂) (G ⇨∙⇾ ε) ∙⇾
      subst (_⇾ G ∙⇨ F ∙⇨ G) (id⇨∙⇨ ext₂)
        (subst (id⇨ ∙⇨ G ⇾_) (sym $ ∙⇨-assoc ext₂ G F) (η ⇾∙⇨ G))
      ≡
    id⇾ G
    where
    ext₁ : Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₄)
    ext₁ = lower-extensionality (ℓ₃ ⊔ ℓ₄) ℓ₃ ext

    ext₂ : Extensionality (ℓ₃ ⊔ ℓ₄) (ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄)
    ext₂ = lower-extensionality (ℓ₁ ⊔ ℓ₂) ℓ₁ ext

-- F ⊣ G means that F is a left adjoint of G.
--
-- This definition avoids the use of subst in the previous definition
-- by making use of the equality characterisation for natural
-- transformations (equality-characterisation⇾). I (NAD) took the idea
-- for this definition from the HoTT-Agda library
-- (https://github.com/HoTT/HoTT-Agda/blob/2871c6f6dbe90b47b3b2770e57abc4732cd1c295/theorems/homotopy/PtdAdjoint.agda).
--
-- TODO: Prove that the two definitions are equivalent.

_⊣_ :
  ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
    {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄} →
  C ⇨ D → D ⇨ C → Type _
_⊣_ {ℓ₁} {ℓ₂} {C} {ℓ₃} {ℓ₄} {D} F G =
  ∃ λ (η : id⇨ ⇾ G ∙⇨ F) →
  ∃ λ (ε : F ∙⇨ G ⇾ id⇨) →
  (∀ {X} → transformation ε D.∙ (F ⊙ transformation η {X = X}) ≡ D.id)
    ×
  (∀ {X} → (G ⊙ transformation ε {X = X}) C.∙ transformation η ≡ C.id)
  where
  open _⇾_
  module C = Precategory C
  module D = Precategory D

-- Adjunctions.

Adjunction :
  ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} →
  Precategory ℓ₁ ℓ₂ → Precategory ℓ₃ ℓ₄ → Type _
Adjunction C D = ∃ λ (F : C ⇨ D) → ∃ λ (G : D ⇨ C) → F ⊣ G

------------------------------------------------------------------------
-- Monads

-- A monad on a precategory.
--
-- This definition is taken from Wikipedia
-- (https://en.wikipedia.org/wiki/Monad_%28category_theory%29).

Monad : ∀ {ℓ₁ ℓ₂} (C : Precategory ℓ₁ ℓ₂) → Type (ℓ₁ ⊔ ℓ₂)
Monad C =
  ∃ λ (F : C ⇨ C) →
  ∃ λ (η : id⇨ ⇾ F) →
  ∃ λ (μ : F ∙⇨ F ⇾ F) →
  (∀ {X} → transformation μ ∙ (F ⊙ transformation μ {X = X})
             ≡
           transformation μ ∙ transformation μ {X = F ⊚ X})
    ×
  (∀ {X} → transformation μ ∙ (F ⊙ transformation η {X = X}) ≡ id)
    ×
  (∀ {X} → transformation μ ∙ transformation η {X = F ⊚ X} ≡ id)
  where
  open _⇾_
  open Precategory C

-- Adjunctions give rise to monads.
--
-- This definition is taken from Wikipedia
-- (https://en.wikipedia.org/wiki/Monad_%28category_theory%29).

adjunction→monad :
  ∀ {ℓ₁ ℓ₂} {C : Precategory ℓ₁ ℓ₂}
    {ℓ₃ ℓ₄} {D : Precategory ℓ₃ ℓ₄} →
  Adjunction C D → Monad C
adjunction→monad {C = C} {D = D} (F , G , η , ε , εFFη≡1 , GεηG≡1) =
    G ∙⇨ F
  , η
  , GεF
  , lemma₁
  , lemma₂
  , lemma₃
  where
  open _⇾_
  module C = Precategory C
  module D = Precategory D

  -- This natural transformation is defined directly, rather than by
  -- using composition, to avoid the use of casts.

  GεF : (G ∙⇨ F) ∙⇨ (G ∙⇨ F) ⇾ G ∙⇨ F
  natural-transformation GεF =
      G ⊙ transformation ε
    , nat
    where
    abstract
      nat :
        ∀ {X Y} {f : C.Hom X Y} →
        ((G ∙⇨ F) ⊙ f) C.∙ (G ⊙ transformation ε) ≡
        (G ⊙ transformation ε) C.∙ (((G ∙⇨ F) ∙⇨ (G ∙⇨ F)) ⊙ f)
      nat {f = f} =
        ((G ∙⇨ F) ⊙ f) C.∙ (G ⊙ transformation ε)                ≡⟨⟩
        (G ⊙ F ⊙ f) C.∙ (G ⊙ transformation ε)                   ≡⟨ sym (⊙-∙ G) ⟩
        G ⊙ ((F ⊙ f) D.∙ transformation ε)                       ≡⟨ cong (G ⊙_) (natural ε) ⟩
        G ⊙ (transformation ε D.∙ (F ⊙ G ⊙ F ⊙ f))               ≡⟨ ⊙-∙ G ⟩
        (G ⊙ transformation ε) C.∙ (G ⊙ F ⊙ G ⊙ F ⊙ f)           ≡⟨⟩
        (G ⊙ transformation ε) C.∙ (((G ∙⇨ F) ∙⇨ (G ∙⇨ F)) ⊙ f)  ∎

  abstract

    lemma₁ :
      ∀ {X} →
      transformation GεF {X = X} C.∙ ((G ∙⇨ F) ⊙ transformation GεF) ≡
      transformation GεF C.∙ transformation GεF
    lemma₁ =
      (G ⊙ transformation ε) C.∙ (G ⊙ F ⊙ G ⊙ transformation ε)  ≡⟨ sym (⊙-∙ G) ⟩
      G ⊙ (transformation ε D.∙ (F ⊙ G ⊙ transformation ε))      ≡⟨ cong (G ⊙_) (sym $ natural ε) ⟩
      G ⊙ (transformation ε D.∙ transformation ε)                ≡⟨ ⊙-∙ G ⟩∎
      (G ⊙ transformation ε) C.∙ (G ⊙ transformation ε)          ∎

    lemma₂ :
      ∀ {X} →
      transformation GεF {X = X} C.∙ ((G ∙⇨ F) ⊙ transformation η) ≡
      C.id
    lemma₂ =
      (G ⊙ transformation ε) C.∙ (G ⊙ F ⊙ transformation η)  ≡⟨ sym (⊙-∙ G) ⟩
      G ⊙ (transformation ε D.∙ (F ⊙ transformation η))      ≡⟨ cong (G ⊙_) εFFη≡1 ⟩
      G ⊙ D.id                                               ≡⟨ ⊙-id G ⟩∎
      C.id                                                   ∎

    lemma₃ :
      ∀ {X} →
      transformation GεF {X = X} C.∙ transformation η ≡ C.id
    lemma₃ =
      (G ⊙ transformation ε) C.∙ transformation η  ≡⟨ GεηG≡1 ⟩∎
      C.id                                         ∎


-- 2010-10-05 Andreas

module TerminationRecordPatternCoerce where

data Empty : Set where

record Unit : Set where
  constructor unit

data Bool : Set where
  true false : Bool

T : Bool -> Set
T true = Unit
T false = Empty

data _==_ {A : Set}(a : A) : A -> Set where
  refl : a == a

subst : forall {A a b} -> a == b -> {P : A -> Set} -> P a -> P b
subst refl x = x

-- Thorsten suggests on the Agda list  thread "Coinductive families"
-- to encode lists as records
record List (A : Set) : Set where
  constructor list
  field
    isCons : Bool
    head   : T isCons -> A
    tail   : T isCons -> List A

open List public

-- However, we have to be careful to preserve termination
-- in the presence of a lie

postulate
  lie : {b : Bool} -> T b

-- if the record constructor list was counted as structural increase
-- this function would not be rejected
f : {A : Set} -> (b : Bool) -> (l : List A) -> b == isCons l -> Unit
f .false (list false h t) refl = unit
f .true (list true h t) refl = f (isCons tl) tl refl
  where tl : List _
        tl = t unit
{- dot patterns inside of record patterns not supported!
f true (list .true h t) refl = f (isCons tl) tl refl
  where tl : List _
        tl = t unit
-}

-- however, it is almost like the following
f' : {A : Set} -> (b : Bool) -> (l : List A) -> b == isCons l -> Unit
f' false l p = unit
f' true (list b' h t) p = f' (isCons tl) tl refl
   where tl : List _
         tl = t (subst p {T} unit)