ermargerd! the Y case in subject expansion lemma finally looks doable!!!!

module ITyping where

open import Data.Empty
open import Data.List
open import Data.Nat
open import Data.Product
open import Data.List.Properties
open import Data.List.Any as LAny
open LAny.Membership-≡
open import Relation.Nullary
open import Relation.Binary.Core

open import Core
open import Core-Lemmas
open import Typing using (dom)
open import Typed-Core
open import Reduction using (_↝_)

data IType : Set where
  o : IType
  _~>_ : List IType -> List IType -> IType

ω : List IType
ω = []

∩' : IType -> List IType
∩' x = (x ∷ [])

_∩_ : IType -> IType -> List IType
A ∩ B = A ∷ B ∷ []

~>-inj-l : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₁ ≡ τ₂₁
~>-inj-l refl = refl

~>-inj-r : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₂ ≡ τ₂₂
~>-inj-r refl = refl

-- list-inj-cons : ∀ {x y τᵢ τⱼ} -> (x ∷ τᵢ) ≡ (y ∷ τⱼ) -> τᵢ ≡ τⱼ
-- list-inj-cons refl = refl
--
-- list-inj : ∀ {x y τᵢ τⱼ} -> (x ∷ τᵢ) ≡ (y ∷ τⱼ) -> x ≡ y
-- ∩-inj refl = refl
--
-- list-∷-≡ : ∀ {x y : IType} {xs ys} -> x ≡ y -> xs ≡ ys -> (x ∷ xs) ≡ (y ∷ ys)
-- list-∷-≡ refl refl = refl

_≟TI_ : Decidable {A = IType} _≡_
_≟TIₗ_ : Decidable {A = List IType} _≡_

o ≟TI o = yes refl
o ≟TI (_ ~> _) = no (λ ())
(_ ~> _) ≟TI o = no (λ ())
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) with τ₁₁ ≟TIₗ τ₂₁ | τ₁₂ ≟TIₗ τ₂₂
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> .τ₁₂) | yes refl | yes refl = yes refl
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> τ₂₂) | yes refl | no τ₁₂≠τ₂₂ = no (λ eq → τ₁₂≠τ₂₂ (~>-inj-r eq))
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) | no τ₁₁≠τ₂₁ | _ = no (λ eq → τ₁₁≠τ₂₁ (~>-inj-l eq))

[] ≟TIₗ [] = yes refl
[] ≟TIₗ (x ∷ τⱼ) = no (λ ())
(x ∷ τᵢ) ≟TIₗ [] = no (λ ())
(x ∷ τᵢ) ≟TIₗ (y ∷ τⱼ) with x ≟TI y | τᵢ ≟TIₗ τⱼ
(x ∷ τᵢ) ≟TIₗ (.x ∷ .τᵢ) | yes refl | yes refl = yes refl
(x ∷ τᵢ) ≟TIₗ (.x ∷ τⱼ) | yes refl | no τᵢ≠τⱼ = no (λ ∩x∷τᵢ≡∩x∷τⱼ → τᵢ≠τⱼ (proj₂ (∷-injective ∩x∷τᵢ≡∩x∷τⱼ)))
(x ∷ τᵢ) ≟TIₗ (y ∷ τⱼ) | no x≠y | _ = no (λ ∩x∷τᵢ≡∩y∷τⱼ → x≠y (proj₁ (∷-injective ∩x∷τᵢ≡∩y∷τⱼ)))

ICtxt = List (Atom × ((List IType) × Type))

data _∷'_ : IType -> Type -> Set
data _∷'ₗ_ : List IType -> Type -> Set

data _∷'_ where
  base : o ∷' σ
  arr : ∀ {δ τ A B} -> δ ∷'ₗ A -> τ ∷'ₗ B -> (δ ~> τ) ∷' (A ⟶ B)

data _∷'ₗ_ where
  nil : ∀ {A} -> ω ∷'ₗ A
  cons : ∀ {τᵢ τ A} -> τ ∷' A -> τᵢ ∷'ₗ A -> (τ ∷ τᵢ) ∷'ₗ A

data Wf-ICtxt : ICtxt -> Set where
  nil : Wf-ICtxt []
  cons : ∀ {A Γ x τ} ->
    (x∉ : x ∉ dom Γ) -> τ ∷'ₗ A -> Wf-ICtxt Γ ->
    --------------------------------------------
            Wf-ICtxt ((x , (τ , A)) ∷ Γ)

data _⊆[_]_ : IType -> Type -> IType -> Set
data _⊆ₗ[_]_ : List IType -> Type -> List IType -> Set

data _⊆[_]_ where
  base : o ⊆[ σ ] o
  arr : ∀ {A B τ₁₁ τ₁₂ τ₂₁ τ₂₂} ->
    τ₂₁ ⊆ₗ[ A ] τ₁₁ -> τ₁₂ ⊆ₗ[ B ] τ₂₂ -> (τ₁₁ ~> τ₁₂) ∷' (A ⟶ B) -> (τ₂₁ ~> τ₂₂) ∷' (A ⟶ B) ->
    -------------------------------------------------------------------------------------------
                            (τ₁₁ ~> τ₁₂) ⊆[ A ⟶ B ] (τ₂₁ ~> τ₂₂)
  -- ⊆-trans : ∀ {A τ₁ τ₂ τ₃} ->
  --   τ₁ ⊆[ A ] τ₂ -> τ₂ ⊆[ A ] τ₃ ->
  --   -------------------------------
  --             τ₁ ⊆[ A ] τ₃

data _⊆ₗ[_]_ where
  nil : ∀ {A τ} ->
    τ ∷'ₗ A ->
    -----------
    ω ⊆ₗ[ A ] τ
  cons : ∀ {A τᵢ τ' τ'ᵢ} ->
    ∃(λ τ -> (τ ∈ τᵢ) × (τ' ⊆[ A ] τ)) -> τ'ᵢ ⊆ₗ[ A ] τᵢ ->
    -------------------------------------------------------
                    (τ' ∷ τ'ᵢ) ⊆ₗ[ A ] τᵢ
  ~>∩ : ∀ {A B τ τᵢ τᵢ' τₓ} ->
                ((τ ~> (τᵢ ++ τᵢ')) ∷ τₓ) ∷'ₗ (A ⟶ B) ->
    ---------------------------------------------------------
    ((τ ~> (τᵢ ++ τᵢ')) ∷ τₓ) ⊆ₗ[ A ⟶ B ] ((τ ~> τᵢ) ∷ (τ ~> τᵢ') ∷ τₓ)
  ⊆ₗ-trans : ∀ {A τᵢ τⱼ τₖ} ->
    τᵢ ⊆ₗ[ A ] τⱼ -> τⱼ ⊆ₗ[ A ] τₖ ->
    ---------------------------------
              τᵢ ⊆ₗ[ A ] τₖ

∷'ₗ-∈ : ∀ {A τ τᵢ} -> τ ∈ τᵢ -> τᵢ ∷'ₗ A -> τ ∷' A
∷'ₗ-∈ {τᵢ = []} () _
∷'ₗ-∈ {τ = τ} {τ' ∷ τᵢ} τ∈τ'τᵢ τ'τᵢ∷A with τ' ≟TI τ
∷'ₗ-∈ {A} {τ} {.τ ∷ τᵢ} τ∈τ'τᵢ (cons τ∷A τ'τᵢ∷A) | yes refl = τ∷A
∷'ₗ-∈ {A} {τ} {τ' ∷ τᵢ} τ∈τ'τᵢ (cons τ'∷A τ'τᵢ∷A) | no τ'≠τ = ∷'ₗ-∈ (∈-∷-elim τ τᵢ τ'≠τ τ∈τ'τᵢ) τ'τᵢ∷A

∷'ₗ-++-l : ∀ {A τᵢ τⱼ} -> (τᵢ ++ τⱼ) ∷'ₗ A -> τᵢ ∷'ₗ A
∷'ₗ-++-l {τᵢ = []} τᵢ++τⱼ∷A = nil
∷'ₗ-++-l {τᵢ = τ ∷ τᵢ} (cons x τᵢ++τⱼ∷A) = cons x (∷'ₗ-++-l τᵢ++τⱼ∷A)

∷'ₗ-++-r : ∀ {A τᵢ τⱼ} -> (τᵢ ++ τⱼ) ∷'ₗ A -> τⱼ ∷'ₗ A
∷'ₗ-++-r {τᵢ = []} τᵢ++τⱼ∷A = τᵢ++τⱼ∷A
∷'ₗ-++-r {A} {τᵢ = τ ∷ τᵢ} (cons x τᵢ++τⱼ∷A) = ∷'ₗ-++-r {A} {τᵢ} τᵢ++τⱼ∷A

⊆-refl : ∀ {A τ} -> τ ∷' A -> τ ⊆[ A ] τ
⊆ₗ-refl : ∀ {A τ} -> τ ∷'ₗ A -> τ ⊆ₗ[ A ] τ
⊆ₗ-⊆ : ∀ {A τᵢ τⱼ} -> τᵢ ⊆ τⱼ -> τⱼ ∷'ₗ A -> τᵢ ⊆ₗ[ A ] τⱼ

⊆-refl {τ = o} base = base
⊆-refl {τ = τ ~> τ'} (arr τ∷ᵢA τ'∷ᵢB) =
  arr (⊆ₗ-refl τ∷ᵢA) (⊆ₗ-refl τ'∷ᵢB) (arr τ∷ᵢA τ'∷ᵢB) (arr τ∷ᵢA τ'∷ᵢB)

⊆ₗ-refl {τ = []} nil = nil nil
⊆ₗ-refl {A} {τ ∷ τᵢ} ττᵢ∷A = ⊆ₗ-⊆ (λ {x} z → z) ττᵢ∷A

⊆ₗ-⊆ {τᵢ = []} τᵢ⊆τⱼ τⱼ∷A = nil τⱼ∷A
⊆ₗ-⊆ {τᵢ = τ ∷ τᵢ} τᵢ⊆τⱼ τⱼ∷A =
  cons (τ , (τᵢ⊆τⱼ (here refl)) , ⊆-refl (∷'ₗ-∈ (τᵢ⊆τⱼ (here refl)) τⱼ∷A)) (⊆ₗ-⊆ (λ {x} z → τᵢ⊆τⱼ (there z)) τⱼ∷A)

-- ⊆ₗ-∈-∃ : ∀ {A τ τ₁ τ₂} -> τ₁ ⊆ₗ[ A ] τ₂ -> τ ∈ τ₁ -> ∃(λ τ' -> (τ' ∈ τ₂) × (τ ⊆[ A ] τ'))
-- -- ⊆ₗ-∈-∃ (cons ∃τ τ₁⊆τ₂) (here refl) = ∃τ
-- -- ⊆ₗ-∈-∃ (cons _ τ₁⊆τ₂) (there τ∈τ₁) = ⊆ₗ-∈-∃ τ₁⊆τ₂ τ∈τ₁
-- ⊆ₗ-∈-∃ (cons ∃τ τ₁⊆τ₂) (here refl) = ∃τ
-- ⊆ₗ-∈-∃ (~>∩ x) (here refl) = {!   !}
-- ⊆ₗ-∈-∃ (cons x₁ τ₁⊆τ₂) (there τ∈τ₁) = {!   !}
-- ⊆ₗ-∈-∃ (~>∩ x) (there τ∈τ₁) = {!   !}

-- ∈-⊆ₗ-trans : ∀ {A τ τᵢ τⱼ} -> τ ∈ τᵢ -> τᵢ ⊆ₗ[ A ] τⱼ -> ∃(λ τ' -> (τ' ∈ τⱼ) × τ ⊆[ A ] τ')
-- ∈-⊆ₗ-trans (here refl) (cons x _) = x
-- ∈-⊆ₗ-trans (there τ∈τᵢ) (cons _ τᵢ⊆τⱼ) = ∈-⊆ₗ-trans τ∈τᵢ τᵢ⊆τⱼ

-- ⊆ₗ-ω-⊥ : ∀ {A τ τᵢ} -> (τ ∷ τᵢ) ⊆ₗ[ A ] ω -> ⊥
-- ⊆ₗ-ω-⊥ (cons (_ , () , _) _)

⊆-∷'-r : ∀ {A τ τ'} -> τ ⊆[ A ] τ' -> τ' ∷' A
⊆-∷'-r base = base
⊆-∷'-r (arr _ _ _ x) = x

⊆-∷'-l : ∀ {A τ τ'} -> τ ⊆[ A ] τ' -> τ ∷' A
⊆-∷'-l base = base
⊆-∷'-l (arr _ _ x _) = x

⊆ₗ-∷'ₗ-r : ∀ {A τᵢ τⱼ} -> τᵢ ⊆ₗ[ A ] τⱼ -> τⱼ ∷'ₗ A
⊆ₗ-∷'ₗ-r {τᵢ = []} (nil τⱼ∷A) = τⱼ∷A
⊆ₗ-∷'ₗ-r {τᵢ = []} (⊆ₗ-trans τᵢ⊆τⱼ τᵢ⊆τⱼ₁) = ⊆ₗ-∷'ₗ-r τᵢ⊆τⱼ₁
⊆ₗ-∷'ₗ-r {τᵢ = τ ∷ τᵢ} (cons x τᵢ⊆τⱼ) = ⊆ₗ-∷'ₗ-r τᵢ⊆τⱼ
⊆ₗ-∷'ₗ-r {τᵢ = _ ∷ τₓ} (~>∩ {τᵢ = τᵢ} (cons (arr x x₁) τₓ∷')) =
  cons (arr x (∷'ₗ-++-l x₁)) (cons (arr x (∷'ₗ-++-r {τᵢ = τᵢ} x₁)) τₓ∷')
⊆ₗ-∷'ₗ-r {τᵢ = τ ∷ τᵢ} (⊆ₗ-trans τᵢ⊆τⱼ τᵢ⊆τⱼ₁) = ⊆ₗ-∷'ₗ-r τᵢ⊆τⱼ₁

⊆ₗ-∷'ₗ-l : ∀ {A τᵢ τⱼ} -> τᵢ ⊆ₗ[ A ] τⱼ -> τᵢ ∷'ₗ A
⊆ₗ-∷'ₗ-l (nil x) = nil
⊆ₗ-∷'ₗ-l (cons (_ , _ , τ'⊆τ) τᵢ⊆τⱼ) = cons (⊆-∷'-l τ'⊆τ) (⊆ₗ-∷'ₗ-l τᵢ⊆τⱼ)
⊆ₗ-∷'ₗ-l (~>∩ x) = x
⊆ₗ-∷'ₗ-l (⊆ₗ-trans τᵢ⊆τⱼ τⱼ⊆τₖ) = ⊆ₗ-∷'ₗ-l τᵢ⊆τⱼ

⊆-trans : ∀ {A τ₁ τ₂ τ₃} ->
  τ₁ ⊆[ A ] τ₂ -> τ₂ ⊆[ A ] τ₃ ->
  -------------------------------
            τ₁ ⊆[ A ] τ₃
⊆-trans base base = base
⊆-trans (arr τ₂₁⊆τ₁₁ τ₁₂⊆τ₂₂ τ₁₁~>τ₁₂∷A⟶B _) (arr τ₂₃⊆τ₂₁ τ₂₂⊆τ₂₄ τ₂₁~>τ₂₂∷A⟶B τ₂₃~>τ₂₄∷A⟶B) =
  arr (⊆ₗ-trans τ₂₃⊆τ₂₁ τ₂₁⊆τ₁₁) (⊆ₗ-trans τ₁₂⊆τ₂₂ τ₂₂⊆τ₂₄) τ₁₁~>τ₁₂∷A⟶B τ₂₃~>τ₂₄∷A⟶B

-- ⊆ₗ-trans {τᵢ = []} τᵢ⊆τⱼ τⱼ⊆τₖ = nil (⊆ₗ-∷'ₗ-r τⱼ⊆τₖ)
-- ⊆ₗ-trans {τᵢ = τ' ∷ τᵢ} τᵢ⊆τⱼ (nil x) = ⊥-elim (⊆ₗ-ω-⊥ τᵢ⊆τⱼ)
-- ⊆ₗ-trans {τᵢ = τ ∷ τᵢ} {τⱼ} {τₖ} (cons (τ' , τ'∈τⱼ , τ⊆τ') τᵢ⊆τⱼ) τⱼ⊆τₖ =
--   cons (τ'' , (τ''∈τₖ , (⊆-trans τ⊆τ' τ'⊆τ''))) (⊆ₗ-trans τᵢ⊆τⱼ τⱼ⊆τₖ)
--     where
--     τ'' = proj₁ (⊆ₗ-∈-∃ τⱼ⊆τₖ τ'∈τⱼ)
--     τ''∈τₖ = proj₁ (proj₂ (⊆ₗ-∈-∃ τⱼ⊆τₖ τ'∈τⱼ))
--     τ'⊆τ'' = proj₂ (proj₂ (⊆ₗ-∈-∃ τⱼ⊆τₖ τ'∈τⱼ))

⊆->⊆ₗ : ∀ {A τ τ'} -> τ ⊆[ A ] τ' -> (∩' τ) ⊆ₗ[ A ] (∩' τ')
⊆->⊆ₗ {τ = τ} {τ'} τ⊆τ' = cons (τ' , (here refl , τ⊆τ')) (nil (cons (⊆-∷'-r τ⊆τ') nil))

data _⊩_∶_ : ∀ {A} -> ICtxt -> Λ A -> IType -> Set
data _⊩ₗ_∶_ : ∀ {A} -> ICtxt -> Λ A -> List IType -> Set

data _⊩_∶_ where
  var : ∀ {A Γ x τ} {τᵢ : List IType} ->
    (wf-Γ : Wf-ICtxt Γ) -> (τᵢ∈Γ : (x , (τᵢ , A)) ∈ Γ) -> (τ⊆τᵢ : (∩' τ) ⊆ₗ[ A ] τᵢ) ->
    -----------------------------------------------------------------------------------
                                    Γ ⊩ fv {A} x ∶ τ
  app : ∀ {A B Γ s t τ τ₁ τ₂} ->
    Γ ⊩ s ∶ (τ₁ ~> τ₂) -> Γ ⊩ₗ t ∶ τ₁ -> (∩' τ) ⊆ₗ[ B ] τ₂ -> τ₁ ∷'ₗ A ->
    ---------------------------------------------------------------------
                        Γ ⊩ (app {A} {B} s t) ∶ τ
  abs : ∀ {A B Γ τ τ'} (L : FVars) -> ∀ {t : Λ B} ->
    ( cf : ∀ {x} -> (x∉L : x ∉ L) -> ((x , (τ , A)) ∷ Γ) ⊩ₗ Λ[ 0 >> fv {A} x ] t ∶ τ' ) -> (τ ~> τ') ∷' (A ⟶ B) ->
    --------------------------------------------------------------------------------------------------------------
                                                Γ ⊩ lam A t ∶ (τ ~> τ')
  Y : ∀ {Γ A τ τ₁ τ₂} ->
    (wf-Γ : Wf-ICtxt Γ) -> (∩' (τ ~> τ)) ⊆ₗ[ A ⟶ A ] τ₁ -> τ₂ ⊆ₗ[ A ] τ -> -- ∃(λ τ' -> (τ' ∈ τ₁) × ((τ ~> τ) ⊆[ A ⟶ A ] τ')) -> τ₁ ∷'ₗ (A ⟶ A) ->
    ----------------------------------------------------------------------
                            Γ ⊩ Y A ∶ (τ₁ ~> τ₂)

data _⊩ₗ_∶_ where
  nil : ∀ {A Γ} {m : Λ A} ->
    (wf-Γ : Wf-ICtxt Γ) ->
    ----------------------
          Γ ⊩ₗ m  ∶ ω
  cons : ∀ {A Γ τ τᵢ} {m : Λ A} ->
    Γ ⊩ m  ∶ τ -> Γ ⊩ₗ m  ∶ τᵢ ->
    --------------------------------
          Γ ⊩ₗ m  ∶ (τ ∷ τᵢ)
  subₗ : ∀ {A Γ τ τ'} {m : Λ A} ->
    Γ ⊩ₗ m ∶ τ -> τ' ⊆ₗ[ A ] τ ->
    -----------------------------
            Γ ⊩ₗ m ∶ τ'

data ΛTerm : ∀ {τ} -> Λ τ -> Set where
  var : ∀ {A x} -> ΛTerm (fv {A} x)
  lam : ∀ {A B} (L : FVars) -> ∀ {e : Λ B} ->
    (cf : ∀ {x} -> (x∉L : x ∉ L) -> ΛTerm (Λ[ 0 >> fv {A} x ] e)) -> ΛTerm (lam A e)
  app : ∀ {A B} {e₁ : Λ (A ⟶ B)} {e₂ : Λ A} -> ΛTerm e₁ -> ΛTerm e₂ -> ΛTerm (app e₁ e₂)
  Y : ∀ {t} -> ΛTerm (Y t)

data _⊆Γ_ : ICtxt -> ICtxt -> Set where
  nil : ∀ {Γ} ->
    (wf-Γ : Wf-ICtxt Γ) ->
    ----------------------
          [] ⊆Γ Γ
  cons : ∀ {A x τ' Γ Γ'} ->
    ∃(λ τ -> ((x , (τ , A)) ∈ Γ') × (τ' ⊆ₗ[ A ] τ)) -> Γ ⊆Γ Γ' ->
    ------------------------------------------------------------
                      ((x , (τ' , A)) ∷ Γ) ⊆Γ Γ'

⊩ₗ-wf-Γ : ∀ {A Γ} {m : Λ A} {τ} -> Γ ⊩ₗ m ∶ τ -> Wf-ICtxt Γ
⊩ₗ-wf-Γ (nil wf-Γ) = wf-Γ
⊩ₗ-wf-Γ (cons _ Γ⊩ₗm∶τ) = ⊩ₗ-wf-Γ Γ⊩ₗm∶τ
⊩ₗ-wf-Γ (subₗ x _) = ⊩ₗ-wf-Γ x

⊆Γ-wfΓ' : ∀ {Γ Γ'} -> Γ ⊆Γ Γ' -> Wf-ICtxt Γ'
⊆Γ-wfΓ' (nil wf-Γ') = wf-Γ'
⊆Γ-wfΓ' (cons _ Γ⊆Γ') = ⊆Γ-wfΓ' Γ⊆Γ'

wf-Γ-∷'ₗ : ∀ {A x τ Γ} -> (x , (τ , A)) ∈ Γ -> Wf-ICtxt Γ -> τ ∷'ₗ A
wf-Γ-∷'ₗ (here refl) (cons _ x₁ _) = x₁
wf-Γ-∷'ₗ (there xτA∈Γ) (cons _ _ wf-Γ) = wf-Γ-∷'ₗ xτA∈Γ wf-Γ

⊆Γ-⊆ : ∀ {Γ Γ'} -> Wf-ICtxt Γ' -> Γ ⊆ Γ' -> Γ ⊆Γ Γ'
⊆Γ-⊆ {[]} wf-Γ' Γ⊆Γ' = nil wf-Γ'
⊆Γ-⊆ {(x , τ , A) ∷ Γ} wf-Γ' Γ⊆Γ' = cons
  (τ , ((Γ⊆Γ' (here refl)) , ⊆ₗ-refl (wf-Γ-∷'ₗ (Γ⊆Γ' (here refl)) wf-Γ')))
  (⊆Γ-⊆ wf-Γ' (λ {x₁} z → Γ⊆Γ' (there z)))

∈-⊆Γ-trans : ∀ {A x τᵢ} {Γ Γ'} -> (x , (τᵢ , A)) ∈ Γ -> Γ ⊆Γ Γ' -> ∃(λ τᵢ' -> ((x , (τᵢ' , A)) ∈ Γ') × τᵢ ⊆ₗ[ A ] τᵢ')
∈-⊆Γ-trans (here refl) (cons x _) = x
∈-⊆Γ-trans (there x∈L) (cons _ L⊆L') = ∈-⊆Γ-trans x∈L L⊆L'

⊆Γ-∷ : ∀ {A x τᵢ Γ Γ'} -> x ∉ dom Γ' -> τᵢ ∷'ₗ A -> Γ ⊆Γ Γ' -> Γ ⊆Γ ((x , τᵢ , A) ∷ Γ')
⊆Γ-∷ {Γ = []} x∉Γ' τᵢ∷A Γ⊆Γ' = nil (cons x∉Γ' τᵢ∷A (⊆Γ-wfΓ' Γ⊆Γ'))
⊆Γ-∷ {Γ = (x , τᵢ , A) ∷ Γ} x∉Γ' τᵢ∷A (cons (proj₁ , proj₂ , proj₃) Γ⊆Γ') =
  cons (proj₁ , ((there proj₂) , proj₃)) (⊆Γ-∷ x∉Γ' τᵢ∷A Γ⊆Γ')

⊩-∷' : ∀ {A Γ} {m : Λ A} {τ} -> Γ ⊩ m ∶ τ -> τ ∷' A
⊩ₗ-∷'ₗ : ∀ {A Γ} {m : Λ A} {τ} -> Γ ⊩ₗ m ∶ τ -> τ ∷'ₗ A

⊩-∷' (var _ _ τ⊆τᵢ) = ∷'ₗ-∈ (here refl) (⊆ₗ-∷'ₗ-l τ⊆τᵢ)
⊩-∷' (app _ _ τ⊆τᵢ _) = ∷'ₗ-∈ (here refl) (⊆ₗ-∷'ₗ-l τ⊆τᵢ)
⊩-∷' (abs _ _ x) = x
⊩-∷' (Y _ τ⊆τ~>τ τ₂⊆τ) = arr (⊆ₗ-∷'ₗ-r τ⊆τ~>τ) (⊆ₗ-∷'ₗ-l τ₂⊆τ)

⊩ₗ-∷'ₗ (nil _) = nil
⊩ₗ-∷'ₗ (cons Γ⊩m∶τ Γ⊩ₗm∶τᵢ) = cons (⊩-∷' Γ⊩m∶τ) (⊩ₗ-∷'ₗ Γ⊩ₗm∶τᵢ)
⊩ₗ-∷'ₗ (subₗ _ x) = ⊆ₗ-∷'ₗ-l x

data _->Λβ_ : ∀ {τ} -> Λ τ ↝ Λ τ where
  redL : ∀ {A B} {n : Λ A} {m m' : Λ (A ⟶ B)} -> ΛTerm n -> m ->Λβ m' -> app m n ->Λβ app m' n
  redR : ∀ {A B} {m : Λ (A ⟶ B)} {n n' : Λ A} -> ΛTerm m -> n ->Λβ n' -> app m n ->Λβ app m n'
  abs : ∀ L {A B} {m m' : Λ B} -> ( ∀ {x} -> x ∉ L -> Λ[ 0 >> fv {A} x ] m ->Λβ Λ[ 0 >> fv {A} x ] m' ) ->
    lam A m ->Λβ lam A m'
  beta : ∀ {A B} {m : Λ (A ⟶ B)} {n : Λ A} -> ΛTerm (lam A m) -> ΛTerm n -> app (lam A m) n ->Λβ (Λ[ 0 >> n ] m)
  Y : ∀ {A} {m : Λ (A ⟶ A)} -> ΛTerm m -> app (Y A) m ->Λβ app m (app (Y A) m)

subΓ : ∀ {A Γ Γ'} {m : Λ A} {τ} -> Γ ⊩ m ∶ τ -> Γ ⊆Γ Γ' -> Γ' ⊩ m ∶ τ
subₗΓ : ∀ {A Γ Γ'} {m : Λ A} {τ} -> Γ ⊩ₗ m ∶ τ -> Γ ⊆Γ Γ' -> Γ' ⊩ₗ m ∶ τ

subΓ (var wf-Γ τᵢ∈Γ τ⊆τᵢ) Γ⊆Γ' = var (⊆Γ-wfΓ' Γ⊆Γ') τᵢ'∈ (⊆ₗ-trans τ⊆τᵢ τᵢ⊆τᵢ')
  where
  τᵢ'∈ = proj₁ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))
  τᵢ⊆τᵢ' = proj₂ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))

subΓ (app Γ⊩m∶τ x x₁ x₂) Γ⊆Γ' = app (subΓ Γ⊩m∶τ Γ⊆Γ') (subₗΓ x Γ⊆Γ') x₁ x₂
subΓ {Γ' = Γ'} (abs {τ = τ} L cf (arr τ∷A τ'∷B)) Γ⊆Γ' = abs
  (L ++ dom Γ')
  (λ x∉ → subₗΓ
    (cf (∉-cons-l _ _ x∉))
    (cons
      (τ , (here refl) , (⊆ₗ-refl τ∷A))
      (⊆Γ-∷ (∉-cons-r L _ x∉) τ∷A Γ⊆Γ')))
  (arr τ∷A τ'∷B)
subΓ (Y x x₁ x₂) Γ⊆Γ' = Y (⊆Γ-wfΓ' Γ⊆Γ') x₁ x₂

subₗΓ (nil wf-Γ) Γ⊆Γ' = nil (⊆Γ-wfΓ' Γ⊆Γ')
subₗΓ (cons x Γ⊩ₗm∶τ) Γ⊆Γ' = cons (subΓ x Γ⊆Γ') (subₗΓ Γ⊩ₗm∶τ Γ⊆Γ')
subₗΓ (subₗ x y) Γ⊆Γ' = subₗ (subₗΓ x Γ⊆Γ') y

sub : ∀ {A Γ Γ'} {m : Λ A} {τ τ'} -> Γ ⊩ m ∶ τ -> τ' ⊆[ A ] τ -> Γ ⊆Γ Γ' -> Γ' ⊩ m ∶ τ'
subₗ' : ∀ {A Γ Γ'} {m : Λ A} {τ τ'} -> Γ ⊩ₗ m ∶ τ -> τ' ⊆ₗ[ A ] τ -> Γ ⊆Γ Γ' -> Γ' ⊩ₗ m ∶ τ'

sub (var wf-Γ τᵢ∈Γ τ⊆τᵢ) τ'⊆τ Γ⊆Γ' =
  var (⊆Γ-wfΓ' Γ⊆Γ') τᵢ'∈ (⊆ₗ-trans (⊆ₗ-trans (⊆->⊆ₗ τ'⊆τ) τ⊆τᵢ) τᵢ⊆τᵢ')
  where
  τᵢ'∈ = proj₁ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))
  τᵢ⊆τᵢ' = proj₂ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))

sub (app Γ⊩s∶τ₁~>τ₂ Γ⊩ₗt∶τ₁ τ⊆τ₂ τ∷A) τ'⊆τ Γ⊆Γ' = app
  (subΓ Γ⊩s∶τ₁~>τ₂ Γ⊆Γ')
  (subₗΓ Γ⊩ₗt∶τ₁ Γ⊆Γ')
  (⊆ₗ-trans (⊆->⊆ₗ τ'⊆τ) τ⊆τ₂)
  τ∷A
sub {_} {Γ} {Γ'} (abs {τ = τ} {τ'} L {t} cf τ~>τ'∷A⟶B) (arr {A} {τ₁₁ = τ₁₁} τ⊆τ₁₁ τ₁₂⊆τ' (arr τ₁₁∷A τ₁₂∷B) x₃) Γ⊆Γ' = abs
  (L ++ dom Γ')
  (λ x∉ → subₗ'
    (cf (∉-cons-l _ _ x∉))
    τ₁₂⊆τ'
    (cons (τ₁₁ , (here refl) , τ⊆τ₁₁) (⊆Γ-∷ (∉-cons-r L _ x∉) τ₁₁∷A Γ⊆Γ'))
  )
  (arr τ₁₁∷A τ₁₂∷B)
sub (Y wf-Γ τ₁⊆τ~>τ τ₂⊆τ) (arr {τ₁₁ = τ₁'} τ₁⊆τ₁' τ₂'⊆τ₂ (arr ∩τ₁'∷A⟶A τ₂'∷A) x₄) Γ⊆Γ' =
  Y (⊆Γ-wfΓ' Γ⊆Γ') (⊆ₗ-trans τ₁⊆τ~>τ τ₁⊆τ₁') (⊆ₗ-trans τ₂'⊆τ₂ τ₂⊆τ)

subₗ' Γ⊩ₗm∶τ τ'⊆τ Γ⊆Γ' = subₗΓ (subₗ Γ⊩ₗm∶τ τ'⊆τ) Γ⊆Γ'
-- subᵢ Γ⊩ₗm∶τ (nil x) Γ⊆Γ' = nil (⊆Γ-wfΓ' Γ⊆Γ')
-- subᵢ Γ⊩ₗm∶τᵢ (cons (τ , τ∈τᵢ , τ'⊆τ) τ'ᵢ⊆τᵢ) Γ⊆Γ' with ⊩ₗ-∈-⊩ Γ⊩ₗm∶τᵢ τ∈τᵢ
-- ... | Γ⊩m∶τ = cons (sub Γ⊩m∶τ τ'⊆τ Γ⊆Γ') (subᵢ Γ⊩ₗm∶τᵢ τ'ᵢ⊆τᵢ Γ⊆Γ')

-- τ≠ω-⊆-τ'≠ω : ∀ {A τ τ'} ->  ¬(τ ≡ ω) -> τ ⊆ₗ[ A ] τ' -> ¬(τ' ≡ ω)
-- τ≠ω-⊆-τ'≠ω {τ = []} τ≠ω τ⊆τ' x = τ≠ω refl
-- τ≠ω-⊆-τ'≠ω {τ = x ∷ τ} {[]} τ≠ω (cons (_ , () , _) τ⊆τ') τ'≡ω
-- τ≠ω-⊆-τ'≠ω {τ = x ∷ τ} {[]} τ≠ω (⊆ₗ-trans {τⱼ = τ''} x∷τ⊆τ'' τ''⊆[]) τ'≡ω = τ≠ω-⊆-τ'≠ω τ''≠ω τ''⊆[] refl
--   where
--   τ''≠ω : ¬(τ'' ≡ ω)
--   τ''≠ω = τ≠ω-⊆-τ'≠ω τ≠ω x∷τ⊆τ''
-- τ≠ω-⊆-τ'≠ω {τ = x ∷ τ} {x₁ ∷ τ'} τ≠ω τ⊆τ' ()
--
-- ∩'⊆ω-imp-⊥ : ∀ {A τ} -> ¬(τ ≡ ω) -> τ ⊆ₗ[ A ] ω -> ⊥
-- ∩'⊆ω-imp-⊥ τ≠ω (nil x) = τ≠ω refl
-- ∩'⊆ω-imp-⊥ τ≠ω (cons (_ , () , _) τ⊆ω)
-- ∩'⊆ω-imp-⊥ τ≠ω (⊆ₗ-trans τ⊆τ' τ'⊆ω) = ∩'⊆ω-imp-⊥ (τ≠ω-⊆-τ'≠ω τ≠ω τ⊆τ') τ'⊆ω
--
--
-- Γ⊩Ym-max : ∀ {A Γ} {m : Λ (A ⟶ A)} {τ} -> Γ ⊩ app (Y A) m ∶ τ -> ∃(λ τ' -> Γ ⊩ m ∶ (τ' ~> τ') × (∩' τ) ⊆ₗ[ A ] τ')
-- Γ⊩Ym-max {A} {Γ} {m} {τ} (app {τ₁ = []} {τ'}
--   (Y {τ = τ''} wf-Γ τ''~>τ''⊆τ₁ τ'⊆τ'')
--   Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ
--   τ⊆τ' τ₁ᵢ~>τ₂ᵢ∷A⟶A) = ⊥-elim (∩'⊆ω-imp-⊥ (λ ()) τ''~>τ''⊆τ₁)
--
-- Γ⊩Ym-max {A} {Γ} {m} {τ} (app {τ₁ = τ₁~>τ₂ ∷ τ₁ᵢ~>τ₂ᵢ} {τ'}
--   (Y {τ = τ''} wf-Γ τ''~>τ''⊆τ₁ τ'⊆τ'')
--   Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ
--   τ⊆τ' τ₁ᵢ~>τ₂ᵢ∷A⟶A) = {!   !}

-- ∈-⊆ₗ-trans : ∀ {A τ τᵢ τᵢ'} -> τ ∈ τᵢ -> τᵢ ⊆ₗ[ A ] τᵢ' -> ∃(λ τ' -> (τ' ∈ τᵢ') × τ' ⊆[ A ] τ)
-- ∈-⊆ₗ-trans () (nil x)
-- ∈-⊆ₗ-trans (here refl) (cons x₁ τᵢ⊆τᵢ') = {!   !}
-- ∈-⊆ₗ-trans (there τ∈τᵢ) (cons x₁ τᵢ⊆τᵢ') = ∈-⊆ₗ-trans τ∈τᵢ τᵢ⊆τᵢ'
-- ∈-⊆ₗ-trans (here refl) (~>∩ x) = {!   !}
-- ∈-⊆ₗ-trans (there τ∈τᵢ) (~>∩ x) = {!   !}
-- ∈-⊆ₗ-trans τ∈τᵢ (⊆ₗ-trans τᵢ⊆τᵢ' τᵢ⊆τᵢ'') = {!   !}
--
-- ⊩ₗ-∈-⊩ : ∀ {A Γ} {m : Λ A} {τ τᵢ} -> Γ ⊩ₗ m ∶ τᵢ -> τ ∈ τᵢ -> ∃(λ τ' -> τ' ⊆[ A ] τ × Γ ⊩ m ∶ τ')
-- ⊩ₗ-∈-⊩ (nil wf-Γ) ()
-- ⊩ₗ-∈-⊩ {τ = τ} (cons x₁ Γ⊩ₗm∶τᵢ) (here refl) = τ , (⊆-refl (⊩-∷' x₁) , x₁)
-- ⊩ₗ-∈-⊩ (cons x₁ Γ⊩ₗm∶τᵢ) (there τ∈τᵢ) = ⊩ₗ-∈-⊩ Γ⊩ₗm∶τᵢ τ∈τᵢ
-- ⊩ₗ-∈-⊩ {A} {Γ} {m} {τ} {τᵢ} (subₗ {τ = τᵢ'} Γ⊩ₗm∶τᵢ τᵢ⊆τᵢ') τ∈τᵢ = proj₁ ih , (⊆-trans τ⊆τ' (proj₁ (proj₂ ih)) , proj₂ (proj₂ ih))
--   where
--   τ' : IType
--   τ' = {!   !}
--
--   τ⊆τ' : τ ⊆[ A ] τ'
--   τ⊆τ' = {!   !}
--
--   ih : ∃(λ τ'' -> τ' ⊆[ A ] τ'' × Γ ⊩ m ∶ τ'')
--   ih = {!   !}

-- aux1 : ∀ {A Γ} {m : Λ (A ⟶ A)} {τ : List IType} ->  Γ ⊩ₗ m ∶ ∩' (τ ~> τ) -> Γ ⊩ m ∶ (τ ~> τ)
-- aux1 (cons x Γ⊩ₗm∶τ~>τ) = x
-- aux1 (subₗ Γ⊩ₗm∶τ~>τ x) = {!   !}

Γ⊩Ym-max : ∀ {A Γ} {m : Λ (A ⟶ A)} {τ} -> Γ ⊩ app (Y A) m ∶ τ -> ∃(λ τ' -> Γ ⊩ₗ m ∶ ∩' (τ' ~> τ') × (∩' τ) ⊆ₗ[ A ] τ')
Γ⊩Ym-max {A} {Γ} {m} {τ} (app {τ₁ = τ₁ᵢ~>τ₂ᵢ} {τ'}
  (Y {τ = τ''} wf-Γ τ''~>τ''⊆τ₁ᵢ~>τ₂ᵢ τ'⊆τ'')
  Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ
  τ⊆τ' τ₁ᵢ~>τ₂ᵢ∷A⟶A) = τ'' , ((subₗ Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ τ''~>τ''⊆τ₁ᵢ~>τ₂ᵢ) , (⊆ₗ-trans τ⊆τ' τ'⊆τ''))

-- Γ⊩Ym-max : ∀ {A Γ} {m : Λ (A ⟶ A)} {τ} -> Γ ⊩ app (Y A) m ∶ τ -> ∃(λ τ' -> Γ ⊩ m ∶ (τ' ~> τ') × (∩' τ) ⊆ₗ[ A ] τ')
-- Γ⊩Ym-max {A} {Γ} {m} {τ} (app {τ₁ = τ₁ᵢ~>τ₂ᵢ} {τ'}
--   (Y {τ = τ''} wf-Γ (cons (_ , τ₁~>τ₂∈τ₁ᵢ~>τ₂ᵢ , arr {τ₂₁ = τ₁} {τ₂} τ₁⊆τ'' τ''⊆τ₂ x₂ x₃) []⊆τ₁ᵢ~>τ₂ᵢ) τ'⊆τ'')
--   Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ
--   τ⊆τ' τ₁ᵢ~>τ₂ᵢ∷A⟶A) = {!   !}
--   -- τ₂ , Γ⊩m∶τ₂~>τ₂ , τ⊆τ₂
--
--   -- where
--   -- Γ⊆Γ-refl = ⊆Γ-⊆ wf-Γ (λ {x} z → z)
--   -- τ⊆τ'' = ⊆ₗ-trans τ⊆τ' τ'⊆τ''
--   -- τ⊆τ₂ = ⊆ₗ-trans τ⊆τ'' τ''⊆τ₂
--   --
--   -- Γ⊩m∶τ₁~>τ₂ : Γ ⊩ m ∶ (τ₁ ~> τ₂)
--   -- Γ⊩m∶τ₁~>τ₂ = ⊩ₗ-∈-⊩ Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ τ₁~>τ₂∈τ₁ᵢ~>τ₂ᵢ
--   --
--   -- Γ⊩m∶τ₂~>τ₂ : Γ ⊩ m ∶ (τ₂ ~> τ₂)
--   -- Γ⊩m∶τ₂~>τ₂ = sub Γ⊩m∶τ₁~>τ₂ (arr (⊆ₗ-trans τ₁⊆τ'' τ''⊆τ₂) (⊆ₗ-refl τ₂∷A) (arr τ₂∷A τ₂∷A) (arr τ₁∷A τ₂∷A)) Γ⊆Γ-refl
-- Γ⊩Ym-max {A} {Γ} {m} {τ} (app
--   (Y wf-Γ (~>∩ x) τ'⊆τ'')
--   Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ
--   τ⊆τ' τ₁ᵢ~>τ₂ᵢ∷A⟶A₂) = {!   !}
--
-- Γ⊩Ym-max {A} {Γ} {m} {τ} (app
--   (Y wf-Γ (⊆ₗ-trans x y) τ'⊆τ'')
--   Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ
--   τ⊆τ' τ₁ᵢ~>τ₂ᵢ∷A⟶A₂) = {!   !}

∷'ₗ-++ : ∀ {A τᵢ τⱼ} -> τᵢ ∷'ₗ A -> τⱼ ∷'ₗ A -> (τᵢ ++ τⱼ) ∷'ₗ A
∷'ₗ-++ nil τⱼ∷A = τⱼ∷A
∷'ₗ-++ (cons x τᵢ∷A) τⱼ∷A = cons x (∷'ₗ-++ τᵢ∷A τⱼ∷A)

⊆-++-comm : ∀ {A τᵢ τⱼ τ} -> (τᵢ ++ τⱼ) ⊆ₗ[ A ] τ -> (τⱼ ++ τᵢ) ⊆ₗ[ A ] τ
⊆-++-comm {A} {τᵢ} {τⱼ} τᵢ++τⱼ⊆ₗτ = ⊆ₗ-trans (⊆ₗ-⊆ {!   !} (∷'ₗ-++ {A} {τᵢ} {τⱼ} (∷'ₗ-++-l τᵢ++τⱼ∷'A) (∷'ₗ-++-r {τᵢ = τᵢ} τᵢ++τⱼ∷'A))) τᵢ++τⱼ⊆ₗτ
  where
  τᵢ++τⱼ∷'A = ⊆ₗ-∷'ₗ-l τᵢ++τⱼ⊆ₗτ

⊆ₗ++-r : ∀ {A τᵢ τᵢ' τⱼ} -> τᵢ ⊆ₗ[ A ] τᵢ' -> τⱼ ∷'ₗ A -> (τᵢ ++ τⱼ) ⊆ₗ[ A ] (τᵢ' ++ τⱼ)
⊆ₗ++-r {τᵢ' = τᵢ'} {τⱼ} (nil x) τⱼ∷'A = ⊆ₗ-⊆ (λ x₂ → ∈-cons-r τᵢ' x₂) (∷'ₗ-++ x τⱼ∷'A)
⊆ₗ++-r (cons (τ , τ∈τᵢ , τ'⊆τ) τᵢ⊆τᵢ') τⱼ∷'A = cons (τ , (∈-cons-l _ τ∈τᵢ , τ'⊆τ)) (⊆ₗ++-r τᵢ⊆τᵢ' τⱼ∷'A)
⊆ₗ++-r {τⱼ = τⱼ} (~>∩ x) τⱼ∷'A = ~>∩ (∷'ₗ-++ {τⱼ = τⱼ} x τⱼ∷'A)
⊆ₗ++-r (⊆ₗ-trans τᵢ⊆τᵢ'' τᵢ''⊆τᵢ') τⱼ∷'A = ⊆ₗ-trans (⊆ₗ++-r τᵢ⊆τᵢ'' τⱼ∷'A) (⊆ₗ++-r τᵢ''⊆τᵢ' τⱼ∷'A)

-- ⊆ₗ++-l : ∀ {A τᵢ τᵢ' τⱼ} -> τᵢ ⊆ₗ[ A ] τᵢ' -> τⱼ ∷'ₗ A -> (τⱼ ++ τᵢ) ⊆ₗ[ A ] (τⱼ ++ τᵢ')
-- ⊆ₗ++-l = {!   !}

⊩++ : ∀ {A Γ} {m : Λ (A ⟶ A)} {τᵢ τⱼ} -> Γ ⊩ₗ m ∶ τᵢ -> Γ ⊩ₗ m ∶ τⱼ -> Γ ⊩ₗ m ∶ (τᵢ ++ τⱼ)
⊩++ {τᵢ = []} Γ⊩ₗm∶τᵢ Γ⊩ₗm∶τⱼ = Γ⊩ₗm∶τⱼ
⊩++ {τᵢ = x ∷ τᵢ} (cons x₁ Γ⊩ₗm∶τᵢ) Γ⊩ₗm∶τⱼ = cons x₁ (⊩++ Γ⊩ₗm∶τᵢ Γ⊩ₗm∶τⱼ)
⊩++ {τᵢ = x ∷ τᵢ} (subₗ Γ⊩ₗm∶τᵢ x₁) Γ⊩ₗm∶τⱼ = subₗ (⊩++ Γ⊩ₗm∶τᵢ Γ⊩ₗm∶τⱼ) (⊆ₗ++-r x₁ (⊩ₗ-∷'ₗ Γ⊩ₗm∶τⱼ))

glb : ∀ {A τ τᵢ τⱼ} -> τᵢ ⊆ₗ[ A ] τ -> τⱼ ⊆ₗ[ A ] τ -> (τᵢ ++ τⱼ) ⊆ₗ[ A ] τ
glb (nil x) τⱼ⊆τ = τⱼ⊆τ
glb (cons x τᵢ⊆τ) τⱼ⊆τ = cons x (glb τᵢ⊆τ τⱼ⊆τ)
glb {A ⟶ B} {τⱼ = τⱼ} (~>∩ {τ = τ} {τᵢ} {τᵢ'} {τₓ} (cons (arr x x₁) x₂)) τⱼ⊆τ = ⊆ₗ-trans {τⱼ = ((τ ~> τᵢ) ∷ (τ ~> τᵢ') ∷ τₓ ++ τⱼ)}
  (~>∩ (∷'ₗ-++ {τᵢ = (τ ~> (τᵢ ++ τᵢ')) ∷ τₓ} {τⱼ} (cons (arr x x₁) x₂) (⊆ₗ-∷'ₗ-l τⱼ⊆τ)))
  (⊆-++-comm {τᵢ = τⱼ} {(τ ~> τᵢ) ∷ (τ ~> τᵢ') ∷ τₓ}
    (⊆ₗ-trans {τⱼ = ((τ ~> τᵢ) ∷ (τ ~> τᵢ') ∷ τₓ) ++ (τ ~> τᵢ) ∷ (τ ~> τᵢ') ∷ τₓ}
      (⊆ₗ++-r {τⱼ = ((τ ~> τᵢ) ∷ (τ ~> τᵢ') ∷ τₓ)} τⱼ⊆τ ∷'A⟶B)
      (⊆ₗ-⊆ {!   !} ∷'A⟶B)))
  where
  ∷'A⟶B : ((τ ~> τᵢ) ∷ (τ ~> τᵢ') ∷ τₓ) ∷'ₗ (A ⟶ B)
  ∷'A⟶B = cons (arr x (∷'ₗ-++-l x₁)) (cons (arr x (∷'ₗ-++-r {τᵢ = τᵢ} x₁)) x₂)

glb (⊆ₗ-trans τᵢ⊆τᵢ' τᵢ'⊆τᵢ) τⱼ⊆τ = ⊆ₗ-trans (⊆ₗ++-r τᵢ⊆τᵢ' (⊆ₗ-∷'ₗ-l τⱼ⊆τ)) (glb τᵢ'⊆τᵢ τⱼ⊆τ)

∩-⊆-imp-⊆-∩ : ∀ {A τ τ' τᵢ τᵢ'} -> τ ⊆ₗ[ A ] τ' -> τᵢ ⊆ₗ[ A ] τᵢ' -> (τ ++ τᵢ) ⊆ₗ[ A ] (τ' ++ τᵢ')
∩-⊆-imp-⊆-∩ {τ' = τ'} τ⊆τ' τᵢ⊆τᵢ' = glb
  (⊆ₗ-trans τ⊆τ' (⊆ₗ-⊆ (λ x₁ → ∈-cons-l _ x₁) (∷'ₗ-++ (⊆ₗ-∷'ₗ-r τ⊆τ') (⊆ₗ-∷'ₗ-r τᵢ⊆τᵢ'))))
  (⊆ₗ-trans τᵢ⊆τᵢ' (⊆ₗ-⊆ (λ x₁ → ∈-cons-r τ' x₁) (∷'ₗ-++ (⊆ₗ-∷'ₗ-r τ⊆τ') (⊆ₗ-∷'ₗ-r τᵢ⊆τᵢ'))))

Γ⊩ₗYm-max : ∀ {A Γ} {m : Λ (A ⟶ A)} {τ} -> ¬(τ ≡ ω) -> Γ ⊩ₗ app (Y A) m ∶ τ -> ∃(λ τ' -> Γ ⊩ₗ m ∶ ∩' (τ' ~> τ') × τ ⊆ₗ[ A ] τ')
Γ⊩ₗYm-max τ≠ω (nil wf-Γ) = ⊥-elim (τ≠ω refl)
Γ⊩ₗYm-max {A} {Γ} {m} {τ ∷ τᵢ} τ≠ω (cons x Γ⊩ₗYm∶τ) with τᵢ ≟TIₗ ω
Γ⊩ₗYm-max {A} {Γ} {m} {τ ∷ .[]} τ≠ω (cons x Γ⊩ₗYm∶τ) | yes refl = Γ⊩Ym-max x
Γ⊩ₗYm-max {A} {Γ} {m} {τ ∷ τᵢ} τ≠ω (cons x Γ⊩ₗYm∶τ) | no τᵢ≠ω =
  τ' ++ τᵢ' ,
  subₗ Γ⊩ₗm∶ττᵢ'~>τ'ττᵢ'~>τᵢ' (~>∩ (cons (arr (∷'ₗ-++ τ'∷'A τᵢ'∷'A) (∷'ₗ-++ τ'∷'A τᵢ'∷'A)) nil)) ,
  ∩-⊆-imp-⊆-∩ τ⊆τ' τᵢ⊆τᵢ'
  where
  ih : ∃(λ τᵢ' -> Γ ⊩ₗ m ∶ ∩' (τᵢ' ~> τᵢ') × τᵢ ⊆ₗ[ A ] τᵢ')
  ih = Γ⊩ₗYm-max τᵢ≠ω Γ⊩ₗYm∶τ

  τᵢ' = proj₁ ih
  Γ⊩ₗm∶τᵢ'~>τᵢ' : Γ ⊩ₗ m ∶ ∩' (τᵢ' ~> τᵢ')
  Γ⊩ₗm∶τᵢ'~>τᵢ' = proj₁ (proj₂ ih)

  τᵢ⊆τᵢ' = proj₂ (proj₂ ih)

  body : ∃(λ τ' -> Γ ⊩ₗ m ∶ ∩' (τ' ~> τ') × ∩' τ ⊆ₗ[ A ] τ')
  body = Γ⊩Ym-max x

  τ' = proj₁ body
  Γ⊩ₗm∶τ'~>τ' : Γ ⊩ₗ m ∶ ∩' (τ' ~> τ')
  Γ⊩ₗm∶τ'~>τ' = proj₁ (proj₂ body)

  τ⊆τ' = proj₂ (proj₂ body)

  τ'∷'A = ⊆ₗ-∷'ₗ-r τ⊆τ'
  τᵢ'∷'A = ⊆ₗ-∷'ₗ-r τᵢ⊆τᵢ'

  Γ⊩ₗm∶ττᵢ'~>τ'ττᵢ'~>τᵢ' : Γ ⊩ₗ m ∶ (∩' ((τ' ++ τᵢ') ~> τ') ++ ∩' ((τ' ++ τᵢ') ~> τᵢ'))
  Γ⊩ₗm∶ττᵢ'~>τ'ττᵢ'~>τᵢ' = ⊩++ {τᵢ = ∩' ((τ' ++ τᵢ') ~> τ')} {∩' ((τ' ++ τᵢ') ~> τᵢ')}
    (subₗ Γ⊩ₗm∶τ'~>τ'
      (cons
        ( (τ' ~> τ') ,
          ((here refl) ,
          (arr (⊆ₗ-⊆ (λ x₂ → ∈-cons-l _ x₂) (∷'ₗ-++ τ'∷'A τᵢ'∷'A)) (⊆ₗ-refl τ'∷'A) (arr (∷'ₗ-++ τ'∷'A τᵢ'∷'A) τ'∷'A) (arr τ'∷'A τ'∷'A))))
        (nil (cons (arr τ'∷'A τ'∷'A) nil))))
    (subₗ Γ⊩ₗm∶τᵢ'~>τᵢ'
      (cons
        ( (τᵢ' ~> τᵢ') ,
          (here refl ,
          arr (⊆ₗ-⊆ (λ x₂ → ∈-cons-r τ' x₂) (∷'ₗ-++ τ'∷'A τᵢ'∷'A)) (⊆ₗ-refl τᵢ'∷'A) (arr (∷'ₗ-++ τ'∷'A τᵢ'∷'A) τᵢ'∷'A) (arr τᵢ'∷'A τᵢ'∷'A)))
        (nil (cons (arr τᵢ'∷'A τᵢ'∷'A) nil))))

Γ⊩ₗYm-max {A} {Γ} {m} {τᵢ} τ≠ω (subₗ {τ = τᵢ'} Γ⊩ₗYm∶τᵢ' x) = τᵢ'' , Γ⊩ₗm∶τᵢ''~>τᵢ'' , (⊆ₗ-trans x τᵢ'⊆τᵢ'')
  where
  ih : ∃(λ τᵢ'' -> Γ ⊩ₗ m ∶ ∩' (τᵢ'' ~> τᵢ'') × τᵢ' ⊆ₗ[ A ] τᵢ'')
  ih = Γ⊩ₗYm-max {!   !} Γ⊩ₗYm∶τᵢ'

  τᵢ'' = proj₁ ih
  Γ⊩ₗm∶τᵢ''~>τᵢ'' = proj₁ (proj₂ ih)
  τᵢ'⊆τᵢ'' = proj₂ (proj₂ ih)

⊩->β : ∀ {A Γ} {m m' : Λ A} {τ} -> Γ ⊩ m' ∶ τ -> m ->Λβ m' -> Γ ⊩ m ∶ τ
⊩->β Γ⊩m'∶τ (redL x m->βm') = {!   !}
⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
⊩->β {A} {Γ} {τ = τ} (app {s = m} {τ₁ = τᵢ'} {τᵢ} Γ⊩m∶τᵢ'~>τᵢ Γ⊩ₗYm∶τᵢ' τ⊆τᵢ τᵢ'∷A) (Y _) = body Γ⊩m∶τᵢ'~>τᵢ τ⊆τᵢ τᵢ'∷A Γ⊩ₗYm∶τᵢ'
  where
  body : ∀ {τᵢ τᵢ'} -> Γ ⊩ m ∶ (τᵢ' ~> τᵢ) -> ∩' τ ⊆ₗ[ A ] τᵢ -> τᵢ' ∷'ₗ A -> Γ ⊩ₗ app (Y A) m ∶ τᵢ' -> Γ ⊩ app (Y A) m ∶ τ
  body Γ⊩m∶τᵢ'~>τᵢ τ⊆τᵢ τᵢ'∷A (nil wf-Γ) = app
    (Y {τ = ∩' τ} {(ω ~> ∩' τ) ∷ []} {∩' τ}
      wf-Γ
      (cons (([] ~> ∩' τ) , ((here refl) , (arr (nil τ∷A) (⊆ₗ-refl τ∷A) (arr τ∷A τ∷A) (arr τᵢ'∷A τ∷A)))) (nil (cons (arr τᵢ'∷A τ∷A) nil)))
      (⊆ₗ-refl τ∷A))
    (cons (sub Γ⊩m∶τᵢ'~>τᵢ (arr (nil τᵢ'∷A) τ⊆τᵢ (arr τᵢ'∷A τ∷A) (arr τᵢ'∷A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) (⊆Γ-⊆ wf-Γ (λ {x} z → z))) (nil wf-Γ))
    (⊆ₗ-refl τ∷A)
    (cons (arr τᵢ'∷A τ∷A) nil)

    where
    τ∷A = ⊆ₗ-∷'ₗ-l τ⊆τᵢ
  body {τᵢ' = τ' ∷ τᵢ'} Γ⊩m∶τᵢ'~>τᵢ τ⊆τᵢ τᵢ'∷A (cons x₁ Γ⊩ₗYm∶τ'ᵢ₁) = app
    (Y {τ = [ τ ] ++ τ''} {∩' (τ'' ~> ([ τ ] ++ τ''))} {∩' τ}
      (⊩ₗ-wf-Γ Γ⊩ₗYm∶τ'ᵢ₁)
      (cons
        (
          (τ'' ~> ([ τ ] ++ τ'')) ,
          here refl ,
          arr
            (⊆ₗ-⊆ (λ x₂ → ∈-cons-r [ τ ] x₂) (cons τ∷'A τ''∷'A))
            (⊆ₗ-refl (cons τ∷'A τ''∷'A))
            (arr (cons τ∷'A τ''∷'A) (cons τ∷'A τ''∷'A))
            (arr τ''∷'A (cons τ∷'A τ''∷'A)))
        (nil (cons (arr τ''∷'A (cons τ∷'A τ''∷'A)) nil)))
      (cons (τ , (here refl , ⊆-refl τ∷'A)) (nil (cons τ∷'A τ''∷'A))))
    Γ⊩ₗm∶τ''~>τ++τ''
    (⊆ₗ-refl (cons τ∷'A nil))
    (cons (arr τ''∷'A (cons τ∷'A τ''∷'A)) nil)

    where
    τᵢ'' = τ' ∷ τᵢ'
    body₁ : ∃(λ τ'' -> Γ ⊩ₗ m ∶ ∩' (τ'' ~> τ'') × τᵢ'' ⊆ₗ[ A ] τ'')
    body₁ = Γ⊩ₗYm-max (λ ()) (cons x₁ Γ⊩ₗYm∶τ'ᵢ₁)

    τ'' = proj₁ body₁

    Γ⊩ₗm∶τ''~>τ'' : Γ ⊩ₗ m ∶ ∩' (τ'' ~> τ'')
    Γ⊩ₗm∶τ''~>τ'' = proj₁ (proj₂ body₁)

    τᵢ''⊆τ'' = proj₂ (proj₂ body₁)
    τ''∷'A = ⊆ₗ-∷'ₗ-r τᵢ''⊆τ''
    τᵢ''∷'A = ⊆ₗ-∷'ₗ-l τᵢ''⊆τ''

    τ∷'A : τ ∷' A
    τ∷'A = ∷'ₗ-∈ (here refl) (⊆ₗ-∷'ₗ-l τ⊆τᵢ)

    Γ⊩m∶τ''~>τ : Γ ⊩ m ∶ (τ'' ~> ∩' τ)
    Γ⊩m∶τ''~>τ = sub Γ⊩m∶τᵢ'~>τᵢ (arr τᵢ''⊆τ'' τ⊆τᵢ (arr τ''∷'A (⊆ₗ-∷'ₗ-l τ⊆τᵢ)) (arr τᵢ''∷'A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) (⊆Γ-⊆ (⊩ₗ-wf-Γ Γ⊩ₗYm∶τ'ᵢ₁) (λ {x} z → z))

    Γ⊩ₗm∶τ''~>τ++τ'' : Γ ⊩ₗ m ∶ ∩' (τ'' ~> ([ τ ] ++ τ''))
    Γ⊩ₗm∶τ''~>τ++τ'' = subₗ (cons Γ⊩m∶τ''~>τ Γ⊩ₗm∶τ''~>τ'') (~>∩ (cons (arr τ''∷'A (cons τ∷'A τ''∷'A)) nil))

  body Γ⊩m∶τᵢ'~>τᵢ τ⊆τᵢ τᵢ'∷A (subₗ Γ⊩ₗYm∶τᵢ'' τᵢ'⊆τᵢ'') = body
    (sub Γ⊩m∶τᵢ'~>τᵢ
      (arr τᵢ'⊆τᵢ''
        (⊆ₗ-refl (⊆ₗ-∷'ₗ-r τ⊆τᵢ))
        (arr (⊆ₗ-∷'ₗ-r τᵢ'⊆τᵢ'') (⊆ₗ-∷'ₗ-r τ⊆τᵢ))
        (arr (⊆ₗ-∷'ₗ-l τᵢ'⊆τᵢ'') (⊆ₗ-∷'ₗ-r τ⊆τᵢ)))
      (⊆Γ-⊆ (⊩ₗ-wf-Γ Γ⊩ₗYm∶τᵢ'') (λ {x} z → z)))
    τ⊆τᵢ
    (⊆ₗ-∷'ₗ-r τᵢ'⊆τᵢ'')
    Γ⊩ₗYm∶τᵢ''

-- ⊩->β {τ = τ} (app Γ⊩m∶[]~>τᵢ (nil wf-Γ) τ⊆τᵢ []∷A) (Y _) = app
--   (Y {τ = ∩' τ} {(ω ~> ∩' τ) ∷ []} {∩' τ}
--     wf-Γ
--     (cons (([] ~> ∩' τ) , ((here refl) , (arr (nil τ∷A) (⊆ₗ-refl τ∷A) (arr τ∷A τ∷A) (arr []∷A τ∷A)))) (nil (cons (arr []∷A τ∷A) nil)))
--     (⊆ₗ-refl τ∷A))
--   (cons (sub Γ⊩m∶[]~>τᵢ (arr (nil []∷A) τ⊆τᵢ (arr []∷A τ∷A) (arr []∷A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) (⊆Γ-⊆ wf-Γ (λ {x} z → z))) (nil wf-Γ))
--   (⊆ₗ-refl τ∷A)
--   (cons (arr []∷A τ∷A) nil)
--
--   where
--   τ∷A = ⊆ₗ-∷'ₗ-l τ⊆τᵢ
--
-- ⊩->β {A} {Γ} {τ = τ} (app {s = m} {τ₁ = τ' ∷ τ'ᵢ} {τᵢ} Γ⊩m∶τ'~>τᵢ Γ⊩ₗYm∶τ' τ⊆τᵢ τ'∷A) (Y _) = {!   !}
--   where
--   Γ⊆Γ-refl = ⊆Γ-⊆ (⊩ₗ-wf-Γ Γ⊩ₗYm∶τ') (λ {x} z → z)
--
--   τ'' = proj₁ (Γ⊩ₗYm-max (λ x → {!   !}) Γ⊩ₗYm∶τ')
--
--   Γ⊩m∶τ''~>τ'' : Γ ⊩ m ∶ (τ'' ~> τ'')
--   Γ⊩m∶τ''~>τ'' = proj₁ (proj₂ (Γ⊩ₗYm-max {!   !} Γ⊩ₗYm∶τ'))
--
--   τ'τ'ᵢ⊆τ'' : (τ' ∷ τ'ᵢ) ⊆ₗ[ A ] τ''
--   τ'τ'ᵢ⊆τ'' = proj₂ (proj₂ (Γ⊩ₗYm-max {!   !} Γ⊩ₗYm∶τ'))
--
--   Γ⊩m∶τ''~>τᵢ : Γ ⊩ m ∶ (τ'' ~> ∩' τ)
--   Γ⊩m∶τ''~>τᵢ = sub Γ⊩m∶τ'~>τᵢ (arr τ'τ'ᵢ⊆τ'' τ⊆τᵢ (arr (⊆ₗ-∷'ₗ-r τ'τ'ᵢ⊆τ'') (⊆ₗ-∷'ₗ-l τ⊆τᵢ)) (arr τ'∷A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) Γ⊆Γ-refl
--
-- ⊩->β {τ = τ} (app Γ⊩m∶[]~>τᵢ (subₗ x y) τ⊆τᵢ []∷A) (Y z) = {!   !}
--
--
--

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

-- ⊩->β {τ = τ} (app Γ⊩m∶[]~>τᵢ (nil wf-Γ) τ⊆τᵢ []∷A) (Y _) = app
--   (Y {τ = ∩' τ} {(ω ~> ∩' τ) ∷ []} {∩' τ}
--     wf-Γ
--     ((ω ~> ∩' τ) , here refl , arr (nil τ∷A) (⊆ₗ-refl τ∷A) (arr τ∷A τ∷A) (arr nil τ∷A))
--     (cons (arr []∷A τ∷A) nil)
--     (⊆ₗ-refl τ∷A))
--   (cons (sub Γ⊩m∶[]~>τᵢ (arr (nil []∷A) τ⊆τᵢ (arr []∷A τ∷A) (arr []∷A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) (⊆Γ-⊆ wf-Γ (λ {x} z → z))) (nil wf-Γ))
--   (⊆ₗ-refl τ∷A)
--   (cons (arr []∷A τ∷A) nil)
--
--
-- -- ⊩->β (app {τ₁ = ∩ (τ₁ ∷ τ₁ᵢ)} Γ⊩m∶τ₁ᵢ~>τ₂ (cons (app (Y wf-Γ (proj₁ , () , proj₃) x₁ x₂) (nil wf-Γ₁) τ₁⊆τ₁₂ x₅) Γ⊩Ym∶τ₁ᵢ) τ⊆τ₂ τ₁∷A) (Y x)
-- -- ⊩->β {τ = τ} (app {τ₁ = ∩ (τ₁ ∷ τ₁ᵢ)} {τ₂} Γ⊩m∶τ₁ᵢ~>τ₂ (cons (app {τ₁ = ∩ (τ₁₁ ∷ τ₁₁ᵢ)} {τ₁₂} (Y {τ = τ'} wf-Γ (τ'' , τ''∈ τ₁₁, proj₃) x₁ x₂) (cons Γ⊩m∶τ₁₁ Γ⊩ₗm∶τ₁₁ᵢ) τ₁⊆τ₁₂ x₅) Γ⊩Ym∶τ₁ᵢ) τ⊆τ₂ τ₁∷A) (Y _) =
-- ⊩->β {A} {Γ} {τ = τ} (app {s = m} {τ₁ = ∩ (τ₁ ∷ τ₁ᵢ)} {τ₂}
--   Γ⊩m∶τ₁ᵢτ₁ᵢ~>τ₂
--   (cons
--     (app {τ₁ = ∩ (τ₁₁)} {τ₁₂}
--       (Y {τ = τ'} wf-Γ (_ , τ''∈τ₁₁ , arr {τ₂₁ = τ''₁} {τ''₂} τ''₁⊆τ' τ'⊆τ''₂ τ'~>τ'∷A⟶A (arr τ''₁∷A τ''₂∷A)) τ₁₁∷A⟶A τ₁₂⊆τ')
--       Γ⊩ₗm∶τ₁₁ τ₁⊆τ₁₂ τ₁₁∷A⟶A₂)
--     Γ⊩Ym∶τ₁ᵢ)
--   τ⊆τ₂
--   τ₁∷A) (Y _) =
--   {!   !}
--
--   where
--   Γ⊆Γ-refl = ⊆Γ-⊆ wf-Γ (λ {x} z → z)
--
--   Γ⊩m∶τ''₁~>τ''₂ : Γ ⊩ m ∶ (τ''₁ ~> τ''₂)
--   Γ⊩m∶τ''₁~>τ''₂ = ⊩ₗ-∈-⊩ Γ⊩ₗm∶τ₁₁ τ''∈τ₁₁
--
--   Γ⊩m∶τ''₂~>τ''₂ : Γ ⊩ m ∶ (τ''₂ ~> τ''₂)
--   Γ⊩m∶τ''₂~>τ''₂ = sub Γ⊩m∶τ''₁~>τ''₂ (arr (⊆ₗ-trans τ''₁⊆τ' τ'⊆τ''₂) (⊆ₗ-refl τ''₂∷A) (arr τ''₂∷A τ''₂∷A) (arr τ''₁∷A τ''₂∷A)) Γ⊆Γ-refl
--
--   Γ⊩m∶τ₁~>τ₂ : Γ ⊩ m ∶ (∩' τ₁ ~> τ₂)
--   Γ⊩m∶τ₁~>τ₂ = sub Γ⊩m∶τ₁ᵢτ₁ᵢ~>τ₂ (arr {!   !} {!   !} {!   !} {!   !}) Γ⊆Γ-refl

-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β (app Γ⊩m'∶ω~>τ₂ (nil wf-Γ) τ⊆τ₂ nil) (Y trm-m) = {!   !}
-- ⊩->β (app Γ⊩m∶τ₃τᵢ~>τ₅ (cons _ (app (Y _ τ₂⊆τ₁ τ₁⊆τ) (cons _ Γ⊩m∶τ~>τ₁ (nil wf-Γ)) τ₃⊆τ₂ (cons τ~>τ₁∷A⟶A _)) Γ⊩ₗYm∶∩τᵢ) τ₄⊆τ₅ τ₃τᵢ∷A) (Y trm-m) = {!   !}

-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- -- ⊩->β (app Γ⊩m∶τ₁~>τ (app (Y wf-Γ (arr (arr ::' ::'') ::''') τ≤τ₁ τ₂≤τ₁) Γ⊩m'∶τ₂ x₄) x₅) (Y x₆) = {!   !}
-- ⊩->β (app {s = m} {τ₂ = τ} Γ⊩m∶τ₁~>τ (app {τ₂ = τ₁} (Y {τ = τ₂} {τ₃} wf-Γ (arr (arr τ₂∷A τ₃∷A) _) τ≤τ₁ τ₂≤τ₁) Γ⊩m∶τ₂~>τ₃ _) (arr {A = A} τ₁∷A τ∷A)) (Y x₆) =
--   app {A = A ⟶ A}
--     (Y {_} {A} {∩ (τ₂ ∷ τ₁ ∷ [])} {∩ (τ₃ ∷ τ ∷ [])} {τ}
--       wf-Γ
--       (arr (arr (∩-cons τ₂∷A (∩-cons τ₁∷A ∩-nil)) (∩-cons τ₃∷A (∩-cons τ∷A ∩-nil))) τ∷A)
--       {!   !}
--       (∩-∈ (there (here refl))))
--     {!   !}
--     (arr (arr (∩-cons τ₂∷A (∩-cons τ₁∷A ∩-nil)) (∩-cons τ₃∷A (∩-cons τ∷A ∩-nil))) τ∷A)
--
-- ⊩->β (app Γ⊩m'∶τ (∩-nil ¬Y-shape wf-Γ) x) (Y x₁) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (app Γ⊩m'∶τ (∩-cons ¬Y-shape wf-Γ Γ⊩m'∶τ₁ Γ⊩m'∶τ₂) x) (Y x₁) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (∩-nil ¬Y-shape wf-Γ) (Y x) = ⊥-elim (¬Y-shape intro₂)
-- ⊩->β (∩-cons ¬Y-shape wf-Γ Γ⊩m'∶τ Γ⊩m'∶τ₁) (Y x) = ⊥-elim (¬Y-shape intro₂)

-- ⊩->β Γ⊩m'∶τ (redL trm-n m->βm') = ⊩->β-redL Γ⊩m'∶τ m->βm'
--   where
--   ⊩->β-redL : ∀ {A B Γ} {m m' : Λ (A ⟶ B)} {n : Λ A} {τ} -> Γ ⊩ app m' n ∶ τ -> m ->Λβ m' -> Γ ⊩ app m n ∶ τ
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁ x x₁) (redL x₂ m->Λβm') =
--     app (⊩->β-redL Γ⊩m'n∶τ m->Λβm') Γ⊩m'n∶τ₁ x x₁
--   ⊩->β-redL (∩-nil ¬Y-shape wf-Γ) (redL x m->Λβm') = {!   !}
--   ⊩->β-redL (∩-cons ¬Y-shape wf-Γ Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (redL x m->Λβm') = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (redR x m->Λβm') = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (abs L x) = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (beta x x₁) = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (Y x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR trm-m n->βn') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β (app {s = m} {τ₂ = τ} Γ⊩m∶τ₁~>τ (app (Y {_} {_} {τ₂} {τ₃} {τ₁} wf-Γ τ₂∷A τ₃∷A τ₁∷A τ₂≤∩τ₃ τ₁≤∩τ₃) Γ⊩m∶τ₂~>τ₃ x τ₂~>τ₃∷A) (arr {A = A} _ τ∷A) _) (Y trm-m) =
--   -- app {A = A ⟶ A} (Y wf-Γ τ₁∷A τ∷A τ∷A {!   !} {!   !}) Γ⊩m∶τ₁~>τ (arr (arr τ₁∷A τ∷A) τ∷A) (arr τ₁∷A τ∷A)
--   app {A = A ⟶ A}
--     (Y {_} {A} {∩ (τ₁ ∷ τ₂ ∷ τ₃ ∷ [])} {∩ (τ ∷ τ₃ ∷ [])} {τ}
--       wf-Γ
--       {!   !}
--       (∩-cons τ∷A (∩-cons τ₃∷A ∩-nil))
--       τ∷A
--       {!   !}
--       {!   !})
--     {!   !}
--     (arr {!   !} {!   !})
--     {!   !}
--
-- ⊩->β (app Γ⊩m∶τ~>τ' (∩-nil ¬Y-shape wf-Γ) x τ∷A) (Y trm-m) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (app Γ⊩m∶τ~>τ' (∩-cons ¬Y-shape wf-Γ Γ⊩Ym∶τ' Γ⊩Ym∶τ'') x τ∷A) (Y trm-m) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (∩-nil ¬Y-shape wf-Γ) (Y x) = ⊥-elim (¬Y-shape intro₂)
-- ⊩->β (∩-cons ¬Y-shape wf-Γ Γ⊩m'∶τ Γ⊩m'∶τ₁) (Y x) = ⊥-elim (¬Y-shape intro₂)

module ITyping where

open import Data.Empty
open import Data.List
open import Data.Nat
open import Data.Product
open import Data.List.Properties
open import Data.List.Any as LAny
open LAny.Membership-≡
open import Relation.Nullary
open import Relation.Binary.Core

open import Core
open import Core-Lemmas
open import Typing using (dom)
open import Typed-Core
open import Reduction using (_↝_)

data IType : Set where
  o : IType
  _~>_ : List IType -> List IType -> IType

ω : List IType
ω = []

∩' : IType -> List IType
∩' x = (x ∷ [])

_∩_ : IType -> IType -> List IType
A ∩ B = A ∷ B ∷ []

~>-inj-l : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₁ ≡ τ₂₁
~>-inj-l refl = refl

~>-inj-r : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₂ ≡ τ₂₂
~>-inj-r refl = refl

-- list-inj-cons : ∀ {x y τᵢ τⱼ} -> (x ∷ τᵢ) ≡ (y ∷ τⱼ) -> τᵢ ≡ τⱼ
-- list-inj-cons refl = refl
--
-- list-inj : ∀ {x y τᵢ τⱼ} -> (x ∷ τᵢ) ≡ (y ∷ τⱼ) -> x ≡ y
-- ∩-inj refl = refl
--
-- list-∷-≡ : ∀ {x y : IType} {xs ys} -> x ≡ y -> xs ≡ ys -> (x ∷ xs) ≡ (y ∷ ys)
-- list-∷-≡ refl refl = refl

_≟TI_ : Decidable {A = IType} _≡_
_≟TIₗ_ : Decidable {A = List IType} _≡_

o ≟TI o = yes refl
o ≟TI (_ ~> _) = no (λ ())
(_ ~> _) ≟TI o = no (λ ())
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) with τ₁₁ ≟TIₗ τ₂₁ | τ₁₂ ≟TIₗ τ₂₂
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> .τ₁₂) | yes refl | yes refl = yes refl
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> τ₂₂) | yes refl | no τ₁₂≠τ₂₂ = no (λ eq → τ₁₂≠τ₂₂ (~>-inj-r eq))
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) | no τ₁₁≠τ₂₁ | _ = no (λ eq → τ₁₁≠τ₂₁ (~>-inj-l eq))

[] ≟TIₗ [] = yes refl
[] ≟TIₗ (x ∷ τⱼ) = no (λ ())
(x ∷ τᵢ) ≟TIₗ [] = no (λ ())
(x ∷ τᵢ) ≟TIₗ (y ∷ τⱼ) with x ≟TI y | τᵢ ≟TIₗ τⱼ
(x ∷ τᵢ) ≟TIₗ (.x ∷ .τᵢ) | yes refl | yes refl = yes refl
(x ∷ τᵢ) ≟TIₗ (.x ∷ τⱼ) | yes refl | no τᵢ≠τⱼ = no (λ ∩x∷τᵢ≡∩x∷τⱼ → τᵢ≠τⱼ (proj₂ (∷-injective ∩x∷τᵢ≡∩x∷τⱼ)))
(x ∷ τᵢ) ≟TIₗ (y ∷ τⱼ) | no x≠y | _ = no (λ ∩x∷τᵢ≡∩y∷τⱼ → x≠y (proj₁ (∷-injective ∩x∷τᵢ≡∩y∷τⱼ)))

ICtxt = List (Atom × ((List IType) × Type))

data _∷'_ : IType -> Type -> Set
data _∷'ₗ_ : List IType -> Type -> Set

data _∷'_ where
  base : o ∷' σ
  arr : ∀ {δ τ A B} -> δ ∷'ₗ A -> τ ∷'ₗ B -> (δ ~> τ) ∷' (A ⟶ B)

data _∷'ₗ_ where
  nil : ∀ {A} -> ω ∷'ₗ A
  cons : ∀ {τᵢ τ A} -> τ ∷' A -> τᵢ ∷'ₗ A -> (τ ∷ τᵢ) ∷'ₗ A

data Wf-ICtxt : ICtxt -> Set where
  nil : Wf-ICtxt []
  cons : ∀ {A Γ x τ} ->
    (x∉ : x ∉ dom Γ) -> τ ∷'ₗ A -> Wf-ICtxt Γ ->
    --------------------------------------------
            Wf-ICtxt ((x , (τ , A)) ∷ Γ)

data _⊆[_]_ : IType -> Type -> IType -> Set
data _⊆ₗ[_]_ : List IType -> Type -> List IType -> Set

data _⊆[_]_ where
  base : o ⊆[ σ ] o
  arr : ∀ {A B τ₁₁ τ₁₂ τ₂₁ τ₂₂} ->
    τ₂₁ ⊆ₗ[ A ] τ₁₁ -> τ₁₂ ⊆ₗ[ B ] τ₂₂ -> (τ₁₁ ~> τ₁₂) ∷' (A ⟶ B) -> (τ₂₁ ~> τ₂₂) ∷' (A ⟶ B) ->
    -------------------------------------------------------------------------------------------
                            (τ₁₁ ~> τ₁₂) ⊆[ A ⟶ B ] (τ₂₁ ~> τ₂₂)
  -- ⊆-trans : ∀ {A τ₁ τ₂ τ₃} ->
  --   τ₁ ⊆[ A ] τ₂ -> τ₂ ⊆[ A ] τ₃ ->
  --   -------------------------------
  --             τ₁ ⊆[ A ] τ₃

data _⊆ₗ[_]_ where
  nil : ∀ {A τ} ->
    τ ∷'ₗ A ->
    -----------
    ω ⊆ₗ[ A ] τ
  cons : ∀ {A τᵢ τ' τ'ᵢ} ->
    ∃(λ τ -> (τ ∈ τᵢ) × (τ' ⊆[ A ] τ)) -> τ'ᵢ ⊆ₗ[ A ] τᵢ ->
    -------------------------------------------------------
                    (τ' ∷ τ'ᵢ) ⊆ₗ[ A ] τᵢ

∷'ₗ-∈ : ∀ {A τ τᵢ} -> τ ∈ τᵢ -> τᵢ ∷'ₗ A -> τ ∷' A
∷'ₗ-∈ {τᵢ = []} () _
∷'ₗ-∈ {τ = τ} {τ' ∷ τᵢ} τ∈τ'τᵢ τ'τᵢ∷A with τ' ≟TI τ
∷'ₗ-∈ {A} {τ} {.τ ∷ τᵢ} τ∈τ'τᵢ (cons τ∷A τ'τᵢ∷A) | yes refl = τ∷A
∷'ₗ-∈ {A} {τ} {τ' ∷ τᵢ} τ∈τ'τᵢ (cons τ'∷A τ'τᵢ∷A) | no τ'≠τ = ∷'ₗ-∈ (∈-∷-elim τ τᵢ τ'≠τ τ∈τ'τᵢ) τ'τᵢ∷A

⊆-refl : ∀ {A τ} -> τ ∷' A -> τ ⊆[ A ] τ
⊆ₗ-refl : ∀ {A τ} -> τ ∷'ₗ A -> τ ⊆ₗ[ A ] τ
⊆ₗ-⊆ : ∀ {A τᵢ τⱼ} -> τᵢ ⊆ τⱼ -> τⱼ ∷'ₗ A -> τᵢ ⊆ₗ[ A ] τⱼ

⊆-refl {τ = o} base = base
⊆-refl {τ = τ ~> τ'} (arr τ∷ᵢA τ'∷ᵢB) =
  arr (⊆ₗ-refl τ∷ᵢA) (⊆ₗ-refl τ'∷ᵢB) (arr τ∷ᵢA τ'∷ᵢB) (arr τ∷ᵢA τ'∷ᵢB)

⊆ₗ-refl {τ = []} nil = nil nil
⊆ₗ-refl {A} {τ ∷ τᵢ} ττᵢ∷A = ⊆ₗ-⊆ (λ {x} z → z) ττᵢ∷A

⊆ₗ-⊆ {τᵢ = []} τᵢ⊆τⱼ τⱼ∷A = nil τⱼ∷A
⊆ₗ-⊆ {τᵢ = τ ∷ τᵢ} τᵢ⊆τⱼ τⱼ∷A =
  cons (τ , (τᵢ⊆τⱼ (here refl)) , ⊆-refl (∷'ₗ-∈ (τᵢ⊆τⱼ (here refl)) τⱼ∷A)) (⊆ₗ-⊆ (λ {x} z → τᵢ⊆τⱼ (there z)) τⱼ∷A)

⊆ₗ-∈-∃ : ∀ {A τ τ₁ τ₂} -> τ₁ ⊆ₗ[ A ] τ₂ -> τ ∈ τ₁ -> ∃(λ τ' -> (τ' ∈ τ₂) × (τ ⊆[ A ] τ'))
⊆ₗ-∈-∃ (cons ∃τ τ₁⊆τ₂) (here refl) = ∃τ
⊆ₗ-∈-∃ (cons _ τ₁⊆τ₂) (there τ∈τ₁) = ⊆ₗ-∈-∃ τ₁⊆τ₂ τ∈τ₁

⊆ₗ-ω-⊥ : ∀ {A τ τᵢ} -> (τ ∷ τᵢ) ⊆ₗ[ A ] ω -> ⊥
⊆ₗ-ω-⊥ (cons (_ , () , _) _)

⊆-∷'-r : ∀ {A τ τ'} -> τ ⊆[ A ] τ' -> τ' ∷' A
⊆-∷'-r base = base
⊆-∷'-r (arr _ _ _ x) = x

⊆-∷'-l : ∀ {A τ τ'} -> τ ⊆[ A ] τ' -> τ ∷' A
⊆-∷'-l base = base
⊆-∷'-l (arr _ _ x _) = x

⊆ₗ-∷'ₗ-r : ∀ {A τᵢ τⱼ} -> τᵢ ⊆ₗ[ A ] τⱼ -> τⱼ ∷'ₗ A
⊆ₗ-∷'ₗ-r {τᵢ = []} (nil τⱼ∷A) = τⱼ∷A
⊆ₗ-∷'ₗ-r {τᵢ = τ ∷ τᵢ} (cons x τᵢ⊆τⱼ) = ⊆ₗ-∷'ₗ-r τᵢ⊆τⱼ

⊆ₗ-∷'ₗ-l : ∀ {A τᵢ τⱼ} -> τᵢ ⊆ₗ[ A ] τⱼ -> τᵢ ∷'ₗ A
⊆ₗ-∷'ₗ-l (nil x) = nil
⊆ₗ-∷'ₗ-l (cons (_ , _ , τ'⊆τ) τᵢ⊆τⱼ) = cons (⊆-∷'-l τ'⊆τ) (⊆ₗ-∷'ₗ-l τᵢ⊆τⱼ)

⊆ₗ-trans : ∀ {A τᵢ τⱼ τₖ} ->
  τᵢ ⊆ₗ[ A ] τⱼ -> τⱼ ⊆ₗ[ A ] τₖ ->
  ---------------------------------
            τᵢ ⊆ₗ[ A ] τₖ

⊆-trans : ∀ {A τ₁ τ₂ τ₃} ->
  τ₁ ⊆[ A ] τ₂ -> τ₂ ⊆[ A ] τ₃ ->
  -------------------------------
            τ₁ ⊆[ A ] τ₃

⊆ₗ-trans {τᵢ = []} τᵢ⊆τⱼ τⱼ⊆τₖ = nil (⊆ₗ-∷'ₗ-r τⱼ⊆τₖ)
⊆ₗ-trans {τᵢ = τ' ∷ τᵢ} τᵢ⊆τⱼ (nil x) = ⊥-elim (⊆ₗ-ω-⊥ τᵢ⊆τⱼ)
⊆ₗ-trans {τᵢ = τ ∷ τᵢ} {τⱼ} {τₖ} (cons (τ' , τ'∈τⱼ , τ⊆τ') τᵢ⊆τⱼ) τⱼ⊆τₖ =
  cons (τ'' , (τ''∈τₖ , (⊆-trans τ⊆τ' τ'⊆τ''))) (⊆ₗ-trans τᵢ⊆τⱼ τⱼ⊆τₖ)
    where
    τ'' = proj₁ (⊆ₗ-∈-∃ τⱼ⊆τₖ τ'∈τⱼ)
    τ''∈τₖ = proj₁ (proj₂ (⊆ₗ-∈-∃ τⱼ⊆τₖ τ'∈τⱼ))
    τ'⊆τ'' = proj₂ (proj₂ (⊆ₗ-∈-∃ τⱼ⊆τₖ τ'∈τⱼ))

⊆-trans base base = base
⊆-trans (arr τ₂₁⊆τ₁₁ τ₁₂⊆τ₂₂ τ₁₁~>τ₁₂∷A⟶B _) (arr τ₂₃⊆τ₂₁ τ₂₂⊆τ₂₄ τ₂₁~>τ₂₂∷A⟶B τ₂₃~>τ₂₄∷A⟶B) =
  arr (⊆ₗ-trans τ₂₃⊆τ₂₁ τ₂₁⊆τ₁₁) (⊆ₗ-trans τ₁₂⊆τ₂₂ τ₂₂⊆τ₂₄) τ₁₁~>τ₁₂∷A⟶B τ₂₃~>τ₂₄∷A⟶B

⊆->⊆ₗ : ∀ {A τ τ'} -> τ ⊆[ A ] τ' -> (∩' τ) ⊆ₗ[ A ] (∩' τ')
⊆->⊆ₗ {τ = τ} {τ'} τ⊆τ' = cons (τ' , (here refl , τ⊆τ')) (nil (cons (⊆-∷'-r τ⊆τ') nil))

data _⊩_∶_ : ∀ {A} -> ICtxt -> Λ A -> IType -> Set
data _⊩ₗ_∶_ : ∀ {A} -> ICtxt -> Λ A -> List IType -> Set

data _⊩_∶_ where
  var : ∀ {A Γ x τ} {τᵢ : List IType} ->
    (wf-Γ : Wf-ICtxt Γ) -> (τᵢ∈Γ : (x , (τᵢ , A)) ∈ Γ) -> (τ⊆τᵢ : (∩' τ) ⊆ₗ[ A ] τᵢ) ->
    -----------------------------------------------------------------------------------
                                    Γ ⊩ fv {A} x ∶ τ
  app : ∀ {A B Γ s t τ τ₁ τ₂} ->
    Γ ⊩ s ∶ (τ₁ ~> τ₂) -> Γ ⊩ₗ t ∶ τ₁ -> (∩' τ) ⊆ₗ[ B ] τ₂ -> τ₁ ∷'ₗ A ->
    ---------------------------------------------------------------------
                        Γ ⊩ (app {A} {B} s t) ∶ τ
  abs : ∀ {A B Γ τ τ'} (L : FVars) -> ∀ {t : Λ B} ->
    ( cf : ∀ {x} -> (x∉L : x ∉ L) -> ((x , (τ , A)) ∷ Γ) ⊩ₗ Λ[ 0 >> fv {A} x ] t ∶ τ' ) -> (τ ~> τ') ∷' (A ⟶ B) ->
    --------------------------------------------------------------------------------------------------------------
                                                Γ ⊩ lam A t ∶ (τ ~> τ')
  Y : ∀ {Γ A τ τ₁ τ₂} ->
    (wf-Γ : Wf-ICtxt Γ) -> ∃(λ τ' -> (τ' ∈ τ₁) × ((τ ~> τ) ⊆[ A ⟶ A ] τ')) -> τ₁ ∷'ₗ (A ⟶ A) -> τ₂ ⊆ₗ[ A ] τ -> --  τ₁ ⊆[ (A ⟶ A) ⟶ A ]((∩' (τ ~> τ)) ~> τ)
    -----------------------------------------------------------------------------------------
                                    Γ ⊩ Y A ∶ (τ₁ ~> τ₂)

data _⊩ₗ_∶_ where
  nil : ∀ {A Γ} {m : Λ A} ->
    (wf-Γ : Wf-ICtxt Γ) ->
    ----------------------
          Γ ⊩ₗ m  ∶ ω
  cons : ∀ {A Γ τ τᵢ} {m : Λ A} ->
    Γ ⊩ m  ∶ τ -> Γ ⊩ₗ m  ∶ τᵢ ->
    --------------------------------
          Γ ⊩ₗ m  ∶ (τ ∷ τᵢ)

data ΛTerm : ∀ {τ} -> Λ τ -> Set where
  var : ∀ {A x} -> ΛTerm (fv {A} x)
  lam : ∀ {A B} (L : FVars) -> ∀ {e : Λ B} ->
    (cf : ∀ {x} -> (x∉L : x ∉ L) -> ΛTerm (Λ[ 0 >> fv {A} x ] e)) -> ΛTerm (lam A e)
  app : ∀ {A B} {e₁ : Λ (A ⟶ B)} {e₂ : Λ A} -> ΛTerm e₁ -> ΛTerm e₂ -> ΛTerm (app e₁ e₂)
  Y : ∀ {t} -> ΛTerm (Y t)

data _⊆Γ_ : ICtxt -> ICtxt -> Set where
  nil : ∀ {Γ} ->
    (wf-Γ : Wf-ICtxt Γ) ->
    ----------------------
          [] ⊆Γ Γ
  cons : ∀ {A x τ' Γ Γ'} ->
    ∃(λ τ -> ((x , (τ , A)) ∈ Γ') × (τ' ⊆ₗ[ A ] τ)) -> Γ ⊆Γ Γ' ->
    ------------------------------------------------------------
                      ((x , (τ' , A)) ∷ Γ) ⊆Γ Γ'

⊩ₗ-wf-Γ : ∀ {A Γ} {m : Λ A} {τ} -> Γ ⊩ₗ m ∶ τ -> Wf-ICtxt Γ
⊩ₗ-wf-Γ (nil wf-Γ) = wf-Γ
⊩ₗ-wf-Γ (cons _ Γ⊩ₗm∶τ) = ⊩ₗ-wf-Γ Γ⊩ₗm∶τ

⊆Γ-wfΓ' : ∀ {Γ Γ'} -> Γ ⊆Γ Γ' -> Wf-ICtxt Γ'
⊆Γ-wfΓ' (nil wf-Γ') = wf-Γ'
⊆Γ-wfΓ' (cons _ Γ⊆Γ') = ⊆Γ-wfΓ' Γ⊆Γ'

wf-Γ-∷'ₗ : ∀ {A x τ Γ} -> (x , (τ , A)) ∈ Γ -> Wf-ICtxt Γ -> τ ∷'ₗ A
wf-Γ-∷'ₗ (here refl) (cons _ x₁ _) = x₁
wf-Γ-∷'ₗ (there xτA∈Γ) (cons _ _ wf-Γ) = wf-Γ-∷'ₗ xτA∈Γ wf-Γ

⊆Γ-⊆ : ∀ {Γ Γ'} -> Wf-ICtxt Γ' -> Γ ⊆ Γ' -> Γ ⊆Γ Γ'
⊆Γ-⊆ {[]} wf-Γ' Γ⊆Γ' = nil wf-Γ'
⊆Γ-⊆ {(x , τ , A) ∷ Γ} wf-Γ' Γ⊆Γ' = cons
  (τ , ((Γ⊆Γ' (here refl)) , ⊆ₗ-refl (wf-Γ-∷'ₗ (Γ⊆Γ' (here refl)) wf-Γ')))
  (⊆Γ-⊆ wf-Γ' (λ {x₁} z → Γ⊆Γ' (there z)))

-- ⊆Γ-refl {[]} _ = nil nil
-- ⊆Γ-refl {(x , τ , A) ∷ Γ} (cons _ τ∷A wf-Γ) = cons (τ , (here refl , ⊆ₗ-refl τ∷A)) {!   !}

⊩-∷' : ∀ {A Γ} {m : Λ A} {τ} -> Γ ⊩ m ∶ τ -> τ ∷' A
⊩ₗ-∷'ₗ : ∀ {A Γ} {m : Λ A} {τ} -> Γ ⊩ₗ m ∶ τ -> τ ∷'ₗ A

⊩-∷' (var _ _ τ⊆τᵢ) = ∷'ₗ-∈ (here refl) (⊆ₗ-∷'ₗ-l τ⊆τᵢ)
⊩-∷' (app _ _ τ⊆τᵢ _) = ∷'ₗ-∈ (here refl) (⊆ₗ-∷'ₗ-l τ⊆τᵢ)
⊩-∷' (abs _ _ x) = x
⊩-∷' (Y _ _ τ₁∷A⟶A τ₂⊆τ) = arr τ₁∷A⟶A (⊆ₗ-∷'ₗ-l τ₂⊆τ)

⊩ₗ-∷'ₗ (nil _) = nil
⊩ₗ-∷'ₗ (cons Γ⊩m∶τ Γ⊩ₗm∶τᵢ) = cons (⊩-∷' Γ⊩m∶τ) (⊩ₗ-∷'ₗ Γ⊩ₗm∶τᵢ)

⊩ₗ-∈-⊩ : ∀ {A Γ} {m : Λ A} {τ τᵢ} -> Γ ⊩ₗ m ∶ τᵢ -> τ ∈ τᵢ -> Γ ⊩ m ∶ τ
⊩ₗ-∈-⊩ (nil _) ()
⊩ₗ-∈-⊩ (cons Γ⊩m∶τ x) (here refl) = Γ⊩m∶τ
⊩ₗ-∈-⊩ (cons _ Γ⊩ₗm∶τᵢ) (there τ∈τᵢ) = ⊩ₗ-∈-⊩ Γ⊩ₗm∶τᵢ τ∈τᵢ

data _->Λβ_ : ∀ {τ} -> Λ τ ↝ Λ τ where
  redL : ∀ {A B} {n : Λ A} {m m' : Λ (A ⟶ B)} -> ΛTerm n -> m ->Λβ m' -> app m n ->Λβ app m' n
  redR : ∀ {A B} {m : Λ (A ⟶ B)} {n n' : Λ A} -> ΛTerm m -> n ->Λβ n' -> app m n ->Λβ app m n'
  abs : ∀ L {A B} {m m' : Λ B} -> ( ∀ {x} -> x ∉ L -> Λ[ 0 >> fv {A} x ] m ->Λβ Λ[ 0 >> fv {A} x ] m' ) ->
    lam A m ->Λβ lam A m'
  beta : ∀ {A B} {m : Λ (A ⟶ B)} {n : Λ A} -> ΛTerm (lam A m) -> ΛTerm n -> app (lam A m) n ->Λβ (Λ[ 0 >> n ] m)
  Y : ∀ {A} {m : Λ (A ⟶ A)} -> ΛTerm m -> app (Y A) m ->Λβ app m (app (Y A) m)

∈-⊆Γ-trans : ∀ {A x τᵢ} {Γ Γ'} -> (x , (τᵢ , A)) ∈ Γ -> Γ ⊆Γ Γ' -> ∃(λ τᵢ' -> ((x , (τᵢ' , A)) ∈ Γ') × τᵢ ⊆ₗ[ A ] τᵢ')
∈-⊆Γ-trans (here refl) (cons x _) = x
∈-⊆Γ-trans (there x∈L) (cons _ L⊆L') = ∈-⊆Γ-trans x∈L L⊆L'

⊆Γ-∷ : ∀ {A x τᵢ Γ Γ'} -> x ∉ dom Γ' -> τᵢ ∷'ₗ A -> Γ ⊆Γ Γ' -> Γ ⊆Γ ((x , τᵢ , A) ∷ Γ')
⊆Γ-∷ {Γ = []} x∉Γ' τᵢ∷A Γ⊆Γ' = nil (cons x∉Γ' τᵢ∷A (⊆Γ-wfΓ' Γ⊆Γ'))
⊆Γ-∷ {Γ = (x , τᵢ , A) ∷ Γ} x∉Γ' τᵢ∷A (cons (proj₁ , proj₂ , proj₃) Γ⊆Γ') =
  cons (proj₁ , ((there proj₂) , proj₃)) (⊆Γ-∷ x∉Γ' τᵢ∷A Γ⊆Γ')

subΓ : ∀ {A Γ Γ'} {m : Λ A} {τ} -> Γ ⊩ m ∶ τ -> Γ ⊆Γ Γ' -> Γ' ⊩ m ∶ τ
subᵢΓ : ∀ {A Γ Γ'} {m : Λ A} {τ} -> Γ ⊩ₗ m ∶ τ -> Γ ⊆Γ Γ' -> Γ' ⊩ₗ m ∶ τ

subΓ (var wf-Γ τᵢ∈Γ τ⊆τᵢ) Γ⊆Γ' = var (⊆Γ-wfΓ' Γ⊆Γ') τᵢ'∈ (⊆ₗ-trans τ⊆τᵢ τᵢ⊆τᵢ')
  where
  τᵢ'∈ = proj₁ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))
  τᵢ⊆τᵢ' = proj₂ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))

subΓ (app Γ⊩m∶τ x x₁ x₂) Γ⊆Γ' = app (subΓ Γ⊩m∶τ Γ⊆Γ') (subᵢΓ x Γ⊆Γ') x₁ x₂
subΓ {Γ' = Γ'} (abs {τ = τ} L cf (arr τ∷A τ'∷B)) Γ⊆Γ' = abs
  (L ++ dom Γ')
  (λ x∉ → subᵢΓ
    (cf (∉-cons-l _ _ x∉))
    (cons
      (τ , (here refl) , (⊆ₗ-refl τ∷A))
      (⊆Γ-∷ (∉-cons-r L _ x∉) τ∷A Γ⊆Γ')))
  (arr τ∷A τ'∷B)
subΓ (Y x x₁ x₂ x₃) Γ⊆Γ' = Y (⊆Γ-wfΓ' Γ⊆Γ') x₁ x₂ x₃

subᵢΓ (nil wf-Γ) Γ⊆Γ' = nil (⊆Γ-wfΓ' Γ⊆Γ')
subᵢΓ (cons x Γ⊩ₗm∶τ) Γ⊆Γ' = cons (subΓ x Γ⊆Γ') (subᵢΓ Γ⊩ₗm∶τ Γ⊆Γ')

∈-⊆ₗ-trans : ∀ {A τ τᵢ τⱼ} -> τ ∈ τᵢ -> τᵢ ⊆ₗ[ A ] τⱼ -> ∃(λ τ' -> (τ' ∈ τⱼ) × τ ⊆[ A ] τ')
∈-⊆ₗ-trans (here refl) (cons x _) = x
∈-⊆ₗ-trans (there τ∈τᵢ) (cons _ τᵢ⊆τⱼ) = ∈-⊆ₗ-trans τ∈τᵢ τᵢ⊆τⱼ

sub : ∀ {A Γ Γ'} {m : Λ A} {τ τ'} -> Γ ⊩ m ∶ τ -> τ' ⊆[ A ] τ -> Γ ⊆Γ Γ' -> Γ' ⊩ m ∶ τ'
subᵢ : ∀ {A Γ Γ'} {m : Λ A} {τ τ'} -> Γ ⊩ₗ m ∶ τ -> τ' ⊆ₗ[ A ] τ -> Γ ⊆Γ Γ' -> Γ' ⊩ₗ m ∶ τ'

sub (var wf-Γ τᵢ∈Γ τ⊆τᵢ) τ'⊆τ Γ⊆Γ' =
  var (⊆Γ-wfΓ' Γ⊆Γ') τᵢ'∈ (⊆ₗ-trans (⊆ₗ-trans (⊆->⊆ₗ τ'⊆τ) τ⊆τᵢ) τᵢ⊆τᵢ')
  where
  τᵢ'∈ = proj₁ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))
  τᵢ⊆τᵢ' = proj₂ (proj₂ (∈-⊆Γ-trans τᵢ∈Γ Γ⊆Γ'))

sub (app Γ⊩s∶τ₁~>τ₂ Γ⊩ₗt∶τ₁ τ⊆τ₂ τ∷A) τ'⊆τ Γ⊆Γ' = app
  (subΓ Γ⊩s∶τ₁~>τ₂ Γ⊆Γ')
  (subᵢΓ Γ⊩ₗt∶τ₁ Γ⊆Γ')
  (⊆ₗ-trans (⊆->⊆ₗ τ'⊆τ) τ⊆τ₂)
  τ∷A
sub {_} {Γ} {Γ'} (abs {τ = τ} {τ'} L {t} cf τ~>τ'∷A⟶B) (arr {A} {τ₁₁ = τ₁₁} τ⊆τ₁₁ τ₁₂⊆τ' (arr τ₁₁∷A τ₁₂∷B) x₃) Γ⊆Γ' = abs
  (L ++ dom Γ')
  (λ x∉ → subᵢ
    (cf (∉-cons-l _ _ x∉))
    τ₁₂⊆τ'
    (cons (τ₁₁ , (here refl) , τ⊆τ₁₁) (⊆Γ-∷ (∉-cons-r L _ x∉) τ₁₁∷A Γ⊆Γ')))
  (arr τ₁₁∷A τ₁₂∷B)
sub (Y wf-Γ (τ' , τ'∈τ₁ , τ~>τ⊆τ') τ₁∷A⟶A τ₂⊆τ) (arr {τ₁₁ = τ₁'} τ₁⊆τ₁' τ₂'⊆τ₂ (arr ∩τ₁'∷A⟶A τ₂'∷A) x₄) Γ⊆Γ' =
  Y ((⊆Γ-wfΓ' Γ⊆Γ')) (τ'' , (τ''∈τ₁' , ⊆-trans τ~>τ⊆τ' τ'⊆τ'')) ∩τ₁'∷A⟶A (⊆ₗ-trans τ₂'⊆τ₂ τ₂⊆τ)
  where
  τ'' = proj₁ (∈-⊆ₗ-trans τ'∈τ₁ τ₁⊆τ₁')
  τ''∈τ₁' = proj₁ (proj₂ (∈-⊆ₗ-trans τ'∈τ₁ τ₁⊆τ₁'))
  τ'⊆τ'' = proj₂ (proj₂ (∈-⊆ₗ-trans τ'∈τ₁ τ₁⊆τ₁'))

subᵢ Γ⊩ₗm∶τ (nil x) Γ⊆Γ' = nil (⊆Γ-wfΓ' Γ⊆Γ')
subᵢ Γ⊩ₗm∶τᵢ (cons (τ , τ∈τᵢ , τ'⊆τ) τ'ᵢ⊆τᵢ) Γ⊆Γ' with ⊩ₗ-∈-⊩ Γ⊩ₗm∶τᵢ τ∈τᵢ
... | Γ⊩m∶τ = cons (sub Γ⊩m∶τ τ'⊆τ Γ⊆Γ') (subᵢ Γ⊩ₗm∶τᵢ τ'ᵢ⊆τᵢ Γ⊆Γ')

~>∩ : ∀ {X A B C} -> (A ~> B) ∷' X -> (A ~> C) ∷' X ->
  ∩' (A ~> (B ++ C)) ⊆ₗ[ X ] ((A ~> B) ∷ (A ~> C) ∷ [])
~>∩ A~>B∷X A~>C∷X = cons ({!   !} , ({!   !} , {!   !})) (nil (cons A~>B∷X (cons A~>C∷X nil)))

Γ⊩Ym-max : ∀ {A Γ} {m : Λ (A ⟶ A)} {τ} -> Γ ⊩ app (Y A) m ∶ τ -> ∃(λ τ' -> Γ ⊩ m ∶ (τ' ~> τ') × (∩' τ) ⊆ₗ[ A ] τ')
Γ⊩Ym-max {A} {Γ} {m} {τ} (app {τ₁ = τ₁ᵢ~>τ₂ᵢ} {τ'}
  (Y {τ = τ''} wf-Γ (_ , τ₁~>τ₂∈τ₁ᵢ~>τ₂ᵢ , arr {τ₂₁ = τ₁} {τ₂} τ₁⊆τ'' τ''⊆τ₂ τ''~>τ''∷A⟶A (arr τ₁∷A τ₂∷A)) τ₁ᵢ~>τ₂ᵢ∷A⟶A τ'⊆τ'')
  Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ
  τ⊆τ' τ₁ᵢ~>τ₂ᵢ∷A⟶A₂) =
  τ₂ , Γ⊩m∶τ₂~>τ₂ , τ⊆τ₂

  where
  Γ⊆Γ-refl = ⊆Γ-⊆ wf-Γ (λ {x} z → z)
  τ⊆τ'' = ⊆ₗ-trans τ⊆τ' τ'⊆τ''
  τ⊆τ₂ = ⊆ₗ-trans τ⊆τ'' τ''⊆τ₂

  Γ⊩m∶τ₁~>τ₂ : Γ ⊩ m ∶ (τ₁ ~> τ₂)
  Γ⊩m∶τ₁~>τ₂ = ⊩ₗ-∈-⊩ Γ⊩ₗm∶τ₁ᵢ~>τ₂ᵢ τ₁~>τ₂∈τ₁ᵢ~>τ₂ᵢ

  Γ⊩m∶τ₂~>τ₂ : Γ ⊩ m ∶ (τ₂ ~> τ₂)
  Γ⊩m∶τ₂~>τ₂ = sub Γ⊩m∶τ₁~>τ₂ (arr (⊆ₗ-trans τ₁⊆τ'' τ''⊆τ₂) (⊆ₗ-refl τ₂∷A) (arr τ₂∷A τ₂∷A) (arr τ₁∷A τ₂∷A)) Γ⊆Γ-refl

Γ⊩ₗYm-max : ∀ {A Γ} {m : Λ (A ⟶ A)} {τ} -> ¬(τ ≡ ω) -> Γ ⊩ₗ app (Y A) m ∶ τ -> ∃(λ τ' -> Γ ⊩ m ∶ (τ' ~> τ') × τ ⊆ₗ[ A ] τ')
Γ⊩ₗYm-max τ≠ω (nil wf-Γ) = ⊥-elim (τ≠ω refl)
Γ⊩ₗYm-max τ≠ω (cons x (nil wf-Γ)) = Γ⊩Ym-max x
Γ⊩ₗYm-max {A} {Γ} {m} τ≠ω (cons {τ = τ} x (cons {τ = τ₂} {τᵢ} x₁ Γ⊩ₗYm∶τ)) =
  {!   !}
  where
  ih : ∃(λ τ' -> Γ ⊩ m ∶ (τ' ~> τ') × (τ₂ ∷ τᵢ) ⊆ₗ[ A ] τ')
  ih = Γ⊩ₗYm-max {!   !} (cons {τ = τ₂} {τᵢ} x₁ Γ⊩ₗYm∶τ)

  τᵢ' = proj₁ ih
  Γ⊩m∶τᵢ'~>τᵢ' = proj₁ (proj₂ ih)
  τ₂τᵢ⊆τᵢ' = proj₂ (proj₂ ih)

  τ' = proj₁ (Γ⊩Ym-max x)
  Γ⊩m∶τ'~>τ' = proj₁ (proj₂ (Γ⊩Ym-max x))
  τ⊆τ' = proj₂ (proj₂ (Γ⊩Ym-max x))

⊩->β : ∀ {A Γ} {m m' : Λ A} {τ} -> Γ ⊩ m' ∶ τ -> m ->Λβ m' -> Γ ⊩ m ∶ τ
⊩->β Γ⊩m'∶τ (redL x m->βm') = {!   !}
⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
⊩->β {τ = τ} (app Γ⊩m∶[]~>τᵢ (nil wf-Γ) τ⊆τᵢ []∷A) (Y _) = app
  (Y {τ = ∩' τ} {(ω ~> ∩' τ) ∷ []} {∩' τ}
    wf-Γ
    ((ω ~> ∩' τ) , here refl , arr (nil τ∷A) (⊆ₗ-refl τ∷A) (arr τ∷A τ∷A) (arr nil τ∷A))
    (cons (arr []∷A τ∷A) nil)
    (⊆ₗ-refl τ∷A))
  (cons (sub Γ⊩m∶[]~>τᵢ (arr (nil []∷A) τ⊆τᵢ (arr []∷A τ∷A) (arr []∷A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) (⊆Γ-⊆ wf-Γ (λ {x} z → z))) (nil wf-Γ))
  (⊆ₗ-refl τ∷A)
  (cons (arr []∷A τ∷A) nil)

  where
  τ∷A = ⊆ₗ-∷'ₗ-l τ⊆τᵢ

⊩->β {A} {Γ} {τ = τ} (app {s = m} {τ₁ = τ' ∷ τ'ᵢ} {τᵢ} Γ⊩m∶τ'~>τᵢ Γ⊩ₗYm∶τ' τ⊆τᵢ τ'∷A) (Y _) = {!   !}
  where
  Γ⊆Γ-refl = ⊆Γ-⊆ (⊩ₗ-wf-Γ Γ⊩ₗYm∶τ') (λ {x} z → z)

  τ'' = proj₁ (Γ⊩ₗYm-max (λ x → {!   !}) Γ⊩ₗYm∶τ')

  Γ⊩m∶τ''~>τ'' : Γ ⊩ m ∶ (τ'' ~> τ'')
  Γ⊩m∶τ''~>τ'' = proj₁ (proj₂ (Γ⊩ₗYm-max {!   !} Γ⊩ₗYm∶τ'))

  τ'τ'ᵢ⊆τ'' : (τ' ∷ τ'ᵢ) ⊆ₗ[ A ] τ''
  τ'τ'ᵢ⊆τ'' = proj₂ (proj₂ (Γ⊩ₗYm-max {!   !} Γ⊩ₗYm∶τ'))

  Γ⊩m∶τ''~>τᵢ : Γ ⊩ m ∶ (τ'' ~> ∩' τ)
  Γ⊩m∶τ''~>τᵢ = sub Γ⊩m∶τ'~>τᵢ (arr τ'τ'ᵢ⊆τ'' τ⊆τᵢ (arr (⊆ₗ-∷'ₗ-r τ'τ'ᵢ⊆τ'') (⊆ₗ-∷'ₗ-l τ⊆τᵢ)) (arr τ'∷A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) Γ⊆Γ-refl

-- ⊩->β {τ = τ} (app Γ⊩m∶[]~>τᵢ (nil wf-Γ) τ⊆τᵢ []∷A) (Y _) = app
--   (Y {τ = ∩' τ} {(ω ~> ∩' τ) ∷ []} {∩' τ}
--     wf-Γ
--     ((ω ~> ∩' τ) , here refl , arr (nil τ∷A) (⊆ₗ-refl τ∷A) (arr τ∷A τ∷A) (arr nil τ∷A))
--     (cons (arr []∷A τ∷A) nil)
--     (⊆ₗ-refl τ∷A))
--   (cons (sub Γ⊩m∶[]~>τᵢ (arr (nil []∷A) τ⊆τᵢ (arr []∷A τ∷A) (arr []∷A (⊆ₗ-∷'ₗ-r τ⊆τᵢ))) (⊆Γ-⊆ wf-Γ (λ {x} z → z))) (nil wf-Γ))
--   (⊆ₗ-refl τ∷A)
--   (cons (arr []∷A τ∷A) nil)
--
--
-- -- ⊩->β (app {τ₁ = ∩ (τ₁ ∷ τ₁ᵢ)} Γ⊩m∶τ₁ᵢ~>τ₂ (cons (app (Y wf-Γ (proj₁ , () , proj₃) x₁ x₂) (nil wf-Γ₁) τ₁⊆τ₁₂ x₅) Γ⊩Ym∶τ₁ᵢ) τ⊆τ₂ τ₁∷A) (Y x)
-- -- ⊩->β {τ = τ} (app {τ₁ = ∩ (τ₁ ∷ τ₁ᵢ)} {τ₂} Γ⊩m∶τ₁ᵢ~>τ₂ (cons (app {τ₁ = ∩ (τ₁₁ ∷ τ₁₁ᵢ)} {τ₁₂} (Y {τ = τ'} wf-Γ (τ'' , τ''∈ τ₁₁, proj₃) x₁ x₂) (cons Γ⊩m∶τ₁₁ Γ⊩ₗm∶τ₁₁ᵢ) τ₁⊆τ₁₂ x₅) Γ⊩Ym∶τ₁ᵢ) τ⊆τ₂ τ₁∷A) (Y _) =
-- ⊩->β {A} {Γ} {τ = τ} (app {s = m} {τ₁ = ∩ (τ₁ ∷ τ₁ᵢ)} {τ₂}
--   Γ⊩m∶τ₁ᵢτ₁ᵢ~>τ₂
--   (cons
--     (app {τ₁ = ∩ (τ₁₁)} {τ₁₂}
--       (Y {τ = τ'} wf-Γ (_ , τ''∈τ₁₁ , arr {τ₂₁ = τ''₁} {τ''₂} τ''₁⊆τ' τ'⊆τ''₂ τ'~>τ'∷A⟶A (arr τ''₁∷A τ''₂∷A)) τ₁₁∷A⟶A τ₁₂⊆τ')
--       Γ⊩ₗm∶τ₁₁ τ₁⊆τ₁₂ τ₁₁∷A⟶A₂)
--     Γ⊩Ym∶τ₁ᵢ)
--   τ⊆τ₂
--   τ₁∷A) (Y _) =
--   {!   !}
--
--   where
--   Γ⊆Γ-refl = ⊆Γ-⊆ wf-Γ (λ {x} z → z)
--
--   Γ⊩m∶τ''₁~>τ''₂ : Γ ⊩ m ∶ (τ''₁ ~> τ''₂)
--   Γ⊩m∶τ''₁~>τ''₂ = ⊩ₗ-∈-⊩ Γ⊩ₗm∶τ₁₁ τ''∈τ₁₁
--
--   Γ⊩m∶τ''₂~>τ''₂ : Γ ⊩ m ∶ (τ''₂ ~> τ''₂)
--   Γ⊩m∶τ''₂~>τ''₂ = sub Γ⊩m∶τ''₁~>τ''₂ (arr (⊆ₗ-trans τ''₁⊆τ' τ'⊆τ''₂) (⊆ₗ-refl τ''₂∷A) (arr τ''₂∷A τ''₂∷A) (arr τ''₁∷A τ''₂∷A)) Γ⊆Γ-refl
--
--   Γ⊩m∶τ₁~>τ₂ : Γ ⊩ m ∶ (∩' τ₁ ~> τ₂)
--   Γ⊩m∶τ₁~>τ₂ = sub Γ⊩m∶τ₁ᵢτ₁ᵢ~>τ₂ (arr {!   !} {!   !} {!   !} {!   !}) Γ⊆Γ-refl

-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β (app Γ⊩m'∶ω~>τ₂ (nil wf-Γ) τ⊆τ₂ nil) (Y trm-m) = {!   !}
-- ⊩->β (app Γ⊩m∶τ₃τᵢ~>τ₅ (cons _ (app (Y _ τ₂⊆τ₁ τ₁⊆τ) (cons _ Γ⊩m∶τ~>τ₁ (nil wf-Γ)) τ₃⊆τ₂ (cons τ~>τ₁∷A⟶A _)) Γ⊩ₗYm∶∩τᵢ) τ₄⊆τ₅ τ₃τᵢ∷A) (Y trm-m) = {!   !}

-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- -- ⊩->β (app Γ⊩m∶τ₁~>τ (app (Y wf-Γ (arr (arr ::' ::'') ::''') τ≤τ₁ τ₂≤τ₁) Γ⊩m'∶τ₂ x₄) x₅) (Y x₆) = {!   !}
-- ⊩->β (app {s = m} {τ₂ = τ} Γ⊩m∶τ₁~>τ (app {τ₂ = τ₁} (Y {τ = τ₂} {τ₃} wf-Γ (arr (arr τ₂∷A τ₃∷A) _) τ≤τ₁ τ₂≤τ₁) Γ⊩m∶τ₂~>τ₃ _) (arr {A = A} τ₁∷A τ∷A)) (Y x₆) =
--   app {A = A ⟶ A}
--     (Y {_} {A} {∩ (τ₂ ∷ τ₁ ∷ [])} {∩ (τ₃ ∷ τ ∷ [])} {τ}
--       wf-Γ
--       (arr (arr (∩-cons τ₂∷A (∩-cons τ₁∷A ∩-nil)) (∩-cons τ₃∷A (∩-cons τ∷A ∩-nil))) τ∷A)
--       {!   !}
--       (∩-∈ (there (here refl))))
--     {!   !}
--     (arr (arr (∩-cons τ₂∷A (∩-cons τ₁∷A ∩-nil)) (∩-cons τ₃∷A (∩-cons τ∷A ∩-nil))) τ∷A)
--
-- ⊩->β (app Γ⊩m'∶τ (∩-nil ¬Y-shape wf-Γ) x) (Y x₁) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (app Γ⊩m'∶τ (∩-cons ¬Y-shape wf-Γ Γ⊩m'∶τ₁ Γ⊩m'∶τ₂) x) (Y x₁) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (∩-nil ¬Y-shape wf-Γ) (Y x) = ⊥-elim (¬Y-shape intro₂)
-- ⊩->β (∩-cons ¬Y-shape wf-Γ Γ⊩m'∶τ Γ⊩m'∶τ₁) (Y x) = ⊥-elim (¬Y-shape intro₂)

-- ⊩->β Γ⊩m'∶τ (redL trm-n m->βm') = ⊩->β-redL Γ⊩m'∶τ m->βm'
--   where
--   ⊩->β-redL : ∀ {A B Γ} {m m' : Λ (A ⟶ B)} {n : Λ A} {τ} -> Γ ⊩ app m' n ∶ τ -> m ->Λβ m' -> Γ ⊩ app m n ∶ τ
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁ x x₁) (redL x₂ m->Λβm') =
--     app (⊩->β-redL Γ⊩m'n∶τ m->Λβm') Γ⊩m'n∶τ₁ x x₁
--   ⊩->β-redL (∩-nil ¬Y-shape wf-Γ) (redL x m->Λβm') = {!   !}
--   ⊩->β-redL (∩-cons ¬Y-shape wf-Γ Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (redL x m->Λβm') = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (redR x m->Λβm') = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (abs L x) = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (beta x x₁) = {!   !}
--   ⊩->β-redL Γ⊩m'n∶τ (Y x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR trm-m n->βn') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β (app {s = m} {τ₂ = τ} Γ⊩m∶τ₁~>τ (app (Y {_} {_} {τ₂} {τ₃} {τ₁} wf-Γ τ₂∷A τ₃∷A τ₁∷A τ₂≤∩τ₃ τ₁≤∩τ₃) Γ⊩m∶τ₂~>τ₃ x τ₂~>τ₃∷A) (arr {A = A} _ τ∷A) _) (Y trm-m) =
--   -- app {A = A ⟶ A} (Y wf-Γ τ₁∷A τ∷A τ∷A {!   !} {!   !}) Γ⊩m∶τ₁~>τ (arr (arr τ₁∷A τ∷A) τ∷A) (arr τ₁∷A τ∷A)
--   app {A = A ⟶ A}
--     (Y {_} {A} {∩ (τ₁ ∷ τ₂ ∷ τ₃ ∷ [])} {∩ (τ ∷ τ₃ ∷ [])} {τ}
--       wf-Γ
--       {!   !}
--       (∩-cons τ∷A (∩-cons τ₃∷A ∩-nil))
--       τ∷A
--       {!   !}
--       {!   !})
--     {!   !}
--     (arr {!   !} {!   !})
--     {!   !}
--
-- ⊩->β (app Γ⊩m∶τ~>τ' (∩-nil ¬Y-shape wf-Γ) x τ∷A) (Y trm-m) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (app Γ⊩m∶τ~>τ' (∩-cons ¬Y-shape wf-Γ Γ⊩Ym∶τ' Γ⊩Ym∶τ'') x τ∷A) (Y trm-m) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (∩-nil ¬Y-shape wf-Γ) (Y x) = ⊥-elim (¬Y-shape intro₂)
-- ⊩->β (∩-cons ¬Y-shape wf-Γ Γ⊩m'∶τ Γ⊩m'∶τ₁) (Y x) = ⊥-elim (¬Y-shape intro₂)


the bultin pragram fix.

the bultin pragram fix.

module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎

module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC  succ #-}

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎


Refactor UNDEFINED to simplify it (XXX untested)

Instance arguments changed behavior, so not every definition is
available anymore. Hence we can avoid the wrapping.

It typechecks, but not really tested on clients.

-- Allow holes in modules to import, by introducing a single general postulate.

module UNDEFINED where

postulate
  UNDEFINED : ∀ {ℓ} → {T : Set ℓ} → T

-- Allow holes in modules to import, by introducing a single general postulate.

module UNDEFINED where

open import Data.Unit.NonEta using (Hidden)
open import Data.Unit.NonEta public using (reveal)

postulate
  -- If this postulate would produce a T, it could be used as instance argument, triggering many ambiguities.
  -- This postulate is named in capitals because it introduces an inconsistency.
  -- Hence, this must be used through `reveal UNDEFINED`.
  UNDEFINED : ∀ {ℓ} → {T : Set ℓ} → Hidden T


minor changes

minor changes

open import Base

module GoaTest where

data Bool : Type where -- finite type
  true : Bool
  false : Bool

idBool : Bool → Bool -- lambda
idBool x = x

alwaysTrue : Bool → Bool
alwaysTrue x = true

not : Bool → Bool -- case defn
not true = false
not false = true

notnot : Bool → Bool -- lambda
notnot x = not(not(x))

_&_ : Bool → Bool → Bool --curried function
true & x = x
false & _ = false

data ℕ : Type where -- infinite type
  zero : ℕ
  succ : ℕ → ℕ

even : ℕ → Bool -- recursive definition
even zero = true
even (succ x) = not (even x)

_+_ : ℕ → ℕ → ℕ
zero + y = y
succ x + y = x + succ y

{-# BUILTIN NATURAL ℕ #-}

data ℕList : Type where --list type
  [] : ℕList -- empty list
  _::_ : ℕ → ℕList → ℕList -- add number to head of list

mylist : ℕList
mylist = 3 :: (4 :: (2 :: [])) -- the list [3, 4, 2]

data Vector : ℕ → Type where -- type family
  [] : Vector 0
  _::_ : {n : ℕ} → ℕ → Vector n → Vector (succ n)

sum : {n : ℕ} → Vector n → ℕ
sum [] = 0
sum (x :: l) = x + sum l

countdown : (n : ℕ) → Vector n -- dependent function
countdown 0 = []
countdown (succ n) = (succ n) :: (countdown n)

sumToN : ℕ → ℕ -- calculation
sumToN n = sum(countdown n)

data isEven : ℕ → Type where
  0even : isEven 0
  +2even : (n : ℕ) → isEven n → isEven (succ(succ(n)))

4even : isEven 4
4even = +2even _ (+2even _ 0even)

data False : Type where

1odd : isEven 1 → False
1odd ()

3odd : isEven 3 → False
3odd (+2even .1 ())

half : (n : ℕ) → isEven n → ℕ
half .0 0even = 0
half .(succ (succ n)) (+2even n pf) = half n pf

double : (n : ℕ) → ℕ
double 0 = 0
double (succ n) = succ(succ(double(n)))

step : (n : ℕ) → (isEven (double n)) → isEven (double(succ(n)))
step n pf = +2even _ pf

thm : (n  : ℕ) → isEven (double n)
thm zero = 0even
thm (succ n) = step _ (thm n)

halfOfDouble : ℕ → ℕ
halfOfDouble n = half (double n) (thm n)

open import Base

module GoaTest where

data Bool : Type where -- finite type
  true : Bool
  false : Bool

idBool : Bool → Bool -- lambda
idBool x = x

alwaysTrue : Bool → Bool
alwaysTrue x = true

not : Bool → Bool -- case defn
not true = false
not false = true

notnot : Bool → Bool -- lambda
notnot x = not(not(x))

_&_ : Bool → Bool → Bool --curried function
true & x = x
false & _ = false

data ℕ : Type where -- infinite type
  zero : ℕ
  succ : ℕ → ℕ

even : ℕ → Bool -- recursive definition
even zero = true
even (succ x) = not (even x)

_+_ : ℕ → ℕ → ℕ
zero + y = y
succ x + y = x + succ y

{-# BUILTIN NATURAL ℕ #-}

data ℕList : Type where --list type
  [] : ℕList
  _::_ : ℕ → ℕList → ℕList

data Vector : ℕ → Type where -- type family
  [] : Vector 0
  _::_ : {n : ℕ} → ℕ → Vector n → Vector (succ n)

sum : {n : ℕ} → Vector n → ℕ
sum [] = 0
sum (x :: l) = x + sum l

countdown : (n : ℕ) → Vector n -- dependent function
countdown 0 = []
countdown (succ n) = (succ n) :: (countdown n)

sumToN : ℕ → ℕ -- calculation
sumToN n = sum(countdown n)

data isEven : ℕ → Type where
  0even : isEven 0
  +2even : (n : ℕ) → isEven n → isEven (succ(succ(n)))

4even : isEven 4
4even = +2even _ (+2even _ 0even)

data False : Type where

1odd : isEven 1 → False
1odd ()

3odd : isEven 3 → False
3odd (+2even .1 ())

half : (n : ℕ) → isEven n → ℕ
half .0 0even = 0
half .(succ (succ n)) (+2even n pf) = half n pf

double : (n : ℕ) → ℕ
double 0 = 0
double (succ n) = succ(succ(double(n)))

step : (n : ℕ) → (isEven (double n)) → isEven (double(succ(n)))
step n pf = +2even _ pf

thm : (n  : ℕ) → isEven (double n)
thm zero = 0even
thm (succ n) = step _ (thm n)


Clarify comment

Clarify comment

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Standard evaluation (Def. 3.3 and Fig. 4i)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value

module Parametric.Denotation.Evaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality
open import Theorem.CongApp
open import Postulate.Extensionality

-- Extension Point: Evaluation of fully applied constants.
Structure : Set
Structure = ∀ {Σ τ} → Const Σ τ → ⟦ Σ ⟧ → ⟦ τ ⟧

module Structure (⟦_⟧Const : Structure) where
  ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧

  ⟦_⟧Terms : ∀ {Γ Σ} → Terms Γ Σ → ⟦ Γ ⟧ → ⟦ Σ ⟧

  -- We provide: Evaluation of arbitrary terms.
  ⟦ const c args ⟧Term ρ = ⟦ c ⟧Const (⟦ args ⟧Terms ρ)
  ⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
  ⟦ app s t ⟧Term ρ = (⟦ s ⟧Term ρ) (⟦ t ⟧Term ρ)
  ⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)

  -- this is what we'd like to write.
  -- unfortunately termination checker complains.
  --
  --   ⟦ terms ⟧Terms ρ = map (λ t → ⟦ t ⟧Term ρ) terms
  --
  -- so we do explicit pattern matching instead.
  ⟦ ∅ ⟧Terms ρ = ∅
  ⟦ s • terms ⟧Terms ρ = ⟦ s ⟧Term ρ • ⟦ terms ⟧Terms ρ

  meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
  meaningOfTerm = meaning ⟦_⟧Term

  weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
    (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken Γ₁≼Γ₂ t ⟧ ρ ≡ ⟦ t ⟧ (⟦ Γ₁≼Γ₂ ⟧ ρ)

  weaken-terms-sound : ∀ {Γ₁ Γ₂ Σ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
    (terms : Terms Γ₁ Σ) (ρ : ⟦ Γ₂ ⟧) →
    ⟦ weaken-terms Γ₁≼Γ₂ terms ⟧Terms ρ ≡ ⟦ terms ⟧Terms (⟦ Γ₁≼Γ₂ ⟧ ρ)

  weaken-terms-sound ∅ ρ = refl
  weaken-terms-sound (t • terms) ρ =
    cong₂ _•_ (weaken-sound t ρ) (weaken-terms-sound terms ρ)

  weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weaken-var-sound Γ₁≼Γ₂ x ρ
  weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
  weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
  weaken-sound {Γ₁} {Γ₂} {Γ₁≼Γ₂ = Γ₁≼Γ₂} (const {Σ} {τ} c args) ρ =
    cong ⟦ c ⟧Const (weaken-terms-sound args ρ)

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but instead of producing object language terms, we
  -- produce host language terms to take advantage of the richer type system of
  -- the host language (in particular, here we need the unit type, product types
  -- and *existentials*).
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit

  -- A semantics for empty caching semantics
  ⟦_⟧Type2 : (τ : Type) → Set
  ⟦ base ι ⟧Type2 = ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧Type2 = ⟦ σ ⟧Type → (⟦ τ ⟧Type × ⊤)

  open import Level

  {-
  -- Hidden cache semantics, try 1.
  --
  -- Wrong: even the inputs should be extended.
  -- It's just that extension on base values does nothing interesting.

  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache =  ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )
  -- This type would be cooler, but it also places "excessive" requirements on
  -- the object language compared to what we formalize - e.g., unit types.
  --
  --⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Type ] ⟦ τ ⟧Type × ⟦ τ₁ ⟧Type )

  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache
  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → ⊤ , (extend (v x) , tt)

  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v x)))

  -- Wrong type signature:
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = {!!}
  -- Oh. We don't even know what to return without matching on the type. That's
  -- also true in our term transformation: we need to eta-expand also
  -- non-primitives (higher-order arguments) for everything to possibly work.
  -- Hm... or we need to have extended values in the environment - where the extension is again just for functions.
  ⟦_⟧TermCache (var x) ρ = extend (⟦ var x ⟧ ρ)
  -- XXX: this delegates to standard evaluation, I'm not sure whether we should do that.
  -- In fact, we should use our evaluation and select from the result.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧Term ρ)))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache (x • ρ) , tt)

  -- Wrong type definitions: functions get argument of transformed types.
  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = {!!}
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (dropCache (⟦ t ⟧TermCache2 ρ))))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache2 (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache2 ((extend x) • ρ) , tt)
  -}

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  open import Parametric.Syntax.CBPVType as CBPVType
  open CBPVType.Structure Base
  open import Parametric.Syntax.CBPVTerm as CBPVTerm
  open CBPVTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

  ⟦ U c ⟧ValType = ⟦ c ⟧CompType
  ⟦ B ι ⟧ValType = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValType = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType × ⟦ τ₂ ⟧ValType
  ⟦ τ₁ v+ τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType ⊎ ⟦ τ₂ ⟧ValType

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType
  ⟦ τ₁ Π τ₂ ⟧CompType = ⟦ τ₁ ⟧CompType × ⟦ τ₂ ⟧CompType

  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.>
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCacheWrong × τ₁ )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set₁

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = Lift ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCache × τ₁ )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦ τ₁ Π τ₂ ⟧CompTypeHidCache = ⟦ τ₁ ⟧CompTypeHidCache × ⟦ τ₂ ⟧CompTypeHidCache

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set₁
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- Now, let us define a caching semantics for terms.

  -- This proves to be hard, because we need to insert and remove caches where
  -- we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  --
  -- Inserting and removing caches --
  --

  -- Implementation note: The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → , (extend (v (dropCache x)) , tt)

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ

  -- It seems odd (a probable bug?) that the result of t needn't be stripped of
  -- its cache.
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (⟦ t ⟧TermCache2 ρ)))

  -- Provide an empty cache!
  ⟦_⟧TermCache2 (abs t) ρ x = , (⟦ t ⟧TermCache2 (x • ρ) , tt)

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values (where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things)!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cProduce v) ρ = , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)

  -- But if we alter _into_ as described above, composing the caches works!

  ⟦_⟧CompTermCache (v₁ into2 v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cProduce time, we just need the nested into2 to do their job, because as I
  -- said intermediate results are a a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using into2 for the same reasons - which makes
  -- sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into2 case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache2, we don't need to invent an empty cache,
  -- that's moved into the handling of cProduce. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Standard evaluation (Def. 3.3 and Fig. 4i)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value

module Parametric.Denotation.Evaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality
open import Theorem.CongApp
open import Postulate.Extensionality

-- Extension Point: Evaluation of fully applied constants.
Structure : Set
Structure = ∀ {Σ τ} → Const Σ τ → ⟦ Σ ⟧ → ⟦ τ ⟧

module Structure (⟦_⟧Const : Structure) where
  ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧

  ⟦_⟧Terms : ∀ {Γ Σ} → Terms Γ Σ → ⟦ Γ ⟧ → ⟦ Σ ⟧

  -- We provide: Evaluation of arbitrary terms.
  ⟦ const c args ⟧Term ρ = ⟦ c ⟧Const (⟦ args ⟧Terms ρ)
  ⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
  ⟦ app s t ⟧Term ρ = (⟦ s ⟧Term ρ) (⟦ t ⟧Term ρ)
  ⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)

  -- this is what we'd like to write.
  -- unfortunately termination checker complains.
  --
  --   ⟦ terms ⟧Terms ρ = map (λ t → ⟦ t ⟧Term ρ) terms
  --
  -- so we do explicit pattern matching instead.
  ⟦ ∅ ⟧Terms ρ = ∅
  ⟦ s • terms ⟧Terms ρ = ⟦ s ⟧Term ρ • ⟦ terms ⟧Terms ρ

  meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
  meaningOfTerm = meaning ⟦_⟧Term

  weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
    (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken Γ₁≼Γ₂ t ⟧ ρ ≡ ⟦ t ⟧ (⟦ Γ₁≼Γ₂ ⟧ ρ)

  weaken-terms-sound : ∀ {Γ₁ Γ₂ Σ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
    (terms : Terms Γ₁ Σ) (ρ : ⟦ Γ₂ ⟧) →
    ⟦ weaken-terms Γ₁≼Γ₂ terms ⟧Terms ρ ≡ ⟦ terms ⟧Terms (⟦ Γ₁≼Γ₂ ⟧ ρ)

  weaken-terms-sound ∅ ρ = refl
  weaken-terms-sound (t • terms) ρ =
    cong₂ _•_ (weaken-sound t ρ) (weaken-terms-sound terms ρ)

  weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weaken-var-sound Γ₁≼Γ₂ x ρ
  weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
  weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
  weaken-sound {Γ₁} {Γ₂} {Γ₁≼Γ₂ = Γ₁≼Γ₂} (const {Σ} {τ} c args) ρ =
    cong ⟦ c ⟧Const (weaken-terms-sound args ρ)

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but instead of producing object language terms, we
  -- produce host language terms to take advantage of the richer type system of
  -- the host language (in particular, here we need the unit type, product types
  -- and *existentials*).
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit

  -- A semantics for empty caching semantics
  ⟦_⟧Type2 : (τ : Type) → Set
  ⟦ base ι ⟧Type2 = ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧Type2 = ⟦ σ ⟧Type → (⟦ τ ⟧Type × ⊤)

  open import Level

  {-
  -- Hidden cache semantics, try 1.
  --
  -- Wrong: even the inputs should be extended.
  -- It's just that extension on base values does nothing interesting.

  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache =  ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )
  -- This type would be cooler, but it also places "excessive" requirements on
  -- the object language compared to what we formalize - e.g., unit types.
  --
  --⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧Type → (Σ[ τ₁ ∈ Type ] ⟦ τ ⟧Type × ⟦ τ₁ ⟧Type )

  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache
  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → ⊤ , (extend (v x) , tt)

  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v x)))

  -- Wrong type signature:
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = {!!}
  -- Oh. We don't even know what to return without matching on the type. That's
  -- also true in our term transformation: we need to eta-expand also
  -- non-primitives (higher-order arguments) for everything to possibly work.
  -- Hm... or we need to have extended values in the environment - where the extension is again just for functions.
  ⟦_⟧TermCache (var x) ρ = extend (⟦ var x ⟧ ρ)
  -- XXX: this delegates to standard evaluation, I'm not sure whether we should do that.
  -- In fact, we should use our evaluation and select from the result.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧Term ρ)))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache (x • ρ) , tt)

  -- Wrong type definitions: functions get argument of transformed types.
  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = {!!}
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (dropCache (⟦ t ⟧TermCache2 ρ))))
  -- Provide an empty cache :-)!
  ⟦_⟧TermCache2 (abs t) ρ x = ⊤ , (⟦ t ⟧TermCache2 ((extend x) • ρ) , tt)
  -}

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  open import Parametric.Syntax.CBPVType as CBPVType
  open CBPVType.Structure Base
  open import Parametric.Syntax.CBPVTerm as CBPVTerm
  open CBPVTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

  ⟦ U c ⟧ValType = ⟦ c ⟧CompType
  ⟦ B ι ⟧ValType = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValType = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType × ⟦ τ₂ ⟧ValType
  ⟦ τ₁ v+ τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType ⊎ ⟦ τ₂ ⟧ValType

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType
  ⟦ τ₁ Π τ₂ ⟧CompType = ⟦ τ₁ ⟧CompType × ⟦ τ₂ ⟧CompType

  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.>
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCacheWrong × τ₁ )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set₁

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = Lift ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = Lift Unit
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCache × τ₁ )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦ τ₁ Π τ₂ ⟧CompTypeHidCache = ⟦ τ₁ ⟧CompTypeHidCache × ⟦ τ₂ ⟧CompTypeHidCache

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set₁
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- Now, let us define a caching semantics for terms.

  -- This proves to be hard, because we need to insert and remove caches where
  -- we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  --
  -- Inserting and removing caches --
  --

  -- Implementation note: The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → , (extend (v (dropCache x)) , tt)

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache2 : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache2 (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache2 (var x) ρ = ⟦ x ⟧VarHidCache ρ

  -- It seems odd (a probable bug?) that the result of t needn't be stripped of
  -- its cache.
  ⟦_⟧TermCache2 (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache2 ρ) (⟦ t ⟧TermCache2 ρ)))

  -- Provide an empty cache!
  ⟦_⟧TermCache2 (abs t) ρ x = , (⟦ t ⟧TermCache2 (x • ρ) , tt)

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values (where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things)!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cProduce v) ρ = , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)

  -- But if we alter _into_ as described above, composing the caches works!

  ⟦_⟧CompTermCache (v₁ into2 v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cProduce time, we just need the nested into2 to do their job, because as I
  -- said intermediate results are a a writer monad. But then, do we still need
  -- to do all the other stuff? IOW, do we still need to forbid (λ x . y <- f
  -- args; g args') and replace it with (λ x . y <- f args; z <- g args'; z)?
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as we don't do (a, b) but
  -- append a b (ahem, where?).

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache2, we don't need to invent an empty cache,
  -- that's moved into the handling of cProduce. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)