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

module Definition.Typed.EqualityRelation where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Weakening using (_∷_⊆_)

-- Generic equality relation used with the logical relation

record EqRelSet : Set₁ where
  constructor eqRel
  field
    ---------------
    -- Relations --
    ---------------

    -- Equality of types
    _⊢_≅_   : Con Term → (A B : Term)   → Set

    -- Equality of terms
    _⊢_≅_∷_ : Con Term → (t u A : Term) → Set

    -- Equality of neutral terms
    _⊢_~_∷_ : Con Term → (t u A : Term) → Set

    ----------------
    -- Properties --
    ----------------

    -- Generic equality compatibility
    ~-to-≅ₜ : ∀ {k l A Γ}
            → Γ ⊢ k ~ l ∷ A
            → Γ ⊢ k ≅ l ∷ A

    -- Judgmental conversion compatibility
    ≅-eq  : ∀ {A B Γ}
          → Γ ⊢ A ≅ B
          → Γ ⊢ A ≡ B
    ≅ₜ-eq : ∀ {t u A Γ}
          → Γ ⊢ t ≅ u ∷ A
          → Γ ⊢ t ≡ u ∷ A

    -- Universe
    ≅-univ : ∀ {A B Γ}
           → Γ ⊢ A ≅ B ∷ U
           → Γ ⊢ A ≅ B

    -- Symmetry
    ≅-sym  : ∀ {A B Γ}   → Γ ⊢ A ≅ B     → Γ ⊢ B ≅ A
    ≅ₜ-sym : ∀ {t u A Γ} → Γ ⊢ t ≅ u ∷ A → Γ ⊢ u ≅ t ∷ A
    ~-sym  : ∀ {k l A Γ} → Γ ⊢ k ~ l ∷ A → Γ ⊢ l ~ k ∷ A

    -- Transitivity
    ≅-trans  : ∀ {A B C Γ}   → Γ ⊢ A ≅ B     → Γ ⊢ B ≅ C     → Γ ⊢ A ≅ C
    ≅ₜ-trans : ∀ {t u v A Γ} → Γ ⊢ t ≅ u ∷ A → Γ ⊢ u ≅ v ∷ A → Γ ⊢ t ≅ v ∷ A
    ~-trans  : ∀ {k l m A Γ} → Γ ⊢ k ~ l ∷ A → Γ ⊢ l ~ m ∷ A → Γ ⊢ k ~ m ∷ A

    -- Conversion
    ≅-conv : ∀ {t u A B Γ} → Γ ⊢ t ≅ u ∷ A → Γ ⊢ A ≡ B → Γ ⊢ t ≅ u ∷ B
    ~-conv : ∀ {k l A B Γ} → Γ ⊢ k ~ l ∷ A → Γ ⊢ A ≡ B → Γ ⊢ k ~ l ∷ B

    -- Weakening
    ≅-wk  : ∀ {A B ρ Γ Δ}
          → ρ ∷ Δ ⊆ Γ
          → ⊢ Δ
          → Γ ⊢ A ≅ B
          → Δ ⊢ wk ρ A ≅ wk ρ B
    ≅ₜ-wk : ∀ {t u A ρ Γ Δ}
          → ρ ∷ Δ ⊆ Γ
          → ⊢ Δ
          → Γ ⊢ t ≅ u ∷ A
          → Δ ⊢ wk ρ t ≅ wk ρ u ∷ wk ρ A
    ~-wk  : ∀ {k l A ρ Γ Δ}
          → ρ ∷ Δ ⊆ Γ
          → ⊢ Δ
          → Γ ⊢ k ~ l ∷ A
          → Δ ⊢ wk ρ k ~ wk ρ l ∷ wk ρ A

    -- Weak head expansion
    ≅-red : ∀ {A A′ B B′ Γ}
          → Γ ⊢ A ⇒* A′
          → Γ ⊢ B ⇒* B′
          → Whnf A′
          → Whnf B′
          → Γ ⊢ A′ ≅ B′
          → Γ ⊢ A  ≅ B

    ≅ₜ-red : ∀ {a a′ b b′ A B Γ}
           → Γ ⊢ A ⇒* B
           → Γ ⊢ a ⇒* a′ ∷ B
           → Γ ⊢ b ⇒* b′ ∷ B
           → Whnf B
           → Whnf a′
           → Whnf b′
           → Γ ⊢ a′ ≅ b′ ∷ B
           → Γ ⊢ a  ≅ b  ∷ A

    -- Universe type reflexivity
    ≅-Urefl   : ∀ {Γ} → ⊢ Γ → Γ ⊢ U ≅ U

    -- Natural number type reflexivity
    ≅-ℕrefl   : ∀ {Γ} → ⊢ Γ → Γ ⊢ ℕ ≅ ℕ
    ≅ₜ-ℕrefl  : ∀ {Γ} → ⊢ Γ → Γ ⊢ ℕ ≅ ℕ ∷ U

    -- Empty type reflexivity
    ≅-Emptyrefl   : ∀ {Γ} → ⊢ Γ → Γ ⊢ Empty ≅ Empty
    ≅ₜ-Emptyrefl  : ∀ {Γ} → ⊢ Γ → Γ ⊢ Empty ≅ Empty ∷ U

    -- Unit type reflexivity
    ≅-Unitrefl : ∀ {Γ} → ⊢ Γ → Γ ⊢ Unit ≅ Unit
    ≅ₜ-Unitrefl  : ∀ {Γ} → ⊢ Γ → Γ ⊢ Unit ≅ Unit ∷ U

    -- Unit η-equality
    ≅ₜ-η-unit : ∀ {Γ e e'}
             → Γ ⊢ e ∷ Unit
             → Γ ⊢ e' ∷ Unit
             → Γ ⊢ e ≅ e' ∷ Unit

    -- Π-congruence

    ≅-Π-cong  : ∀ {F G H E Γ}
              → Γ ⊢ F
              → Γ ⊢ F ≅ H
              → Γ ∙ F ⊢ G ≅ E
              → Γ ⊢ Π F ▹ G ≅ Π H ▹ E

    ≅ₜ-Π-cong : ∀ {F G H E Γ}
              → Γ ⊢ F
              → Γ ⊢ F ≅ H ∷ U
              → Γ ∙ F ⊢ G ≅ E ∷ U
              → Γ ⊢ Π F ▹ G ≅ Π H ▹ E ∷ U

    -- Σ-congruence

    ≅-Σ-cong  : ∀ {F G H E Γ}
              → Γ ⊢ F
              → Γ ⊢ F ≅ H
              → Γ ∙ F ⊢ G ≅ E
              → Γ ⊢ Σ F ▹ G ≅ Σ H ▹ E

    ≅ₜ-Σ-cong : ∀ {F G H E Γ}
              → Γ ⊢ F
              → Γ ⊢ F ≅ H ∷ U
              → Γ ∙ F ⊢ G ≅ E ∷ U
              → Γ ⊢ Σ F ▹ G ≅ Σ H ▹ E ∷ U

    -- Zero reflexivity
    ≅ₜ-zerorefl : ∀ {Γ} → ⊢ Γ → Γ ⊢ zero ≅ zero ∷ ℕ

    -- Successor congruence
    ≅-suc-cong : ∀ {m n Γ} → Γ ⊢ m ≅ n ∷ ℕ → Γ ⊢ suc m ≅ suc n ∷ ℕ

    -- η-equality
    ≅-η-eq : ∀ {f g F G Γ}
           → Γ ⊢ F
           → Γ ⊢ f ∷ Π F ▹ G
           → Γ ⊢ g ∷ Π F ▹ G
           → Function f
           → Function g
           → Γ ∙ F ⊢ wk1 f ∘ var 0 ≅ wk1 g ∘ var 0 ∷ G
           → Γ ⊢ f ≅ g ∷ Π F ▹ G

    -- η for product types
    ≅-Σ-η : ∀ {p r F G Γ}
          → Γ ⊢ F
          → Γ ∙ F ⊢ G
          → Γ ⊢ p ∷ Σ F ▹ G
          → Γ ⊢ r ∷ Σ F ▹ G
          → Product p
          → Product r
          → Γ ⊢ fst p ≅ fst r ∷ F
          → Γ ⊢ snd p ≅ snd r ∷ G [ fst p ]
          → Γ ⊢ p ≅ r ∷ Σ F ▹ G

    -- Variable reflexivity
    ~-var : ∀ {x A Γ} → Γ ⊢ var x ∷ A → Γ ⊢ var x ~ var x ∷ A

    -- Application congruence
    ~-app : ∀ {a b f g F G Γ}
          → Γ ⊢ f ~ g ∷ Π F ▹ G
          → Γ ⊢ a ≅ b ∷ F
          → Γ ⊢ f ∘ a ~ g ∘ b ∷ G [ a ]

    -- Product projections congruence
    ~-fst : ∀ {p r F G Γ}
          → Γ ⊢ F
          → Γ ∙ F ⊢ G
          → Γ ⊢ p ~ r ∷ Σ F ▹ G
          → Γ ⊢ fst p ~ fst r ∷ F

    ~-snd : ∀ {p r F G Γ}
          → Γ ⊢ F
          → Γ ∙ F ⊢ G
          → Γ ⊢ p ~ r ∷ Σ F ▹ G
          → Γ ⊢ snd p ~ snd r ∷ G [ fst p ]

    -- Natural recursion congruence
    ~-natrec : ∀ {z z′ s s′ n n′ F F′ Γ}
             → Γ ∙ ℕ ⊢ F ≅ F′
             → Γ     ⊢ z ≅ z′ ∷ F [ zero ]
             → Γ     ⊢ s ≅ s′ ∷ Π ℕ ▹ (F ▹▹ F [ suc (var 0) ]↑)
             → Γ     ⊢ n ~ n′ ∷ ℕ
             → Γ     ⊢ natrec F z s n ~ natrec F′ z′ s′ n′ ∷ F [ n ]

    -- Empty recursion congruence
    ~-Emptyrec : ∀ {n n′ F F′ Γ}
               → Γ ⊢ F ≅ F′
               → Γ ⊢ n ~ n′ ∷ Empty
               → Γ ⊢ Emptyrec F n ~ Emptyrec F′ n′ ∷ F

  -- Star reflexivity
  ≅ₜ-starrefl : ∀ {Γ} → ⊢ Γ → Γ ⊢ star ≅ star ∷ Unit
  ≅ₜ-starrefl [Γ] = ≅ₜ-η-unit (starⱼ [Γ]) (starⱼ [Γ])

  -- Composition of universe and generic equality compatibility
  ~-to-≅ : ∀ {k l Γ} → Γ ⊢ k ~ l ∷ U → Γ ⊢ k ≅ l
  ~-to-≅ k~l = ≅-univ (~-to-≅ₜ k~l)

  ≅-W-cong : ∀ {F G H E Γ} W
          → Γ ⊢ F
          → Γ ⊢ F ≅ H
          → Γ ∙ F ⊢ G ≅ E
          → Γ ⊢ ⟦ W ⟧ F ▹ G ≅ ⟦ W ⟧ H ▹ E
  ≅-W-cong BΠ = ≅-Π-cong
  ≅-W-cong BΣ = ≅-Σ-cong

  ≅ₜ-W-cong : ∀ {F G H E Γ} W
            → Γ ⊢ F
            → Γ ⊢ F ≅ H ∷ U
            → Γ ∙ F ⊢ G ≅ E ∷ U
            → Γ ⊢ ⟦ W ⟧ F ▹ G ≅ ⟦ W ⟧ H ▹ E ∷ U
  ≅ₜ-W-cong BΠ = ≅ₜ-Π-cong
  ≅ₜ-W-cong BΣ = ≅ₜ-Σ-cong


------------------------------------------------------------------------
-- Compiler correctness
------------------------------------------------------------------------

{-# OPTIONS --cubical --sized-types #-}

module Lambda.Partiality-monad.Inductive.Compiler-correctness where

open import Equality.Propositional.Cubical
open import Prelude hiding (⊥)

open import Bijection equality-with-J using (_↔_)
open import Maybe equality-with-J as Maybe
open import Monad equality-with-J
open import Vec.Function equality-with-J

open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Monad

open import Lambda.Compiler
open import Lambda.Partiality-monad.Inductive.Interpreter
open import Lambda.Partiality-monad.Inductive.Virtual-machine
open import Lambda.Syntax
open import Lambda.Virtual-machine

private
  module C = Closure Code
  module T = Closure Tm

-- Compiler correctness.

mutual

  ⟦⟧-correct :
    ∀ {n} t {ρ : T.Env n} {c s} {k : ℕ → T.Value → M C.Value} {n} →
    (∀ v → steps ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≳[ n ]
           λ n → run (k n v)) →
    steps ⟨ comp t c , s , comp-env ρ ⟩ ≳[ n ]
    λ n → run (⟦ t ⟧′ ρ n >>= k n)
  ⟦⟧-correct (con i) {ρ} {c} {s} {k} hyp =
    steps ⟨ con i ∷ c , s , comp-env ρ ⟩                     ≳⟨ step⇓ ⟩
    steps ⟨ c , val (comp-val (T.con i)) ∷ s , comp-env ρ ⟩  ≳⟨ hyp (T.con i) ⟩
    (λ n → run (k n (T.con i)))                              ≡⟨ sym now->>= ⟩≳
    (λ n → run (⟦ con i ⟧′ ρ n >>= k n))                     ∎≳

  ⟦⟧-correct (var x) {ρ} {c} {s} {k} hyp =
    steps ⟨ var x ∷ c , s , comp-env ρ ⟩                 ≳⟨ step⇓ ⟩
    steps ⟨ c , val (comp-val (ρ x)) ∷ s , comp-env ρ ⟩  ≳⟨ hyp (ρ x) ⟩
    (λ n → run (k n (ρ x)))                              ≡⟨ sym now->>= ⟩≳
    (λ n → run (⟦ var x ⟧′ ρ n >>= k n))                 ∎≳

  ⟦⟧-correct (ƛ t) {ρ} {c} {s} {k} hyp =
    steps ⟨ clo (comp t (ret ∷ [])) ∷ c , s , comp-env ρ ⟩   ≳⟨ step⇓ ⟩
    steps ⟨ c , val (comp-val (T.ƛ t ρ)) ∷ s , comp-env ρ ⟩  ≳⟨ hyp (T.ƛ t ρ) ⟩
    (λ n → run (k n (T.ƛ t ρ)))                              ≡⟨ sym now->>= ⟩≳
    (λ n → run (⟦ ƛ t ⟧′ ρ n >>= k n))                       ∎≳

  ⟦⟧-correct (t₁ · t₂) {ρ} {c} {s} {k} {n} hyp =
    steps ⟨ comp t₁ (comp t₂ (app ∷ c)) , s , comp-env ρ ⟩     ≳⟨ (⟦⟧-correct t₁ {n = n} λ v₁ → ⟦⟧-correct t₂ λ v₂ → ∙-correct v₁ v₂ hyp) ⟩

    (λ n → run (⟦ t₁ ⟧′ ρ n >>= λ v₁ →
                ⟦ t₂ ⟧′ ρ n >>= λ v₂ →
                (v₁ ∙ v₂) n >>= k n))                          ≡⟨ cong (λ f → run (⟦ t₁ ⟧′ ρ n >>= f))
                                                                       (⟨ext⟩ λ v₁ → Monad.associativity tr (⟦ t₂ ⟧′ ρ n) _ _) ⟩≳
    (λ n → run (⟦ t₁ ⟧′ ρ n >>= λ v₁ →
               (⟦ t₂ ⟧′ ρ n >>= λ v₂ → (v₁ ∙ v₂) n) >>= k n))  ≡⟨ cong MaybeT.run $ Monad.associativity tr (⟦ t₁ ⟧′ ρ n) _ _ ⟩≳

    (λ n → run (⟦ t₁ · t₂ ⟧′ ρ n >>= k n))                     ∎≳
    where
    tr = Monad-transformer.transform (Maybe.monad-transformer ext)

  ∙-correct :
    ∀ {n} v₁ v₂ {ρ : T.Env n} {c s} {k : ℕ → T.Value → M C.Value} {n} →
    (∀ v → steps ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≳[ n ]
           λ n → run (k n v)) →
    steps ⟨ app ∷ c
          , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s
          , comp-env ρ
          ⟩ ≳[ n ]
    λ n → run ((v₁ ∙ v₂) n >>= k n)
  ∙-correct (T.con i) v₂ {ρ} {c} {s} {k} hyp =
    steps ⟨ app ∷ c
          , val (comp-val v₂) ∷ val (C.con i) ∷ s
          , comp-env ρ
          ⟩                                        ≳⟨⟩

    const (run fail)                               ≡⟨ sym now->>= ⟩≳

    (λ n → run ((T.con i ∙ v₂) n >>= k n))         ∎≳

  ∙-correct (T.ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} {zero} hyp =
    steps ⟨ app ∷ c
          , val (comp-val v₂) ∷ val (comp-val (T.ƛ t₁ ρ₁)) ∷ s
          , comp-env ρ
          ⟩                                   ≡⟨ refl ⟩≳

    const never                               ≡⟨ sym never->>= ⟩≳

    const (never >>= _)                       ≡⟨ cong (_>>= maybe (MaybeT.run ∘ k 0) (return nothing) ⦂ (_ ⊥ → _)) (sym never->>=) ⟩≳

    (λ n → run ((T.ƛ t₁ ρ₁ ∙ v₂) n >>= k n))  ∎≳

  ∙-correct (T.ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} {suc n} hyp = later (
    steps ⟨ app ∷ c
          , val (comp-val v₂) ∷
            val (comp-val (T.ƛ t₁ ρ₁)) ∷ s
          , comp-env ρ
          ⟩ ∘ suc                                         ≳⟨⟩

    steps ⟨ comp t₁ (ret ∷ [])
          , ret c (comp-env ρ) ∷ s
          , cons (comp-val v₂) (comp-env ρ₁)
          ⟩                                               ∀≡⟨ (λ n → cong (λ ρ′ → steps ⟨ comp t₁ (ret ∷ []) , ret c (comp-env ρ) ∷ s , ρ′ ⟩ n) $
                                                                          sym comp-cons) ⟩≳
    steps ⟨ comp t₁ (ret ∷ [])
          , ret c (comp-env ρ) ∷ s
          , comp-env (cons v₂ ρ₁)
          ⟩                                               ≳⟨ (⟦⟧-correct t₁ {n = n} λ v →

        steps ⟨ ret ∷ []
              , val (comp-val v) ∷ ret c (comp-env ρ) ∷ s
              , comp-env (cons v₂ ρ₁)
              ⟩                                                ≳⟨ step⇓ ⟩

        steps ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩        ≳⟨ hyp v ⟩

        (λ n → run (k n v))                                    ≳⟨ step⇓ ⟩

        (λ n → run (k (suc n) v))                              ∎≳) ⟩

    (λ n → run (⟦ t₁ ⟧′ (cons v₂ ρ₁) n >>= k (suc n)))    ≳⟨⟩

    (λ n → run ((T.ƛ t₁ ρ₁ ∙ v₂) (suc n) >>= k (suc n)))  ∎≳)

-- Note that the equality that is used here is syntactic.

correct :
  ∀ t →
  wrap (exec ⟨ comp t [] , [] , nil ⟩) ≡
  (⟦ t ⟧ nil >>= λ v → return (comp-val v))
correct t =
  wrap (exec ⟨ comp t [] , [] , nil ⟩)                     ≡⟨ cong (λ ρ → wrap (exec ⟨ comp t [] , [] , ρ ⟩)) $ sym comp-nil ⟩

  wrap (exec ⟨ comp t [] , [] , comp-env nil ⟩)            ≡⟨⟩

  wrap (⨆ (stepsˢ ⟨ comp t [] , [] , comp-env nil ⟩))      ≡⟨ cong wrap (≳→⨆≡⨆ 0 $ ⟦⟧-correct t λ v →
                                                                                const (MaybeT.run (return (comp-val v))) ∎≳) ⟩
  wrap (⨆ (⟦ t ⟧ˢ nil >>=ˢ λ v →
           constˢ (MaybeT.run (return (comp-val v)))))     ≡⟨ cong (λ s → wrap (⨆ s))
                                                                   (_↔_.to equality-characterisation-increasing (λ _ → refl)) ⟩
  wrap (⨆ (maybe (λ v → MaybeT.run (return (comp-val v)))
                 (return nothing)
             ∗-inc
           ⟦ t ⟧ˢ nil))                                    ≡⟨ cong wrap (sym ⨆->>=) ⟩∎

  (⟦ t ⟧ nil >>= λ v → return (comp-val v))                ∎


-- Soundness proofs of structural lemmas and substitution
module Semantics.Substitution.Soundness where

open import Syntax.Types
open import Syntax.Context renaming (_,_ to _,,_)
open import Syntax.Terms
open import Syntax.Substitution.Kits
open import Syntax.Substitution.Instances
open import Syntax.Substitution.Lemmas

open import Semantics.Types
open import Semantics.Context
open import Semantics.Terms
open import Semantics.Substitution.Kits
open import Semantics.Substitution.Traversal
open import Semantics.Substitution.Instances
open import Semantics.Bind

open import CategoryTheory.Categories using (Category ; ext)
open import CategoryTheory.Functor
open import CategoryTheory.NatTrans
open import CategoryTheory.Monad
open import CategoryTheory.Comonad
open import CategoryTheory.Linear
open import CategoryTheory.Instances.Reactive renaming (top to ⊤)
open import TemporalOps.Diamond
open import TemporalOps.Box
open import TemporalOps.OtherOps
open import TemporalOps.StrongMonad
open import TemporalOps.Linear

open import Data.Sum
open import Data.Product using (_,_)
open import Relation.Binary.PropositionalEquality as ≡
    using (_≡_ ; refl ; sym ; trans ; cong ; cong₂ ; subst)

open ≡.≡-Reasoning
open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

open ⟦K⟧ ⟦𝒯erm⟧

-- | Interpretation of various types of substitution as context morphisms

-- Denotation of term substitutions
⟦_⟧ₛ : ∀{Γ Δ} -> Subst Term Γ Δ -> ⟦ Δ ⟧ₓ ⇴ ⟦ Γ ⟧ₓ
⟦ σ ⟧ₛ = ⟦subst⟧ σ

-- Denotation of OPEs
⟦_⟧⊆ : ∀{Γ Δ} -> Γ ⊆ Δ -> ⟦ Δ ⟧ₓ ⇴ ⟦ Γ ⟧ₓ
⟦ s ⟧⊆ = ⟦ s ⊆ₛ 𝒯erm ⟧ₛ

-- Denotation of context exchange
⟦exch⟧ : ∀ Γ Γ′ Γ″ {A B} -> ⟦ Γ ⌊ B ⌋ Γ′ ⌊ A ⌋ Γ″ ⟧ₓ ⇴ ⟦ Γ ⌊ A ⌋ Γ′ ⌊ B ⌋ Γ″ ⟧ₓ
⟦exch⟧ Γ Γ′ Γ″ = ⟦ exₛ 𝒯ermₛ Γ Γ′ Γ″ ⟧ₛ

-- Denotation of context contraction
⟦contr⟧ : ∀ Γ Γ′ Γ″ {A} -> ⟦ Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″ ⟧ₓ ⇴ ⟦ Γ ⌊ A ⌋ Γ′ ⌊ A ⌋ Γ″ ⟧ₓ
⟦contr⟧ Γ Γ′ Γ″ = ⟦ contr-lₛ 𝒯ermₛ Γ Γ′ Γ″ ⟧ₛ

-- Denotation of middle context substitution
⟦_⌊⌋ₛ_⊢ₛ_⟧ : ∀ Γ Γ′ {A} -> Γ ⌊⌋ Γ′ ⊢ A -> ⟦ Γ ⌊⌋ Γ′ ⟧ₓ ⇴ ⟦ Γ ⌊ A ⌋ Γ′ ⟧ₓ
⟦ Γ ⌊⌋ₛ Γ′ ⊢ₛ M ⟧ = ⟦ sub-midₛ 𝒯ermₛ Γ Γ′ M ⟧ₛ

-- Denotational soundness of top substitution
⟦sub-topₛ⟧ : ∀ {Γ A} -> (M : Γ ⊢ A)
        -> ⟦ sub-topₛ 𝒯ermₛ M ⟧ₛ ≈ ⟨ id , ⟦ M ⟧ₘ ⟩
⟦sub-topₛ⟧ {Γ} M {n} {⟦Γ⟧} rewrite ⟦idₛ⟧ {Γ} {n} {⟦Γ⟧} = refl

-- | Soundness theorems
-- | Concrete soundness theorems for structural lemmas and substitution
-- | are instances of the general traversal soundness proof

-- Substituting traversal is sound
substitute-sound : ∀{Γ Δ A} (σ : Subst Term Γ Δ) (M : Γ ⊢ A)
                -> ⟦ substitute σ M ⟧ₘ ≈ ⟦ M ⟧ₘ ∘ ⟦ σ ⟧ₛ
substitute-sound σ M = traverse-sound ⟦𝒯erm⟧ σ M

substitute′-sound : ∀{Γ Δ A} (σ : Subst Term Γ Δ) (M : Γ ⊨ A)
                -> ⟦ substitute′ σ M ⟧ᵐ ≈ ⟦ M ⟧ᵐ ∘ ⟦ σ ⟧ₛ
substitute′-sound σ M = traverse′-sound ⟦𝒯erm⟧ σ M

-- Weakening lemma is sound
weakening-sound : ∀{Γ Δ A} (s : Γ ⊆ Δ) (M : Γ ⊢ A)
               -> ⟦ weakening s M ⟧ₘ ≈ ⟦ M ⟧ₘ ∘ ⟦ s ⟧⊆
weakening-sound s = substitute-sound (s ⊆ₛ 𝒯erm)

-- Exchange lemma is sound
exchange-sound : ∀{Γ Γ′ Γ″ A B C} (M : Γ ⌊ A ⌋ Γ′ ⌊ B ⌋ Γ″ ⊢ C)
              -> ⟦ exchange Γ Γ′ Γ″ M ⟧ₘ ≈ ⟦ M ⟧ₘ ∘ (⟦exch⟧ Γ Γ′ Γ″)
exchange-sound {Γ} {Γ′} {Γ″} = substitute-sound (exₛ 𝒯ermₛ Γ Γ′ Γ″)

-- Contraction lemma is sound
contraction-sound : ∀{Γ Γ′ Γ″ A B} (M : Γ ⌊ A ⌋ Γ′ ⌊ A ⌋ Γ″ ⊢ B)
                 -> ⟦ contraction Γ Γ′ Γ″ M ⟧ₘ ≈ ⟦ M ⟧ₘ ∘ (⟦contr⟧ Γ Γ′ Γ″)
contraction-sound {Γ} {Γ′} {Γ″} = substitute-sound (contr-lₛ 𝒯ermₛ Γ Γ′ Γ″)

-- Substitution lemma is sound
substitution-sound : ∀{Γ Γ′ A B} (M : Γ ⌊⌋ Γ′ ⊢ A) (N : Γ ⌊ A ⌋ Γ′ ⊢ B)
                 -> ⟦ substitution Γ Γ′ M N ⟧ₘ ≈ ⟦ N ⟧ₘ ∘ ⟦ Γ ⌊⌋ₛ Γ′ ⊢ₛ M ⟧
substitution-sound {Γ} {Γ′} M = substitute-sound (sub-midₛ 𝒯ermₛ Γ Γ′ M)

-- Substitution lemma is sound
substitution′-sound : ∀{Γ Γ′ A B} (M : Γ ⌊⌋ Γ′ ⊢ A) (N : Γ ⌊ A ⌋ Γ′ ⊨ B)
                 -> ⟦ substitution′ Γ Γ′ M N ⟧ᵐ ≈ ⟦ N ⟧ᵐ ∘ ⟦ Γ ⌊⌋ₛ Γ′ ⊢ₛ M ⟧
substitution′-sound {Γ} {Γ′} M N = traverse′-sound ⟦𝒯erm⟧ (sub-midₛ 𝒯ermₛ Γ Γ′ M) N

-- Top substitution is sound (full categorical proof)
subst-sound : ∀{Γ A B} (M : Γ ⊢ A) (N : Γ ,, A ⊢ B)
           -> ⟦ [ M /] N ⟧ₘ ≈ ⟦ N ⟧ₘ ∘ ⟨ id , ⟦ M ⟧ₘ ⟩
subst-sound M N {n} {a} rewrite sym (⟦sub-topₛ⟧ M {n} {a}) =
    substitute-sound (sub-topₛ 𝒯ermₛ M) N

-- Top substitution is sound (full categorical proof)
subst′-sound : ∀{Γ A B} (M : Γ ⊢ A) (N : Γ ,, A ⊨ B)
           -> ⟦ [ M /′] N ⟧ᵐ ≈ ⟦ N ⟧ᵐ ∘ ⟨ id , ⟦ M ⟧ₘ ⟩
subst′-sound M N {n} {a} rewrite sym (⟦sub-topₛ⟧ M {n} {a}) =
    traverse′-sound ⟦𝒯erm⟧ (sub-topₛ 𝒯ermₛ M) N

open K 𝒯erm
open Monad M-◇
open Comonad W-□
open Functor F-□ renaming (fmap to □-f)
open Functor F-◇ renaming (fmap to ◇-f)
private module F-◇ = Functor F-◇

-- Lemma used in the soundness proof of computational substitution
subst″-sound-lemma : ∀ Γ {A B} (n k l : ℕ)
                    -> (D : Γ ˢ ,, A now ⊨ B now)
                    -> (⟦Γ⟧ : ⟦ Γ ⟧ₓ n) (⟦A⟧ : ⟦ A ⟧ₜ l)
                  -> ⟦ substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ l (⟦ Γ ˢ ˢ⟧□ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k) l , ⟦A⟧)
                   ≡ ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧)
subst″-sound-lemma Γ {A} n k l D ⟦Γ⟧ ⟦A⟧
    rewrite substitute′-sound ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D {l} {⟦ Γ ˢ ˢ⟧□ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k) l , ⟦A⟧}
          | ⟦↑⟧ (A now) (Γ ˢˢₛ 𝒯erm) {l} {⟦ Γ ˢ ˢ⟧□ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k) l , ⟦A⟧}
          | □-≡ k l (□-≡ n k (⟦ˢ⟧□-twice Γ {n} {⟦Γ⟧}) k) l
          | □-≡ k l (⟦ˢˢ⟧ Γ {n} {⟦Γ⟧}) l = refl

subst″-sound : ∀{Γ A B} (C : Γ ⊨ A now) (D : Γ ˢ ,, A now ⊨ B now)
            -> ⟦ ⟨ C /⟩ D ⟧ᵐ ≈ bindEvent Γ ⟦ C ⟧ᵐ ⟦ D ⟧ᵐ
subst″-sound {Γ}{A}{B} (pure M) D {n} {⟦Γ⟧}
    rewrite traverse′-sound ⟦𝒯erm⟧ (sub-topˢₛ 𝒯ermₛ M) D {n} {⟦Γ⟧}
          | ⟦subst⟧-Γˢ⊆Γ Γ {n} {⟦Γ⟧} | ⟦ˢ⟧-factor Γ {n} {⟦Γ⟧} = refl
subst″-sound {Γ}{A}{B} (letSig_InC_ {A = G} S C) D {n} {⟦Γ⟧}
    rewrite subst″-sound C (substitute′ (idₛ 𝒯erm ⁺ 𝒯erm ↑ 𝒯erm) D) {n} {⟦Γ⟧ , ⟦ S ⟧ₘ n ⟦Γ⟧}
    =
    begin
        bindEvent (Γ ,, G always) ⟦ C ⟧ᵐ ⌞ ⟦ substitute′ ((_⁺_ {G always} (idₛ 𝒯erm) 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ ⌟ n (⟦Γ⟧ , ⟦ S ⟧ₘ n ⟦Γ⟧)
    ≡⟨ bind-to->>= (Γ ,, G always) ⟦ C ⟧ᵐ ⟦ substitute′ ((_⁺_ {G always} (idₛ 𝒯erm) 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ n (⟦Γ⟧ , ⟦ S ⟧ₘ n ⟦Γ⟧) ⟩
            ⟦ C ⟧ᵐ n (⟦Γ⟧ , ⟦ S ⟧ₘ n ⟦Γ⟧)
            >>= (λ l ⟦A⟧ → ⟦ substitute′ (idₛ 𝒯erm ⁺ 𝒯erm ↑ 𝒯erm) D ⟧ᵐ l ((⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦ S ⟧ₘ n ⟦Γ⟧) , ⟦A⟧))
    ≡⟨ cong (λ x → (⟦ C ⟧ᵐ n (⟦Γ⟧ , ⟦ S ⟧ₘ n ⟦Γ⟧) >>= x))
        (ext λ l → ext λ ⟦A⟧ →
            begin
                ⟦ substitute′ (idₛ 𝒯erm ⁺ 𝒯erm ↑ 𝒯erm) D ⟧ᵐ l ((⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦ S ⟧ₘ n ⟦Γ⟧) , ⟦A⟧)
            ≡⟨ substitute′-sound (_↑_ {A now} (_⁺_ {G always} (idₛ 𝒯erm) 𝒯erm) 𝒯erm) D {l} {((⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦ S ⟧ₘ n ⟦Γ⟧) , ⟦A⟧)} ⟩
                ⟦ D ⟧ᵐ l (⟦ (_↑_ {A now} {Γ = Γ ˢ} (_⁺_ {G always} (idₛ 𝒯erm) 𝒯erm) 𝒯erm) ⟧ₛ l ((⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦ S ⟧ₘ n ⟦Γ⟧) , ⟦A⟧))
            ≡⟨ cong (⟦ D ⟧ᵐ l) (⟦↑⟧ (A now) {Γ ˢ ,, G always} (_⁺_ {G always} (idₛ 𝒯erm) 𝒯erm) {l} {(⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦ S ⟧ₘ n ⟦Γ⟧) , ⟦A⟧}) ⟩
                ⟦ D ⟧ᵐ l (⟦ _⁺_ {G always} {Γ = Γ ˢ} (idₛ 𝒯erm) 𝒯erm ⟧ₛ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦ S ⟧ₘ n ⟦Γ⟧) , ⟦A⟧)
            ≡⟨ cong (λ x → ⟦ D ⟧ᵐ l (x , ⟦A⟧)) (⟦⁺⟧ (G always) {Γ ˢ} (idₛ 𝒯erm) {l} {⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦ S ⟧ₘ n ⟦Γ⟧}) ⟩
                ⟦ D ⟧ᵐ l (⟦ idₛ {Γ ˢ} 𝒯erm ⟧ₛ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , ⟦A⟧)
            ≡⟨ cong (λ x → ⟦ D ⟧ᵐ l (x , ⟦A⟧)) (⟦idₛ⟧ {Γ ˢ} {l} {⟦ Γ ˢ⟧□ n ⟦Γ⟧ l}) ⟩
                ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧)
            ∎
        )
     ⟩
        ⟦ letSig S InC C ⟧ᵐ n ⟦Γ⟧
        >>= (λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    ≡⟨ sym (bind-to->>= Γ ⟦ letSig S InC C ⟧ᵐ ⟦ D ⟧ᵐ n ⟦Γ⟧) ⟩
        bindEvent Γ ⟦ letSig S InC C ⟧ᵐ ⟦ D ⟧ᵐ n ⟦Γ⟧
    ∎

subst″-sound {Γ}{A}{B} (letEvt_In_ {A = G} E C) D {n} {⟦Γ⟧} =
    begin
        ⟦ ⟨ letEvt E In C /⟩ D ⟧ᵐ n ⟦Γ⟧
    ≡⟨ bind-to->>= Γ ⟦ E ⟧ₘ ⟦ ⟨ C /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ n ⟦Γ⟧ ⟩
        ⟦ E ⟧ₘ n ⟦Γ⟧
            >>= (λ k ⟦A⟧ → ⟦ ⟨ C /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧))
    ≡⟨ cong (λ x → ⟦ E ⟧ₘ n ⟦Γ⟧ >>= x)
        (ext λ k → ext λ ⟦A⟧ → (begin
            ⟦ ⟨ C /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧)
        ≡⟨ subst″-sound C (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) {k} {⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧} ⟩
            bindEvent (Γ ˢ ,, G now) ⟦ C ⟧ᵐ
                ⟦ substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧)
        ≡⟨ bind-to->>= (Γ ˢ ,, G now) ⟦ C ⟧ᵐ ⟦ substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧) ⟩
            ⟦ C ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧)
            >>= (λ l ⟦A⟧₁ → ⟦ substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ l (⟦ Γ ˢ ˢ⟧□ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k) l , ⟦A⟧₁))
        ≡⟨ cong (λ x → ⟦ C ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧) >>= x)
                (ext λ l → ext λ ⟦A⟧₁ → subst″-sound-lemma Γ n k l D ⟦Γ⟧ ⟦A⟧₁) ⟩
            ⟦ C ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧)
            >>= (λ l ⟦A⟧₁ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧₁))
        ∎)) ⟩
        ⟦ E ⟧ₘ n ⟦Γ⟧
            >>= (λ k ⟦A⟧ → ⟦ C ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧)
                >>=  λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    ≡⟨ sym (>>=-assoc (⟦ E ⟧ₘ n ⟦Γ⟧) _ _) ⟩
        (⟦ E ⟧ₘ n ⟦Γ⟧
            >>= λ k ⟦A⟧ → ⟦ C ⟧ᵐ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧ k , ⟦A⟧))
        >>= (λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    ≡⟨ cong (λ x -> x >>= _) (sym (bind-to->>= Γ ⟦ E ⟧ₘ ⟦ C ⟧ᵐ n ⟦Γ⟧)) ⟩
        (⟦ letEvt E In C ⟧ᵐ n ⟦Γ⟧
            >>= (λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧)))
    ≡⟨ sym (bind-to->>= Γ ⟦ letEvt E In C ⟧ᵐ ⟦ D ⟧ᵐ n ⟦Γ⟧) ⟩
        bindEvent Γ ⟦ letEvt E In C ⟧ᵐ ⟦ D ⟧ᵐ n ⟦Γ⟧
    ∎

subst″-sound {Γ}{A}{B} (select_↦_||_↦_||both↦_ {A = G}{H} E₁ C₁ E₂ C₂ C₃) D {n} {⟦Γ⟧} =
    begin
        ⟦ ⟨ select E₁ ↦ C₁ || E₂ ↦ C₂ ||both↦ C₃ /⟩ D ⟧ᵐ n ⟦Γ⟧
    ≡⟨⟩
        ⟦ select E₁ ↦ ⟨ C₁ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D)
              || E₂ ↦ ⟨ C₂ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D)
              ||both↦ ⟨ C₃ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ n ⟦Γ⟧
    ≡⟨⟩
        bindEvent Γ (⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫) (handle
            ⟦ ⟨ C₁ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
            ⟦ ⟨ C₂ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
            ⟦ ⟨ C₃ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ) n ⟦Γ⟧
    ≡⟨ bind-to->>= Γ (⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫) (handle
                ⟦ ⟨ C₁ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
                ⟦ ⟨ C₂ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
                ⟦ ⟨ C₃ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ) n ⟦Γ⟧ ⟩
        ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫ n ⟦Γ⟧
        >>= (λ l ⟦A⟧ → handle
                ⟦ ⟨ C₁ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
                ⟦ ⟨ C₂ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
                ⟦ ⟨ C₃ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    ≡⟨ cong (λ x → ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫ n ⟦Γ⟧ >>= x) (ext λ m → ext λ c → lemma m c) ⟩
        ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫ n ⟦Γ⟧
            >>= (λ m c → handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ m (⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , c)
                >>= λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    ≡⟨ sym (>>=-assoc (⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫ n ⟦Γ⟧) _ _) ⟩
        (⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫ n ⟦Γ⟧
            >>= λ m c -> handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ m (⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , c))
        >>= (λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    ≡⟨ cong (λ x -> x >>= _) (sym (bind-to->>= Γ (⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫)
                (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ) n ⟦Γ⟧)) ⟩
        bindEvent Γ (⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫)
            (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ) n ⟦Γ⟧
        >>= (λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    ≡⟨ sym (bind-to->>= Γ (bindEvent Γ (⟪_,_⟫ ⟦ E₁ ⟧ₘ ⟦ E₂ ⟧ₘ) (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ))
                    ⟦ D ⟧ᵐ n ⟦Γ⟧) ⟩
        bindEvent Γ (bindEvent Γ ⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫ (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ)) ⟦ D ⟧ᵐ n ⟦Γ⟧
    ∎
    where
    lemma : ∀ m c
           -> handle
               ⟦ ⟨ C₁ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
               ⟦ ⟨ C₂ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ
               ⟦ ⟨ C₃ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) ⟧ᵐ m (⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , c)
            ≡ (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ m (⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , c)
                >>= λ l ⟦A⟧ → ⟦ D ⟧ᵐ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
    lemma m (inj₁ (inj₁ (⟦A⟧ , ⟦◇B⟧)))
        rewrite subst″-sound C₁ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) {m} {(⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , ⟦A⟧) , ⟦◇B⟧}
              | bind-to->>= (Γ ˢ ,, G now ,, Event H now) ⟦ C₁ ⟧ᵐ ⟦ substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ m ((⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , ⟦A⟧) , ⟦◇B⟧)
              | (ext λ l → ext λ ⟦C⟧ → subst″-sound-lemma Γ n m l D ⟦Γ⟧ ⟦C⟧)
        = refl
    lemma m (inj₁ (inj₂ (⟦◇A⟧ , ⟦B⟧)))
        rewrite subst″-sound C₂ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) {m} {(⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , ⟦◇A⟧) , ⟦B⟧}
              | bind-to->>= (Γ ˢ ,, Event G now ,, H now) ⟦ C₂ ⟧ᵐ ⟦ substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ m ((⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , ⟦◇A⟧) , ⟦B⟧)
              | (ext λ l → ext λ ⟦C⟧ → subst″-sound-lemma Γ n m l D ⟦Γ⟧ ⟦C⟧)
        = refl
    lemma m (inj₂ (⟦A⟧ , ⟦B⟧))
        rewrite subst″-sound C₃ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D) {m} {(⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , ⟦A⟧) , ⟦B⟧}
              | bind-to->>= (Γ ˢ ,, G now ,, H now) ⟦ C₃ ⟧ᵐ ⟦ substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D ⟧ᵐ m ((⟦ Γ ˢ⟧□ n ⟦Γ⟧ m , ⟦A⟧) , ⟦B⟧)
              | (ext λ l → ext λ ⟦C⟧ → subst″-sound-lemma Γ n m l D ⟦Γ⟧ ⟦C⟧)
        = refl


module _ where

open import Data.Nat using (_+_)
open import Data.Nat.Properties.Simple using ( +-comm ; +-assoc)
open import utility
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Environment as Env
open import Esterel.Context
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import sn-calculus
open import context-properties
open import Esterel.Lang.Binding
open import Data.Maybe using ( just )
open import Function using (_$_)

open import Data.FiniteMap
import Data.OrderedListMap as OMap
open import Data.Nat as Nat using (ℕ)
open import Esterel.Variable.Signal as Signal
  using (Signal)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar)
open import Esterel.Variable.Sequential as SeqVar

open import sn-calculus-confluence.helper
open import sn-calculus-confluence.rec
open import sn-calculus-confluence.potrec
open import sn-calculus-confluence.potpot

ρ-conf : ∀{p FV BV ql qr θ qi A} → CorrectBinding p FV BV → p sn⟶₁ ql → p sn⟶₁ qr → p ≡ (ρ⟨ θ , A ⟩· qi)
         → ql ≡ qr
         ⊎ (∃ (λ o → ql sn⟶₁ o × qr sn⟶₁ o))
         ⊎ ql sn⟶₁ qr
         ⊎ qr sn⟶₁ ql
ρ-conf {(ρ⟨ θ , .A ⟩· qi)}{ql = ql}{qr = qr}{A = A} cb redl redr refl with ρ-stays-ρ-sn⟶₁ redl | ρ-stays-ρ-sn⟶₁ redr
... | (θl , qlin , Al , refl) | (θr , qrin , Ar , refl) with get-view redl | get-view redr
ρ-conf {(ρ⟨ θ , .A ⟩· qi)}{ql = ql}{qr = qr}{A = A} cb redl redr refl | (θl , qlin , Al , refl) | (θr , qrin , Ar , refl) | inj₁ (_ , _ , _ , _ , _ , viewl) | inj₁ (_ , _ , _ , _ , _ , viewr)
   with E-view-main-bind viewl viewr
... | inj₁ (e= , q= , θ= , A=) rewrite e= | q= | θ= | A= = inj₁ refl
... | inj₂ ~a with ρ-conf-rec cb _ _ ~a redl redr _ _ viewl viewr
... | (θo , Ao , so , _ , _ , _ , _ , _ , _ , redol , redor , _) = inj₂ $ inj₁ ((ρ⟨ θo , Ao ⟩· so) , redol , redor)
ρ-conf {(ρ⟨ θ  , .A ⟩· qi)}{ql = ql}{qr = qr}{A = A} cb redl redr refl | (θl , qlin , Al , refl) | (θr , qrin , Ar , refl) | inj₁ (_ , _ , _ , _ , _ , viewl) | inj₂ (_ , _ , viewr)
  with ρ-pot-conf-rec cb viewr viewl
... | inj₁ redo = inj₂ (inj₂ (inj₂ redo))
... | inj₂ (s , env , Ao , redol , redor) = inj₂ $ inj₁ (ρ⟨ env , Ao ⟩· s , redor , redol)
ρ-conf {(ρ⟨ θ  , .A ⟩· qi)}{ql = ql}{qr = qr}{A = A} cb redl redr refl | (θl , qlin , Al , refl) | (θr , qrin , Ar , refl) | inj₂ (_ , _ , viewl) | inj₁ (_ , _ , _ , _ , _ , viewr)
    with ρ-pot-conf-rec cb viewl viewr
... | inj₁ redo = inj₂ (inj₂ (inj₁ redo))
... | inj₂ (s , env , Ao , redol , redor) = inj₂ $ inj₁ ((ρ⟨ env , Ao ⟩· s) , redol , redor)
ρ-conf {(ρ⟨ θ  , .A ⟩· qi)}{ql = ql}{qr = qr}{A = A} cb redl redr refl | (θl , qlin , Al , refl) | (θr , qrin , Ar , refl) | inj₂ (_ , _ , viewl) | inj₂ (_ , _ , viewr)
    with pot-pot-conf-rec viewl viewr
... | inj₁ eq = inj₁ eq
... | inj₂ (env , redol , redor) = inj₂ $ inj₁ (ρ⟨ env , A ⟩· qi , redol , redor)

R-confluent : ∀{p q r BV FV} → CorrectBinding p BV FV → p sn⟶₁ q → p sn⟶₁ r
                                   → q ≡ r
                                   ⊎ (∃ (λ s → q sn⟶₁ s × r sn⟶₁ s))
                                   ⊎ q sn⟶₁ r
                                   ⊎ r sn⟶₁ q
R-confluent {.(_ ∥ _)} cb (rpar-done-right p'' q'') (rpar-done-right p' q') = inj₁ ( value-max-unique{d1 = (dhalted p'')}{d2 = q''}{d3 = (dhalted p')}{d4 = q'} )
R-confluent {.(_ ∥ _)} cb (rpar-done-right p'' q'') (rpar-done-left p' q') = inj₁ ( value-max-unique{d1 = (dhalted p'')}{d2 = q''}{d3 = p'}{d4 = (dhalted q')} )
R-confluent {.(_ ∥ _)} cb (rpar-done-left p'' q'') (rpar-done-right p' q') = inj₁ (value-max-unique{d1 = (p'')}{d2 =(dhalted q'')}{d3 = (dhalted p')}{d4 = (q')})
R-confluent {.(_ ∥ _)} cb (rpar-done-left p'' q'') (rpar-done-left p' q') = inj₁ (value-max-unique{d1 = p''}{d2 = (dhalted q'')}{d3 = p'}{d4 = (dhalted q')})
R-confluent {.(loop _)} cb rloop-unroll rloop-unroll = inj₁ refl
R-confluent {.(nothin >> _)} cb rseq-done rseq-done = inj₁ refl
R-confluent {.(exit _ >> _)} cb rseq-exit rseq-exit = inj₁ refl
R-confluent {.(loopˢ (exit _) _)} cb rloopˢ-exit rloopˢ-exit = inj₁ refl
R-confluent {.(suspend nothin _)} cb (rsuspend-done hnothin) (rsuspend-done hnothin) = inj₁ refl
R-confluent {.(suspend (exit n) _)} cb (rsuspend-done (hexit n)) (rsuspend-done (hexit .n)) = inj₁ refl
R-confluent {.(trap nothin)} cb (rtrap-done hnothin) (rtrap-done hnothin) = inj₁ refl
R-confluent {.(trap (exit n))} cb (rtrap-done (hexit n)) (rtrap-done (hexit .n)) = inj₁ refl
R-confluent {.(signl _ _)} cb rraise-signal rraise-signal = inj₁ refl
R-confluent {p@(ρ⟨ _ , _ ⟩· _)} cb redl redr = ρ-conf cb redl redr refl


module Progress where

open import Data.Bool
open import Data.Empty
open import Data.Maybe hiding (Any ; All)
open import Data.Nat
open import Data.List
open import Data.List.All
open import Data.List.Any
open import Data.Product
open import Data.Unit

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Typing
open import Syntax
open import Global
open import Channel
open import Values
open import Session
open import Schedule

open import ProcessSyntax
open import ProcessRun

-- resources appear in pairs
data Paired : SEntry → Set where
  aon-nothing : Paired nothing
  aon-all : ∀ {s} → Paired (just (s , POSNEG))

-- need lemmas for matchXAndGo ...
-- matchXandGo-preserves-paired

matchWaitAndGo-preserves-paired :
  ∀ {G G₁ G₂  G₁₁ G₁₂ φ G₂₁ G₂₂ Gnext tpnext}
    {ss : SSplit G G₁ G₂}
    {ss-cl : SSplit G₁ G₁₁ G₁₂}
    {v : Val G₁₁ (TChan send!)}
    {cl-κ : Cont G₁₂ φ TUnit}
    {ss-GG' : SSplit G₂ G₂₁ G₂₂}
  → All Paired G
  → (tp' : ThreadPool G₂₁)
  → (tp'' : ThreadPool G₂₂)
  → matchWaitAndGo ss (ss-cl , v , cl-κ) ss-GG' tp' tp'' ≡ just (Gnext , tpnext)
  → All Paired Gnext
matchWaitAndGo-preserves-paired all-paired (tnil ina) tp'' ()
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Fork ss₁ κ₁ κ₂) tp') tp'' match-≡
  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Ready ss₁ v κ) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Halt x x₁ x₂) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(New s κ) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Close ss₁ v κ) tp') tp'' match-≡ with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Send ss₁ ss-args vch v κ) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Recv ss₁ vch κ) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Select ss₁ lab vch κ) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(Branch ss₁ vch dcont) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(NSelect ss₁ lab vch κ) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss-GG' =  ss-GG'} all-paired (tcons ss cmd@(NBranch ss₁ vch dcont) tp') tp'' match-≡  with ssplit-compose5 ss-GG' ss
... | Gi , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp' (tcons ss' cmd tp'') match-≡
matchWaitAndGo-preserves-paired {ss = ss-top} {ss-cl = ss-cl} {v = VChan cl-b cl-vcr} {ss-GG' =  ss-tp}
  all-paired (tcons ss cmd@(Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc match-≡
  with ssplit-compose6 ss ss₁
... | Gi , ss-g3gi , ss-g4g2
  with ssplit-compose6 ss-tp ss-g3gi
... | Gi' , ss-g3gi' , ss-gtpacc
  with ssplit-join ss-top ss-cl ss-g3gi'
... | Gchannels , Gother , ss-top' , ss-channels , ss-others
   with vcr-match ss-channels cl-vcr w-vcr
matchWaitAndGo-preserves-paired {ss = ss-top} {ss-cl} {VChan cl-b cl-vcr} {ss-GG' = ss-tp} all-paired (tcons ss cmd@(Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc match-≡ | Gi , ss-g3gi , ss-g4g2 | Gi' , ss-g3gi' , ss-gtpacc | Gchannels , Gother , ss-top' , ss-channels , ss-others | nothing with ssplit-compose5 ss-tp ss
... | _ , ss-tp' , ss' =
  matchWaitAndGo-preserves-paired all-paired tp-wl (tcons ss' cmd tp-acc) match-≡
matchWaitAndGo-preserves-paired {ss = ss-top} {ss-cl} {VChan cl-b cl-vcr} {ss-GG' = ss-tp} all-paired (tcons ss cmd@(Wait ss₁ (VChan w-b w-vcr) κ) tp-wl) tp-acc refl | Gi , ss-g3gi , ss-g4g2 | Gi' , ss-g3gi' , ss-gtpacc | Gchannels , Gother , ss-top' , ss-channels , ss-others | just x = {!!}
-- remains to prove All Paired Gother

step-preserves-paired : ∀ {G G' ev tp'} → All Paired G → (tp : ThreadPool G) → Original.step tp ≡ (_,_ {G'} ev tp') → All Paired G'
step-preserves-paired all-paired tp step-≡ with tp
step-preserves-paired all-paired tp refl | tnil ina = all-paired
step-preserves-paired all-paired tp refl | tcons ss (Fork ss₁ κ₁ κ₂) tp' = all-paired
step-preserves-paired all-paired tp refl | tcons ss (Ready ss₁ v κ) tp' = all-paired
step-preserves-paired all-paired tp step-≡ | tcons ss (Halt x x₁ x₂) tp' with inactive-left-ssplit ss x
step-preserves-paired all-paired tp refl | tcons ss (Halt x x₁ x₂) tp' | refl = all-paired
step-preserves-paired all-paired tp refl | tcons ss (New s κ) tp' = aon-all ∷ all-paired
step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (Close ss-vκ v κ) tp'
  with ssplit-refl-left-inactive G₂
... | G' , ina-G' , ss-GG'
  with matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp' (tnil ina-G')
step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Close ss-vκ v κ) tp' | G' , ina-G' , ss-GG' | just (Gnext , tpnext) = matchWaitAndGo-preserves-paired {ss = ss}{ss-cl = ss-vκ}{v = v}{cl-κ = κ}{ss-GG'} all-paired tp' (tnil ina-G') p
  where
    p : matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp' (tnil ina-G') ≡ just (Gnext , tpnext)
    p = sym {!refl!}
step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Close ss-vκ v κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired
step-preserves-paired all-paired tp refl | tcons ss (Wait ss₁ v κ) tp' = all-paired
step-preserves-paired all-paired tp refl | tcons ss (Send ss₁ ss-args vch v κ) tp' = all-paired
step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (Recv ss-vκ vch κ) tp' with ssplit-refl-left-inactive G₂
... | G' , ina-G' , ss-GG' with matchSendAndGo ss (ss-vκ , vch , κ) ss-GG' tp' (tnil ina-G')
... | just (G-next , tp-next) = {!!}
step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Recv ss-vκ vch κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired
step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (Select ss-vκ lab vch κ) tp' with ssplit-refl-left-inactive G₂
... | G' , ina-G' , ss-GG' with matchBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp' (tnil ina-G')
... | just (G-next , tp-next) = {!!}
step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (Select ss-vκ lab vch κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired
step-preserves-paired all-paired tp refl | tcons ss (Branch ss₁ vch dcont) tp' = all-paired
step-preserves-paired all-paired tp step-≡ | tcons{G₁}{G₂} ss (NSelect ss-vκ lab vch κ) tp' with ssplit-refl-left-inactive G₂
... | G' , ina-G' , ss-GG' with matchNBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp' (tnil ina-G')
... | just (G-next , tp-next) = {!!}
step-preserves-paired all-paired tp refl | tcons {G₁} {G₂} ss (NSelect ss-vκ lab vch κ) tp' | G' , ina-G' , ss-GG' | nothing = all-paired
step-preserves-paired all-paired tp refl | tcons ss (NBranch ss₁ vch dcont) tp' = all-paired

-- check if the first thread can make a step
topCanStep : ∀ {G} → ThreadPool G → Set
topCanStep (tnil ina) = ⊥
topCanStep (tcons ss (Fork ss₁ κ₁ κ₂) tp) = ⊤
topCanStep (tcons ss (Ready ss₁ v κ) tp) = ⊤
topCanStep (tcons ss (Halt x x₁ x₂) tp) = ⊤
topCanStep (tcons ss (New s κ) tp) = ⊤
topCanStep (tcons{G₁}{G₂} ss (Close ss-vκ v κ) tp) with ssplit-refl-left-inactive G₂
... |  G' , ina-G' , ss-GG' = Is-just (matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp (tnil ina-G'))
topCanStep (tcons ss (Wait ss₁ v κ) tp) = ⊥
topCanStep (tcons ss (Send ss₁ ss-args vch v κ) tp) = ⊥
topCanStep (tcons{G₁}{G₂} ss (Recv ss-vκ vch κ) tp) with ssplit-refl-left-inactive G₂
... | G' , ina-G' , ss-GG' = Is-just (matchSendAndGo ss (ss-vκ , vch , κ) ss-GG' tp (tnil ina-G'))
topCanStep (tcons{G₁}{G₂} ss (Select ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂
... | G' , ina-G' , ss-GG' = Is-just (matchBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G'))
topCanStep (tcons ss (Branch ss₁ vch dcont) tp) = ⊥
topCanStep (tcons{G₁}{G₂} ss (NSelect ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂
... | G' , ina-G' , ss-GG' = Is-just (matchNBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G'))
topCanStep (tcons ss (NBranch ss₁ vch dcont) tp) = ⊥

tpLength : ∀ {G} → ThreadPool G → ℕ
tpLength (tnil ina) = 0
tpLength (tcons ss cmd tp) = suc (tpLength tp)

allRotations : ∀ {G} → ThreadPool G → List (ThreadPool G)
allRotations tp = nRotations (tpLength tp) tp
  where
    rotate : ∀ {G} → ThreadPool G → ThreadPool G
    rotate (tnil ina) = tnil ina
    rotate (tcons ss cmd tp) = tsnoc ss tp cmd
    nRotations : ∀ {G} ℕ → ThreadPool G → List (ThreadPool G)
    nRotations zero tp = []
    nRotations (suc n) tp = tp ∷ nRotations n (rotate tp)

-- the thread pool can step if any command in the pool can make a step
canStep : ∀ {G} → ThreadPool G → Set
canStep tp = Any topCanStep (allRotations tp)

deadlocked : ∀ {G} → ThreadPool G → Set
deadlocked (tnil ina) = ⊥
deadlocked tp@(tcons _ _ _) = ¬ canStep tp

-- progress


module Luau.Type.FromJSON where

open import Luau.Type using (Type; nil; _⇒_; _∪_; _∩_; any; number)

open import Agda.Builtin.List using (List; _∷_; [])

open import FFI.Data.Aeson using (Value; Array; Object; object; array; string; fromString; lookup)
open import FFI.Data.Bool using (true; false)
open import FFI.Data.Either using (Either; Left; Right)
open import FFI.Data.Maybe using (Maybe; nothing; just)
open import FFI.Data.String using (String; _++_)
open import FFI.Data.Vector using (head; tail; null; empty)

name = fromString "name"
type = fromString "type"
argTypes = fromString "argTypes"
returnTypes = fromString "returnTypes"
types = fromString "types"

{-# TERMINATING #-}
typeFromJSON : Value → Either String Type
compoundFromArray : (Type → Type → Type) → Array → Either String Type

typeFromJSON (object o) with lookup type o
typeFromJSON (object o) | just (string "AstTypeFunction") with lookup argTypes o | lookup returnTypes o
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) with lookup types argsSet | lookup types retsSet
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just (array args) | just (array rets) with head args | head rets
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just (array args) | just (array rets) | just argValue | just retValue with typeFromJSON argValue | typeFromJSON retValue
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just (array args) | just (array rets) | just argValue | just retValue | Right arg | Right ret = Right (arg ⇒ ret)
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just (array args) | just (array rets) | just argValue | just retValue | Left err | _ = Left err
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just (array args) | just (array rets) | just argValue | just retValue | _ | Left err = Left err
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just (array args) | just (array rets) | _ | nothing = Left "No return type"
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just (array args) | just (array rets) | nothing | _ = Left "No argument type"
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | just _ | _ = Left "argTypes.types is not an array"
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | _ | just _ = Left "retTypes.types is not an array"
typeFromJSON (object o) | just (string "AstTypeFunction") | just (object argsSet) | just (object retsSet) | nothing | _ = Left "argTypes.types does not exist"
typeFromJSON (object o) | just (string "AstTypeFunction") | _ | just _ = Left "argTypes is not an object"
typeFromJSON (object o) | just (string "AstTypeFunction") | just _ | _ = Left "returnTypes is not an object"
typeFromJSON (object o) | just (string "AstTypeFunction") | nothing | nothing = Left "Missing argTypes and returnTypes"

typeFromJSON (object o) | just (string "AstTypeReference") with lookup name o
typeFromJSON (object o) | just (string "AstTypeReference") | just (string "nil") = Right nil
typeFromJSON (object o) | just (string "AstTypeReference") | just (string "any") = Right any
typeFromJSON (object o) | just (string "AstTypeReference") | just (string "number") = Right number
typeFromJSON (object o) | just (string "AstTypeReference") | _ = Left "Unknown referenced type"

typeFromJSON (object o) | just (string "AstTypeUnion") with lookup types o
typeFromJSON (object o) | just (string "AstTypeUnion") | just (array types) = compoundFromArray _∪_ types
typeFromJSON (object o) | just (string "AstTypeUnion") | _ = Left "`types` field must be an array"

typeFromJSON (object o) | just (string "AstTypeIntersection") with lookup types o
typeFromJSON (object o) | just (string "AstTypeIntersection") | just (array types) = compoundFromArray _∩_ types
typeFromJSON (object o) | just (string "AstTypeIntersection") | _ = Left "`types` field must be an array"

typeFromJSON (object o) | just (string ty) = Left ("Unsupported type " ++ ty)
typeFromJSON (object o) | just _ = Left "`type` field must be a string"
typeFromJSON (object o) | nothing = Left "No `type` field"
typeFromJSON _ = Left "Unsupported JSON type"

compoundFromArray ctor ts with head ts | tail ts
compoundFromArray ctor ts | just hd | tl with null tl
compoundFromArray ctor ts | just hd | tl | true = typeFromJSON hd
compoundFromArray ctor ts | just hd | tl | false with typeFromJSON hd | compoundFromArray ctor tl
compoundFromArray ctor ts | just hd | tl | false | Right hdTy | Right tlTy = Right (ctor hdTy tlTy)
compoundFromArray ctor ts | just hd | tl | false | Left err | _ = Left err
compoundFromArray ctor ts | just hd | tl | false | _ | Left Err = Left Err
compoundFromArray ctor ts | nothing | empty = Left "Empty types array?"


module par-swap.union-confluent where

open import par-swap
open import par-swap.properties
open import par-swap.confluent
open import par-swap.dpg

open import Data.Nat using (_+_ ;  _≤′_ ; _<′_ ; suc ; zero ; ≤′-refl ; ℕ)
open import Data.Nat.Properties.Simple using ( +-comm ; +-assoc)
open import Data.Nat.Properties using (s≤′s ; z≤′n)
open import Data.MoreNatProp using (≤′-trans ; suc≤′⇒≤′)
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Data.Empty

open import Induction.Nat using (<-rec)
open import Induction.Lexicographic using ()
open import Induction using ()
open import Induction.WellFounded using ()
open import Level using ()
open import Relation.Binary using (Rel)

open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Environment as Env
open import Esterel.Context
open import Esterel.Lang.Binding

open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; subst ; cong ; trans ;
         module ≡-Reasoning ; cong₂ ; subst₂ ; inspect)
open import sn-calculus
open import context-properties -- get view, E-views

open import binding-preserve using (sn⟶-maintains-binding ; sn⟶*-maintains-binding)
open import noetherian using (noetherian ; ∥_∥s)
open import sn-calculus-props

∥R-preserves-∥∥s : ∀ {p q} -> p ∥R q -> ∥ q ∥s ≡ ∥ p ∥s
∥R-preserves-∥∥s (∥Rstep{C}{p}{q} d≐C⟦p∥q⟧c)
  rewrite sym (unplugc d≐C⟦p∥q⟧c) = ∥∥par-sym p q C where

  ∥∥par-sym : ∀ p q C ->  ∥ C ⟦ q ∥ p ⟧c ∥s ≡ ∥ C ⟦ p ∥ q ⟧c ∥s
  ∥∥par-sym p q [] rewrite +-comm ∥ p ∥s ∥ q ∥s = refl
  ∥∥par-sym p q (_ ∷ C) with ∥∥par-sym p q C
  ∥∥par-sym p q (ceval (epar₁ _) ∷ C)    | R rewrite R = refl
  ∥∥par-sym p q (ceval (epar₂ _) ∷ C)    | R rewrite R = refl
  ∥∥par-sym p q (ceval (eseq _) ∷ C)     | R rewrite R = refl
  ∥∥par-sym p q (ceval (eloopˢ _) ∷ C)   | R rewrite R = refl
  ∥∥par-sym p q (ceval (esuspend _) ∷ C) | R rewrite R = refl
  ∥∥par-sym p q (ceval etrap ∷ C)        | R rewrite R = refl
  ∥∥par-sym p q (csignl _ ∷ C)           | R rewrite R = refl
  ∥∥par-sym p q (cpresent₁ _ _ ∷ C)      | R rewrite R = refl
  ∥∥par-sym p q (cpresent₂ _ _ ∷ C)      | R rewrite R = refl
  ∥∥par-sym p q (cloop ∷ C)              | R rewrite R = refl
  ∥∥par-sym p q (cloopˢ₂ _ ∷ C)          | R rewrite R = refl
  ∥∥par-sym p q (cseq₂ _ ∷ C)            | R rewrite R = refl
  ∥∥par-sym p q (cshared _ _ ∷ C)        | R rewrite R = refl
  ∥∥par-sym p q (cvar _ _ ∷ C)           | R rewrite R = refl
  ∥∥par-sym p q (cif₁ _ _ ∷ C)           | R rewrite R = refl
  ∥∥par-sym p q (cif₂ _ _ ∷ C)           | R rewrite R = refl
  ∥∥par-sym p q (cenv _ _ ∷ C)             | R rewrite R = refl

∥R*-preserves-∥∥s : ∀ {p q} -> p ∥R* q -> ∥ q ∥s ≡ ∥ p ∥s
∥R*-preserves-∥∥s ∥R0 = refl
∥R*-preserves-∥∥s (∥Rn p∥Rq p∥R*q) with ∥R*-preserves-∥∥s p∥R*q
... | x rewrite ∥R-preserves-∥∥s p∥Rq = x

module LexicographicLE {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
                       (RelA : Rel A ℓ₁)
                       (RelB : Rel B ℓ₂) where

  open import Level
  open import Relation.Binary
  open import Induction.WellFounded
  open import Data.Product
  open import Function
  open import Induction
  open import Relation.Unary

  data _<_ : Rel (Σ A \ _ → B) (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    left  : ∀ {x₁ y₁ x₂ y₂} (x₁<x₂ : RelA x₁ x₂) → (x₁ , y₁) < (x₂ , y₂)
    right : ∀ {x₁ y₁ x₂ y₂} (y₁<y₂ : RelB y₁ y₂) → (x₁ ≡ x₂ ⊎ RelA x₁ x₂) →
            (x₁  , y₁) < (x₂  , y₂)

  mutual

    accessibleLE : ∀ {x y} →
                    Acc RelA x → WellFounded RelB →
                    Acc _<_ (x , y)
    accessibleLE accA wfB = acc (accessibleLE′ accA (wfB _) wfB)

    accessibleLE′ :
      ∀ {x y} →
      Acc RelA x → Acc RelB y →  WellFounded RelB →
      WfRec _<_ (Acc _<_) (x , y)
    accessibleLE′ (acc rsA) _    wfB ._ (left  x′<x) = accessibleLE (rsA _ x′<x) wfB
    accessibleLE′ accA (acc rsB) wfB .(_ , _) (right y′<y (inj₁ refl)) =
      acc (accessibleLE′ accA (rsB _ y′<y) wfB)
    accessibleLE′ (acc rsA) (acc rsB) wfB .(_ , _) (right y′<y (inj₂ x′<x)) =
      acc (accessibleLE′ (rsA _ x′<x) (rsB _ y′<y) wfB)

  wellFounded : WellFounded RelA → WellFounded RelB →
                 WellFounded _<_
  wellFounded wfA wfB p = accessibleLE (wfA (proj₁ p)) wfB

module _ where
  open LexicographicLE _<′_ _<′_ public
    renaming (_<_ to _<<′_;
              wellFounded to <<′-wellFounded;
              left to <<′-left;
              right to <<′-right)

module _ {ℓ} where
  open Induction.WellFounded.All
       (<<′-wellFounded Induction.Nat.<′-wellFounded Induction.Nat.<′-wellFounded) ℓ public
    renaming (wfRec-builder to <<′-rec-builder;
              wfRec to <<′-rec)

{-
  proof from _On the Power of Simple Diagrams_
  by Roberto Di Cosmo, RTA 1996 (lemma 7)
-}
∥R*-sn⟶*-commute : CB-COMMUTE _∥R*_ _sn⟶*_
∥R*-sn⟶*-commute = thm where
  redlen : ∀ {p q} -> p ∥R* q -> ℕ
  redlen ∥R0 = zero
  redlen (∥Rn p∥Rq p∥R*q) = suc (redlen p∥R*q)

  sharedtype : (ℕ × ℕ) -> Set
  sharedtype (sizeb , distab) =
     ∀ {a b c BV FV} ->
      CorrectBinding a BV FV ->
      (a∥R*b : a ∥R* b) ->
      a sn⟶* c ->
      redlen a∥R*b ≡ distab ->
      ∥ b ∥s ≡ sizeb ->
      ∃ \ {d -> b sn⟶* d × c ∥R* d}

  {- this proof is not working the way that
     Di Cosmo intended; it uses properties
     about ∥R* reduction directly -}
  composing-the-diagram-in-the-hypothesis-down :
    ∀ {p1 p2 p3 q1 q3} ->
    p1 sn⟶ p2 ->
    p2 sn⟶* p3 ->
    p1 ∥R* q1 ->
    p3 ∥R* q3 ->
    (∥ q3 ∥s) <′ (∥ q1 ∥s)
  composing-the-diagram-in-the-hypothesis-down = thm where

    thm-no-∥R* : ∀ {p1 p2 p3} ->
     p1 sn⟶ p2 ->
     p2 sn⟶* p3 ->
     ∥ p3 ∥s <′ ∥ p1 ∥s
    thm-no-∥R* p1sn⟶p2 rrefl = noetherian p1sn⟶p2
    thm-no-∥R* {p1}{p2}{p3} p1sn⟶p2 (rstep{q = r} p2sn⟶r rsn⟶*p3)
      with thm-no-∥R* p2sn⟶r rsn⟶*p3
    ... | ∥p3∥s<′∥p2∥s =
        ≤′-trans {y = ∥ p2 ∥s}
                 ∥p3∥s<′∥p2∥s
                 (suc≤′⇒≤′ ∥ p2 ∥s ∥ p1 ∥s (noetherian p1sn⟶p2))

    thm : ∀ {p1 p2 p3 q1 q3} ->
     p1 sn⟶ p2 ->
     p2 sn⟶* p3 ->
     p1 ∥R* q1 ->
     p3 ∥R* q3 ->
     (∥ q3 ∥s) <′ (∥ q1 ∥s)
    thm p1sn⟶p2 p2sn⟶*p3 p1∥R*q1 p3∥R*q3
      rewrite ∥R*-preserves-∥∥s p1∥R*q1
            | ∥R*-preserves-∥∥s p3∥R*q3 =
            thm-no-∥R* p1sn⟶p2 p2sn⟶*p3

  step : ∀ nm ->
          (∀ (nm′ : ℕ × ℕ) -> nm′ <<′ nm -> sharedtype nm′) ->
          sharedtype nm
  step (sizeb , distab) rec  CBa ∥R0 asn⟶*c redlena∥R*b≡distab ∥b∥s≡sizeb = _ , asn⟶*c , ∥R0
  step (sizeb , distab) rec CBa a∥R*b rrefl redlena∥R*b≡distab ∥b∥s≡sizeb = _ , rrefl , a∥R*b
  step (sizeb , distab) rec {a} {b} {c} CBa
       (∥Rn{q = a″} a∥Ra″ a″∥R*b)
       (rstep{q = a′} asn⟶a′ a′sn⟶*c)
       redlena∥R*b≡distab
       ∥b∥s≡sizeb rewrite sym redlena∥R*b≡distab
    with sn⟶-maintains-binding CBa asn⟶a′
  ... | (_ , CBa′ , _)
    with DPG a∥Ra″ asn⟶a′
  ... | (a‴ , gap) , a″sn⟶gap ,  gapsn⟶*a‴ , a′∥R*a‴
    with rec (sizeb , redlen a″∥R*b) (<<′-right (s≤′s ≤′-refl) (inj₁ refl))
             (∥R-maintains-binding CBa a∥Ra″)
             a″∥R*b  (rstep a″sn⟶gap gapsn⟶*a‴) refl ∥b∥s≡sizeb
  ... | (b′ , bsn⟶*b′ , a‴∥R*b′) rewrite sym ∥b∥s≡sizeb
    with composing-the-diagram-in-the-hypothesis-down a″sn⟶gap gapsn⟶*a‴ a″∥R*b a‴∥R*b′
  ... | ∥b′∥s<′∥b∥s
    with rec (∥ b′ ∥s , redlen (∥R*-concat a′∥R*a‴ a‴∥R*b′))
             (<<′-left ∥b′∥s<′∥b∥s)
             CBa′ (∥R*-concat a′∥R*a‴ a‴∥R*b′) a′sn⟶*c refl refl
  ... | ( d , b′sn⟶*d , c∥R*d) =  d , sn⟶*+ bsn⟶*b′ b′sn⟶*d , c∥R*d

  lemma7-commutation : ∀ (nm : ℕ × ℕ) -> sharedtype nm
  lemma7-commutation = <<′-rec _ step

  thm : CB-COMMUTE _∥R*_ _sn⟶*_
  thm {p}{q}{r} CBp p∥R*q psn⟶*r =
   lemma7-commutation (∥ q ∥s , redlen p∥R*q) CBp p∥R*q psn⟶*r refl refl

∥R*∪sn⟶*-confluent : CB-CONFLUENT _∥R*∪sn⟶*_
∥R*∪sn⟶*-confluent =
  \ { CBp p∥R*∪sn⟶*q p∥R*∪sn⟶*r ->
      hindley-rosen
       (redlen p∥R*∪sn⟶*q , redlen p∥R*∪sn⟶*r)
       CBp p∥R*∪sn⟶*q p∥R*∪sn⟶*r refl refl} where

  redlen : ∀ {p q} -> p ∥R*∪sn⟶* q -> ℕ
  redlen (∪∥R* _ r) = suc (redlen r)
  redlen (∪sn⟶* _ r) = suc (redlen r)
  redlen ∪refl = zero

  sharedtype : ℕ × ℕ -> Set
  sharedtype (n , m) = ∀ {p q r BV FV} ->
    CorrectBinding p BV FV ->
    (p∥R*∪sn⟶*q : p ∥R*∪sn⟶* q) ->
    (p∥R*∪sn⟶*r : p ∥R*∪sn⟶* r) ->
    n ≡ redlen p∥R*∪sn⟶*q ->
    m ≡ redlen p∥R*∪sn⟶*r ->
    ∃ λ {z → (q ∥R*∪sn⟶* z × r ∥R*∪sn⟶* z)}

  length-lemma : ∀ {a b}  (l : a ∥R*∪sn⟶* b) ->
      suc zero ≡ suc (redlen l) ⊎
      suc zero <′ suc (redlen l)
  length-lemma (∪∥R* p∥R*q l) = inj₂ (s≤′s (s≤′s z≤′n))
  length-lemma (∪sn⟶* psn⟶*q l) = inj₂ (s≤′s (s≤′s z≤′n))
  length-lemma ∪refl = inj₁ refl

  step : ∀ nm ->
          (∀ (nm′ : ℕ × ℕ) -> nm′ <<′ nm -> sharedtype nm′) ->
          sharedtype nm
  step (n , m) rec CBp (∪∥R* p∥R*q a) ∪refl n≡ m≡ = _ , ∪refl , ∪∥R* p∥R*q a
  step (n , m) rec CBp (∪sn⟶* psn⟶*q a) ∪refl n≡ m≡ =   _ , ∪refl , ∪sn⟶* psn⟶*q a
  step (n , m) rec CBp ∪refl (∪∥R* p∥R*q b) n≡ m≡ = _ , ∪∥R* p∥R*q b , ∪refl
  step (n , m) rec CBp ∪refl (∪sn⟶* psn⟶*q b) n≡ m≡ = _ , ∪sn⟶* psn⟶*q b , ∪refl
  step (n , m) rec CBp ∪refl ∪refl n≡ m≡ = _ , ∪refl , ∪refl

  step(n , m) rec {p}{q}{r} CBp
      (∪∥R* {_}{q₁} p∥R*q₁ q₁∥R*∪sn⟶*q)
      (∪∥R* {_}{r₁} p∥R*r₁ r₁∥R*∪sn⟶*r)
     n≡ m≡  rewrite n≡ | m≡
    with BVFVcorrect _ _ _ CBp
  ... | refl , refl
    with ∥R*-maintains-binding CBp p∥R*q₁
  ... | CBq₁
    with  BVFVcorrect _ _ _ CBq₁
  ... | refl , refl
    with ∥R*-maintains-binding CBp p∥R*r₁
  ... | CBr₁
    with  BVFVcorrect _ _ _ CBr₁
  ... | refl , refl
    with ∥R*-confluent CBp p∥R*q₁ p∥R*r₁
  ... | q₁r₁ , q₁∥R*q₁r₁ , r₁∥R*q₁r₁
    with rec (suc zero , redlen r₁∥R*∪sn⟶*r)
             (<<′-right ≤′-refl (length-lemma q₁∥R*∪sn⟶*q))
             CBr₁ (∪∥R* r₁∥R*q₁r₁ ∪refl) r₁∥R*∪sn⟶*r
             refl refl
  ... | q₁r₁r , q₁r₁∥R*∪sn⟶*q₁r₁r , r∥R*∪sn⟶*q₁r₁r
    with rec (redlen q₁∥R*∪sn⟶*q , suc (redlen q₁r₁∥R*∪sn⟶*q₁r₁r))
             (<<′-left ≤′-refl)
             CBq₁ q₁∥R*∪sn⟶*q (∪∥R* q₁∥R*q₁r₁ q₁r₁∥R*∪sn⟶*q₁r₁r)
             refl refl
  ... | qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , q₁r₁r∥R*∪sn⟶*qq₁r₁r
    = qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , ∥R*∪sn⟶*-concat r∥R*∪sn⟶*q₁r₁r q₁r₁r∥R*∪sn⟶*qq₁r₁r

  step (n , m) rec {p}{q}{r} CBp
    (∪∥R*{_}{q₁} p∥R*q₁ q₁∥R*∪sn⟶*q)
    (∪sn⟶*{_}{r₁} psn⟶*r₁  r₁∥R*∪sn⟶*r)
    n≡ m≡ rewrite n≡ | m≡
    with BVFVcorrect _ _ _ CBp
  ... | refl , refl
    with ∥R*-maintains-binding CBp p∥R*q₁
  ... | CBq₁
    with  BVFVcorrect _ _ _ CBq₁
  ... | refl , refl
    with sn⟶*-maintains-binding CBp psn⟶*r₁
  ... | (BVr₁ , FVr₁) , CBr₁
    with ∥R*-sn⟶*-commute CBp p∥R*q₁ psn⟶*r₁
  ... | q₁r₁ , q₁sn⟶*q₁r₁ , r₁∥R*q₁r₁
    with rec (suc zero , redlen r₁∥R*∪sn⟶*r)
             (<<′-right ≤′-refl (length-lemma q₁∥R*∪sn⟶*q))
             CBr₁ (∪∥R* r₁∥R*q₁r₁ ∪refl) r₁∥R*∪sn⟶*r
             refl refl
  ... | q₁r₁r , q₁r₁∥R*∪sn⟶*q₁r₁r , r∥R*∪sn⟶*q₁r₁r
     with rec (redlen q₁∥R*∪sn⟶*q , suc (redlen q₁r₁∥R*∪sn⟶*q₁r₁r))
             (<<′-left ≤′-refl)
             CBq₁ q₁∥R*∪sn⟶*q (∪sn⟶*  q₁sn⟶*q₁r₁  q₁r₁∥R*∪sn⟶*q₁r₁r)
             refl refl
  ... | qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , q₁r₁r∥R*∪sn⟶*qq₁r₁r
    =  qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , ∥R*∪sn⟶*-concat r∥R*∪sn⟶*q₁r₁r q₁r₁r∥R*∪sn⟶*qq₁r₁r

  step (n , m) rec {p}{q}{r} CBp
    (∪sn⟶*{_}{q₁} psn⟶*q₁ q₁∥R*∪sn⟶*q)
    (∪∥R*{_}{r₁} p∥R*r₁  r₁∥R*∪sn⟶*r)
    n≡ m≡ rewrite n≡ | m≡
    with BVFVcorrect _ _ _ CBp
  ... | refl , refl
    with sn⟶*-maintains-binding CBp psn⟶*q₁
  ... | (BVq₁ , FVq₁) , CBq₁
    with ∥R*-maintains-binding CBp p∥R*r₁
  ... | CBr₁
    with  BVFVcorrect _ _ _ CBr₁
  ... | refl , refl
    with ∥R*-sn⟶*-commute CBp p∥R*r₁ psn⟶*q₁
  ... | r₁q₁ , r₁sn⟶*r₁q₁ , q₁∥R*r₁q₁
    with rec (suc zero , redlen r₁∥R*∪sn⟶*r)
             (<<′-right ≤′-refl (length-lemma q₁∥R*∪sn⟶*q))
             CBr₁ (∪sn⟶* r₁sn⟶*r₁q₁ ∪refl) r₁∥R*∪sn⟶*r
             refl refl
  ... | r₁q₁r , r₁q₁∥R*∪sn⟶*r₁q₁r , r∥R*∪sn⟶*r₁q₁r
     with rec (redlen q₁∥R*∪sn⟶*q , suc (redlen r₁q₁∥R*∪sn⟶*r₁q₁r))
             (<<′-left ≤′-refl)
             CBq₁ q₁∥R*∪sn⟶*q (∪∥R*  q₁∥R*r₁q₁  r₁q₁∥R*∪sn⟶*r₁q₁r)
             refl refl
  ... | qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , q₁r₁r∥R*∪sn⟶*qq₁r₁r
    =  qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , ∥R*∪sn⟶*-concat r∥R*∪sn⟶*r₁q₁r q₁r₁r∥R*∪sn⟶*qq₁r₁r

  step (n , m) rec {p}{q}{r} CBp
    (∪sn⟶*{_}{q₁} psn⟶*q₁  q₁∥R*∪sn⟶*q)
    (∪sn⟶*{_}{r₁} psn⟶*r₁ r₁∥R*∪sn⟶*r)
    n≡ m≡ rewrite n≡ | m≡
    with BVFVcorrect _ _ _ CBp
  ... | refl , refl
    with sn⟶*-maintains-binding CBp psn⟶*q₁
  ... | (BVq₁ , FVq₁) , CBq₁
    with sn⟶*-maintains-binding CBp psn⟶*r₁
  ... | (BVr₁ , FVr₁) , CBr₁
    with sn⟶*-confluent CBp psn⟶*q₁ psn⟶*r₁
  ... | q₁r₁ , q₁sn⟶*q₁r₁ , r₁sn⟶*q₁r₁
    with rec (suc zero , redlen r₁∥R*∪sn⟶*r)
             (<<′-right ≤′-refl (length-lemma q₁∥R*∪sn⟶*q))
             CBr₁ (∪sn⟶* r₁sn⟶*q₁r₁ ∪refl) r₁∥R*∪sn⟶*r
             refl refl
  ... | q₁r₁r , q₁r₁∥R*∪sn⟶*q₁r₁r , r∥R*∪sn⟶*q₁r₁r
    with rec (redlen q₁∥R*∪sn⟶*q , suc (redlen q₁r₁∥R*∪sn⟶*q₁r₁r))
             (<<′-left ≤′-refl)
             CBq₁ q₁∥R*∪sn⟶*q (∪sn⟶* q₁sn⟶*q₁r₁ q₁r₁∥R*∪sn⟶*q₁r₁r)
             refl refl
  ... | qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , q₁r₁r∥R*∪sn⟶*qq₁r₁r
    = qq₁r₁r , q∥R*∪sn⟶*qq₁r₁r , ∥R*∪sn⟶*-concat r∥R*∪sn⟶*q₁r₁r q₁r₁r∥R*∪sn⟶*qq₁r₁r

  hindley-rosen : ∀ (nm : ℕ × ℕ) -> sharedtype nm
  hindley-rosen = <<′-rec _ step


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

module Definition.Conversion.Symmetry where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Conversion
open import Definition.Conversion.Stability
open import Definition.Conversion.Soundness
open import Definition.Conversion.Conversion
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Equality
open import Definition.Typed.Consequences.Reduction
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.SucCong

open import Tools.Product
import Tools.PropositionalEquality as PE

mutual
  -- Symmetry of algorithmic equality of neutrals.
  sym~↑ : ∀ {t u A Γ Δ} → ⊢ Γ ≡ Δ
        → Γ ⊢ t ~ u ↑ A
        → ∃ λ B → Γ ⊢ A ≡ B × Δ ⊢ u ~ t ↑ B
  sym~↑ Γ≡Δ (var-refl x x≡y) =
    let ⊢A = syntacticTerm x
    in  _ , refl ⊢A
     ,  var-refl (PE.subst (λ y → _ ⊢ var y ∷ _) x≡y (stabilityTerm Γ≡Δ x))
                 (PE.sym x≡y)
  sym~↑ Γ≡Δ (app-cong t~u x) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓ Γ≡Δ t~u
        F′ , G′ , ΠF′G′≡B = Π≡A A≡B whnfB
        F≡F′ , G≡G′ = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x) ΠF′G′≡B A≡B)
    in  _ , substTypeEq G≡G′ (soundnessConv↑Term x)
    ,   app-cong (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) ΠF′G′≡B u~t)
                 (convConvTerm (symConv↑Term Γ≡Δ x) (stabilityEq Γ≡Δ F≡F′))
  sym~↑ Γ≡Δ (fst-cong p~r) =
    let B , whnfB , A≡B , r~p = sym~↓ Γ≡Δ p~r
        F′ , G′ , Σ≡ = Σ≡A A≡B whnfB
        F≡ , G≡ = Σ-injectivity (PE.subst (λ x → _ ⊢ _ ≡ x) Σ≡ A≡B)
    in  F′ , F≡ , fst-cong (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) Σ≡ r~p)
  sym~↑ Γ≡Δ (snd-cong {p} {r} {F} {G} p~r) =
    let fst≡  = soundness~↑ (fst-cong p~r)
        B , whnfB , A≡B , r~p = sym~↓ Γ≡Δ p~r
        F′ , G′ , Σ≡ = Σ≡A A≡B whnfB
        r~p = PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) Σ≡ r~p
        F≡ , G≡ = Σ-injectivity (PE.subst (λ x → _ ⊢ _ ≡ x) Σ≡ A≡B)
    in  G′ [ fst r ] , substTypeEq G≡ fst≡ , snd-cong r~p
  sym~↑ Γ≡Δ (natrec-cong x x₁ x₂ t~u) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓ Γ≡Δ t~u
        B≡ℕ = ℕ≡A A≡B whnfB
        F≡G = stabilityEq (Γ≡Δ ∙ refl (ℕⱼ ⊢Γ)) (soundnessConv↑ x)
        F[0]≡G[0] = substTypeEq F≡G (refl (zeroⱼ ⊢Δ))
    in  _ , substTypeEq (soundnessConv↑ x) (soundness~↓ t~u)
    ,   natrec-cong (symConv↑ (Γ≡Δ ∙ (refl (ℕⱼ ⊢Γ))) x)
                    (convConvTerm (symConv↑Term Γ≡Δ x₁) F[0]≡G[0])
                    (convConvTerm (symConv↑Term Γ≡Δ x₂) (sucCong F≡G))
                    (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) B≡ℕ u~t)
  sym~↑ Γ≡Δ (Emptyrec-cong x t~u) =
    let ⊢Γ , ⊢Δ , _ = contextConvSubst Γ≡Δ
        B , whnfB , A≡B , u~t = sym~↓ Γ≡Δ t~u
        B≡Empty = Empty≡A A≡B whnfB
        F≡G = stabilityEq Γ≡Δ (soundnessConv↑ x)
    in  _ , soundnessConv↑ x
    , Emptyrec-cong (symConv↑ Γ≡Δ x)
                    (PE.subst (λ x₁ → _ ⊢ _ ~ _ ↓ x₁) B≡Empty u~t)

  -- Symmetry of algorithmic equality of neutrals of types in WHNF.
  sym~↓ : ∀ {t u A Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ t ~ u ↓ A
         → ∃ λ B → Whnf B × Γ ⊢ A ≡ B × Δ ⊢ u ~ t ↓ B
  sym~↓ Γ≡Δ ([~] A₁ D whnfA k~l) =
    let B , A≡B , k~l′ = sym~↑ Γ≡Δ k~l
        _ , ⊢B = syntacticEq A≡B
        B′ , whnfB′ , D′ = whNorm ⊢B
        A≡B′ = trans (sym (subset* D)) (trans A≡B (subset* (red D′)))
    in  B′ , whnfB′ , A≡B′ , [~] B (stabilityRed* Γ≡Δ (red D′)) whnfB′ k~l′

  -- Symmetry of algorithmic equality of types.
  symConv↑ : ∀ {A B Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A [conv↑] B → Δ ⊢ B [conv↑] A
  symConv↑ Γ≡Δ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′) =
    [↑] B′ A′ (stabilityRed* Γ≡Δ D′) (stabilityRed* Γ≡Δ D) whnfB′ whnfA′
        (symConv↓ Γ≡Δ A′<>B′)

  -- Symmetry of algorithmic equality of types in WHNF.
  symConv↓ : ∀ {A B Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A [conv↓] B → Δ ⊢ B [conv↓] A
  symConv↓ Γ≡Δ (U-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  U-refl ⊢Δ
  symConv↓ Γ≡Δ (ℕ-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  ℕ-refl ⊢Δ
  symConv↓ Γ≡Δ (Empty-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  Empty-refl ⊢Δ
  symConv↓ Γ≡Δ (Unit-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  Unit-refl ⊢Δ
  symConv↓ Γ≡Δ (ne A~B) =
    let B , whnfB , U≡B , B~A = sym~↓ Γ≡Δ A~B
        B≡U = U≡A U≡B
    in  ne (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) B≡U B~A)
  symConv↓ Γ≡Δ (Π-cong x A<>B A<>B₁) =
    let F≡H = soundnessConv↑ A<>B
        _ , ⊢H = syntacticEq (stabilityEq Γ≡Δ F≡H)
    in  Π-cong ⊢H (symConv↑ Γ≡Δ A<>B)
                  (symConv↑ (Γ≡Δ ∙ F≡H) A<>B₁)
  symConv↓ Γ≡Δ (Σ-cong x A<>B A<>B₁) =
    let F≡H = soundnessConv↑ A<>B
        _ , ⊢H = syntacticEq (stabilityEq Γ≡Δ F≡H)
    in  Σ-cong ⊢H (symConv↑ Γ≡Δ A<>B)
                  (symConv↑ (Γ≡Δ ∙ F≡H) A<>B₁)

  -- Symmetry of algorithmic equality of terms.
  symConv↑Term : ∀ {t u A Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ t [conv↑] u ∷ A → Δ ⊢ u [conv↑] t ∷ A
  symConv↑Term Γ≡Δ ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    [↑]ₜ B u′ t′ (stabilityRed* Γ≡Δ D) (stabilityRed*Term Γ≡Δ d′)
         (stabilityRed*Term Γ≡Δ d) whnfB whnfu′ whnft′ (symConv↓Term Γ≡Δ t<>u)

  -- Symmetry of algorithmic equality of terms in WHNF.
  symConv↓Term : ∀ {t u A Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ t [conv↓] u ∷ A → Δ ⊢ u [conv↓] t ∷ A
  symConv↓Term Γ≡Δ (ℕ-ins t~u) =
    let B , whnfB , A≡B , u~t = sym~↓ Γ≡Δ t~u
        B≡ℕ = ℕ≡A A≡B whnfB
    in  ℕ-ins (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) B≡ℕ u~t)
  symConv↓Term Γ≡Δ (Empty-ins t~u) =
    let B , whnfB , A≡B , u~t = sym~↓ Γ≡Δ t~u
        B≡Empty = Empty≡A A≡B whnfB
    in  Empty-ins (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) B≡Empty u~t)
  symConv↓Term Γ≡Δ (Unit-ins t~u) =
    let B , whnfB , A≡B , u~t = sym~↓ Γ≡Δ t~u
        B≡Unit = Unit≡A A≡B whnfB
    in  Unit-ins (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) B≡Unit u~t)
  symConv↓Term Γ≡Δ (ne-ins t u x t~u) =
    let B , whnfB , A≡B , u~t = sym~↓ Γ≡Δ t~u
    in  ne-ins (stabilityTerm Γ≡Δ u) (stabilityTerm Γ≡Δ t) x u~t
  symConv↓Term Γ≡Δ (univ x x₁ x₂) =
    univ (stabilityTerm Γ≡Δ x₁) (stabilityTerm Γ≡Δ x) (symConv↓ Γ≡Δ x₂)
  symConv↓Term Γ≡Δ (zero-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  zero-refl ⊢Δ
  symConv↓Term Γ≡Δ (suc-cong t<>u) = suc-cong (symConv↑Term Γ≡Δ t<>u)
  symConv↓Term Γ≡Δ (η-eq x₁ x₂ y y₁ t<>u) =
    let ⊢F , _ = syntacticΠ (syntacticTerm x₁)
    in  η-eq (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₁)
             y₁ y (symConv↑Term (Γ≡Δ ∙ refl ⊢F) t<>u)
  symConv↓Term Γ≡Δ (Σ-η ⊢p ⊢r pProd rProd fstConv sndConv) =
    let Δ⊢p = stabilityTerm Γ≡Δ ⊢p
        Δ⊢r = stabilityTerm Γ≡Δ ⊢r
        ⊢G = proj₂ (syntacticΣ (syntacticTerm ⊢p))
        Δfst≡ = symConv↑Term Γ≡Δ fstConv
        Δsnd≡₁ = symConv↑Term Γ≡Δ sndConv
        ΔGfstt≡Gfstu = stabilityEq Γ≡Δ (substTypeEq (refl ⊢G)
                                                    (soundnessConv↑Term fstConv))
        Δsnd≡ = convConvTerm Δsnd≡₁ ΔGfstt≡Gfstu
    in  Σ-η Δ⊢r Δ⊢p rProd pProd Δfst≡ Δsnd≡
  symConv↓Term Γ≡Δ (η-unit [t] [u] tUnit uUnit) =
    let [t] = stabilityTerm Γ≡Δ [t]
        [u] = stabilityTerm Γ≡Δ [u]
    in  (η-unit [u] [t] uUnit tUnit)

symConv↓Term′ : ∀ {t u A Γ} → Γ ⊢ t [conv↓] u ∷ A → Γ ⊢ u [conv↓] t ∷ A
symConv↓Term′ tConvU =
  symConv↓Term (reflConEq (wfEqTerm (soundnessConv↓Term tConvU))) tConvU

-- Symmetry of algorithmic equality of types with preserved context.
symConv : ∀ {A B Γ} → Γ ⊢ A [conv↑] B → Γ ⊢ B [conv↑] A
symConv A<>B =
  let ⊢Γ = wfEq (soundnessConv↑ A<>B)
  in  symConv↑ (reflConEq ⊢Γ) A<>B

-- Symmetry of algorithmic equality of terms with preserved context.
symConvTerm : ∀ {t u A Γ} → Γ ⊢ t [conv↑] u ∷ A → Γ ⊢ u [conv↑] t ∷ A
symConvTerm t<>u =
  let ⊢Γ = wfEqTerm (soundnessConv↑Term t<>u)
  in  symConv↑Term (reflConEq ⊢Γ) t<>u