Added a simpler way of constructing syntax for the linear solver.

module linear-solver where

open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as F using (Fin)
import Data.Fin.Props as FP

module Syntax {a} (A : Set a)(_x_ : A → A → A)(T : A)
  (R' : A → A → Set)
  (id' : ∀ {A} → R' A A)
  (_∻'_ : ∀ {A B C} → R' A B → R' B C → R' A C)
  (<id,tt>' : ∀ {A} → R' (A x T) A)
  (<id,tt>⁻¹' : ∀ {A} → R' A (A x T))
  (<tt,id>' : ∀ {A} → R' (T x A) A)
  (<tt,id>⁻¹' : ∀ {A} → R' A (T x A))
  (⟨_×'_⟩   : ∀ {A B C D} → R' A C → R' B D → R' (A x B) (C x D))
  (first'    : ∀ {A B C} → R' A B → R' (A x C) (B x C))
  (second'   : ∀ {A B C} → R' B C → R' (A x B) (A x C))
  (assoc'   : ∀ {A B C} → R' (A x (B x C)) ((A x B) x C))
  (assoc⁻¹' : ∀ {A B C} → R' ((A x B) x C) (A x (B x C)))
  (swap'    : ∀ {A B}   → R' (A x B) (B x A))
  nrVars (!_ : Fin nrVars → A) where

  Var = Fin nrVars

  open import Relation.Nullary using (yes ; no)
  open import Relation.Nullary.Decidable

  data Syn : Set where
   var : Var → Syn
   tt  : Syn
   _,_ : Syn → Syn → Syn

  #_ : ∀ m {m<n : True (ℕ.suc m ℕ.≤? nrVars)} → Syn
  #_ m {p} = var (F.#_ m {nrVars} {p})

  eval : Syn → A
  eval (var x) = ! x
  eval tt = T
  eval (s , s₁) = eval s x eval s₁

  data R : Syn → Syn → Set where
    _∻''_ : ∀ {A B C} → R A B → R B C → R A C
    <id,tt> : ∀ {A} → R (A , tt) A
    <tt,id> : ∀ {A} → R (tt , A) A
    <tt,id>⁻¹ : ∀ {A} → R A (tt , A)
    <id,tt>⁻¹ : ∀ {A} → R A (A , tt)
    ⟨_×''_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    id : ∀ {A} → R A A
    swap : ∀ {A B} → R (A , B) (B , A)

  ⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  ⟨ id × id ⟩ = id
  ⟨ r₁ × r₂ ⟩ = ⟨ r₁ ×'' r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  id ∻ r₂ = r₂
  r₁ ∻ id = r₁
  <tt,id>⁻¹ ∻ <tt,id> = id
  <id,tt>⁻¹ ∻ <id,tt> = id
  <tt,id> ∻ <tt,id>⁻¹ = id
  <id,tt> ∻ <id,tt>⁻¹ = id
  swap ∻ <id,tt> = <tt,id>
  swap ∻ <tt,id> = <id,tt>
  <id,tt>⁻¹ ∻ swap = <tt,id>⁻¹
  <tt,id>⁻¹ ∻ swap = <id,tt>⁻¹
  assoc ∻ assoc⁻¹ = id
  assoc ∻ (assoc⁻¹ ∻'' r) = r
  assoc⁻¹ ∻ assoc = id
  assoc⁻¹ ∻ (assoc ∻'' r) = r
  swap ∻ swap = id
  swap ∻ (swap ∻'' r) = r
  (r₁ ∻'' r₂) ∻ r₃ = r₁ ∻ (r₂ ∻ r₃)
  ⟨ r₁ ×'' r₂ ⟩ ∻ ⟨ r₃ ×'' r₄ ⟩ = ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ⟨ r₁ ×'' r₂ ⟩ ∻ (⟨ r₃ ×'' r₄ ⟩ ∻'' r₅) with ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ... | id = r₅
  ... | r₆ = r₆ ∻'' r₅
  r₁ ∻ r₂ = r₁ ∻'' r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ∻'' r₁) = sym r₁ ∻ sym r
  sym <id,tt> = <id,tt>⁻¹
  sym <tt,id> = <tt,id>⁻¹
  sym <id,tt>⁻¹ = <id,tt>
  sym <tt,id>⁻¹ = <tt,id>
  sym ⟨ r ×'' r₁ ⟩ = ⟨ sym r × sym r₁ ⟩
  sym assoc = assoc⁻¹
  sym assoc⁻¹ = assoc
  sym id = id
  sym swap = swap

  proof₁ : ∀ {S S'} → R S S' → R' (eval S) (eval S')
  proof₁ (r ∻'' r₁) = proof₁ r ∻' proof₁ r₁
  proof₁ <id,tt> = <id,tt>'
  proof₁ <tt,id> = <tt,id>'
  proof₁ <id,tt>⁻¹ = <id,tt>⁻¹'
  proof₁ <tt,id>⁻¹ = <tt,id>⁻¹'
  proof₁ ⟨ id ×'' r ⟩ = second' (proof₁ r)
  proof₁ ⟨ r ×'' id ⟩ = first'  (proof₁ r)
  proof₁ ⟨ r ×'' r₁ ⟩ = ⟨ proof₁ r ×' proof₁ r₁ ⟩
  proof₁ assoc = assoc'
  proof₁ assoc⁻¹ = assoc⁻¹'
  proof₁ id = id'
  proof₁ swap = swap'

  proof₂ : ∀ {S S'} → R S S' → R' (eval S') (eval S)
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set where
    tt : NF tt
    var : (x : Var) → NF (var x)
    var_::_ : ∀ {S}(i : Var) → NF S → NF (var i , S)

  record NFP S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ <tt,id>⁻¹
  merge (var i) n2 = (var i :: n2) ⊢ id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ id
  norm tt = tt ⊢ id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 × p2 ⟩)

  insert : ∀ {S} → (x : Var) → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ <id,tt>⁻¹
  insert y (var i) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: var i) ⊢ id
  ... | no  _ = (var i :: var y) ⊢ swap
  insert y (var i :: n1) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: (var i :: n1)) ⊢ id
  ... | no  _ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ (assoc ∻ (⟨ swap × id ⟩ ∻ assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ id
  sort (var i) = var i ⊢ id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ id × p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
  open import Relation.Nullary

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = id

  _≢_ : ∀ {A : Set} → A → A → Set
  x ≢ y = x ≡ y → Data.Empty.⊥

  ≢-cong : ∀ {A B}{x y : A}(f : A → B) → f x ≢ f y → x ≢ y
  ≢-cong f fr refl = fr refl

  var-inj : ∀ {i j : Fin nrVars} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x FP.≟ x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = Data.Empty.⊥

  rewire : (S₁ S₂ : Syn) → CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire s₁ s₂ eq with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire _ _ () | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

  infix 4 _⇛_

  record Eq : Set where
    constructor _⇛_
    field
      LHS RHS : Syn

  open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
  open import Data.Vec using (allFin) renaming (map to vmap)

  rewire' : (f : N-ary nrVars Syn Eq) → let (S₁ ⇛ S₂) = f $ⁿ (vmap Syn.var (allFin nrVars))
          in CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire' f eq = let S ⇛ S' = f $ⁿ vmap Syn.var (allFin  nrVars)
         in rewire S S' eq

module example where

  open import Data.Vec

  open import Data.Product
  open import Data.Unit

  open import Function

  -- need to etaexpand this because otherwise we get an error
  module STest n M = Syntax Set _×_ ⊤ (λ x x₁ → x → x₁) (λ x → x)
         (λ x x₁ x₂ → x₁ (x x₂)) (λ x → proj₁ x) (λ x → x , tt)
         (λ x → proj₂ x) (λ x → tt , x) (λ x x₁ x₂ → (x (proj₁ x₂)) , (x₁ (proj₂ x₂)))
         (λ x x₁ → (x (proj₁ x₁)) , (proj₂ x₁)) (λ x x₁ → (proj₁ x₁) , (x (proj₂ x₁)))
         (λ x → ((proj₁ x) , (proj₁ (proj₂ x))) , (proj₂ (proj₂ x)))
         (λ x → (proj₁ (proj₁ x)) , ((proj₂ (proj₁ x)) , (proj₂ x)))
         (λ x → (proj₂ x) , (proj₁ x)) n M

  test : (A B C : Set) → (A × B) × C → (B × A) × C
  test A B C = rewire LHS RHS _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

    LHS = (# 0 , # 1) , # 2
    RHS = (# 1 , # 0) , # 2

  test2 : (A B C : Set) → (A × B) × C → (B × A) × C
  test2 A B C = rewire' (λ a b c → (a , b) , c ⇛ (b , a) , c) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module example₂ where

  open import Data.Vec

  data Ty : Set where
    _×_ : Ty → Ty → Ty
    ⊤ : Ty

  infix 4 _⟶_

  data _⟶_ : Ty → Ty → Set where
    id' : ∀ {A} → A ⟶ A
    _∻'_ : ∀ {A B C} → A ⟶ B → B ⟶ C → A ⟶ C
    <id,tt>' : ∀ {A} → (A × ⊤) ⟶ A
    <id,tt>⁻¹' : ∀ {A} → A ⟶ (A × ⊤)
    <tt,id>' : ∀ {A} → (⊤ × A) ⟶ A
    <tt,id>⁻¹' : ∀ {A} → A ⟶ (⊤ × A)
    ⟨_×'_⟩   : ∀ {A B C D} → A ⟶ C → B ⟶ D → (A × B) ⟶ (C × D)
    first    : ∀ {A B C} → A ⟶ B → A × C ⟶ B × C
    second   : ∀ {A B C} → B ⟶ C → A × B ⟶ A × C
    assoc'   : ∀ {A B C} → (A × (B × C)) ⟶ ((A × B) × C)
    assoc⁻¹' : ∀ {A B C} → ((A × B) × C) ⟶ (A × (B × C))
    swap'    : ∀ {A B}   → (A × B) ⟶ (B × A)

  module STest n M = Syntax Ty _×_ ⊤ _⟶_ id' _∻'_ <id,tt>' <id,tt>⁻¹' <tt,id>' <tt,id>⁻¹' ⟨_×'_⟩ first second assoc' assoc⁻¹' swap' n M

  test2 : (A B C : Ty) → (A × B) × C ⟶  (B × A) × C
  test2 A B C = rewire ((# 0 , # 1) , # 2) ((# 1 , # 0) , # 2) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module linear-solver where

open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as F using (Fin)
import Data.Fin.Props as FP

module Syntax {a} (A : Set a)(_x_ : A → A → A)(T : A)
  (R' : A → A → Set)
  (id' : ∀ {A} → R' A A)
  (_∻'_ : ∀ {A B C} → R' A B → R' B C → R' A C)
  (<id,tt>' : ∀ {A} → R' (A x T) A)
  (<id,tt>⁻¹' : ∀ {A} → R' A (A x T))
  (<tt,id>' : ∀ {A} → R' (T x A) A)
  (<tt,id>⁻¹' : ∀ {A} → R' A (T x A))
  (⟨_×'_⟩   : ∀ {A B C D} → R' A C → R' B D → R' (A x B) (C x D))
  (first'    : ∀ {A B C} → R' A B → R' (A x C) (B x C))
  (second'   : ∀ {A B C} → R' B C → R' (A x B) (A x C))
  (assoc'   : ∀ {A B C} → R' (A x (B x C)) ((A x B) x C))
  (assoc⁻¹' : ∀ {A B C} → R' ((A x B) x C) (A x (B x C)))
  (swap'    : ∀ {A B}   → R' (A x B) (B x A))
  nrVars (!_ : Fin nrVars → A) where

  Var = Fin nrVars

  open import Relation.Nullary using (yes ; no)
  open import Relation.Nullary.Decidable

  data Syn : Set where
   var : Var → Syn
   tt  : Syn
   _,_ : Syn → Syn → Syn

  #_ : ∀ m {m<n : True (ℕ.suc m ℕ.≤? nrVars)} → Syn
  #_ m {p} = var (F.#_ m {nrVars} {p})

  eval : Syn → A
  eval (var x) = ! x
  eval tt = T
  eval (s , s₁) = eval s x eval s₁

  data R : Syn → Syn → Set where
    _∻''_ : ∀ {A B C} → R A B → R B C → R A C
    <id,tt> : ∀ {A} → R (A , tt) A
    <tt,id> : ∀ {A} → R (tt , A) A
    <tt,id>⁻¹ : ∀ {A} → R A (tt , A)
    <id,tt>⁻¹ : ∀ {A} → R A (A , tt)
    ⟨_×''_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    id : ∀ {A} → R A A
    swap : ∀ {A B} → R (A , B) (B , A)

  ⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  ⟨ id × id ⟩ = id
  ⟨ r₁ × r₂ ⟩ = ⟨ r₁ ×'' r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  id ∻ r₂ = r₂
  r₁ ∻ id = r₁
  <tt,id>⁻¹ ∻ <tt,id> = id
  <id,tt>⁻¹ ∻ <id,tt> = id
  <tt,id> ∻ <tt,id>⁻¹ = id
  <id,tt> ∻ <id,tt>⁻¹ = id
  swap ∻ <id,tt> = <tt,id>
  swap ∻ <tt,id> = <id,tt>
  <id,tt>⁻¹ ∻ swap = <tt,id>⁻¹
  <tt,id>⁻¹ ∻ swap = <id,tt>⁻¹
  assoc ∻ assoc⁻¹ = id
  assoc ∻ (assoc⁻¹ ∻'' r) = r
  assoc⁻¹ ∻ assoc = id
  assoc⁻¹ ∻ (assoc ∻'' r) = r
  swap ∻ swap = id
  swap ∻ (swap ∻'' r) = r
  (r₁ ∻'' r₂) ∻ r₃ = r₁ ∻ (r₂ ∻ r₃)
  ⟨ r₁ ×'' r₂ ⟩ ∻ ⟨ r₃ ×'' r₄ ⟩ = ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ⟨ r₁ ×'' r₂ ⟩ ∻ (⟨ r₃ ×'' r₄ ⟩ ∻'' r₅) with ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ... | id = r₅
  ... | r₆ = r₆ ∻'' r₅
  r₁ ∻ r₂ = r₁ ∻'' r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ∻'' r₁) = sym r₁ ∻ sym r
  sym <id,tt> = <id,tt>⁻¹
  sym <tt,id> = <tt,id>⁻¹
  sym <id,tt>⁻¹ = <id,tt>
  sym <tt,id>⁻¹ = <tt,id>
  sym ⟨ r ×'' r₁ ⟩ = ⟨ sym r × sym r₁ ⟩
  sym assoc = assoc⁻¹
  sym assoc⁻¹ = assoc
  sym id = id
  sym swap = swap

  proof₁ : ∀ {S S'} → R S S' → R' (eval S) (eval S')
  proof₁ (r ∻'' r₁) = proof₁ r ∻' proof₁ r₁
  proof₁ <id,tt> = <id,tt>'
  proof₁ <tt,id> = <tt,id>'
  proof₁ <id,tt>⁻¹ = <id,tt>⁻¹'
  proof₁ <tt,id>⁻¹ = <tt,id>⁻¹'
  proof₁ ⟨ id ×'' r ⟩ = second' (proof₁ r)
  proof₁ ⟨ r ×'' id ⟩ = first'  (proof₁ r)
  proof₁ ⟨ r ×'' r₁ ⟩ = ⟨ proof₁ r ×' proof₁ r₁ ⟩
  proof₁ assoc = assoc'
  proof₁ assoc⁻¹ = assoc⁻¹'
  proof₁ id = id'
  proof₁ swap = swap'

  proof₂ : ∀ {S S'} → R S S' → R' (eval S') (eval S)
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set where
    tt : NF tt
    var : (x : Var) → NF (var x)
    var_::_ : ∀ {S}(i : Var) → NF S → NF (var i , S)

  record NFP S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ <tt,id>⁻¹
  merge (var i) n2 = (var i :: n2) ⊢ id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ id
  norm tt = tt ⊢ id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 × p2 ⟩)

  insert : ∀ {S} → (x : Var) → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ <id,tt>⁻¹
  insert y (var i) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: var i) ⊢ id
  ... | no  _ = (var i :: var y) ⊢ swap
  insert y (var i :: n1) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: (var i :: n1)) ⊢ id
  ... | no  _ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ (assoc ∻ (⟨ swap × id ⟩ ∻ assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ id
  sort (var i) = var i ⊢ id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ id × p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
  open import Relation.Nullary

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = id

  _≢_ : ∀ {A : Set} → A → A → Set
  x ≢ y = x ≡ y → Data.Empty.⊥

  ≢-cong : ∀ {A B}{x y : A}(f : A → B) → f x ≢ f y → x ≢ y
  ≢-cong f fr refl = fr refl

  var-inj : ∀ {i j : Fin nrVars} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x FP.≟ x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = Data.Empty.⊥

  rewire : (S₁ S₂ : Syn) → CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire s₁ s₂ eq with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire _ _ () | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

module example where

  open import Data.Vec

  open import Data.Product
  open import Data.Unit

  open import Function

  -- need to etaexpand this because otherwise we get an error
  module STest n M = Syntax Set _×_ ⊤ (λ x x₁ → x → x₁) (λ x → x)
         (λ x x₁ x₂ → x₁ (x x₂)) (λ x → proj₁ x) (λ x → x , tt)
         (λ x → proj₂ x) (λ x → tt , x) (λ x x₁ x₂ → (x (proj₁ x₂)) , (x₁ (proj₂ x₂)))
         (λ x x₁ → (x (proj₁ x₁)) , (proj₂ x₁)) (λ x x₁ → (proj₁ x₁) , (x (proj₂ x₁)))
         (λ x → ((proj₁ x) , (proj₁ (proj₂ x))) , (proj₂ (proj₂ x)))
         (λ x → (proj₁ (proj₁ x)) , ((proj₂ (proj₁ x)) , (proj₂ x)))
         (λ x → (proj₂ x) , (proj₁ x)) n M

  test : (A B C : Set) → (A × B) × C → (B × A) × C
  test A B C = rewire LHS RHS _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

    LHS = (# 0 , # 1) , # 2
    RHS = (# 1 , # 0) , # 2

module example₂ where

  open import Data.Vec

  data Ty : Set where
    _×_ : Ty → Ty → Ty
    ⊤ : Ty

  infix 4 _⟶_

  data _⟶_ : Ty → Ty → Set where
    id' : ∀ {A} → A ⟶ A
    _∻'_ : ∀ {A B C} → A ⟶ B → B ⟶ C → A ⟶ C
    <id,tt>' : ∀ {A} → (A × ⊤) ⟶ A
    <id,tt>⁻¹' : ∀ {A} → A ⟶ (A × ⊤)
    <tt,id>' : ∀ {A} → (⊤ × A) ⟶ A
    <tt,id>⁻¹' : ∀ {A} → A ⟶ (⊤ × A)
    ⟨_×'_⟩   : ∀ {A B C D} → A ⟶ C → B ⟶ D → (A × B) ⟶ (C × D)
    first    : ∀ {A B C} → A ⟶ B → A × C ⟶ B × C
    second   : ∀ {A B C} → B ⟶ C → A × B ⟶ A × C
    assoc'   : ∀ {A B C} → (A × (B × C)) ⟶ ((A × B) × C)
    assoc⁻¹' : ∀ {A B C} → ((A × B) × C) ⟶ (A × (B × C))
    swap'    : ∀ {A B}   → (A × B) ⟶ (B × A)

  module STest n M = Syntax Ty _×_ ⊤ _⟶_ id' _∻'_ <id,tt>' <id,tt>⁻¹' <tt,id>' <tt,id>⁻¹' ⟨_×'_⟩ first second assoc' assoc⁻¹' swap' n M

  test2 : (A B C : Ty) → (A × B) × C ⟶  (B × A) × C
  test2 A B C = rewire ((# 0 , # 1) , # 2) ((# 1 , # 0) , # 2) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))


Avoiding bug "undefined", changing Zq to BigI

{-# OPTIONS --without-K #-}
module ZK.JSChecker where

open import Function         using (id; _∘′_; case_of_)
open import Data.Bool.Base   using (Bool; true; false; _∧_)
open import Data.List.Base   using (List; []; _∷_; and; foldr)
open import Data.String.Base using (String)

open import FFI.JS
  hiding (check)
  renaming (_*_ to _*Number_)
-- open import FFI.JS.Proc using (URI; JSProc; showURI; server)
-- open import Control.Process.Type
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS

import FiniteField.JS as 𝔽

import FFI.JS.BigI as BigI
open BigI using (BigI; bigI)

-- trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
-- trace _ inp f = f inp

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

-- TODO bug (undefined)!
record ZK-chaum-pedersen-pok-elgamal-rnd {--(ℤq ℤp★ : Set)--} : Set where
  field
    m c s : BigI {--ℤq--}
    g p q y α β A B : BigI --ℤp★

-- TODO dynamise me
t : Number
t = readNumber "10"

-- TODO: check if this is large enough
min-bits-q : Number
min-bits-q = 256N

min-bits-p : Number
min-bits-p = 2048N

check : (title  : String)
        (pred   : Bool)
        (errmsg : 𝟙 → String)
     → JS!
check title true  errmsg = Console.log (title ++ ": PASS")
check title false errmsg = Console.log (title ++ ": FAIL [" ++ errmsg _ ++ "]")

check-size : Number → String → BigI → JS!
check-size min-bits name value =
  check ("check size of " ++ name)
        (len ≥Number min-bits)
        (λ _ → name ++ " is not a necessarily a safe prime: "
             ++ BigI.toString value    ++ " has "
             ++ Number▹String len      ++ " bits which is less than "
             ++ Number▹String min-bits ++ " bits")
  module Check-size where
    len = BigI.byteLength value *Number 8N

check-pq-relation : (p q : BigI) → JS!
check-pq-relation p q =
  check ("check p and q relation p-1/q=" ++ BigI.toString s)
        (equals r 0I)
        (λ _ → "Not necessarily a safe group: (p-1) mod q != 0\np="
             ++ BigI.toString p
             ++ ", q=" ++ BigI.toString q)
  module Check-pq-relation where
    open BigI
    p-1 = subtract p 1I
    r   = mod    p-1 q
    s   = divide p-1 q

check-primality : String → BigI → JS!
check-primality name value =
  check ("check primality of " ++ name)
        (BigI.isProbablePrime value t)
        (λ _ → "Not a prime number: " ++ BigI.toString value)

check-generator-group-order : (g q p : BigI) → JS!
check-generator-group-order g q p =
  check "check generator & group order"
        (BigI.equals (BigI.modPow g q p) BigI.1I)
        (λ _ → "Not a generator of a group of order q: modPow "
             ++ BigI.toString g ++ " " ++ BigI.toString q ++ " "
             ++ BigI.toString p)

module [ℤq]ℤp★ (qI pI gI : BigI) where

  checks : JS!
  checks =
    check-pq-relation      pI qI >>
    check-size min-bits-q "q" qI >>
    check-size min-bits-p "p" pI >>
    check-primality       "q" qI >>
    check-primality       "p" pI >>
    check-generator-group-order gI qI pI

  module ℤq = 𝔽 qI
    using (0#; 1#; _+_; _−_; _*_; _/_)
    renaming (𝔽 to ℤq; fromBigI to BigI▹ℤq; repr to ℤq-repr)
  module ℤp★ = 𝔽 pI
    using (_==_)
    renaming ( fromBigI to BigI▹ℤp★; 𝔽 to ℤp★; _*_ to _·_
             ; repr to ℤp★-repr; _/_ to _·/_)

  open ℤq  -- public -- <- BUG
  open ℤp★ public

  g : ℤp★
  g = BigI▹ℤp★ gI

  _^_ : ℤp★ → ℤq → ℤp★
  b ^ e = BigI▹ℤp★ (BigI.modPow (ℤp★-repr b) (ℤq-repr e) pI)

zk-check-chaum-pedersen-pok-elgamal-rnd : ZK-chaum-pedersen-pok-elgamal-rnd {-BigI BigI-} → JS!
zk-check-chaum-pedersen-pok-elgamal-rnd pf
      = trace "g=" g λ _ →
        trace "p=" I.p λ _ →
        trace "q=" I.q λ _ →
        trace "y=" y λ _ →
        trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
         checks
      >> check "g^s==A·α^c"     ((g ^ s) == (A · (α ^ c)))        (λ _ → "")
      >> check "y^s==B·(β/M)^c" ((y ^ s) == (B · ((β ·/ M) ^ c))) (λ _ → "")
  module ZK-check-chaum-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    open module IM = [ℤq]ℤp★ I.q I.p I.g
    open ℤq
--  open ℤp★ -- <- BUG
    A = BigI▹ℤp★ I.A
    B = BigI▹ℤp★ I.B
    α = BigI▹ℤp★ I.α
    β = BigI▹ℤp★ I.β
    y = BigI▹ℤp★ I.y
    s = BigI▹ℤq  I.s
    c = BigI▹ℤq  I.c
    m = BigI▹ℤq  I.m
    M = g ^ m

zk-check : JSValue → JS!
zk-check arg =
    check "type of statement" (typ === fromString "chaum-pedersen-pok-elgamal-rnd")
                              (λ _ → "")
 >> zk-check-chaum-pedersen-pok-elgamal-rnd pok
 module Zk-check where
    stm = arg ·« "statement" »
    typ = stm ·« "type" »
    dat = stm ·« "data" »
    g   = bigdec (dat ·« "g" »)
    p   = bigdec (dat ·« "p" »)
    q   = bigdec (dat ·« "q" »)
    y   = bigdec (dat ·« "y" »)
    m   = bigdec (dat ·« "plain" »)
    enc = dat ·« "enc" »
    α   = bigdec (enc ·« "alpha" »)
    β   = bigdec (enc ·« "beta"  »)
    prf = arg ·« "proof" »
    com = prf ·« "commitment" »
    A   = bigdec (com ·« "A" »)
    B   = bigdec (com ·« "B" »)
    c   = bigdec (prf ·« "challenge" »)
    s   = bigdec (prf ·« "response" »)
    pok = record { g = g; p = p; q = q; y = y; α = α; β = β; A = A; B = B; c = c; s = s; m = m }

{-
srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (zk-check q))
  end
-}

-- Working around Agda.Primitive.lsuc being undefined
-- case_of_ : {A : Set} {B : Set} → A → (A → B) → B
-- case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
        Console.log "usage: No arguments"
        {- server "127.0.0.1" "1337" srv !₁ λ uri →
           Console.log (showURI uri)
         -}
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              FS.readFile arg nullJS !₂ λ err dat →
                check "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check (JSON-parse (castString dat))
          ; _ →
              Console.log "usage: Too many arguments"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module ZK.JSChecker where

open import Function         using (id; _∘′_; case_of_)
open import Data.Bool.Base   using (Bool; true; false; _∧_)
open import Data.List.Base   using (List; []; _∷_; and; foldr)
open import Data.String.Base using (String)

open import FFI.JS
  hiding (check; trace)
  renaming (_*_ to _*Number_)
-- open import FFI.JS.Proc using (URI; JSProc; showURI; server)
-- open import Control.Process.Type
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS

import FiniteField.JS as 𝔽

import FFI.JS.BigI as BigI
open BigI using (BigI; bigI)

trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
trace _ inp f = f inp

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

record ZK-chaum-pedersen-pok-elgamal-rnd (ℤq ℤp★ : Set) : Set where
  field
    m c s : ℤq
    g p q y α β A B : ℤp★

-- TODO dynamise me
t : Number
t = readNumber "10"

-- TODO: check if this is large enough
min-bits-q : Number
min-bits-q = 256N

min-bits-p : Number
min-bits-p = 2048N

check : (title  : String)
        (pred   : Bool)
        (errmsg : 𝟙 → String)
     → JS!
check title true  errmsg = Console.log (title ++ ": PASS")
check title false errmsg = Console.log (title ++ ": FAIL [" ++ errmsg _ ++ "]")

check-size : Number → String → BigI → JS!
check-size min-bits name value =
  check ("check size of " ++ name)
        (len ≥Number min-bits)
        (λ _ → name ++ " is not a necessarily a safe prime: "
             ++ BigI.toString value    ++ " has "
             ++ Number▹String len      ++ " bits which is less than "
             ++ Number▹String min-bits ++ " bits")
  module Check-size where
    len = BigI.byteLength value *Number 8N

check-pq-relation : (p q : BigI) → JS!
check-pq-relation p q =
  check ("check p and q relation p-1/q=" ++ BigI.toString s)
        (equals r 0I)
        (λ _ → "Not necessarily a safe group: (p-1) mod q != 0\np="
             ++ BigI.toString p
             ++ ", q=" ++ BigI.toString q)
  module Check-pq-relation where
    open BigI
    p-1 = subtract p 1I
    r   = mod    p-1 q
    s   = divide p-1 q

check-primality : String → BigI → JS!
check-primality name value =
  check ("check primality of " ++ name)
        (BigI.isProbablePrime value t)
        (λ _ → "Not a prime number: " ++ BigI.toString value)

check-generator-group-order : (g q p : BigI) → JS!
check-generator-group-order g q p =
  check "check generator & group order"
        (BigI.equals (BigI.modPow g q p) BigI.1I)
        (λ _ → "Not a generator of a group of order q: modPow "
             ++ BigI.toString g ++ " " ++ BigI.toString q ++ " "
             ++ BigI.toString p)

module [ℤq]ℤp★ (qI pI gI : BigI) where

  checks : JS!
  checks =
    check-pq-relation      pI qI >>
    check-size min-bits-q "q" qI >>
    check-size min-bits-p "p" pI >>
    check-primality       "q" qI >>
    check-primality       "p" pI >>
    check-generator-group-order gI qI pI

  module ℤq = 𝔽 qI
    using (0#; 1#; _+_; _−_; _*_; _/_)
    renaming (𝔽 to ℤq; fromBigI to BigI▹ℤq; repr to ℤq-repr)
  module ℤp★ = 𝔽 pI
    using (_==_)
    renaming ( fromBigI to BigI▹ℤp★; 𝔽 to ℤp★; _*_ to _·_
             ; repr to ℤp★-repr; _/_ to _·/_)

  open ℤq  -- public -- <- BUG
  open ℤp★ public

  g : ℤp★
  g = BigI▹ℤp★ gI

  _^_ : ℤp★ → ℤq → ℤp★
  b ^ e = BigI▹ℤp★ (BigI.modPow (ℤp★-repr b) (ℤq-repr e) pI)

zk-check-chaum-pedersen-pok-elgamal-rnd : ZK-chaum-pedersen-pok-elgamal-rnd BigI BigI → JS!
zk-check-chaum-pedersen-pok-elgamal-rnd pf
      = trace "g=" g λ _ →
        trace "p=" I.p λ _ →
        trace "q=" I.q λ _ →
        trace "y=" y λ _ →
        trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
         checks
      >> check "g^s==A·α^c"     ((g ^ s) == (A · (α ^ c)))        (λ _ → "")
      >> check "y^s==B·(β/M)^c" ((y ^ s) == (B · ((β ·/ M) ^ c))) (λ _ → "")
  module Zk-check-chaume-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    open [ℤq]ℤp★ I.q I.p I.g
    open ℤq
--  open ℤp★ -- <- BUG
    A = BigI▹ℤp★ I.A
    B = BigI▹ℤp★ I.B
    α = BigI▹ℤp★ I.α
    β = BigI▹ℤp★ I.β
    y = BigI▹ℤp★ I.y
    s = BigI▹ℤq  I.s
    c = BigI▹ℤq  I.c
    m = BigI▹ℤq  I.m
    M = g ^ m

zk-check : JSValue → JS!
zk-check arg =
    check "type of statement" (typ === fromString "chaum-pedersen-pok-elgamal-rnd")
                              (λ _ → "")
 >> zk-check-chaum-pedersen-pok-elgamal-rnd pok
 module Zk-check where
    stm = arg ·« "statement" »
    typ = stm ·« "type" »
    dat = stm ·« "data" »
    g   = bigdec (dat ·« "g" »)
    p   = bigdec (dat ·« "p" »)
    q   = bigdec (dat ·« "q" »)
    y   = bigdec (dat ·« "y" »)
    m   = bigdec (dat ·« "plain" »)
    enc = dat ·« "enc" »
    α   = bigdec (enc ·« "alpha" »)
    β   = bigdec (enc ·« "beta"  »)
    prf = arg ·« "proof" »
    com = prf ·« "commitment" »
    A   = bigdec (com ·« "A" »)
    B   = bigdec (com ·« "B" »)
    c   = bigdec (prf ·« "challenge" »)
    s   = bigdec (prf ·« "response" »)
    pok = record { g = g; p = p; q = q; y = y; α = α; β = β; A = A; B = B; c = c; s = s; m = m }

{-
srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (zk-check q))
  end
-}

-- Working around Agda.Primitive.lsuc being undefined
-- case_of_ : {A : Set} {B : Set} → A → (A → B) → B
-- case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
        Console.log "usage: No arguments"
        {- server "127.0.0.1" "1337" srv !₁ λ uri →
           Console.log (showURI uri)
         -}
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              FS.readFile arg nullJS !₂ λ err dat →
                check "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check (JSON-parse (castString dat))
          ; _ →
              Console.log "usage: Too many arguments"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}


Updated the mirror draft.

Updated the mirror draft.

Ignore-this: 775599b409b5d3ddd96b6542a5d61e1

darcs-hash:20110211172236-3bd4e-5593c52c7622802e3890bc8c25540f9493e5dd86.gz

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

module Draft.Mirror.PropertiesI where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesI

open import LTC.Data.List
open import LTC.Data.List.PropertiesI using ( reverse-[x]≡[x] )
open import Draft.Mirror.ListTree.PropertiesI

open import LTC.Relation.Binary.EqReasoning

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

-- TODO: To remove the postulate
postulate
  mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)

-- mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
-- mirror-Tree (treeT d nilLT) =
--   subst Tree (sym (mirror-eq d [])) (treeT d aux₂)
--     where
--       aux₁ : rev (map mirror []) [] ≡ []
--       aux₁ =
--         begin
--           rev (map mirror []) []
--           ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
--                    (map-[] mirror)
--                    refl
--           ⟩
--           rev [] []
--             ≡⟨ rev-[] [] ⟩
--           []
--         ∎

--       aux₂ : ListTree (rev (map mirror []) [])
--       aux₂ = subst ListTree (sym aux₁) nilLT

-- mirror-Tree (treeT d (consLT {t} {ts} Tt LTts)) =
--   subst Tree (sym (mirror-eq d (t ∷ ts))) (treeT d aux)

--   where
--     aux : ListTree (reverse (map mirror (t ∷ ts)))
--     aux = rev-ListTree (map-ListTree mirror {!!} (consLT Tt LTts)) nilLT

mutual
  mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
  mirror² (treeT d nilLT) =
    begin
      mirror · (mirror · (node d []))
        ≡⟨ subst (λ x → mirror · (mirror · (node d [])) ≡ mirror · x )
                 (mirror-eq d [])
                 refl
        ⟩
      mirror · node d (reverse (map mirror []))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror [])) ≡
                        mirror · node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      mirror · node d (reverse [])
        ≡⟨ subst (λ x → mirror · node d (reverse []) ≡ mirror · node d x)
                 (rev-[] [])
                 refl
        ⟩
      mirror · node d []
        ≡⟨ mirror-eq d [] ⟩
      node d (reverse (map mirror []))
        ≡⟨ subst (λ x → node d (reverse (map mirror [])) ≡
                        node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      node d (reverse [])
        ≡⟨ subst (λ x → node d (reverse []) ≡ node d x)
                 (rev-[] [])
                 refl
        ⟩
      node d []
    ∎

  mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
    begin
      mirror · (mirror · node d (t ∷ ts))
        ≡⟨ subst (λ x → mirror · (mirror · node d (t ∷ ts)) ≡ mirror · x)
                 (mirror-eq d (t ∷ ts))
                 refl
        ⟩
      mirror · node d (reverse (map mirror (t ∷ ts)))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror (t ∷ ts))) ≡
                        x)
                 (mirror-eq d (reverse (map mirror (t ∷ ts))))
                 refl
        ⟩
      node d (reverse (map mirror (reverse (map mirror (t ∷ ts)))))
      ≡⟨ subst (λ x → node d (reverse (map mirror (reverse (map mirror (t ∷ ts))))) ≡
                      node d x)
               (aux (consLT Tt LTts))
               refl
      ⟩
      node d (t ∷ ts)
    ∎

  aux : ∀ {ts} → ListTree ts →
        reverse (map mirror (reverse (map mirror ts))) ≡ ts
  aux nilLT =
    begin
      reverse (map mirror (reverse (map mirror [])))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror []))) ≡
                        reverse (map mirror (reverse x)))
                 (map-[] mirror)
                 refl
        ⟩
      reverse (map mirror (reverse []))
        ≡⟨ subst (λ x → reverse (map mirror (reverse [])) ≡
                        reverse (map mirror x))
                 (rev-[] [])
                 refl
        ⟩
      reverse (map mirror [])
        ≡⟨ subst (λ x → reverse (map mirror []) ≡
                        reverse x)
                 (map-[] mirror)
                 refl
        ⟩
      reverse []
        ≡⟨ rev-[] [] ⟩
      []
    ∎

  aux (consLT {t} {ts} Tt LTts) =
    begin
      reverse (map mirror (reverse (map mirror (t ∷ ts))))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror (t ∷ ts)))) ≡
                        reverse (map mirror (reverse x)))
                 (map-∷ mirror t ts)
                 refl
        ⟩
      reverse (map mirror (reverse (mirror · t ∷ map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (mirror · t ∷ map mirror ts))) ≡
                        reverse (map mirror x))
                 (reverse-∷ (mirror · t) (map-ListTree mirror mirror-Tree LTts))
                 refl
        ⟩
      reverse (map mirror (reverse (map mirror ts) ++ (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror · t ∷ []))) ≡
                        reverse x)
           (map-++ mirror
                   mirror-Tree
                   (rev-ListTree (map-ListTree mirror mirror-Tree LTts) nilLT)
                   (consLT (mirror-Tree Tt) nilLT))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror · t ∷ [])))) ≡
                        x)
                 (reverse-++ (map-ListTree mirror
                                           mirror-Tree
                                           (rev-ListTree (map-ListTree mirror
                                                                       mirror-Tree
                                                                       LTts)
                                                         nilLT))
                             (map-ListTree mirror
                                           mirror-Tree
                                           (consLT (mirror-Tree Tt) nilLT)))
                 refl
        ⟩
      reverse (map mirror (mirror · t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (mirror · t ∷ [])) ++ n₁ ≡
                        reverse x ++ n₁)
                 (map-∷ mirror (mirror · t) [])
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁ ≡
                        reverse (mirror · (mirror · t) ∷ x) ++ n₁)
                 (map-[] mirror)
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ []) ++ n₁ ≡
                        x ++ n₁)
                 (reverse-[x]≡[x] (mirror · (mirror · t)))
                 refl
        ⟩
      (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ ++-∷ (mirror · (mirror · t)) [] n₁ ⟩
      mirror · (mirror · t) ∷ [] ++ n₁
        ≡⟨ subst (λ x →  mirror · (mirror · t) ∷ [] ++ n₁ ≡
                         mirror · (mirror · t) ∷ x)
                 (++-leftIdentity LTn₁)
                 refl
        ⟩
      mirror · (mirror · t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror · (mirror · t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² Tt)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (aux LTts)
                 refl
        ⟩
      t ∷ ts
    ∎
      where
        n₁ : D
        n₁ = reverse (map mirror (reverse (map mirror ts)))

        LTn₁ : ListTree n₁
        LTn₁ = rev-ListTree (map-ListTree mirror
                                          mirror-Tree
                                          (rev-ListTree (map-ListTree mirror
                                                                      mirror-Tree
                                                                      LTts)
                                                        nilLT))
                            nilLT

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

module Draft.Mirror.PropertiesI where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesI

open import LTC.Data.List
open import LTC.Data.List.PropertiesI using ( reverse-[x]≡[x] )
open import Draft.Mirror.ListTree.PropertiesI

open import LTC.Relation.Binary.EqReasoning

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

-- TODO: To remove
postulate
  mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)

-- mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
-- mirror-Tree (treeT d nilLT) =
--   subst Tree (sym (mirror-eq d [])) (treeT d aux₂)
--     where
--       aux₁ : rev (map mirror []) [] ≡ []
--       aux₁ =
--         begin
--           rev (map mirror []) []
--           ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
--                    (map-[] mirror)
--                    refl
--           ⟩
--           rev [] []
--             ≡⟨ rev-[] [] ⟩
--           []
--         ∎

--       aux₂ : ListTree (rev (map mirror []) [])
--       aux₂ = subst ListTree (sym aux₁) nilLT

-- mirror-Tree (treeT d (consLT {t} {ts} Tt LTts)) =
--   subst Tree (sym (mirror-eq d (t ∷ ts))) (treeT d aux)

--   where
--     aux : ListTree (reverse (map mirror (t ∷ ts)))
--     aux = rev-ListTree (map-ListTree mirror {!!} (consLT Tt LTts)) nilLT

mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
mirror² (treeT d nilLT) =
  begin
    mirror · (mirror · (node d []))
      ≡⟨ subst (λ x → mirror · (mirror · (node d [])) ≡ mirror · x )
               (mirror-eq d [])
               refl
      ⟩
    mirror · node d (reverse (map mirror []))
      ≡⟨ subst (λ x → mirror · node d (reverse (map mirror [])) ≡
                      mirror · node d (reverse x))
               (map-[] mirror)
               refl
      ⟩
    mirror · node d (reverse [])
      ≡⟨ subst (λ x → mirror · node d (reverse []) ≡ mirror · node d x)
               (rev-[] [])
               refl
      ⟩
    mirror · node d []
      ≡⟨ mirror-eq d [] ⟩
    node d (reverse (map mirror []))
      ≡⟨ subst (λ x → node d (reverse (map mirror [])) ≡
                      node d (reverse x))
               (map-[] mirror)
               refl
      ⟩
    node d (reverse [])
      ≡⟨ subst (λ x → node d (reverse []) ≡ node d x)
               (rev-[] [])
               refl
      ⟩
    node d []
  ∎

mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
  begin
    mirror · (mirror · node d (t ∷ ts))
      ≡⟨ subst (λ x → mirror · (mirror · node d (t ∷ ts)) ≡ mirror · x)
               (mirror-eq d (t ∷ ts))
               refl
      ⟩
    mirror · node d (reverse (map mirror (t ∷ ts)))
      ≡⟨ subst (λ x → mirror · node d (reverse (map mirror (t ∷ ts))) ≡
                      mirror · node d (reverse x))
               (map-∷ mirror t ts)
               refl
      ⟩
    mirror · node d (reverse (mirror · t ∷ map mirror ts))
      ≡⟨ subst (λ x → mirror · node d (reverse (mirror · t ∷ map mirror ts)) ≡
                      mirror · node d x)
               (reverse-∷ (mirror · t) (map-ListTree mirror mirror-Tree LTts))
               refl
      ⟩
    mirror · node d (reverse (map mirror ts) ++ (mirror · t ∷ []))
      ≡⟨ mirror-eq d (reverse (map mirror ts) ++ (mirror · t ∷ [])) ⟩
    node d (reverse (map mirror (reverse (map mirror ts) ++ (mirror · t ∷ []))))
      ≡⟨ subst (λ x → node d (reverse (map mirror (reverse (map mirror ts) ++
                                      (mirror · t ∷ [])))) ≡
                      node d (reverse x))
               (map-++ mirror
                       mirror-Tree
                       (rev-ListTree (map-ListTree mirror mirror-Tree LTts) nilLT)
                       (consLT (mirror-Tree Tt) nilLT))
               refl
      ⟩
    node d (reverse ((map mirror (reverse (map mirror ts))) ++
                      map mirror (mirror · t ∷ [])))
      ≡⟨ subst (λ x → node d (reverse ((map mirror (reverse (map mirror ts))) ++
                      map mirror (mirror · t ∷ []))) ≡
                      node d x)
               (reverse-++ (map-ListTree mirror
                                         mirror-Tree
                                         (rev-ListTree (map-ListTree mirror
                                                                     mirror-Tree
                                                                     LTts)
                                                       nilLT))
                           (map-ListTree mirror
                                         mirror-Tree
                                         (consLT (mirror-Tree Tt) nilLT)))
               refl
      ⟩
    node d (reverse (map mirror (mirror · t ∷ [])) ++
            reverse (map mirror (reverse (map mirror ts))))
      ≡⟨ subst (λ x → node d (reverse (map mirror (mirror · t ∷ [])) ++
                             reverse (map mirror (reverse (map mirror ts)))) ≡
                      node d (reverse x ++
                             reverse (map mirror (reverse (map mirror ts)))))
               (map-∷ mirror (mirror · t) [])
               refl
      ⟩
    node d (reverse (mirror · (mirror · t) ∷ map mirror []) ++
            reverse (map mirror (reverse (map mirror ts))))
      ≡⟨ subst (λ x → node d (reverse (mirror · (mirror · t) ∷ map mirror []) ++
                              reverse (map mirror (reverse (map mirror ts)))) ≡
                      node d (reverse (x ∷ map mirror []) ++
                             reverse (map mirror (reverse (map mirror ts)))))
               (mirror² Tt)  -- IH.
               refl
      ⟩
    node d (reverse (t ∷ map mirror []) ++
            reverse (map mirror (reverse (map mirror ts))))
      ≡⟨ subst (λ x → node d (reverse (t ∷ map mirror []) ++
                              reverse (map mirror (reverse (map mirror ts)))) ≡
                      node d (reverse (t ∷ x) ++
                              reverse (map mirror (reverse (map mirror ts)))))
               (map-[] mirror)
               refl
      ⟩
    node d (reverse (t ∷ []) ++
            reverse (map mirror (reverse (map mirror ts))))
      ≡⟨ subst (λ x → node d (reverse (t ∷ []) ++
                              reverse (map mirror (reverse (map mirror ts)))) ≡
                      node d (x ++
                              reverse (map mirror (reverse (map mirror ts)))))
               (reverse-[x]≡[x] t)
               refl
      ⟩
    node d ((t ∷ []) ++
            reverse (map mirror (reverse (map mirror ts))))
      ≡⟨ subst (λ x → node d ((t ∷ []) ++
                              reverse (map mirror (reverse (map mirror ts)))) ≡
                      node d ((t ∷ []) ++ x))
               (prf (mirror² {!!}))
               refl
      ⟩
    node d ((t ∷ []) ++ ts)
      ≡⟨ subst (λ x → node d ((t ∷ []) ++ ts) ≡ node d x)
               (++-∷ t [] ts)
               refl
      ⟩
    node d (t ∷ [] ++ ts)
      ≡⟨ subst (λ x → node d (t ∷ [] ++ ts) ≡ node d (t ∷ x))
               (++-leftIdentity LTts)
               refl
      ⟩
    node d (t ∷ ts)
  ∎
  where
    postulate prf : mirror · (mirror · ts) ≡ ts →  -- IH
                    rev (map mirror (rev (map mirror ts) [])) [] ≡ ts
    {-# ATP prove prf #-}


finished the sub lemma

finished the sub lemma

module ITyping where

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

open import Core
open import Core-Lemmas
open import Typing
open import Reduction

data IType : Set
data ITypeᵢ : Set

data IType where
  o : IType
  _~>_ : ITypeᵢ -> ITypeᵢ -> IType

data ITypeᵢ where
  ∩ : List IType -> ITypeᵢ

ω = ∩ []

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

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

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

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

∩-inj : ∀ {x y τᵢ τⱼ} -> ∩ (x ∷ τᵢ) ≡ ∩ (y ∷ τⱼ) -> x ≡ y
∩-inj refl = refl

∩-∷-≡ : ∀ {x y : IType} {xs ys} -> x ≡ y -> ∩ xs ≡ ∩ ys -> ∩ (x ∷ xs) ≡ ∩ (y ∷ ys)
∩-∷-≡ refl refl = refl

_≟TI_ : Decidable {A = IType} _≡_
_≟TIᵢ_ : Decidable {A = 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∷τⱼ → τᵢ≠τⱼ (∩-inj-cons ∩x∷τᵢ≡∩x∷τⱼ))
∩ (x ∷ τᵢ) ≟TIᵢ ∩ (y ∷ τⱼ) | no x≠y | _ = no (λ ∩x∷τᵢ≡∩y∷τⱼ → x≠y (∩-inj ∩x∷τᵢ≡∩y∷τⱼ))

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

data _∷'_ : IType -> Type -> Set
data _∷'ᵢ_ : ITypeᵢ -> Type -> Set

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

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

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

data _⊆[_]_ : IType -> Type -> IType -> Set
data _⊆ᵢ[_]_ : ITypeᵢ -> Type -> 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 ] τ
  -- ∩-∈ : ∀ {τ τᵢ} -> τ ∈ τᵢ -> (∩' τ) ⊆[ A ] (∩ τᵢ)
  cons : ∀ {A τᵢ τ' τ'ᵢ} ->
    ∃(λ τ -> (τ ∈ τᵢ) × (τ' ⊆[ A ] τ)) -> (∩ τ'ᵢ) ⊆ᵢ[ A ] (∩ τᵢ) ->
    -------------------------------------------------------------
                  (∩ (τ' ∷ τ'ᵢ)) ⊆ᵢ[ A ] (∩ τᵢ)

-- data _≤∩_ : IType -> IType -> Set where
--   base : o ≤∩ o
--   arr : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> τ₁₂ ≤∩ τ₂₂ -> τ₂₁ ≤∩ τ₁₁ -> (τ₁₁ ~> τ₁₂) ≤∩ (τ₂₁ ~> τ₂₂)
--   ∩-∈ : ∀ {τ τᵢ} -> τ ∈ τᵢ -> ∩ τᵢ ≤∩ τ
--   ∩-nil : ∀ {τ} -> τ ≤∩ ω
--   ∩-cons : ∀ {τ τ' τᵢ} -> τ ≤∩ τ' -> τ ≤∩ ∩ τᵢ -> τ ≤∩ ∩ (τ' ∷ τᵢ)
--   ∩-trans : ∀ {τ₁ τ₂ τ₃} -> τ₁ ≤∩ τ₂ -> τ₂ ≤∩ τ₃ -> τ₁ ≤∩ τ₃

∷'ᵢ-∈ : ∀ {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 {τᵢ = ∩ (τ' ∷ τᵢ)} {∩ (_ ∷ τⱼ)} {∩ τₖ} (cons (τ , τ∈τⱼ , τ'⊆τ) τᵢ⊆τⱼ) (cons x τⱼ⊆τₖ) = cons (τ , ({!   !} , {!   !})) {!   !}

-- ⊆ᵢ-trans {τᵢ = ∩ (τ' ∷ τᵢ)} (cons (τ , τ∈τⱼ , τ'⊆τ) τᵢ⊆τⱼ) τⱼ⊆τₖ = {!   !}

⊆-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 Λ : Type -> Set where
  bv : ∀ {A} -> (i : ℕ) -> Λ A
  fv : ∀ {A} -> (x : Atom) -> Λ A
  lam : ∀ {B} -> (A : Type) -> (e : Λ B) -> Λ (A ⟶ B)
  app : ∀ {A B} -> (e₁ : Λ (A ⟶ B)) -> (e₂ : Λ A) -> Λ B
  Y : (t : Type) -> Λ ((t ⟶ t) ⟶ t)

data _~_ : ∀{t} -> Λ t -> PTerm -> Set where
  bv : ∀ {t i} -> (bv {t} i) ~ (bv i)
  fv : ∀ {t x} -> (fv {t} x) ~ (fv x)
  lam : ∀ {t s m m'} -> m ~ m' -> (lam {s} t m) ~ (lam m')
  app : ∀ {t s m n m' n'} -> m ~ m' -> n ~ n' -> (app {t} {s} m n) ~ (app m' n')
  Y : ∀ {t} -> (Y t) ~ (Y t)

Λ[_<<_] : ∀ {t} -> ℕ -> Atom -> Λ t -> Λ t
Λ[ k << x ] (bv i) = bv i
Λ[ k << x ] (fv y) with x ≟ y
... | yes _ = bv k
... | no _ = fv y
Λ[ k << x ] (lam t m) = lam t (Λ[ (suc k) << x ] m)
Λ[ k << x ] (app t1 t2) = app (Λ[ k << x ] t1) (Λ[ k << x ] t2)
Λ[ k << x ] (Y t) = Y t

⊢->Λ : ∀ {Γ m t} -> Γ ⊢ m ∶ t -> Λ t
⊢->Λ {m = bv i} ()
⊢->Λ {m = fv x} {t} Γ⊢m∶t = fv {t} x
⊢->Λ {m = lam m} (abs {_} {τ₁} {τ₂} L cf) =
  lam τ₁ ( Λ[ 0 << ∃fresh (L ++ FV m) ] (⊢->Λ (cf (∉-cons-l _ _ (∃fresh-spec (L ++ FV m)) ))) )
⊢->Λ {m = app s t} (app Γ⊢s Γ⊢t) = app (⊢->Λ Γ⊢s) (⊢->Λ Γ⊢t)
⊢->Λ {m = Y τ} (Y _) = Y τ

-- ⊢->Λ≡ : ∀ {Γ m n t} -> m ≡ n -> {Γ⊢m : Γ ⊢ m ∶ t} -> {Γ⊢n : Γ ⊢ n ∶ t} -> (⊢->Λ Γ⊢m) ≡ (⊢->Λ Γ⊢m)
-- ⊢->Λ≡ refl = λ {Γ⊢m} {Γ⊢n} → refl

Λ*^-*^~ : ∀ {τ x k} t t' -> _~_ {τ} t t' -> Λ[ k << x ] t ~ ([ k << x ] t')
Λ*^-*^~ _ _ bv = bv
Λ*^-*^~ {x = x} (fv y) _ fv with x ≟ y
Λ*^-*^~ (fv x) .(fv x) fv | yes _ = bv
Λ*^-*^~ (fv y) .(fv y) fv | no _ = fv
Λ*^-*^~ _ _ (lam {m = m} {m'} t~t') = lam (Λ*^-*^~ m m' t~t')
Λ*^-*^~ _ _ (app {m = m} {n} {m'} {n'} t~t' t~t'') = app (Λ*^-*^~ m m' t~t') (Λ*^-*^~ n n' t~t'')
Λ*^-*^~ _ _ Y = Y

⊢->Λ~ : ∀ {Γ t τ} -> (Γ⊢t : Γ ⊢ t ∶ τ) -> (⊢->Λ Γ⊢t) ~ t
⊢->Λ~ {t = bv i} ()
⊢->Λ~ {t = fv x} (var _ _) = fv
⊢->Λ~ {t = lam t} (abs {τ₁ = τ₁} {τ₂} L cf) = lam ih
  where
  x = ∃fresh (L ++ FV t)
  x∉ = ∃fresh-spec (L ++ FV t)
  x∷Γ⊢t^'x = cf (∉-cons-l _ _ x∉)

  sub : ∀ {τ x m} -> x ∉ FV t -> _~_ {τ} m t ≡ m ~ (* x ^ (t ^' x))
  sub {_} {x} x∉ rewrite fv-^-*^-refl x t {0} x∉ = refl

  ih : Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x) ~ t
  ih rewrite sub {_} {x} {Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x)} (∉-cons-r L _ x∉) =
    Λ*^-*^~ (⊢->Λ x∷Γ⊢t^'x) (t ^' x) (⊢->Λ~ (cf (∉-cons-l _ _ x∉)))
⊢->Λ~ {t = app t t₁} (app Γ⊢t Γ⊢t₁) = app (⊢->Λ~ Γ⊢t) (⊢->Λ~ Γ⊢t₁)
⊢->Λ~ {t = Y t₁} (Y x) = Y

Λ[_>>_] : ∀ {τ τ'} -> ℕ -> Λ τ' -> Λ τ -> Λ τ
Λ[_>>_] {τ} {τ'} k u (bv i) with k ≟ i | τ ≟T τ'
Λ[ k >> u ] (bv i) | yes _ | yes refl = u
... | yes _ | no _ = bv i
... | no _ | _ = bv i
Λ[ k >> u ] (fv x) = fv x
Λ[ k >> u ] (lam A t) = lam A (Λ[ (suc k) >> u ] t)
Λ[ k >> u ] (app t1 t2) = app (Λ[ k >> u ] t1) (Λ[ k >> u ] t2)
Λ[ k >> u ] (Y t) = Y t

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

data _⊩_∶_ where
  var : ∀ {A Γ x τ} {τᵢ : 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Γ' : ∀ {Γ Γ'} -> Γ ⊆Γ Γ' -> Wf-ICtxt Γ'
⊆Γ-wfΓ' (nil wf-Γ') = wf-Γ'
⊆Γ-wfΓ' (cons _ Γ⊆Γ') = ⊆Γ-wfΓ' Γ⊆Γ'

⊩-∷' : ∀ {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∶τᵢ τ'ᵢ⊆τᵢ Γ⊆Γ')

-- ⊩->β : ∀ {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-Γ) τ⊆τ₂ 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.Sum
open import Data.List.Any as LAny
open LAny.Membership-≡
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Core

open import Core
open import Core-Lemmas
open import Typing
open import Reduction

data IType : Set
data ITypeᵢ : Set

data IType where
  o : IType
  _~>_ : ITypeᵢ -> ITypeᵢ -> IType

data ITypeᵢ where
  ∩ : List IType -> ITypeᵢ

ω = ∩ []

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

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

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

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

∩-inj : ∀ {x y τᵢ τⱼ} -> ∩ (x ∷ τᵢ) ≡ ∩ (y ∷ τⱼ) -> x ≡ y
∩-inj refl = refl

∩-∷-≡ : ∀ {x y : IType} {xs ys} -> x ≡ y -> ∩ xs ≡ ∩ ys -> ∩ (x ∷ xs) ≡ ∩ (y ∷ ys)
∩-∷-≡ refl refl = refl

_≟TI_ : Decidable {A = IType} _≡_
_≟TIᵢ_ : Decidable {A = 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∷τⱼ → τᵢ≠τⱼ (∩-inj-cons ∩x∷τᵢ≡∩x∷τⱼ))
∩ (x ∷ τᵢ) ≟TIᵢ ∩ (y ∷ τⱼ) | no x≠y | _ = no (λ ∩x∷τᵢ≡∩y∷τⱼ → x≠y (∩-inj ∩x∷τᵢ≡∩y∷τⱼ))

ICtxt = List (Atom × ITypeᵢ)

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

data _∷'_ : IType -> Type -> Set
data _∷'ᵢ_ : 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 _⊆[_]_ : IType -> Type -> IType -> Set
data _⊆ᵢ[_]_ : ITypeᵢ -> Type -> 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 ] τ
  -- ∩-∈ : ∀ {τ τᵢ} -> τ ∈ τᵢ -> (∩' τ) ⊆[ A ] (∩ τᵢ)
  cons : ∀ {A τᵢ τ' τ'ᵢ} ->
    ∃(λ τ -> (τ ∈ τᵢ) × (τ' ⊆[ A ] τ)) -> (∩ τ'ᵢ) ⊆ᵢ[ A ] (∩ τᵢ) ->
    -------------------------------------------------------------
                  (∩ (τ' ∷ τ'ᵢ)) ⊆ᵢ[ A ] (∩ τᵢ)

-- data _≤∩_ : IType -> IType -> Set where
--   base : o ≤∩ o
--   arr : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> τ₁₂ ≤∩ τ₂₂ -> τ₂₁ ≤∩ τ₁₁ -> (τ₁₁ ~> τ₁₂) ≤∩ (τ₂₁ ~> τ₂₂)
--   ∩-∈ : ∀ {τ τᵢ} -> τ ∈ τᵢ -> ∩ τᵢ ≤∩ τ
--   ∩-nil : ∀ {τ} -> τ ≤∩ ω
--   ∩-cons : ∀ {τ τ' τᵢ} -> τ ≤∩ τ' -> τ ≤∩ ∩ τᵢ -> τ ≤∩ ∩ (τ' ∷ τᵢ)
--   ∩-trans : ∀ {τ₁ τ₂ τ₃} -> τ₁ ≤∩ τ₂ -> τ₂ ≤∩ τ₃ -> τ₁ ≤∩ τ₃

∷'ᵢ-∈ : ∀ {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 {τᵢ = ∩ (τ' ∷ τᵢ)} {∩ (_ ∷ τⱼ)} {∩ τₖ} (cons (τ , τ∈τⱼ , τ'⊆τ) τᵢ⊆τⱼ) (cons x τⱼ⊆τₖ) = cons (τ , ({!   !} , {!   !})) {!   !}

-- ⊆ᵢ-trans {τᵢ = ∩ (τ' ∷ τᵢ)} (cons (τ , τ∈τⱼ , τ'⊆τ) τᵢ⊆τⱼ) τⱼ⊆τₖ = {!   !}

⊆-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 Λ : Type -> Set where
  bv : ∀ {A} -> (i : ℕ) -> Λ A
  fv : ∀ {A} -> (x : Atom) -> Λ A
  lam : ∀ {B} -> (A : Type) -> (e : Λ B) -> Λ (A ⟶ B)
  app : ∀ {A B} -> (e₁ : Λ (A ⟶ B)) -> (e₂ : Λ A) -> Λ B
  Y : (t : Type) -> Λ ((t ⟶ t) ⟶ t)

data _~_ : ∀{t} -> Λ t -> PTerm -> Set where
  bv : ∀ {t i} -> (bv {t} i) ~ (bv i)
  fv : ∀ {t x} -> (fv {t} x) ~ (fv x)
  lam : ∀ {t s m m'} -> m ~ m' -> (lam {s} t m) ~ (lam m')
  app : ∀ {t s m n m' n'} -> m ~ m' -> n ~ n' -> (app {t} {s} m n) ~ (app m' n')
  Y : ∀ {t} -> (Y t) ~ (Y t)

Λ[_<<_] : ∀ {t} -> ℕ -> Atom -> Λ t -> Λ t
Λ[ k << x ] (bv i) = bv i
Λ[ k << x ] (fv y) with x ≟ y
... | yes _ = bv k
... | no _ = fv y
Λ[ k << x ] (lam t m) = lam t (Λ[ (suc k) << x ] m)
Λ[ k << x ] (app t1 t2) = app (Λ[ k << x ] t1) (Λ[ k << x ] t2)
Λ[ k << x ] (Y t) = Y t

⊢->Λ : ∀ {Γ m t} -> Γ ⊢ m ∶ t -> Λ t
⊢->Λ {m = bv i} ()
⊢->Λ {m = fv x} {t} Γ⊢m∶t = fv {t} x
⊢->Λ {m = lam m} (abs {_} {τ₁} {τ₂} L cf) =
  lam τ₁ ( Λ[ 0 << ∃fresh (L ++ FV m) ] (⊢->Λ (cf (∉-cons-l _ _ (∃fresh-spec (L ++ FV m)) ))) )
⊢->Λ {m = app s t} (app Γ⊢s Γ⊢t) = app (⊢->Λ Γ⊢s) (⊢->Λ Γ⊢t)
⊢->Λ {m = Y τ} (Y _) = Y τ

-- ⊢->Λ≡ : ∀ {Γ m n t} -> m ≡ n -> {Γ⊢m : Γ ⊢ m ∶ t} -> {Γ⊢n : Γ ⊢ n ∶ t} -> (⊢->Λ Γ⊢m) ≡ (⊢->Λ Γ⊢m)
-- ⊢->Λ≡ refl = λ {Γ⊢m} {Γ⊢n} → refl

Λ*^-*^~ : ∀ {τ x k} t t' -> _~_ {τ} t t' -> Λ[ k << x ] t ~ ([ k << x ] t')
Λ*^-*^~ _ _ bv = bv
Λ*^-*^~ {x = x} (fv y) _ fv with x ≟ y
Λ*^-*^~ (fv x) .(fv x) fv | yes _ = bv
Λ*^-*^~ (fv y) .(fv y) fv | no _ = fv
Λ*^-*^~ _ _ (lam {m = m} {m'} t~t') = lam (Λ*^-*^~ m m' t~t')
Λ*^-*^~ _ _ (app {m = m} {n} {m'} {n'} t~t' t~t'') = app (Λ*^-*^~ m m' t~t') (Λ*^-*^~ n n' t~t'')
Λ*^-*^~ _ _ Y = Y

⊢->Λ~ : ∀ {Γ t τ} -> (Γ⊢t : Γ ⊢ t ∶ τ) -> (⊢->Λ Γ⊢t) ~ t
⊢->Λ~ {t = bv i} ()
⊢->Λ~ {t = fv x} (var _ _) = fv
⊢->Λ~ {t = lam t} (abs {τ₁ = τ₁} {τ₂} L cf) = lam ih
  where
  x = ∃fresh (L ++ FV t)
  x∉ = ∃fresh-spec (L ++ FV t)
  x∷Γ⊢t^'x = cf (∉-cons-l _ _ x∉)

  sub : ∀ {τ x m} -> x ∉ FV t -> _~_ {τ} m t ≡ m ~ (* x ^ (t ^' x))
  sub {_} {x} x∉ rewrite fv-^-*^-refl x t {0} x∉ = refl

  ih : Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x) ~ t
  ih rewrite sub {_} {x} {Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x)} (∉-cons-r L _ x∉) =
    Λ*^-*^~ (⊢->Λ x∷Γ⊢t^'x) (t ^' x) (⊢->Λ~ (cf (∉-cons-l _ _ x∉)))
⊢->Λ~ {t = app t t₁} (app Γ⊢t Γ⊢t₁) = app (⊢->Λ~ Γ⊢t) (⊢->Λ~ Γ⊢t₁)
⊢->Λ~ {t = Y t₁} (Y x) = Y

Λ[_>>_] : ∀ {τ τ'} -> ℕ -> Λ τ' -> Λ τ -> Λ τ
Λ[_>>_] {τ} {τ'} k u (bv i) with k ≟ i | τ ≟T τ'
Λ[ k >> u ] (bv i) | yes _ | yes refl = u
... | yes _ | no _ = bv i
... | no _ | _ = bv i
Λ[ k >> u ] (fv x) = fv x
Λ[ k >> u ] (lam A t) = lam A (Λ[ (suc k) >> u ] t)
Λ[ k >> u ] (app t1 t2) = app (Λ[ k >> u ] t1) (Λ[ k >> u ] t2)
Λ[ k >> u ] (Y t) = Y t

-- ~>' : ITypeᵢ × ITypeᵢ -> IType
-- ~>' (a , b) = a ~> b
--
-- ∷-++-≡ : ∀ {a} {A : Set a} {x : A} {xs ys : List A} -> (x ∷ xs) ++ ys ≡ x ∷ (xs ++ ys)
-- ∷-++-≡ {a} {A} {x} {xs} {ys} = refl
--
--
-- ∷ᵢ-++ : ∀ {A τᵢ τⱼ} -> (∩ τᵢ) ∷'ᵢ A -> (∩ τⱼ) ∷'ᵢ A -> ∩ (τᵢ ++ τⱼ) ∷'ᵢ A
-- ∷ᵢ-++ nil τⱼ∷A = τⱼ∷A
-- ∷ᵢ-++ (cons x τᵢ∷A) τⱼ∷A = cons x (∷ᵢ-++ τᵢ∷A τⱼ∷A)
--
-- ⊆ᵢ-++ : ∀ {A τ τᵢ τⱼ} -> τ ⊆ᵢ[ A ] (∩ τᵢ) -> τ ⊆ᵢ[ A ] (∩ τⱼ) -> τ ⊆ᵢ[ A ] ∩ (τᵢ ++ τⱼ)
-- ⊆ᵢ-++ {τ = ∩ []} τ⊆τᵢ τ⊆τⱼ = nil (∷ᵢ-++ (⊆ᵢ-∷'ᵢ-r τ⊆τᵢ) (⊆ᵢ-∷'ᵢ-r τ⊆τⱼ))
-- ⊆ᵢ-++ {τ = ∩ (x ∷ xᵢ)} (cons (τ , τ∈τᵢ , x⊆τ) x₁⊆τᵢ) (cons ∃τ₂ x₁⊆τⱼ) =
--   cons (τ , ((∈-cons-l _ τ∈τᵢ) , x⊆τ)) (⊆ᵢ-++ {τ = ∩ xᵢ} x₁⊆τᵢ x₁⊆τⱼ)
--
-- concatᵢ : List (ITypeᵢ) -> ITypeᵢ
-- concatᵢ [] = ω
-- concatᵢ ((∩ x) ∷ xs) with concatᵢ xs
-- ... | ∩ xs' = ∩ (x ++ xs')
--
-- ∩₁ : List (ITypeᵢ × ITypeᵢ) -> ITypeᵢ
-- ∩₁ xs×ys = concatᵢ (Data.List.map proj₁ xs×ys)
--
-- ∩₂ : List (ITypeᵢ × ITypeᵢ) -> ITypeᵢ
-- ∩₂ xs×ys = concatᵢ (Data.List.map proj₂ xs×ys)
--
--
-- inv-⊆ᵢ-∩~>-r : ∀ {A B τ} -> τ ∷'ᵢ (A ⟶ B) ->
--   ∃(λ (τᵢ×τⱼ : List (ITypeᵢ × ITypeᵢ)) -> τ ≡ ∩ (Data.List.map ~>' τᵢ×τⱼ))
-- inv-⊆ᵢ-∩~>-r nil = [] , refl
-- inv-⊆ᵢ-∩~>-r (cons {τᵢ = τᵢ} (arr {δ = τ} {τ'} _ _) τᵢ∷A⟶B) = ((τ , τ') ∷ τᵢ×τⱼ) , ∩-∷-≡ refl τᵢ≡∩τᵢ×τⱼ
--   where
--   ih : ∃ (λ τᵢ×τⱼ → ∩ τᵢ ≡ ∩ (Data.List.map ~>' τᵢ×τⱼ))
--   ih = inv-⊆ᵢ-∩~>-r τᵢ∷A⟶B
--
--   τᵢ×τⱼ = proj₁ ih
--   τᵢ≡∩τᵢ×τⱼ = proj₂ ih

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

data _⊩_∶_ where
  var : ∀ {A Γ x τ} {τᵢ : ITypeᵢ} ->
    (wf-Γ : Wf-ICtxt Γ) -> (τᵢ∈Γ : (x , τᵢ) ∈ Γ) -> (τ⊆τᵢ : (∩' τ) ⊆ᵢ[ 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 , τ) ∷ Γ) ⊩ᵢ Λ[ 0 >> fv {A} x ] t ∶ τ' ) -> (τ ~> τ') ∷' (A ⟶ B) ->
    ---------------------------------------------------------------------------------------------------------
                                        Γ ⊩ lam A t ∶ (τ ~> τ')
  -- Y : ∀ {Γ A τ₂} {τ×τ₁ : List (ITypeᵢ × ITypeᵢ)} ->
  --   Wf-ICtxt Γ -> τ₂ ⊆ᵢ[ A ] (∩₂ τ×τ₁) -> (∩₂ τ×τ₁) ⊆ᵢ[ A ] (∩₁ τ×τ₁) ->
  --   --------------------------------------------------------------------
  --           Γ ⊩ Y A ∶ ((∩ (Data.List.map ~>' τ×τ₁)) ~> τ₂)

  Y : ∀ {Γ A τ τ₁ τ₂ τ₃} ->
    Wf-ICtxt Γ -> τ₂ ⊆ᵢ[ 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 : ∀ {x τ' Γ Γ'} ->
    ∃(λ τA -> ((x , (proj₁ τA)) ∈ Γ') × (τ' ⊆ᵢ[ (proj₂ τA) ] (proj₁ τA))) -> Γ ⊆Γ Γ' ->
    -----------------------------------------------------------------------------------
                                  ((x , τ') ∷ Γ) ⊆Γ Γ'

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

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

⊩-∷' (var _ _ τ⊆τᵢ) = ∷'ᵢ-∈ (here refl) (⊆ᵢ-∷'ᵢ-l τ⊆τᵢ)
⊩-∷' (app _ _ τ⊆τᵢ _) = ∷'ᵢ-∈ (here refl) (⊆ᵢ-∷'ᵢ-l τ⊆τᵢ)
⊩-∷' (abs _ _ x) = x
⊩-∷' (Y _ _ _ x) = ⊆-∷'-l x

⊩ᵢ-∷'ᵢ (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)

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

subΓ (var wf-Γ τᵢ∈Γ τ⊆τᵢ) Γ⊆Γ' = var (⊆Γ-wfΓ' Γ⊆Γ') {!   !} τ⊆τᵢ
subΓ (app Γ⊩m∶τ x x₁ x₂) Γ⊆Γ' = app (subΓ Γ⊩m∶τ Γ⊆Γ') (subᵢΓ x Γ⊆Γ') x₁ x₂
subΓ (abs L cf x) Γ⊆Γ' = abs L (λ x∉L → subᵢΓ (cf x∉L) {!   !}) x
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∶τ Γ⊆Γ')

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

sub (var wf-Γ τᵢ∈Γ τ⊆τᵢ) τ'⊆τ Γ⊆Γ' =
  var (⊆Γ-wfΓ' Γ⊆Γ') {!   !} (⊆ᵢ-trans (⊆->⊆ᵢ τ'⊆τ) τ⊆τᵢ)
sub (app Γ⊩s∶τ₁~>τ₂ Γ⊩ᵢt∶τ₁ τ⊆τ₂ τ∷A) τ'⊆τ Γ⊆Γ' = app
  (subΓ Γ⊩s∶τ₁~>τ₂ Γ⊆Γ')
  (subᵢΓ Γ⊩ᵢt∶τ₁ Γ⊆Γ')
  (⊆ᵢ-trans (⊆->⊆ᵢ τ'⊆τ) τ⊆τ₂)
  τ∷A
sub {_} {Γ} (abs {τ = τ} {τ'} L {t} cf τ~>τ'∷A⟶B) (arr {A} {τ₁₁ = τ₁₁} τ⊆τ₁₁ τ₁₂⊆τ' τ₁₁~>τ₁₂∷A⟶B x₃) Γ⊆Γ' =
  abs L (λ x∉L → subᵢ (cf x∉L) τ₁₂⊆τ' (cons ((τ₁₁ , A) , (here refl , τ⊆τ₁₁)) {!   !}) ) τ₁₁~>τ₁₂∷A⟶B
sub {_} {Γ} (Y {τ = τ} {τ₁} {τ₂} {τ₃} wf-Γ τ₂⊆τ₁ τ⊆τ₁ τ₃⊆) τ'⊆τ Γ⊆Γ' =
  Y (⊆Γ-wfΓ' Γ⊆Γ') τ₂⊆τ₁ τ⊆τ₁ (⊆-trans τ'⊆τ τ₃⊆)

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

-- -- weakening-τ {A} {Γ} {_} {τ} {τ'} {_} {τ'ₛₛ} (var wf-Γ τᵢ∈Γ τᵢ≤∩τ τ∷A) τ≤τ' τ'∷A = var {A} {Γ} {_} {τ'} {τ'ₛₛ} wf-Γ τᵢ∈Γ (∩-trans τᵢ≤∩τ τ≤τ') τ'∷A
-- -- weakening-τ (app Γ⊩m∶τₛₛ Γ⊩m∶τₛₛ₁ x) τ≤τ' τ'∷A =
-- --   app (weakening-τ Γ⊩m∶τₛₛ (arr τ≤τ' ≤∩-refl) (arr {!   !} τ'∷A)) (weakening-τ Γ⊩m∶τₛₛ₁ ≤∩-refl {!   !}) (arr {!   !} τ'∷A)
-- --   -- (weakening-τ Γ⊩m∶τₛₛ (arr τ≤τ' ≤∩-refl) ?) (weakening-τ Γ⊩m∶τₛₛ₁ ≤∩-refl ?) ?)
-- -- weakening-τ (∩-nil ¬Y-shape wf-Γ) τ≤τ' τ'∷A = {!   !}
-- -- weakening-τ (∩-cons ¬Y-shape wf-Γ Γ⊩m∶τₛₛ Γ⊩m∶τₛₛ₁) τ≤τ' τ'∷A = {!   !}
-- -- weakening-τ (abs L cf x x₁) τ≤τ' τ'∷A = {!   !}
-- -- weakening-τ (Y x (arr (arr x₁ x₂) x₃) x₄ x₅) (arr τ≤τ' τ≤τ'') τ'∷A = {!   !}
-- -- weakening-τ (Y x (arr (arr x₁ x₂) x₃) x₄ x₅) ∩-nil τ'∷A = {!   !}
-- -- weakening-τ (Y x (arr (arr x₁ x₂) x₃) x₄ x₅) (∩-cons τ≤τ' τ≤τ'') τ'∷A = {!   !}
-- -- weakening-τ (Y x (arr (arr x₁ x₂) x₃) x₄ x₅) (∩-trans τ≤τ' τ≤τ'') τ'∷A = {!   !}

-- ⊩->β : ∀ {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-Γ) τ⊆τ₂ 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₂)


IDesc stratified model: silly code indentation

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

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

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

pair : {i j : Level}{A : Set i}{B : A -> Set j} ->
       (x : A) (y : B x) -> Sigma {i = i}{j = j} A B
pair x y = x , y

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

trans : {l : Level}{A : Set l}{x y z : A} -> x == y -> y == z -> x == z
trans refl refl = refl

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

-- Intensionally extensional
postulate
  reflFun : {l m : Level}{A : Set l}{B : Set m}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set (suc l)) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set (suc l)} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set (suc l)}(R : I -> IDesc {l = l} I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set (suc l)}(D : IDesc I)(P : I -> Set l) -> desc D P -> IDesc (Sigma I P)
box (var i)     P x        = var (i , x)
box (const X)   P x        = const X
box (prod D D') P (d , d') = prod (box D P d) (box D' P d')
box (sigma S T) P (a , b)  = box (T a) P b
box (pi S T)    P f        = pi S (\s -> box (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set (suc l)}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set (suc l)}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : {l : Level} -> Set (suc l) -> DescDConst -> IDesc Unit
descDChoice I lvar = const I
descDChoice _ lconst = const (Set _)
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))
descDChoice _ lsigma = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))

IDescD : {l : Level}(I : Set (suc l)) -> IDesc {l = suc l} Unit
IDescD I = sigma DescDConst (descDChoice I)

IDescl0 : {l : Level}(I : Set (suc l)) -> Unit -> Set (suc l)
IDescl0 {x} I = IMu {l = suc x} (\_ -> IDescD {l = x} I)

IDescl : {l : Level}(I : Set (suc l)) -> Set (suc l)
IDescl I = IDescl0 I Void

varl : {l : Level}{I : Set (suc l)}(i : I) -> IDescl I
varl {x} i = con (lvar {l = suc x} , i)

constl : {l : Level}{I : Set (suc l)}(X : Set l) -> IDescl I
constl {x} X = con (lconst {l = suc x} , X)

prodl : {l : Level}{I : Set (suc l)}(D D' : IDescl I) -> IDescl I
prodl {x} D D' = con (lprod {l = suc x} , (D , D'))

pil : {l : Level}{I : Set (suc l)}(S : Set l)(T : S -> IDescl I) -> IDescl I
pil {x} S T = con (lpi {l = suc x} , pair {i = suc x}{j = suc x} S (\s -> T (unlift s)))

sigmal : {l : Level}{I : Set (suc l)}(S : Set l)(T : S -> IDescl I) -> IDescl I
sigmal {x} S T = con (lsigma {l = suc x} , pair {i = suc x}{j = suc x} S (\s -> T (unlift s)))

--********************************************
-- From the embedding to the host
--********************************************

cases : {l : Level}
        {I : Set (suc l)}
        (xs : desc (IDescD I) (IMu (λ _ -> IDescD I)))
        (hs : desc (box (IDescD I) (IMu (λ _ -> IDescD I)) xs) (λ _ -> IDesc I)) ->
        IDesc I
cases ( lvar , i ) hs =  var i
cases ( lconst , X ) hs =  const X
cases ( lprod , (D , D') ) ( d , d' ) =  prod d d'
cases ( lpi , ( S , T ) ) hs =  pi S (\s -> hs (lifter s) )
cases ( lsigma , ( S , T ) ) hs = sigma S (\s -> hs (lifter s))

phi : {l : Level}{I : Set (suc l)} -> IDescl I -> IDesc I
phi {x} {I} d = induction (\_ -> IDescD I) (\_ -> IDesc I) (\_ -> cases) Void d

--********************************************
-- From the host to the embedding
--********************************************

psi : {l : Level}{I : Set (suc l)} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set (suc l)} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-psi-phi : {l : Level}(I : Set (suc l)) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> IDescD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
    where P : Sigma Unit (IMu (\ x -> IDescD I)) -> Set (suc x)
          P ( Void , D ) = psi (phi D) == D
          proof-psi-phi-cases : (i : Unit)
                                (xs : desc (IDescD I) (IDescl0 I))
                                (hs : desc (box (IDescD I) (IDescl0 I) xs) P)
                                -> P (i , con xs)
          proof-psi-phi-cases Void (lvar , i) hs = refl
          proof-psi-phi-cases Void (lconst , x) hs = refl
          proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
          proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\T -> con (lpi {l = suc x} , ( S , T ) ))
                                                               (trans (reflFun (λ s → psi (phi (T (lifter (unlift s)))))
                                                                               (λ s → psi (phi (T (s))))
                                                                               (\s -> cong (λ s → psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                       (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))
          proof-psi-phi-cases Void (lsigma , ( S , T )) hs = cong (\T -> con (lsigma {l = suc x} , ( S , T ) ))
                                                                  (trans (reflFun (λ s → psi (phi (T (lifter (unlift s)))))
                                                                                (λ s → psi (phi (T (s))))
                                                                                (\s -> cong (λ s → psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                         (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))


Document P.C.Derive.

Document P.C.Derive.

Old-commit-hash: 962425cf9bb190e1b8fb2c400bd9765180081dd0

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Incrementalization as term-to-term transformation (Fig. 4g).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Derive
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

-- Extension point: Incrementalization of fully applied primitives.
Structure : Set
Structure = ∀ {Γ Σ τ} →
  Const Σ τ →
  Terms (ΔContext Γ) Σ →
  Terms (ΔContext Γ) (mapContext ΔType Σ) →
  Term (ΔContext Γ) (ΔType τ)

module Structure (deriveConst : Structure) where
  fit : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) τ
  fit = weaken Γ≼ΔΓ

  fit-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) Σ
  fit-terms = weaken-terms Γ≼ΔΓ

  -- In the paper, we transform "x" to "dx". Here, we work with
  -- de Bruijn indices, so we have to manipulate the indices to
  -- account for a bigger context after transformation.
  deriveVar : ∀ {τ Γ} → Var Γ τ → Var (ΔContext Γ) (ΔType τ)
  deriveVar this = this
  deriveVar (that x) = that (that (deriveVar x))

  derive-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) (mapContext ΔType Σ)
  derive : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) (ΔType τ)

  derive-terms {∅}    ∅ = ∅
  derive-terms {τ • Σ} (t • ts) = derive t • derive-terms ts

  -- We provide: Incrementalization of arbitrary terms.
  derive (var x) = var (deriveVar x)
  derive (app s t) = app (app (derive s) (fit t)) (derive t)
  derive (abs t) = abs (abs (derive t))
  derive (const c ts) = deriveConst c (fit-terms ts) (derive-terms ts)

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Derive
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

Structure : Set
Structure = ∀ {Γ Σ τ} →
  Const Σ τ →
  Terms (ΔContext Γ) Σ →
  Terms (ΔContext Γ) (mapContext ΔType Σ) →
  Term (ΔContext Γ) (ΔType τ)

module Structure (deriveConst : Structure) where
  fit : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) τ
  fit = weaken Γ≼ΔΓ

  fit-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) Σ
  fit-terms = weaken-terms Γ≼ΔΓ

  deriveVar : ∀ {τ Γ} → Var Γ τ → Var (ΔContext Γ) (ΔType τ)
  deriveVar this = this
  deriveVar (that x) = that (that (deriveVar x))

  derive-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) (mapContext ΔType Σ)
  derive : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) (ΔType τ)

  derive-terms {∅}    ∅ = ∅
  derive-terms {τ • Σ} (t • ts) = derive t • derive-terms ts

  derive (var x) = var (deriveVar x)
  derive (app s t) = app (app (derive s) (fit t)) (derive t)
  derive (abs t) = abs (abs (derive t))
  derive (const c ts) = deriveConst c (fit-terms ts) (derive-terms ts)