------------------------------------------------------------------------
-- A semantics which uses continuation-passing style
------------------------------------------------------------------------

module TotalParserCombinators.Semantics.Continuation where

open import Algebra
open import Codata.Musical.Notation
open import Data.List
import Data.List.Properties as ListProp
open import Data.List.Relation.Binary.BagAndSetEquality
  using (bag) renaming (_∼[_]_ to _List-∼[_]_)
open import Data.Maybe using (Maybe)
open import Data.Product as Prod
open import Function
open import Relation.Binary.PropositionalEquality as P using (_≡_)

private
  module LM {Tok : Set} = Monoid (ListProp.++-monoid Tok)

open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics as S
  hiding ([_-_]_⊛_; [_-_]_>>=_)

-- The statement x ⊕ s₂ ∈ p · s means that there is some s₁ such that
-- s ≡ s₁ ++ s₂ and x ∈ p · s₁. This variant of the semantics is
-- perhaps harder to understand, but sometimes easier to work with
-- (and it is proved to be language equivalent to the semantics in
-- TotalParserCombinators.Semantics).

infix  60 <$>_
infixl 50 [_-_]_⊛_
infixl 10 [_-_]_>>=_
infix   4 _⊕_∈_·_

data _⊕_∈_·_ {Tok} : ∀ {R xs} → R → List Tok →
                     Parser Tok R xs → List Tok → Set₁ where
  return     : ∀ {R} {x : R} {s} → x ⊕ s ∈ return x · s
  token      : ∀ {x s} → x ⊕ s ∈ token · x ∷ s
  ∣-left     : ∀ {R x xs₁ xs₂ s s₁}
                 {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂}
               (x∈p₁ : x ⊕ s₁ ∈ p₁ · s) → x ⊕ s₁ ∈ p₁ ∣ p₂ · s
  ∣-right    : ∀ {R x xs₂ s s₁} xs₁
                 {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂}
               (x∈p₂ : x ⊕ s₁ ∈ p₂ · s) → x ⊕ s₁ ∈ p₁ ∣ p₂ · s
  <$>_       : ∀ {R₁ R₂ x s s₁ xs} {p : Parser Tok R₁ xs} {f : R₁ → R₂}
               (x∈p : x ⊕ s₁ ∈ p · s) → f x ⊕ s₁ ∈ f <$> p · s
  [_-_]_⊛_   : ∀ {R₁ R₂ f x s s₁ s₂} xs fs
                 {p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs)}
                 {p₂ : ∞⟨ fs ⟩Parser Tok  R₁       (flatten xs)} →
               (f∈p₁ : f ⊕ s₁ ∈ ♭? p₁ · s)
               (x∈p₂ : x ⊕ s₂ ∈ ♭? p₂ · s₁) →
               f x ⊕ s₂ ∈ p₁ ⊛ p₂ · s
  [_-_]_>>=_ : ∀ {R₁ R₂ x y s s₁ s₂} (f : Maybe (R₁ → List R₂)) xs
                 {p₁ : ∞⟨ f ⟩Parser Tok R₁ (flatten xs)}
                 {p₂ : (x : R₁) → ∞⟨ xs ⟩Parser Tok R₂ (apply f x)} →
               (x∈p₁ : x ⊕ s₁ ∈ ♭? p₁ · s)
               (y∈p₂x : y ⊕ s₂ ∈ ♭? (p₂ x) · s₁) →
               y ⊕ s₂ ∈ p₁ >>= p₂ · s
  nonempty   : ∀ {R xs x y s₂} s₁ {p : Parser Tok R xs}
               (x∈p : y ⊕ s₂ ∈ p · x ∷ s₁ ++ s₂) →
               y ⊕ s₂ ∈ nonempty p · x ∷ s₁ ++ s₂
  cast       : ∀ {R xs₁ xs₂ x s₁ s₂} {xs₁≈xs₂ : xs₁ List-∼[ bag ] xs₂}
                 {p : Parser Tok R xs₁}
               (x∈p : x ⊕ s₂ ∈ p · s₁) → x ⊕ s₂ ∈ cast xs₁≈xs₂ p · s₁

-- A simple cast lemma.

private

  cast∈′ : ∀ {Tok R xs} {p : Parser Tok R xs} {x s s′ s₁} →
           s ≡ s′ → x ⊕ s₁ ∈ p · s → x ⊕ s₁ ∈ p · s′
  cast∈′ P.refl x∈ = x∈

-- The definition is sound and complete with respect to the one in
-- TotalParserCombinators.Semantics.

sound′ : ∀ {Tok R xs x s₂ s} {p : Parser Tok R xs} →
         x ⊕ s₂ ∈ p · s → ∃ λ s₁ → s ≡ s₁ ++ s₂ × x ∈ p · s₁
sound′ return                      = ([]    , P.refl , return)
sound′ {x = x} token               = ([ x ] , P.refl , token)
sound′ (∣-left x∈p₁)               = Prod.map id (Prod.map id ∣-left)       (sound′ x∈p₁)
sound′ (∣-right e₁ x∈p₁)           = Prod.map id (Prod.map id (∣-right e₁)) (sound′ x∈p₁)
sound′ (<$> x∈p)                   = Prod.map id (Prod.map id (<$>_))       (sound′ x∈p)
sound′ ([ xs - fs ] f∈p₁ ⊛ x∈p₂)   with sound′ f∈p₁ | sound′ x∈p₂
sound′ ([ xs - fs ] f∈p₁ ⊛ x∈p₂)   | (s₁ , P.refl , f∈p₁′) | (s₂ , P.refl , x∈p₂′) =
                                     (s₁ ++ s₂ , P.sym (LM.assoc s₁ s₂ _) ,
                                      S.[_-_]_⊛_ xs fs f∈p₁′ x∈p₂′)
sound′ (nonempty s₁ x∈p)           with sound′ x∈p
sound′ (nonempty s₁ x∈p)           | (y ∷ s , eq , x∈p′) = (y ∷ s , eq , nonempty x∈p′)
sound′ (nonempty s₁ x∈p)           | ([]    , eq , x∈p′)
                                     with ListProp.++-identityˡ-unique (_ ∷ s₁) (P.sym eq)
sound′ (nonempty s₁ x∈p)           | ([]    , eq , x∈p′) | ()
sound′ (cast x∈p)                  = Prod.map id (Prod.map id cast) (sound′ x∈p)
sound′ ([ f - xs ] x∈p₁ >>= y∈p₂x) with sound′ x∈p₁ | sound′ y∈p₂x
sound′ ([ f - xs ] x∈p₁ >>= y∈p₂x) | (s₁ , P.refl , x∈p₁′) | (s₂ , P.refl , y∈p₂x′) =
  (s₁ ++ s₂ , P.sym (LM.assoc s₁ s₂ _) , S.[_-_]_>>=_ f xs x∈p₁′ y∈p₂x′)

sound : ∀ {Tok R xs x s} {p : Parser Tok R xs} →
        x ⊕ [] ∈ p · s → x ∈ p · s
sound x∈p with sound′ x∈p
sound x∈p | (s , P.refl , x∈p′) with s ++ [] | Prod.proj₂ LM.identity s
sound x∈p | (s , P.refl , x∈p′) | .s | P.refl = x∈p′

extend : ∀ {Tok R xs x s s′ s″} {p : Parser Tok R xs} →
         x ⊕ s′ ∈ p · s → x ⊕ s′ ++ s″ ∈ p · s ++ s″
extend return                       = return
extend token                        = token
extend (∣-left x∈p₁)                = ∣-left     (extend x∈p₁)
extend (∣-right e₁ x∈p₂)            = ∣-right e₁ (extend x∈p₂)
extend (<$> x∈p)                    = <$> extend x∈p
extend ([ xs - fs ] f∈p₁ ⊛   x∈p₂)  = [ xs - fs ] extend f∈p₁ ⊛   extend x∈p₂
extend ([ f  - xs ] x∈p₁ >>= y∈p₂x) = [ f  - xs ] extend x∈p₁ >>= extend y∈p₂x
extend (cast x∈p)                   = cast (extend x∈p)
extend (nonempty s₁ x∈p)            = cast₂ (nonempty s₁ (cast₁ (extend x∈p)))
  where
  lem   = LM.assoc (_ ∷ s₁) _ _
  cast₁ = cast∈′        lem
  cast₂ = cast∈′ (P.sym lem)

complete : ∀ {Tok R xs x s} {p : Parser Tok R xs} →
           x ∈ p · s → x ⊕ [] ∈ p · s
complete return                                 = return
complete token                                  = token
complete (∣-left x∈p₁)                          = ∣-left     (complete x∈p₁)
complete (∣-right e₁ x∈p₂)                      = ∣-right e₁ (complete x∈p₂)
complete (<$> x∈p)                              = <$> complete x∈p
complete (_⊛_   {fs = fs} {xs = xs} f∈p₁ x∈p₂)  = [ xs - fs ] extend (complete f∈p₁) ⊛   complete x∈p₂
complete (_>>=_ {xs = xs} {f  = f}  x∈p₁ y∈p₂x) = [ f  - xs ] extend (complete x∈p₁) >>= complete y∈p₂x
complete (cast x∈p)                             = cast (complete x∈p)
complete (nonempty {s = s} x∈p)                 = cast₂ (nonempty s (cast₁ (complete x∈p)))
  where
  lem   = Prod.proj₂ LM.identity _
  cast₁ = cast∈′ (P.sym lem)
  cast₂ = cast∈′        lem

complete′ : ∀ {Tok R xs x s₂ s} {p : Parser Tok R xs} →
            (∃ λ s₁ → s ≡ s₁ ++ s₂ × x ∈ p · s₁) →
            x ⊕ s₂ ∈ p · s
complete′ (s₁ , P.refl , x∈p) = extend (complete x∈p)


{-# OPTIONS --warning=error #-}

module UselessPrivateImport2 where

private
  open import Common.Issue481ParametrizedModule Set


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Reduction {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.Typed.Weakening
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Reflexivity
open import Definition.LogicalRelation.Properties.Transitivity
open import Definition.LogicalRelation.Properties.Symmetry
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Conversion

open import Tools.Product
open import Tools.Empty
import Tools.PropositionalEquality as PE

import Data.Fin as Fin
import Data.Nat as Nat

-- Weak head expansion of reducible types.
redSubst* : ∀ {A B r l Γ}
          → Γ ⊢ A ⇒* B ^ r
          → Γ ⊩⟨ l ⟩ B ^ r
          → ∃ λ ([A] : Γ ⊩⟨ l ⟩ A ^ r)
          → Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A]
redSubst* {A = A} D (Uᵣ′ B .(next l′) rU l′ l< PE.refl [[ ⊢A , ⊢B , D' ]]) =
  let ⊢A = redFirst* D
  in  Uᵣ′ A (next l′) rU l′ l< PE.refl [[ ⊢A , ⊢B , D ⇨* D' ]] , D'
redSubst* D (ℕᵣ [[ ⊢B , ⊢ℕ , D′ ]]) =
  let ⊢A = redFirst* D
  in  ℕᵣ ([[ ⊢A , ⊢ℕ , D ⇨* D′ ]]) , D′
redSubst* D (Emptyᵣ [[ ⊢B , ⊢Empty , D′ ]]) =
  let ⊢A = redFirst* D
  in  Emptyᵣ ([[ ⊢A , ⊢Empty , D ⇨* D′ ]]) , D′
redSubst* D (ne′ K [[ ⊢B , ⊢K , D′ ]] neK K≡K) =
  let ⊢A = redFirst* D
  in  (ne′ K [[ ⊢A , ⊢K , D ⇨* D′ ]] neK K≡K)
  ,   (ne₌ _ [[ ⊢B , ⊢K , D′ ]] neK K≡K)
redSubst* D (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢B , ⊢ΠFG , D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext) =
  let ⊢A = redFirst* D
  in  (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢ΠFG , D ⇨* D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext)
  ,   (Π₌ _ _ D′ A≡A (λ ρ ⊢Δ → reflEq ([F] ρ ⊢Δ))
        (λ ρ ⊢Δ [a] → reflEq ([G] ρ ⊢Δ [a])))
redSubst* D (∃ᵣ′ F G [[ ⊢B , ⊢ΠFG , D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext) =
  let ⊢A = redFirst* D
  in  (∃ᵣ′ F G [[ ⊢A , ⊢ΠFG , D ⇨* D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext)
  ,   (∃₌ _ _ D′ A≡A (λ ρ ⊢Δ → reflEq ([F] ρ ⊢Δ))
        (λ ρ ⊢Δ [a] → reflEq ([G] ρ ⊢Δ [a])))
redSubst* {l = ι ¹} D (emb l< X) with redSubst* D X
redSubst* {l = ι ¹} D (emb l< X) | y , y₁ = emb l< y , y₁
redSubst* {l = ∞} D (emb l< X) with redSubst* D X
redSubst* {l = ∞} D (emb ∞< X) | y , y₁ = emb {l′ = ι ¹} ∞< y , y₁

redSubst*Term⁰ : ∀ {A t u ll Γ} → let l = ι ⁰ in
                Γ ⊢ t ⇒* u ∷ A ^ ll
              → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
              → Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ll ] / [A]
              → Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ll ] / [A]
              × Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubst*Term⁰ t⇒u (ℕᵣ D) (ℕₜ n [[ ⊢u , ⊢n , d ]] n≡n prop) =
  let A≡ℕ  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡ℕ
      t⇒u′ = conv* t⇒u A≡ℕ
  in  ℕₜ n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] n≡n prop
  ,   ℕₜ₌ n n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] [[ ⊢u , ⊢n , d ]]
          n≡n (reflNatural-prop prop)
redSubst*Term⁰ t⇒u (ne′ K D neK K≡K) (neₜ k [[ ⊢t , ⊢u , d ]] (neNfₜ neK₁ ⊢k k≡k)) =
  let A≡K  = subset* (red D)
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡K , ⊢u , conv* t⇒u A≡K ⇨∷* d ]]
  in  neₜ k [d′] (neNfₜ neK₁ ⊢k k≡k) , neₜ₌ k k [d′] [d] (neNfₜ₌ neK₁ neK₁ k≡k)
redSubst*Term⁰ {A} {t} {u} {l} {Γ} t⇒u (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                  (Πₜ f [[ ⊢t , ⊢u , d ]] funcF f≡f [f] [f]₁) =
  let A≡ΠFG = subset* (red D)
      t⇒u′  = conv* t⇒u A≡ΠFG
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡ΠFG , ⊢u , conv* t⇒u A≡ΠFG ⇨∷* d ]]
  in  Πₜ f [d′] funcF f≡f [f] [f]₁
  ,   Πₜ₌ f f [d′] [d] funcF funcF f≡f
          (Πₜ f [d′] funcF f≡f [f] [f]₁)
          (Πₜ f [d] funcF f≡f [f] [f]₁)
          (λ [ρ] ⊢Δ [a] → reflEqTerm ([G] [ρ] ⊢Δ [a]) ([f]₁ [ρ] ⊢Δ [a]))

-- Weak head expansion of reducible terms.
redSubst*Term : ∀ {A t u l ll Γ}
              → Γ ⊢ t ⇒* u ∷ A ^ ll
              → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
              → Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ll ] / [A]
              → Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ll ] / [A]
              × Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubst*Term {t = t} {l = ι ¹} {Γ = Γ} t⇒u (Uᵣ′ A .(next ⁰) rU ⁰ l< PE.refl D) (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) =
  let
    A≡U  = subset* (red D)
    ⊢t   = conv (redFirst*Term t⇒u) A≡U
    t⇒u′ = conv* t⇒u A≡U
    [t] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₁ (redSubst* {l = ι ⁰} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [t≡u] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₂ (redSubst* {l = ι ⁰} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [[t]] = Uₜ K [[ ⊢t , ⊢K , t⇒u′ ⇨∷* d ]] typeA A≡A [t]
  in
  ([[t]] , Uₜ₌ [[t]] (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) A≡A [t≡u])
redSubst*Term {t = t} {l = ∞} {Γ = Γ} t⇒u (Uᵣ′ A .(next ¹) rU ¹ l< PE.refl D) (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) =
  let
    A≡U  = subset* (red D)
    ⊢t   = conv (redFirst*Term t⇒u) A≡U
    t⇒u′ = conv* t⇒u A≡U
    [t] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₁ (redSubst* {l = ι ¹} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [t≡u] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₂ (redSubst* {l = ι ¹} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [[t]] = Uₜ K [[ ⊢t , ⊢K , t⇒u′ ⇨∷* d ]] typeA A≡A [t]
  in
  ([[t]] , Uₜ₌ [[t]] (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) A≡A [t≡u])
redSubst*Term t⇒u (ℕᵣ D) (ℕₜ n [[ ⊢u , ⊢n , d ]] n≡n prop) =
  let A≡ℕ  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡ℕ
      t⇒u′ = conv* t⇒u A≡ℕ
  in  ℕₜ n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] n≡n prop
  ,   ℕₜ₌ n n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] [[ ⊢u , ⊢n , d ]]
          n≡n (reflNatural-prop prop)
redSubst*Term t⇒u (ne′ K D neK K≡K) (neₜ k [[ ⊢t , ⊢u , d ]] (neNfₜ neK₁ ⊢k k≡k)) =
  let A≡K  = subset* (red D)
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡K , ⊢u , conv* t⇒u A≡K ⇨∷* d ]]
  in  neₜ k [d′] (neNfₜ neK₁ ⊢k k≡k) , neₜ₌ k k [d′] [d] (neNfₜ₌ neK₁ neK₁ k≡k)
redSubst*Term {A} {t} {u} {l} {Γ} t⇒u (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                  (Πₜ f [[ ⊢t , ⊢u , d ]] funcF f≡f [f] [f]₁) =
  let A≡ΠFG = subset* (red D)
      t⇒u′  = conv* t⇒u A≡ΠFG
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡ΠFG , ⊢u , conv* t⇒u A≡ΠFG ⇨∷* d ]]
  in  Πₜ f [d′] funcF f≡f [f] [f]₁
  ,   Πₜ₌ f f [d′] [d] funcF funcF f≡f
          (Πₜ f [d′] funcF f≡f [f] [f]₁)
          (Πₜ f [d] funcF f≡f [f] [f]₁)
          (λ [ρ] ⊢Δ [a] → reflEqTerm ([G] [ρ] ⊢Δ [a]) ([f]₁ [ρ] ⊢Δ [a]))
redSubst*Term {l = ι ¹} D (emb l< X) [u] = redSubst*Term D X [u]
redSubst*Term {l = ∞} D (emb l< X) [u] = redSubst*Term D X [u]

-- Weak head expansion of reducible types with single reduction step.
redSubst : ∀ {A B r l Γ}
         → Γ ⊢ A ⇒ B ^ r
         → Γ ⊩⟨ l ⟩ B ^ r
         → ∃ λ ([A] : Γ ⊩⟨ l ⟩ A ^ r)
         → Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A]
redSubst A⇒B [B] = redSubst* (A⇒B ⇨ id (escape [B])) [B]

-- Weak head expansion of reducible terms with single reduction step.
redSubstTerm : ∀ {A t u l ll Γ}
             → Γ ⊢ t ⇒ u ∷ A ^ ll
             → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
             → Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ll ] / [A]
             → Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ll ] / [A]
             × Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubstTerm t⇒u [A] [u] = redSubst*Term (t⇒u ⇨ id (escapeTerm [A] [u])) [A] [u]

-- Equalities
redSubst*EqTerm : ∀ {A B t t′ u u′ l ll Γ}
                → Γ ⊢ t ⇒* t′ ∷ A ^ ll
                → Γ ⊢ u ⇒* u′ ∷ B ^ ll
                → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
                → ([B] : Γ ⊩⟨ l ⟩ B ^ [ ! , ll ])
                → Γ ⊩⟨ l ⟩ A ≡ B ^ [ ! , ll ] / [A]
                → Γ ⊩⟨ l ⟩ t′ ∷ A ^ [ ! , ll ] / [A]
                → Γ ⊩⟨ l ⟩ u′ ∷ B ^ [ ! , ll ] / [B]
                → Γ ⊩⟨ l ⟩ t′ ≡ u′ ∷ A ^ [ ! , ll ] / [A]
                → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubst*EqTerm D D′ [A] [B] [A≡B] [t′] [u′] [t′≡u′] =
  let
    [t≡t′] = proj₂ (redSubst*Term D [A] [t′])
    [u≡u′:B] = proj₂ (redSubst*Term D′ [B] [u′])
    [u≡u′] = convEqTerm₂ [A] [B] [A≡B] [u≡u′:B]
  in transEqTerm [A] [t≡t′] (transEqTerm [A] [t′≡u′] (symEqTerm [A] [u≡u′]))


open import Prelude

module Implicits.Oliveira.Deterministic.Decidable where

open import Data.Fin.Substitution
open import Implicits.Oliveira.Types
open import Implicits.Oliveira.Terms
open import Implicits.Oliveira.Contexts
open import Implicits.Oliveira.Substitutions
open import Implicits.Oliveira.Substitutions.Lemmas
open import Implicits.Oliveira.Deterministic.Resolution
open import Implicits.Oliveira.Types.Unification
open import Data.Star hiding (map)

MICtx : ℕ → ℕ → Set
MICtx m ν = List (MetaType m ν)

private
  module M = MetaTypeMetaSubst
  module T = MetaTypeTypeSubst

{-
{-# NO_TERMINATION_CHECK #-}
_,_amatch_ : ∀ {m ν} → (MetaType m ν) → (ρs : MICtx m ν) → (τ : SimpleType ν) → Maybe (ICtx ν)
(a ⇒ b) , ρs amatch τ = b , a List.∷ ρs amatch τ
∀' x , ρs amatch τ = open-meta x , (List.map meta-weaken ρs) amatch τ
(simpl x) , ρs amatch τ with mgu (simpl x) τ
(simpl x) , ρs amatch τ | just (u , proj₂) =
  just $ List.map (λ r → from-meta $ substitute (asub u) r) ρs
(simpl x) , ρs amatch τ | nothing = nothing

_match_ : ∀ {ν} → (Type ν) → (SimpleType ν) → Maybe (ICtx ν)
r match a = (to-meta {zero} r) , List.[] amatch a

{-# NO_TERMINATION_CHECK #-}
lem-a6 : ∀ {m ν} {ρs ρs'} (a : MetaType m ν) (τ : SimpleType ν) → a , ρs amatch τ ≡ just ρs' →
  (∃ λ (u : AList ν m zero) → (from-meta $ substitute (asub u) a) ◁ τ)
lem-a6 {ρs = ρs} (a ⇒ b) τ m
  with _,_amatch_ b (a List.∷ ρs) τ | inspect (_,_amatch_ b (a List.∷ ρs)) τ
lem-a6 (a ⇒ b) τ refl | ._ | reveal[ eq ] with lem-a6 b τ eq
lem-a6 (a ⇒ b) τ refl | ._ | reveal[ eq ] | u , b/u◁τ = u , (m-iabs b/u◁τ)
lem-a6 {ρs = ρs} (∀' a) τ m
  with open-meta a , (List.map meta-weaken ρs) amatch τ | inspect (_,_amatch_ (open-meta a) (List.map meta-weaken ρs)) τ
lem-a6 (∀' a) τ refl | ._ | reveal[ eq ] with lem-a6 (open-meta a) τ eq
lem-a6 (∀' a) τ refl | ._ | reveal[ eq ] | (t' // x ◅ u , b/u◁τ) = {!!} -- {!u!} , (m-tabs {!!})
lem-a6 (simpl x) τ m with mgu (simpl x) τ | inspect (mgu (simpl x)) τ
lem-a6 (simpl x) τ refl | just (u , proj₂) | reveal[ eq ] =
  u , subst (λ u → u ◁ τ) (sym $ mgu-unifies (simpl x) τ {!!}) m-simp
lem-a6 (simpl x) τ () | nothing

_match1st_ : ∀ {ν} (Δ : ICtx ν) → (a : SimpleType ν) → Maybe (Type ν × ICtx ν)
List.[] match1st a = nothing
(x List.∷ Δ) match1st a with x match a
(x List.∷ Δ) match1st a | just z = just (x , z)
(x List.∷ Δ) match1st a | nothing = Δ match1st a

_⊢alg_ : ∀ {ν n} (K : Ktx ν n) → (a : Type ν) → Dec (K ⊢ᵣ a)
(Γ , Δ) ⊢alg simpl x with Δ match1st x
(Γ , Δ) ⊢alg simpl x | just (proj₁ , proj₂) = {!!}
(Γ , Δ) ⊢alg simpl x | nothing = {!!}
K ⊢alg (a ⇒ b) with (a ∷K K) ⊢alg b
K ⊢alg (a ⇒ b) | yes p = yes $ r-iabs a p
K ⊢alg (a ⇒ b) | no ¬p = no (λ{ (r-iabs .a x) → ¬p x })
K ⊢alg ∀' a with (ktx-weaken K) ⊢alg a
K ⊢alg ∀' a | yes p = yes (r-tabs p)
K ⊢alg ∀' a | no ¬p = no (λ{ (r-tabs p) → ¬p p })

-}
module relational where

  data _⊢_amatch_↠_ {m ν} : (ρs : MICtx m ν) → MetaType m ν → SimpleType ν → (ICtx ν) → Set where
    mtc-tabs : ∀ {r ρs ρs' a} → (List.map meta-weaken ρs) ⊢ (open-meta r) amatch a ↠ ρs' →
                ρs ⊢ ∀' r amatch a ↠ ρs'
    mtc-iabs : ∀ {ρs ρs' a b c} → (a List.∷ ρs) ⊢ b amatch c ↠ ρs' → ρs ⊢ a ⇒ b amatch c ↠ ρs'
    mtc-simp : ∀ {ρs a b} → (u : Unifiable (simpl a) b) →
               ρs ⊢ (simpl a) amatch b ↠ (List.map (λ r → from-meta $ r M./ (asub (proj₁ u))) ρs)

  _⊢match_↠_ : ∀ {ν} → (Type ν) → (SimpleType ν) → ICtx ν → Set
  r ⊢match a ↠ ρs = List.[] ⊢ (to-meta {zero} r) amatch a ↠ ρs

  data _⊢match1st_↠_ {ν} : List (Type ν) → (a : SimpleType ν) → ICtx ν → Set where
    m1-head : ∀ {rs ρs} {r : Type ν} {a} → r ⊢match a ↠ ρs → (r List.∷ rs) ⊢match1st a ↠ ρs
    m1-tail : ∀ {rs ρs} {r : Type ν} {a} → ¬ r ⊢match a ↠ ρs → rs ⊢match1st a ↠ ρs →
              (r List.∷ rs) ⊢match1st a ↠ ρs

  {-}
  gather : ∀ {ν} {ρs ρs' : ICtx ν} {a} → ρs ⊢match1st a ↠ ρs' → List (Type ν)
  gather (m1-head x) = gather' x
    where
        gather' : ∀ {m ν} {ρs : MICtx m ν} {r a} → ρs ⊢ r amatch a ↠→ List (Type ν)
        gather' (mtc-tabs x) = gather' x
        gather' (mtc-iabs x) = gather' x
        gather' {ρs = ρs} (mtc-simp {a = a} {b = b} u) =
                (List.map (λ r → from-meta $ substitute (asub (proj₁ u)) r) ρs)
  gather (m1-tail ¬x xs) = gather xs
  -}

  {-# NO_TERMINATION_CHECK #-}
  amatch : ∀ {m ν} → (ρs : MICtx m ν) → (r : MetaType m ν) (a : SimpleType ν) →
            Dec (∃ λ ρs' → ρs ⊢ r amatch a ↠ ρs')
  amatch ρs (simpl x) a with mgu (simpl x) a | inspect (mgu (simpl x)) a
  amatch ρs (simpl x) a | just mgu | _ = yes (, mtc-simp mgu)
  amatch ρs (simpl x) a | nothing | reveal[ eq ] =
    no (λ{ (._ , mtc-simp p) → (mgu-sound (simpl x) a eq) p})
  amatch ρs (b ⇒ c) a with amatch (b List.∷ ρs) c a
  amatch ρs (b ⇒ c) a | yes (_ , p) = yes $ , mtc-iabs p
  amatch ρs (b ⇒ c) a | no ¬p = no (λ{ (._ , mtc-iabs x) → ¬p (, x)})
  amatch ρs (∀' r) a with amatch (List.map meta-weaken ρs) (open-meta r) a
  amatch ρs (∀' r) a | yes (_ , p) = yes $ , mtc-tabs p
  amatch ρs (∀' r) a | no ¬p = no (λ{ (._ , mtc-tabs x) → ¬p (, x) })

  match : ∀ {ν} → (r : Type ν) → (a : SimpleType ν) → Dec (∃ λ ρs → r ⊢match a ↠ ρs)
  match r a = amatch List.[] (to-meta {zero} r) a

  _match1st_ : ∀ {ν} (Δ : ICtx ν) → (a : SimpleType ν) → Dec (∃ λ ρs → Δ ⊢match1st a ↠ ρs)
  List.[] match1st a = no (λ{ (_ , ()) })
  (x List.∷ xs) match1st a with match x a
  (x List.∷ xs) match1st a | yes (ρs , p) = yes (ρs , m1-head p)
  (x List.∷ xs) match1st a | no ¬p with xs match1st a
  (x List.∷ xs) match1st a | no ¬p | yes p = yes  ? -- (, m1-tail ¬p p)
  (x List.∷ xs) match1st a | no ¬p-head | no ¬p-tail =
    no (λ{ (_ , m1-head p-head) → ¬p-head (, p-head) ; (_ , m1-tail _ p-tail) → ¬p-tail (, p-tail) })

  module Lemmas where

    lem-A3 : ∀ {ν n} (K : Ktx ν n) {a r} → proj₂ K ⟨ a ⟩= r → r List.∈ (proj₂ K)
    lem-A3 f = proj₁ ∘ FirstLemmas.first⟶∈

    lem-A6-1 : ∀ {m ν} → AList ν (suc m) zero → ASub ν (suc m) m × AList ν m zero
    lem-A6-1 (t' // zero ◅ s) = t' // zero , s
    lem-A6-1 {zero} (t' // suc () ◅ xs)
    lem-A6-1 {suc m} (t' // x ◅ xs) with lem-A6-1 xs
    lem-A6-1 {suc m} (t' // zero ◅ xs) | e , u = t' // zero , xs -- same case as above
    lem-A6-1 {suc m} (t' // suc x ◅ xs) | e , u = asub-weaken e , t' // x ◅ u

    lem-A6 : ∀ {m ν} {ρs ρs'} {a : MetaType m ν} {τ : SimpleType ν} → ρs ⊢ a amatch τ ↠ ρs' →
             (∃ λ (u : AList ν m zero) → (from-meta $ a M./ (asub u)) ◁ τ)
    lem-A6 {a = ∀' a} {τ = τ} (mtc-tabs x) with lem-A6 x
    lem-A6 {a = ∀' a} {τ = τ} (mtc-tabs x) | u , p with lem-A6-1 u
    lem-A6 {a = ∀' a} {τ = τ} (mtc-tabs x) | u , p | b , bs = bs , m-tabs {!p!}
      where
        -- q : from-meta (substitute (asub u) a []) ◁ τ
        -- q = {!!}
    lem-A6 (mtc-iabs x) with lem-A6 x
    lem-A6 (mtc-iabs x) | u , p = u , (m-iabs p)
    lem-A6 {τ = τ} (mtc-simp {a = a} (u , eq)) =
      u , subst (flip _◁_ τ) (sym $ mgu-unifies (simpl a) τ (u , eq)) m-simp

    lem-A6' : ∀ {ν} {ρs ρs' } {r : Type ν} {a} → r ◁ a → ρs ⊢ (to-meta {zero} r) amatch a ↠ ρs'
    lem-A6' {a = a} m-simp = mtc-simp (mgu-id a)
    lem-A6' (m-tabs r◁a) = mtc-tabs {!!}
    lem-A6' (m-iabs r◁a) = mtc-iabs (lem-A6' r◁a)

    -- p'haps counterintuitively the following proposition is NOT a theorem:
    -- Δ⊢ᵣa⟶Δ≢Ø : ∀ {ν n} {K : Ktx ν n} {a} → K ⊢ᵣ a → ∃ λ b → b List.∈ (proj₂ K)
    -- since [] ⊢ᵣ Nat ⇒ Nat through the r-iabs rule, but also:
    -- [] ⊢ᵣ Nat ⇒ (Nat ⇒ Nat), etc; through recursion on r-iabs

    lem-A7a : ∀ {ν} (Δ : ICtx ν) {a ρs} → Δ ⊢match1st a ↠ ρs → ∃ λ r → Δ ⟨ a ⟩= r
    lem-A7a List.[] ()
    lem-A7a (x List.∷ Δ) {a = a} (m1-head x₁) = , (l-head u Δ)
        where
        p = lem-A6 x₁
        u = subst (λ u' → u' ◁ a) (alist-zero-vanishes (proj₁ p)) (proj₂ p)
    lem-A7a (r List.∷ Δ) (m1-tail ¬pr y) =
        , (l-tail (λ r◁a → ¬pr $ lem-A6' r◁a) (proj₂ $ lem-A7a Δ y))

  open Lemmas

  _⊢alg_ : ∀ {ν n} (K : Ktx ν n) → (a : Type ν) → Dec (K ⊢ᵣ a)
  K ⊢alg simpl x with proj₂ K match1st x
  K ⊢alg simpl x | yes p = yes (r-simp (proj₂ $ lem-A7a (proj₂ K) p) {!!})
  K ⊢alg simpl x | no ¬p = no (λ{ (r-simp x₁ x₂) → {!!} })
  K ⊢alg (a ⇒ b) with (a ∷K K) ⊢alg b
  K ⊢alg (a ⇒ b) | yes p = yes $ r-iabs a p
  K ⊢alg (a ⇒ b) | no ¬p = no (λ{ (r-iabs .a x) → ¬p x })
  K ⊢alg ∀' a with (ktx-weaken K) ⊢alg a
  K ⊢alg ∀' a | yes p = yes (r-tabs p)
  K ⊢alg ∀' a | no ¬p = no (λ{ (r-tabs x) → ¬p x })


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.List.Relation.Unary.Any.Properties directly.
------------------------------------------------------------------------

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

module Data.List.Relation.BagAndSetEquality where

open import Data.List.Relation.Binary.BagAndSetEquality public


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Interface.Output

-- This module defines the LBFT monad used by our (fake/simple,
-- for now) "implementation", along with some utility functions
-- to facilitate reasoning about it.

module LibraBFT.ImplShared.Util.Util where
  open import Optics.All
  open import LibraBFT.ImplShared.Util.Dijkstra.Syntax public
  open import LibraBFT.ImplShared.Util.Dijkstra.RWS public
  open import LibraBFT.ImplShared.Util.Dijkstra.RWS.Syntax public
  open import LibraBFT.ImplShared.Util.Dijkstra.EitherD public
  open import LibraBFT.ImplShared.Util.Dijkstra.EitherD.Syntax public
  ----------------
  -- LBFT Monad --
  ----------------

  -- Global 'LBFT'; works over the whole state.
  LBFT : Set → Set₁
  LBFT = RWS Unit Output RoundManager

  LBFT-run : ∀ {A} → LBFT A → RoundManager → (A × RoundManager × List Output)
  LBFT-run m = RWS-run m unit

  LBFT-result : ∀ {A} → LBFT A → RoundManager → A
  LBFT-result m rm = proj₁ (LBFT-run m rm)

  LBFT-post : ∀ {A} → LBFT A → RoundManager → RoundManager
  LBFT-post m rm = proj₁ (proj₂ (LBFT-run m rm))

  LBFT-outs : ∀ {A} → LBFT A → RoundManager → List Output
  LBFT-outs m rm = proj₂ (proj₂ (LBFT-run m rm))

  LBFT-Pre  = RoundManager → Set
  LBFT-Post = RWS-Post Output RoundManager

  LBFT-Post-True : ∀ {A} → LBFT-Post A → LBFT A → RoundManager → Set
  LBFT-Post-True Post m pre =
    let (x , post , outs) = LBFT-run m pre in
    Post x post outs

  LBFT-weakestPre : ∀ {A} (m : LBFT A)
                    → LBFT-Post A → LBFT-Pre
  LBFT-weakestPre m Post pre = RWS-weakestPre m Post unit pre

  LBFT-Contract : ∀ {A} (m : LBFT A) → Set₁
  LBFT-Contract{A} m =
    (Post : RWS-Post Output RoundManager A)
    → (pre : RoundManager) → LBFT-weakestPre m Post pre
    → LBFT-Post-True Post m pre

  LBFT-contract : ∀ {A} (m : LBFT A) → LBFT-Contract m
  LBFT-contract m Post pre pf = RWS-contract m Post unit pre pf

  LBFT-⇒
    : ∀ {A} (P Q : LBFT-Post A) → (RWS-Post-⇒ P Q)
    → ∀ m pre → LBFT-weakestPre m P pre → LBFT-weakestPre m Q pre
  LBFT-⇒ Post₁ Post₂ f m pre pf = RWS-⇒ Post₁ Post₂ f m unit pre pf

  LBFT-⇒-bind
    : ∀ {A B} (P : LBFT-Post A) (Q : LBFT-Post B) (f : A → LBFT B)
      → (RWS-Post-⇒ P (RWS-weakestPre-bindPost unit f Q))
      → ∀ m st → LBFT-weakestPre m P st → LBFT-weakestPre (m >>= f) Q st
  LBFT-⇒-bind Post Q f pf m st con = RWS-⇒-bind Post Q f unit pf m st con

  LBFT-⇒-ebind
    : ∀ {A B C} (P : LBFT-Post (Either C A)) (Q : LBFT-Post (Either C B))
      → (f : A → LBFT (Either C B))
      → RWS-Post-⇒ P (RWS-weakestPre-ebindPost unit f Q)
      → ∀ m st → LBFT-weakestPre m P st
      → LBFT-weakestPre (m ∙?∙ f) Q st
  LBFT-⇒-ebind Post Q f pf m st con =
    RWS-⇒-ebind Post Q f unit pf m st con


module Text.Greek.SBLGNT-Query where

open import Data.Bool
open import Data.Nat hiding (_≟_)
open import Data.List
open import Data.Maybe
open import Data.Product hiding (map)
open import Function
open import Relation.Binary.PropositionalEquality
open import Text.Greek.Bible
open import Text.Greek.Script
open import Text.Greek.SBLGNT.1John

texts = ΙΩΑΝΝΟΥ-Α ∷ []

wordCount = length ΙΩΑΝΝΟΥ-Α
--tokenCount = length (concat ΙΩΑΝΝΟΥ-Α)

getLetters : Word → List Token
getLetters (word x _) = x

tokens = concatMap getLetters ΙΩΑΝΝΟΥ-Α

adjacent-accent : (Token → Maybe Accent) → List Token → List (Σ Token (const Token))
adjacent-accent f [] = []
adjacent-accent f (_ ∷ []) = []
adjacent-accent f (t₁ ∷ t₂ ∷ ts) with (f t₁) , (f t₂) , adjacent-accent f (t₂ ∷ ts)
… | (just circumflex-mark , just circumflex-mark , ts′)  = (t₁ , t₂) ∷ ts′
… | (_ , _ , ts′) = ts′

adj = adjacent-accent get-accent tokens


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Escape {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.LogicalRelation

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Reducible types are well-formed.
escape : ∀ {l Γ A} → Γ ⊩⟨ l ⟩ A → Γ ⊢ A
escape (Uᵣ′ l′ l< ⊢Γ) = Uⱼ ⊢Γ
escape (ℕᵣ [ ⊢A , ⊢B , D ]) = ⊢A
escape (Emptyᵣ [ ⊢A , ⊢B , D ]) = ⊢A
escape (Unitᵣ [ ⊢A , ⊢B , D ]) = ⊢A
escape (ne′ K [ ⊢A , ⊢B , D ] neK K≡K) = ⊢A
escape (Bᵣ′ W F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext) = ⊢A
escape (emb 0<1 A) = escape A

-- Reducible type equality respect the equality relation.
escapeEq : ∀ {l Γ A B} → ([A] : Γ ⊩⟨ l ⟩ A)
            → Γ ⊩⟨ l ⟩ A ≡ B / [A]
            → Γ ⊢ A ≅ B
escapeEq (Uᵣ′ l′ l< ⊢Γ) PE.refl = ≅-Urefl ⊢Γ
escapeEq (ℕᵣ [ ⊢A , ⊢B , D ]) D′ = ≅-red D D′ ℕₙ ℕₙ (≅-ℕrefl (wf ⊢A))
escapeEq (Emptyᵣ [ ⊢A , ⊢B , D ]) D′ = ≅-red D D′ Emptyₙ Emptyₙ (≅-Emptyrefl (wf ⊢A))
escapeEq (Unitᵣ [ ⊢A , ⊢B , D ]) D′ = ≅-red D D′ Unitₙ Unitₙ (≅-Unitrefl (wf ⊢A))
escapeEq (ne′ K D neK K≡K) (ne₌ M D′ neM K≡M) =
  ≅-red (red D) (red D′) (ne neK) (ne neM) (~-to-≅ K≡M)
escapeEq (Bᵣ′ W F G D ⊢F ⊢G A≡A [F] [G] G-ext)
             (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ≅-red (red D) D′ ⟦ W ⟧ₙ ⟦ W ⟧ₙ A≡B
escapeEq (emb 0<1 A) A≡B = escapeEq A A≡B

-- Reducible terms are well-formed.
escapeTerm : ∀ {l Γ A t} → ([A] : Γ ⊩⟨ l ⟩ A)
              → Γ ⊩⟨ l ⟩ t ∷ A / [A]
              → Γ ⊢ t ∷ A
escapeTerm (Uᵣ′ l′ l< ⊢Γ) (Uₜ A [ ⊢t , ⊢u , d ] typeA A≡A [A]) = ⊢t
escapeTerm (ℕᵣ D) (ℕₜ n [ ⊢t , ⊢u , d ] t≡t prop) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Emptyᵣ D) (Emptyₜ e [ ⊢t , ⊢u , d ] t≡t prop) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Unitᵣ D) (Unitₜ e [ ⊢t , ⊢u , d ] prop) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (ne′ K D neK K≡K) (neₜ k [ ⊢t , ⊢u , d ] nf) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
               (Πₜ f [ ⊢t , ⊢u , d ] funcF f≡f [f] [f]₁) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
               (Σₜ p [ ⊢t , ⊢u , d ] pProd p≅p [fst] [snd]) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (emb 0<1 A) t = escapeTerm A t

-- Reducible term equality respect the equality relation.
escapeTermEq : ∀ {l Γ A t u} → ([A] : Γ ⊩⟨ l ⟩ A)
                → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / [A]
                → Γ ⊢ t ≅ u ∷ A
escapeTermEq (Uᵣ′ l′ l< ⊢Γ) (Uₜ₌ A B d d′ typeA typeB A≡B [A] [B] [A≡B]) =
  ≅ₜ-red (id (Uⱼ ⊢Γ)) (redₜ d) (redₜ d′) Uₙ (typeWhnf typeA) (typeWhnf typeB) A≡B
escapeTermEq (ℕᵣ D) (ℕₜ₌ k k′ d d′ k≡k′ prop) =
  let natK , natK′ = split prop
  in  ≅ₜ-red (red D) (redₜ d) (redₜ d′) ℕₙ
             (naturalWhnf natK) (naturalWhnf natK′) k≡k′
escapeTermEq (Emptyᵣ D) (Emptyₜ₌ k k′ d d′ k≡k′ prop) =
  let natK , natK′ = esplit prop
  in  ≅ₜ-red (red D) (redₜ d) (redₜ d′) Emptyₙ
             (ne natK) (ne natK′) k≡k′
escapeTermEq {l} {Γ} {A} {t} {u} (Unitᵣ D) (Unitₜ₌ ⊢t ⊢u) =
  let t≅u = ≅ₜ-η-unit ⊢t ⊢u
      A≡Unit = subset* (red D)
  in  ≅-conv t≅u (sym A≡Unit)
escapeTermEq (ne′ K D neK K≡K)
                 (neₜ₌ k m d d′ (neNfₜ₌ neT neU t≡u)) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) (ne neK) (ne neT) (ne neU)
         (~-to-≅ₜ t≡u)
escapeTermEq (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                 (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) Πₙ (functionWhnf funcF) (functionWhnf funcG) f≡g
escapeTermEq (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                 (Σₜ₌ p r d d′ pProd rProd p≅r [t] [u] [fstp] [fstr] [fst≡] [snd≡]) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) Σₙ (productWhnf pProd) (productWhnf rProd) p≅r
escapeTermEq (emb 0<1 A) t≡u = escapeTermEq A t≡u


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness --sized-types #-}

open import Data.Empty
open import Data.Unit
open import Data.Product
open import Data.Maybe
open import Data.Sum
open import Data.List using (_++_; []; _∷_; _∷ʳ_; length)
open import Data.List.Properties using (∷-injective)

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_; _⊆_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; subst; cong)

open import Function.Base using (case_of_)

open import Common

module Divergence {ℙ : Set} (message : Message ℙ)
  where

open import SessionType message
open import Session message
open import Trace message
open import HasTrace message
open import TraceSet message
open import Transitions message
open import Semantics message
open import Subtyping message

DivergeForward : SessionType -> SessionType -> Trace -> Set

record _↑_ (T : SessionType) (S : SessionType) : Set where
  coinductive
  field
    trace : Trace
    with-trace : T HasTrace trace
    without-trace : ¬ S HasTrace trace
    divergence : DivergeForward T S trace

DivergeForward T S φ =
  ∀{ψ x}
  (pre : ψ ⊑ φ)
  (tψx : T HasTrace (ψ ∷ʳ O x))
  (sψx : S HasTrace (ψ ∷ʳ O x)) -> after tψx ↑ after sψx

diverge-before-input : ∀{f g x} -> f x .force ↑ g x .force -> inp f ↑ inp g
_↑_.trace (diverge-before-input {_} {_} {x} div) = I x ∷ _↑_.trace div
_↑_.with-trace (diverge-before-input div) = inp-has-trace (_↑_.with-trace div)
_↑_.without-trace (diverge-before-input div) = inp-has-no-trace (_↑_.without-trace div)
_↑_.divergence (diverge-before-input div) none (_ , _ , step () _) _
_↑_.divergence (diverge-before-input div) (some le) (_ , tdef , step inp tr) (_ , sdef , step inp sr) =
  _↑_.divergence div le (_ , tdef , tr) (_ , sdef , sr)

DivergeBackward : ∀{T S φ} -> T HasTrace φ -> S HasTrace φ -> Set
DivergeBackward {_} {_} {φ} tφ sφ =
  ∀{ψ} (pre : ψ ⊑ φ) -> after (⊑-has-trace pre tφ) ↑ after (⊑-has-trace pre sφ)

⊑-diverge-backward :
  ∀{T S φ ψ}
  {tφ  : T HasTrace φ}
  {sφ  : S HasTrace φ}
  (pre : ψ ⊑ φ) ->
  DivergeBackward tφ sφ ->
  DivergeBackward (⊑-has-trace pre tφ) (⊑-has-trace pre sφ)
⊑-diverge-backward {_} {_} {_} {_} {tφ} {sφ} pre div pre'  rewrite ⊑-tran-has-trace pre' pre tφ | ⊑-tran-has-trace pre' pre sφ =
  div (⊑-tran pre' pre)

data DiscSet : SessionType -> SessionType -> Trace -> Set where
  inc : ∀{T S φ}
        (tφ : T HasTrace φ)
        (sφ : S HasTrace φ)
        (div←φ : DivergeBackward tφ sφ) -> DiscSet T S φ
  exc : ∀{T S φ ψ x}
        (eq : φ ≡ ψ ∷ʳ O x)
        (tψ : T HasTrace ψ)
        (sψ : S HasTrace ψ)
        (tφ : T HasTrace φ)
        (nsφ : ¬ S HasTrace φ)
        (div←ψ : DivergeBackward tψ sψ) -> DiscSet T S φ

⊑-proper : ∀{φ ψ α} -> φ ⊑ (ψ ∷ʳ α) -> φ ⊑ ψ ⊎ φ ≡ ψ ∷ʳ α
⊑-proper {[]} {[]} none = inj₁ none
⊑-proper {_ ∷ []} {[]} (some none) = inj₂ refl
⊑-proper {[]} {_ ∷ _} none = inj₁ none
⊑-proper {_} {_ ∷ _} (some pre) with ⊑-proper pre
... | inj₁ pre' = inj₁ (some pre')
... | inj₂ refl = inj₂ refl

disc-set->closed : (T S : SessionType) -> PrefixClosed (DiscSet T S)
disc-set->closed T S pre (inc tφ sφ div←φ) =
  inc (⊑-has-trace pre tφ) (⊑-has-trace pre sφ) (⊑-diverge-backward pre div←φ)
disc-set->closed T S pre (exc refl tψ sψ tφ nsφ div←ψ) with ⊑-proper pre
... | inj₁ pre' = inc (⊑-has-trace pre' tψ) (⊑-has-trace pre' sψ) (⊑-diverge-backward pre' div←ψ)
... | inj₂ refl = exc refl tψ sψ tφ nsφ div←ψ

input-lemma : ∀{φ x ψ χ y} -> φ ++ I x ∷ ψ ≡ χ ∷ʳ O y -> (φ ∷ʳ I x) ⊑ χ
input-lemma {[]} {_} {_} {I x ∷ χ} refl = some none
input-lemma {x ∷ φ} {_} {_} {[]} eq with ∷-injective eq
... | (_ , eq') = ⊥-elim (absurd-++-≡ eq')
input-lemma {x ∷ φ} {_} {_} {y ∷ χ} eq with ∷-injective eq
... | (refl , eq'') = some (input-lemma eq'')

disc-set-input : ∀{φ x ψ} {T S : SessionType} -> DiscSet T S (φ ++ I x ∷ ψ) ->
  T HasTrace (φ ∷ʳ I x) × S HasTrace (φ ∷ʳ I x)
disc-set-input {φ} {x} {ψ} (inc tφ sφ div←φ) with ⊑-precong-++ {φ} {I x ∷ []} {I x ∷ ψ} (some none)
... | pre = ⊑-has-trace pre tφ , ⊑-has-trace pre sφ
disc-set-input (exc eq tχ sχ _ _ _) with input-lemma eq
... | pre = ⊑-has-trace pre tχ , ⊑-has-trace pre sχ

disc-set-output : ∀{φ x ψ} {T S : SessionType} -> DiscSet T S (φ ++ O x ∷ ψ) -> T HasTrace (φ ∷ʳ O x)
disc-set-output {φ} {x} {ψ} (inc tφx sφx _) =
  let pre = ⊑-precong-++ {φ} {O x ∷ []} {O x ∷ ψ} (some none) in
  ⊑-has-trace pre tφx
disc-set-output {φ} {x} {ψ} (exc _ _ _ tφx _ _) =
  let pre = ⊑-precong-++ {φ} {O x ∷ []} {O x ∷ ψ} (some none) in
  ⊑-has-trace pre tφx

disc-set->coherent : (T S : SessionType) -> Coherent (DiscSet T S)
disc-set->coherent T S ti to =
  let (ti[] , _) = disc-set-input ti in
  let to[] = disc-set-output to in
  ⊥-elim (coherent (sem-sound T) ti[] to[])

disc-set->semantics : (T S : SessionType) -> Semantics (DiscSet T S)
closed (disc-set->semantics T S) = disc-set->closed T S
coherent (disc-set->semantics T S) = disc-set->coherent T S

disc-set-subset : ∀{T S} -> DiscSet T S ⊆ ⟦ T ⟧
disc-set-subset (inc tφ _ _) = tφ
disc-set-subset (exc _ _ _ tφ _ _) = tφ

disc-set-disjoint :
  ∀{T S φ} ->
  φ ∈ DiscSet T S ->
  ¬ S HasTrace φ ->
  ∃[ ψ ] ∃[ x ] (φ ≡ ψ ∷ʳ O x × S HasTrace ψ)
disc-set-disjoint (inc _ sφ _) nsφ = ⊥-elim (nsφ sφ)
disc-set-disjoint (exc eq _ sψ _ _ _) nsφ = _ , _ , eq , sψ

-- --| BEGIN MAXIMAL TRACES |--

diverge-forward-input :
  ∀{f g x φ} -> DivergeForward (inp f) (inp g) (I x ∷ φ)
             -> DivergeForward (f x .force) (g x .force) φ
diverge-forward-input div pre (_ , tdef , tr) (_ , sdef , sr) = div (some pre) (_ , tdef , step inp tr) (_ , sdef , step inp sr)

diverge-forward-input' :
  ∀{f g x φ} -> DivergeForward (f x .force) (g x .force) φ
             -> DivergeForward (inp f) (inp g) (I x ∷ φ)
diverge-forward-input' div none (_ , _ , step () _) (_ , _ , _)
diverge-forward-input' div (some le) (_ , tdef , step inp tr) (_ , sdef , step inp sr) = div le (_ , tdef , tr) (_ , sdef , sr)

diverge-forward-output :
  ∀{f g x φ} -> DivergeForward (out f) (out g) (O x ∷ φ)
             -> DivergeForward (f x .force) (g x .force) φ
diverge-forward-output div pre (_ , tdef , tr) (_ , sdef , sr) =
  div (some pre)
      (_ , tdef , step (out (transitions+defined->defined tr tdef)) tr)
      (_ , sdef , step (out (transitions+defined->defined sr sdef)) sr)

-- the next lemma says that if T ↑ S and φ is the trace that
-- discriminates between them, then we have divergence along any
-- common prefix of φ shared by both T and S

diverge-forward->backward :
  ∀{T S φ ψ}
  (tφ  : T HasTrace φ)
  (nsφ : ¬ S HasTrace φ)
  (div : DivergeForward T S φ)
  (pre : ψ ⊑ φ)
  (tψ  : T HasTrace ψ)
  (sψ  : S HasTrace ψ) ->
  DivergeBackward tψ sψ
_↑_.trace (diverge-forward->backward tφ nsφ div pre tψ sψ none) = _
_↑_.with-trace (diverge-forward->backward tφ nsφ div pre tψ sψ none) = tφ
_↑_.without-trace (diverge-forward->backward tφ nsφ div pre tψ sψ none) = nsφ
_↑_.divergence (diverge-forward->backward tφ nsφ div pre tψ sψ none) = div
diverge-forward->backward (_ , tdef , step inp tr) nsφ div (some pre) (_ , tdef' , step (inp {f}) tr') (_ , sdef , step (inp {g}) sr) (some pre') =
  diverge-forward->backward (_ , tdef , tr) (contraposition inp-has-trace nsφ) (diverge-forward-input {f} {g} div) pre (_ , tdef' , tr') (_ , sdef , sr) pre'
diverge-forward->backward (_ , tdef , step (out _) tr) nsφ div (some pre) (_ , tdef' , step (out {f} _) tr') (_ , sdef , step (out {g} _) sr) (some pre') =
  diverge-forward->backward (_ , tdef , tr) (contraposition out-has-trace nsφ) (diverge-forward-output {f} {g} div) pre (_ , tdef' , tr') (_ , sdef , sr) pre'

prefix-last-element : ∀{φ φ' ψ ψ' x y} -> φ ⊑ ψ -> φ ≡ φ' ++ O x ∷ [] -> ψ ≡ ψ' ∷ʳ O y -> ψ ≡ φ ⊎ φ ⊑ ψ'
prefix-last-element none e1 e2 = inj₂ none
prefix-last-element {φ' = []} {ψ' = []} (some pre) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (_ , e1') | (_ , e2') rewrite e1' | e2' = inj₁ refl
prefix-last-element {φ' = []} {ψ' = x ∷ ψ'} (some _) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (eq1 , e1') | (eq2 , e2') rewrite eq1 | eq2 | e1' | e2' = inj₂ (some none)
prefix-last-element {φ' = x ∷ φ'} {ψ' = []} (some pre) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (eq1 , e1') | (eq2 , e2') rewrite e1' | e2' = ⊥-elim (absurd-++-⊑ pre)
prefix-last-element {φ' = x ∷ φ'} {ψ' = x₁ ∷ ψ'} (some pre) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (eq1 , e1') | (eq2 , e2') rewrite eq1 | eq2 with prefix-last-element pre e1' e2'
... | inj₁ eq rewrite eq = inj₁ refl
... | inj₂ pre' = inj₂ (some pre')

disc-set-maximal-1 :
  ∀{T S φ} ->
  φ ∈ DiscSet T S ->
  ¬ S HasTrace φ ->
  φ ∈ Maximal (DiscSet T S)
disc-set-maximal-1 dsφ nsφ with disc-set-disjoint dsφ nsφ
... | _ , _ , refl , sψ =
  maximal dsφ λ le ds' ->
  let _ , _ , eq , sψ' = disc-set-disjoint ds' (contraposition (⊑-has-trace le) nsφ) in
  case prefix-last-element le refl eq of λ
  { (inj₁ refl) → refl
  ; (inj₂ le') → ⊥-elim (contraposition (⊑-has-trace le') nsφ sψ') }

has-trace-after : ∀{T φ ψ} (tφ : T HasTrace φ) -> after tφ HasTrace ψ -> T HasTrace (φ ++ ψ)
has-trace-after (_ , _ , refl) tφψ = tφψ
has-trace-after (_ , tdef , step inp tr) tφψ = inp-has-trace (has-trace-after (_ , tdef , tr) tφψ)
has-trace-after (_ , tdef , step (out _) tr) tφψ = out-has-trace (has-trace-after (_ , tdef , tr) tφψ)

has-no-trace-after : ∀{T φ ψ} (tφ : T HasTrace φ) -> ¬ after tφ HasTrace ψ -> ¬ T HasTrace (φ ++ ψ)
has-no-trace-after (_ , _ , refl) tφ/nψ = tφ/nψ
has-no-trace-after (_ , tdef , step inp tr) tφ/nψ = inp-has-no-trace (has-no-trace-after (_ , tdef , tr) tφ/nψ)
has-no-trace-after (_ , tdef , step (out _) tr) tφ/nψ = out-has-no-trace (has-no-trace-after (_ , tdef , tr) tφ/nψ)

append-diverge-backward :
  ∀{T S φ ψ}
  (tφ : T HasTrace φ)
  (sφ : S HasTrace φ)
  (tφ/ψ : after tφ HasTrace ψ)
  (sφ/ψ : after sφ HasTrace ψ)
  (div←φ : DivergeBackward tφ sφ)
  (divφ←ψ : DivergeBackward tφ/ψ sφ/ψ) ->
  DivergeBackward (has-trace-after tφ tφ/ψ) (has-trace-after sφ sφ/ψ)
append-diverge-backward (_ , tdef , refl) (_ , sdef , refl) tφ/ψ sφ/ψ div←φ divφ←ψ pre = divφ←ψ pre
append-diverge-backward (_ , tdef , step t tr) (_ , sdef , step s sr) tφ/ψ sφ/ψ div←φ divφ←ψ none = div←φ none
append-diverge-backward (_ , tdef , step inp tr) (_ , sdef , step inp sr) tφ/ψ sφ/ψ div←φ divφ←ψ (some pre) =
  append-diverge-backward (_ , tdef , tr) (_ , sdef , sr) tφ/ψ sφ/ψ (λ pre -> div←φ (some pre)) divφ←ψ pre
append-diverge-backward (_ , tdef , step (out _) tr) (_ , sdef , step (out _) sr) tφ/ψ sφ/ψ div←φ divφ←ψ (some pre) =
  append-diverge-backward (_ , tdef , tr) (_ , sdef , sr) tφ/ψ sφ/ψ (λ pre -> div←φ (some pre)) divφ←ψ pre

append-snoc : ∀{φ ψ : Trace}{α : Action} -> φ ++ (ψ ∷ʳ α) ≡ (φ ++ ψ) ∷ʳ α
append-snoc {[]} = refl
append-snoc {β ∷ φ} = cong (β ∷_) (append-snoc {φ})

completion :
  ∀{φ T S} ->
  T <: S ->
  φ ∈ DiscSet T S ->
  (∃[ ψ ] (φ ⊏ ψ × ψ ∈ Maximal (DiscSet T S))) ⊎ (φ ∈ Maximal (DiscSet T S) × ¬ S HasTrace φ)
completion {φ} sub (inc tφ sφ div←φ) with div←φ (⊑-refl _)
... | div rewrite ⊑-has-trace-after tφ | ⊑-has-trace-after sφ =
  let χ = _↑_.trace div in
  let tφ/χ = _↑_.with-trace div in
  let sφ/nχ = _↑_.without-trace div in
  let divφ→χ = _↑_.divergence div in
  let subφ = sub-after tφ sφ sub in
  let ψ , x , ψ⊑χ , tφ/ψ , sφ/ψ , tφ/ψx , sφ/nψx = sub-excluded subφ tφ/χ sφ/nχ in
  let tφψ = has-trace-after tφ tφ/ψ in
  let sφψ = has-trace-after sφ sφ/ψ in
  let tφψx = has-trace-after tφ tφ/ψx in
  let sφnψx = has-no-trace-after sφ sφ/nψx in
  let divφ←ψ = diverge-forward->backward tφ/χ sφ/nχ divφ→χ ψ⊑χ tφ/ψ sφ/ψ in
  let div←ψ  = append-diverge-backward tφ sφ tφ/ψ sφ/ψ div←φ divφ←ψ in
  let ds = exc {_} {_} {φ ++ (ψ ∷ʳ O x)} {φ ++ ψ} {x} (append-snoc {φ} {ψ} {O x}) tφψ sφψ tφψx sφnψx div←ψ in
  inj₁ (φ ++ (ψ ∷ʳ O x) , ⊏-++ , disc-set-maximal-1 ds sφnψx)
completion sub ds@(exc _ _ _ _ nsφ _) =
  inj₂ (disc-set-maximal-1 ds nsφ , nsφ)

disc-set-maximal-2 :
  ∀{T S φ} ->
  T <: S ->
  φ ∈ Maximal (DiscSet T S) ->
  ¬ S HasTrace φ
disc-set-maximal-2 sub (maximal dφ F) sφ with completion sub dφ
... | inj₁ (ψ , φ⊏ψ , maximal dψ _) = ⊏->≢ φ⊏ψ (sym (F (⊏->⊑ φ⊏ψ) dψ))
... | inj₂ (_ , nsφ) = nsφ sφ

--| END MAXIMAL TRACES |--

-- Sia R il session type determinato da disc-set T S quando T ↑
-- S. L'obiettivo è dimostrare che R |- T e ¬ R |- S
--
-- R |- T
--
-- Ogni riduzione di (R # T) può essere completata a (R' # T') in
-- cui Win R' e Defined T'
--
-- Siccome le tracce di R sono incluse in quelle di T, basta
-- dimostrare che ogni traccia di R può essere completata, cioè che
-- ogni traccia di disc-set T S è prefisso di una traccia completa
-- di disc-set T S.
--
-- ∀ φ ∈ R => ∃ ψ : φ ++ ψ ∈ Maximal R
--
-- ¬ R |- S
--
-- Dimostrare che ogni traccia completa di R non è una traccia di S.
--
-- Maximal R ∩ ⟦ S ⟧ ≡ ∅


{-# OPTIONS --allow-unsolved-metas #-}
module FindTermNode where

open import TermNode
open import OscarPrelude

record FindTermNode (A : Set) : Set
 where
  field
    findTermNode : A → TermNode → Maybe TermNode

open FindTermNode ⦃ … ⦄ public

open import TermCode
open import Term
open import Element

instance
  FindTermNodeTermCode : FindTermNode TermCode
  FindTermNode.findTermNode FindTermNodeTermCode termCode record { children = [] ; number = number₁ } = nothing
  FindTermNode.findTermNode FindTermNodeTermCode termCode 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } = ifYes fst₁ ≟ termCode then just snd₁ else findTermNode termCode record 𝔫 { children = children₁ }

  FindTermNodeTermCodes : FindTermNode (List TermCode)
  FindTermNode.findTermNode FindTermNodeTermCodes [] node = just node
  FindTermNode.findTermNode FindTermNodeTermCodes (x ∷ termCodes) node = join $ findTermNode termCodes <$> findTermNode x node

  FindTermNodeTerm : FindTermNode Term
  FindTermNode.findTermNode FindTermNodeTerm term node = findTermNode (encodeTerm term) node

-- This is starting to get difficult. We need Agda to know that the Term is encoded in the TermNode. Then we can drop the Maybe
getInterpretationOfTerm : Term → TermNode → Maybe Element
getInterpretationOfTerm τ node = ⟨_⟩ ∘ number <$> findTermNode (encodeTerm τ) node

open import Membership

FindTermNodeTermCode-ok : ∀ {𝔠 𝔫} → 𝔠 child∈ 𝔫 → IsJust (findTermNode 𝔠 𝔫)
FindTermNodeTermCode-ok {𝔠} {record { children = [] ; number = number₁ }} ()
--FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ = case (fst₁ ≟_) 𝔠 , graphAt {B = λ 𝑐 → Dec (fst₁ ≡ 𝑐)} (fst₁ ≟_) 𝔠 of λ { (yes x , snd₂) → {!!} ; (no x , snd₂) → {!!}} --λ { ((yes ===) , (inspect s1)) → {!!} ; ((no =n=) , inspect s2) → {!!} }
--FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ = case fst₁ ≟ 𝔠 of λ { (yes refl) → {!!} ; (no x) → {!!}}
FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ with fst₁ ≟ 𝔠
FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ | yes eq2 = tt
FindTermNodeTermCode-ok {.fst₁} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} (zero) | no neq = ⊥-elim (neq refl)
FindTermNodeTermCode-ok {𝔠} {𝔫@record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} (suc x₁) | no neq = FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} x₁

Justified : ∀ {a} {A : Set a} → (m : Maybe A) → IsJust m → ∃ λ x → m ≡ just x
Justified nothing ()
Justified (just x) x₁ = _ , refl

open import FunctionName
open import Vector

storeTerm-ok : ∀ τ 𝔫 𝔑 → IsJust (findTermNode τ (snd (runIdentity (runStateT (runStateT (storeTerm τ) 𝔑) 𝔫))))
storeTerm-ok (variable 𝑥) 𝔫 𝔑 with variable 𝑥 child∈? 𝔫
storeTerm-ok (variable 𝑥) 𝔫 𝔑 | no x with TermCode.variable 𝑥 ≟ variable 𝑥
storeTerm-ok (variable 𝑥) 𝔫 𝔑 | no x | yes _ = tt
storeTerm-ok (variable 𝑥) 𝔫 𝔑 | no x | no variable𝑥≢variable𝑥 = ⊥-elim (variable𝑥≢variable𝑥 refl)
--storeTerm-ok (variable 𝑥) 𝔫 𝔑 | yes vx∈𝔫 rewrite setGet-ok 𝔫 vx∈𝔫 = {!𝔫!}
storeTerm-ok (variable 𝑥) record { children = [] ; number = number₁ } 𝔑 | yes ()
--storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 rewrite setGet-ok 𝔫 vx∈𝔫 = {!!}
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 rewrite setGet-ok 𝔫 vx∈𝔫 with fst₁ ≟ variable 𝑥
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | yes eq = tt
--… | no neq = case vx∈𝔫 of λ { (here .(map fst children₁)) → ⊥-elim (neq refl)  ; (there .fst₁ asdf) → case graphAt FindTermNodeTermCode-ok asdf of λ { (ingraph sss) → {!!} } } -- storeTerm-ok x {!record 𝔫 { children = children₁ }!} 𝔑 -- x record 𝔫 { children = children₁ } 𝔑
--… | no neq = case vx∈𝔫 of λ { (here .(map fst children₁)) → ⊥-elim (neq refl)  ; (there .fst₁ asdf) → case inspect $ FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} asdf of λ { (.(FindTermNodeTermCode-ok asdf) , ingraph refl) → {!!}} } -- storeTerm-ok x {!record 𝔫 { children = children₁ }!} 𝔑 -- x record 𝔫 { children = children₁ } 𝔑
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq with vx∈𝔫
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq | zero = ⊥-elim (neq refl)
--storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq | there dfdsf fdsdfs with FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} fdsdfs | graphAt (FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }}) fdsdfs
--… | frfrrf | ingraph tttttt = transport _ (snd $ Justified (FindTermNode.findTermNode FindTermNodeTermCode (variable 𝑥) (record { children = children₁ ; number = number₁ })) (FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} fdsdfs)) _
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq | suc fdsdfs rewrite (snd $ Justified (FindTermNode.findTermNode FindTermNodeTermCode (variable 𝑥) (record { children = children₁ ; number = number₁ })) (FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} fdsdfs)) = tt
storeTerm-ok (function 𝑥 𝑎) 𝔫 𝔑 with (function 𝑥 (arity 𝑎)) child∈? 𝔫
storeTerm-ok (function 𝑥 ⟨ ⟨ [] ⟩ ⟩) 𝔫 𝔑 | no x with Eq._==_ EqFunctionName ⟨ name 𝑥 ⟩ ⟨ name 𝑥 ⟩
storeTerm-ok (function 𝑥 ⟨ ⟨ [] ⟩ ⟩) 𝔫 𝔑 | no x | (yes refl) = tt
… | no neq = ⊥-elim (neq refl)
--storeTerm-ok τ₀@(function 𝑓 ⟨ τ₁ ∷ τ₂s ⟩) 𝔫 𝔑 | no 𝔠₁∉𝔫 = {!τ₁!}
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₁∉𝔫 with variable 𝑥 child∈? 𝔫
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) with 𝑓₀ ≟ 𝑓₀
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | yes refl with TermCode.variable 𝑥 ≟ variable 𝑥
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | yes refl | yes eq = tt
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | yes refl | no neq = ⊥-elim (neq refl)
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | no neq = ⊥-elim (neq refl)
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) with 𝑓₀ ≟ 𝑓₀
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | yes refl with TermCode.variable 𝑥₁ ≟ variable 𝑥₁
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | yes refl | yes 𝔠₁≡𝔠₁ = tt
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | yes refl | no 𝔠₁≢𝔠₁ = ⊥-elim (𝔠₁≢𝔠₁ refl)
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | no 𝑓₀≢𝑓₀ = ⊥-elim (𝑓₀≢𝑓₀ refl) -- rewrite setGet-ok 𝔫 𝔠₁∈𝔫
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ τ₂ ∷ τ₃s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₀∉𝔫 with variable 𝑥₁ child∈? 𝔫
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ τ₂ ∷ τ₃s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₀∉𝔫 | yes 𝔠₁∈𝔫 = {!!}
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ τ₂ ∷ τ₃s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₀∉𝔫 | no 𝔠₁∉𝔫 = {!!}
storeTerm-ok τ₀@(function 𝑓₀ ⟨ ⟨ function 𝑓₁ τ₁s ∷ τ₂s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₁∉𝔫 = {!!}
storeTerm-ok (function 𝑥 x₁) 𝔫 𝔑 | yes x = {!!}

mutual

  storeTermVerifiably' : (τ : Term) → StateT Nat (StateT (Σ TermNode λ n → IsJust (findTermNode τ n)) Identity) ⊤
  storeTermVerifiably' (variable x) = {!!}
  storeTermVerifiably' (function x x₁) = {!!}

  storeTermVerifiably : Term → StateT Nat (StateT TermNode Identity) ⊤
  storeTermVerifiably τ@(variable _) = storeTermCodes' (encodeTerm τ)
  storeTermVerifiably τ@(function _ τs) = storeTermCodes' (encodeTerm τ) ~| storeTermsVerifiably τs

  storeTermsVerifiably : Terms → StateT Nat (StateT TermNode Identity) ⊤
  storeTermsVerifiably ⟨ ⟨ [] ⟩ ⟩ = return tt
  storeTermsVerifiably ⟨ ⟨ τ ∷ τs ⟩ ⟩ = storeTermVerifiably τ ~| storeTermsVerifiably ⟨ ⟨ τs ⟩ ⟩ ~| return tt


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Conversion {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.RedSteps
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance

open import Tools.Embedding
open import Tools.Product
import Tools.PropositionalEquality as PE

-- Conversion of syntactic reduction closures.
convRed:*: : ∀ {t u A B Γ} → Γ ⊢ t :⇒*: u ∷ A → Γ ⊢ A ≡ B → Γ ⊢ t :⇒*: u ∷ B
convRed:*: [ ⊢t , ⊢u , d ] A≡B = [ conv ⊢t  A≡B , conv ⊢u  A≡B , conv* d  A≡B ]

mutual
  -- Helper function for conversion of terms converting from left to right.
  convTermT₁ : ∀ {l l′ Γ A B t} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
             → ShapeView Γ l l′ A B [A] [B]
             → Γ ⊩⟨ l ⟩  A ≡ B / [A]
             → Γ ⊩⟨ l ⟩  t ∷ A / [A]
             → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
  convTermT₁ (ℕᵥ D D′) A≡B (ιx (ℕₜ n d n≡n prop)) = ιx (ℕₜ n d n≡n prop)
  convTermT₁ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
             (ιx (neₜ k d (neNfₜ neK₂ ⊢k k≡k))) =
    let K≡K₁ = PE.subst (λ x → _ ⊢ _ ≡ x)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (≅-eq (~-to-≅ K≡M))
    in ιx (neₜ k (convRed:*: d K≡K₁)
            (neNfₜ neK₂ (conv ⊢k K≡K₁) (~-conv k≡k K≡K₁)))
  convTermT₁ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
             (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
             (Πₜ f d funcF f≡f [f] [f]₁) =
    let ΠF₁G₁≡ΠF′G′   = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        F₁≡F′ , G₁≡G′ = Π-PE-injectivity ΠF₁G₁≡ΠF′G′
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x) (PE.sym ΠF₁G₁≡ΠF′G′)
                             (≅-eq A≡B)
    in  Πₜ f (convRed:*: d ΠFG≡ΠF₁G₁) funcF (≅-conv f≡f ΠFG≡ΠF₁G₁)
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                           ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                  [a]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                  [b]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [b]
                  [a≡b]₁ = convEqTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a≡b]
                  [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                    (PE.sym G₁≡G′))
                                           ([G] [ρ] ⊢Δ [a]₁)
                                           ([G≡G′] [ρ] ⊢Δ [a]₁)
              in  convEqTerm₁ ([G] [ρ] ⊢Δ [a]₁) ([G]₁ [ρ] ⊢Δ [a]) [G≡G₁]
                              ([f] [ρ] ⊢Δ [a]₁ [b]₁ [a≡b]₁))
          (λ {ρ} [ρ] ⊢Δ [a] →
             let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                          ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                 [a]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                 [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                   (PE.sym G₁≡G′))
                                          ([G] [ρ] ⊢Δ [a]₁)
                                          ([G≡G′] [ρ] ⊢Δ [a]₁)
             in  convTerm₁ ([G] [ρ] ⊢Δ [a]₁) ([G]₁ [ρ] ⊢Δ [a]) [G≡G₁] ([f]₁ [ρ] ⊢Δ [a]₁))
  convTermT₁ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t = t
  convTermT₁ (emb⁰¹ PE.refl x) (ιx A≡B) (ιx t) = convTermT₁ x A≡B t
  convTermT₁ (emb¹⁰ PE.refl x) A≡B t = ιx (convTermT₁ x A≡B t)

  -- Helper function for conversion of terms converting from right to left.
  convTermT₂ : ∀ {l l′ Γ A B t} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
           → ShapeView Γ l l′ A B [A] [B]
           → Γ ⊩⟨ l ⟩  A ≡ B / [A]
           → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
           → Γ ⊩⟨ l ⟩  t ∷ A / [A]
  convTermT₂ (ℕᵥ D D′) A≡B (ιx (ℕₜ n d n≡n prop)) = ιx (ℕₜ n d n≡n prop)
  convTermT₂ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
             (ιx (neₜ k d (neNfₜ neK₂ ⊢k k≡k))) =
    let K₁≡K = PE.subst (λ x → _ ⊢ x ≡ _)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (sym (≅-eq (~-to-≅ K≡M)))
    in ιx (neₜ k (convRed:*: d K₁≡K)
            (neNfₜ neK₂ (conv ⊢k K₁≡K) (~-conv k≡k K₁≡K)))
  convTermT₂ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
             (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
             (Πₜ f d funcF f≡f [f] [f]₁) =
    let ΠF₁G₁≡ΠF′G′   = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        F₁≡F′ , G₁≡G′ = Π-PE-injectivity ΠF₁G₁≡ΠF′G′
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x)
                             (PE.sym ΠF₁G₁≡ΠF′G′) (≅-eq A≡B)
    in  Πₜ f (convRed:*: d (sym ΠFG≡ΠF₁G₁)) funcF (≅-conv f≡f (sym ΠFG≡ΠF₁G₁))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                           ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                  [a]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                  [b]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [b]
                  [a≡b]₁ = convEqTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a≡b]
                  [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                    (PE.sym G₁≡G′))
                                           ([G] [ρ] ⊢Δ [a])
                                           ([G≡G′] [ρ] ⊢Δ [a])
              in  convEqTerm₂ ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                              [G≡G₁] ([f] [ρ] ⊢Δ [a]₁ [b]₁ [a≡b]₁))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                           ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                  [a]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                  [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                    (PE.sym G₁≡G′))
                                           ([G] [ρ] ⊢Δ [a])
                                           ([G≡G′] [ρ] ⊢Δ [a])
              in  convTerm₂ ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                            [G≡G₁] ([f]₁ [ρ] ⊢Δ [a]₁))
  convTermT₂ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t = t
  convTermT₂ (emb⁰¹ PE.refl x) (ιx A≡B) t = ιx (convTermT₂ x A≡B t)
  convTermT₂ (emb¹⁰ PE.refl x) A≡B (ιx t) = convTermT₂ x A≡B t

  -- Conversion of terms converting from left to right.
  convTerm₁ : ∀ {Γ A B t l l′} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
            → Γ ⊩⟨ l ⟩  A ≡ B / [A]
            → Γ ⊩⟨ l ⟩  t ∷ A / [A]
            → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
  convTerm₁ [A] [B] A≡B t = convTermT₁ (goodCases [A] [B] A≡B) A≡B t

  -- Conversion of terms converting from right to left.
  convTerm₂ : ∀ {Γ A B t l l′} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
          → Γ ⊩⟨ l ⟩  A ≡ B / [A]
          → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
          → Γ ⊩⟨ l ⟩  t ∷ A / [A]
  convTerm₂ [A] [B] A≡B t = convTermT₂ (goodCases [A] [B] A≡B) A≡B t

  -- Conversion of terms converting from right to left
  -- with some propsitionally equal types.
  convTerm₂′ : ∀ {Γ A B B′ t l l′} → B PE.≡ B′
          → ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
          → Γ ⊩⟨ l ⟩  A ≡ B′ / [A]
          → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
          → Γ ⊩⟨ l ⟩  t ∷ A / [A]
  convTerm₂′ PE.refl [A] [B] A≡B t = convTerm₂ [A] [B] A≡B t

  -- Helper function for conversion of term equality converting from left to right.
  convEqTermT₁ : ∀ {l l′ Γ A B t u} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
               → ShapeView Γ l l′ A B [A] [B]
               → Γ ⊩⟨ l ⟩  A ≡ B / [A]
               → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
               → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
  convEqTermT₁ (ℕᵥ D D′) A≡B (ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)) = ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)
  convEqTermT₁ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
               (ιx (neₜ₌ k m d d′ (neNfₜ₌ neK₂ neM₁ k≡m))) =
    let K≡K₁ = PE.subst (λ x → _ ⊢ _ ≡ x)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (≅-eq (~-to-≅ K≡M))
    in ιx (neₜ₌ k m (convRed:*: d K≡K₁)
                 (convRed:*: d′ K≡K₁)
                 (neNfₜ₌ neK₂ neM₁ (~-conv k≡m K≡K₁)))
  convEqTermT₁ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                           (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
               (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
               (Πₜ₌ f g d d′ funcF funcG t≡u [t] [u] [t≡u]) =
    let [A] = Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext
        [B] = Πᵣ′ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁
        [A≡B] = Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]
        ΠF₁G₁≡ΠF′G′ = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x)
                             (PE.sym ΠF₁G₁≡ΠF′G′) (≅-eq A≡B)
    in  Πₜ₌ f g (convRed:*: d ΠFG≡ΠF₁G₁) (convRed:*: d′ ΠFG≡ΠF₁G₁)
            funcF funcG (≅-conv t≡u ΠFG≡ΠF₁G₁)
            (convTerm₁ [A] [B] [A≡B] [t]) (convTerm₁ [A] [B] [A≡B] [u])
            (λ {ρ} [ρ] ⊢Δ [a] →
               let F₁≡F′ , G₁≡G′ = Π-PE-injectivity (whrDet* (red D₁ , Πₙ) (D′ , Πₙ))
                   [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                            ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                   [a]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                   [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                     (PE.sym G₁≡G′))
                                            ([G] [ρ] ⊢Δ [a]₁)
                                            ([G≡G′] [ρ] ⊢Δ [a]₁)
               in  convEqTerm₁ ([G] [ρ] ⊢Δ [a]₁) ([G]₁ [ρ] ⊢Δ [a])
                               [G≡G₁] ([t≡u] [ρ] ⊢Δ [a]₁))
  convEqTermT₁ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t≡u = t≡u
  convEqTermT₁ (emb⁰¹ PE.refl x) (ιx A≡B) (ιx t≡u) = convEqTermT₁ x A≡B t≡u
  convEqTermT₁ (emb¹⁰ PE.refl x) A≡B t≡u = ιx (convEqTermT₁ x A≡B t≡u)

  -- Helper function for conversion of term equality converting from right to left.
  convEqTermT₂ : ∀ {l l′ Γ A B t u} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
             → ShapeView Γ l l′ A B [A] [B]
             → Γ ⊩⟨ l ⟩  A ≡ B / [A]
             → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
             → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
  convEqTermT₂ (ℕᵥ D D′) A≡B (ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)) = ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)
  convEqTermT₂ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
               (ιx (neₜ₌ k m d d′ (neNfₜ₌ neK₂ neM₁ k≡m))) =
    let K₁≡K = PE.subst (λ x → _ ⊢ x ≡ _)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (sym (≅-eq (~-to-≅ K≡M)))
    in ιx (neₜ₌ k m (convRed:*: d K₁≡K) (convRed:*: d′ K₁≡K)
                 (neNfₜ₌ neK₂ neM₁ (~-conv k≡m K₁≡K)))
  convEqTermT₂ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                           (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
               (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
               (Πₜ₌ f g d d′ funcF funcG t≡u [t] [u] [t≡u]) =
    let [A] = Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext
        [B] = Πᵣ′ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁
        [A≡B] = Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]
        ΠF₁G₁≡ΠF′G′ = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x)
                             (PE.sym ΠF₁G₁≡ΠF′G′) (≅-eq A≡B)
    in  Πₜ₌ f g (convRed:*: d (sym ΠFG≡ΠF₁G₁)) (convRed:*: d′ (sym ΠFG≡ΠF₁G₁))
            funcF funcG (≅-conv t≡u (sym ΠFG≡ΠF₁G₁))
            (convTerm₂ [A] [B] [A≡B] [t]) (convTerm₂ [A] [B] [A≡B] [u])
            (λ {ρ} [ρ] ⊢Δ [a] →
               let F₁≡F′ , G₁≡G′ = Π-PE-injectivity (whrDet* (red D₁ , Πₙ) (D′ , Πₙ))
                   [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                            ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                   [a]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                   [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                     (PE.sym G₁≡G′))
                                            ([G] [ρ] ⊢Δ [a])
                                            ([G≡G′] [ρ] ⊢Δ [a])
               in  convEqTerm₂ ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                               [G≡G₁] ([t≡u] [ρ] ⊢Δ [a]₁))
  convEqTermT₂ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t≡u = t≡u
  convEqTermT₂ (emb⁰¹ PE.refl x) (ιx A≡B) t≡u = ιx (convEqTermT₂ x A≡B t≡u)
  convEqTermT₂ (emb¹⁰ PE.refl x) A≡B (ιx t≡u) = convEqTermT₂ x A≡B t≡u

  -- Conversion of term equality converting from left to right.
  convEqTerm₁ : ∀ {l l′ Γ A B t u} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
              → Γ ⊩⟨ l ⟩  A ≡ B / [A]
              → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
              → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
  convEqTerm₁ [A] [B] A≡B t≡u = convEqTermT₁ (goodCases [A] [B] A≡B) A≡B t≡u

  -- Conversion of term equality converting from right to left.
  convEqTerm₂ : ∀ {l l′ Γ A B t u} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
            → Γ ⊩⟨ l ⟩  A ≡ B / [A]
            → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
            → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
  convEqTerm₂ [A] [B] A≡B t≡u = convEqTermT₂ (goodCases [A] [B] A≡B) A≡B t≡u


module IndentedCheckingMessages where

import A.M

Foo : Set
Foo = Foo


module Esterel.Lang where

open import Esterel.Environment as Env
  using (Env)
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
  using (SeqVar)

open import Data.List
  using (List)
open import Data.Nat as Nat
  using (ℕ)

data s/l : Set where
  num : ℕ → s/l
  seq-ref : (x : SeqVar) → s/l
  shr-ref : (s : SharedVar) → s/l

data Expr : Set where
  plus : List s/l → Expr

data Ctrl : Set where
  GO : Ctrl
  WAIT : Ctrl

data Term : Set where
  nothin         : Term
  pause          : Term
  signl          : (S : Signal) → (p : Term) → Term
  present_∣⇒_∣⇒_ : (S : Signal) → (p : Term) → (q : Term) → Term
  emit           : (S : Signal) → Term
  _∥_            : (p : Term) → (q : Term) → Term
  loop           : (p : Term) → Term
  loopˢ          : (p : Term) → (q : Term) → Term
  _>>_           : (p : Term) → (q : Term) → Term
  suspend        : (p : Term) → (S : Signal) → Term
  trap           : (p : Term) → Term
  exit           : (n : ℕ) → Term
  shared_≔_in:_  : (s : SharedVar) → (e : Expr) → (p : Term) → Term
  _⇐_            : (s : SharedVar) → (e : Expr) → Term
  var_≔_in:_     : (x : SeqVar) → (e : Expr) → (p : Term) → Term
  _≔_            : (x : SeqVar) → (e : Expr) → Term
  if_∣⇒_∣⇒_      : (x : SeqVar) → (p : Term) → (q : Term) → Term
  ρ⟨_,_⟩·_        : (θ : Env) → (A : Ctrl) → (p : Term) → Term

infix  20 _⇐_
infix  20 _≔_
infix  17 if_∣⇒_∣⇒_
infixr 15 _>>_
infixr 13 _∥_
infix  11 present_∣⇒_∣⇒_
infix  10 shared_≔_in:_
infix  10 var_≔_in:_
infix   6 ρ⟨_,_⟩·_


------------------------------------------------------------------------
-- Simplification of parsers
------------------------------------------------------------------------

module TotalParserCombinators.Simplification where

open import Algebra
open import Codata.Musical.Notation
open import Data.List using (List; [])
import Data.List.Relation.Binary.BagAndSetEquality as BSEq
open import Data.Maybe using (Maybe); open Data.Maybe.Maybe
open import Data.Nat
open import Data.Product
open import Data.Vec.Recursive hiding ([])
open import Function
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; [_])
open import Relation.Binary.HeterogeneousEquality
  using (refl) renaming (_≅_ to _≅H_)

private
  module BSMonoid {k} {A : Set} =
    CommutativeMonoid (BSEq.commutativeMonoid k A)

open import TotalParserCombinators.Congruence
  hiding (return; fail; token) renaming (_∣_ to _∣′_)
import TotalParserCombinators.Congruence.Sound as C
import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Laws
open import TotalParserCombinators.Parser

------------------------------------------------------------------------
-- Simplification of a single "layer"

-- The result type used for single-layer simplification.

record Simplify₁ {Tok R xs} (p : Parser Tok R xs) : Set₁ where
  constructor result
  field
    {bag}   : List R
    parser  : Parser Tok R bag
    correct : p ≅P parser

-- The function simplify₁ simplifies the first "layer" of a parser,
-- down to the first occurrences of ♯_. The following simplifications
-- are applied in a bottom-up manner (in relevant cases also for
-- delayed arguments):
--
-- f <$> fail                  → fail
-- f <$> return x              → return (f x)
-- fail         ∣ p            → p
-- p            ∣ fail         → p
-- token >>= p₁ ∣ token >>= p₂ → token >>= λ t →
--                                 ♯ (♭? (p₁ t) ∣ ♭? (p₂ t))
-- fail     ⊛ p                → fail
-- p        ⊛ fail             → fail
-- return f ⊛ return x         → return (f x)
-- fail     >>= p              → fail
-- return x >>= p              → p x
-- nonempty fail               → fail
-- nonempty (return x)         → fail
-- cast eq p                   → p
--
-- Some ♯_'s may be removed, but care is taken to ensure that
-- non-simplified parsers in the result are delayed.

mutual

  simplify₁ : ∀ {Tok R xs} (p : Parser Tok R xs) → Simplify₁ p

  -- • return:

  simplify₁ (return x) = result _ (return x ∎)

  -- • fail:

  simplify₁ fail       = result _ (fail ∎)

  -- • token:

  simplify₁ token      = result _ (token ∎)

  -- • _<$>_:

  simplify₁ (f <$> p) with simplify₁ p
  ... | result fail       p≅∅  = result _ (
                                 f <$> p     ≅⟨ (λ _ → refl) <$> p≅∅ ⟩
                                 f <$> fail  ≅⟨ <$>.zero ⟩
                                 fail        ∎)
  ... | result (return x) p≅ε  = result _ (
                                 f <$> p         ≅⟨ (λ x → refl {x = f x}) <$> p≅ε ⟩
                                 f <$> return x  ≅⟨ <$>.homomorphism f ⟩
                                 return (f x)    ∎)
  ... | result p′         p≅p′ = result _ (
                                 f <$> p   ≅⟨ (λ _ → refl) <$> p≅p′ ⟩
                                 f <$> p′  ∎)

  -- • _∣_:

  simplify₁ (p₁ ∣ p₂) with simplify₁ p₁ | simplify₁ p₂
  ... | result fail          p₁≅∅
      | result p₂′           p₂≅p₂′ = result _ (
                                      p₁   ∣ p₂   ≅⟨ p₁≅∅ ∣′ p₂≅p₂′ ⟩
                                      fail ∣ p₂′  ≅⟨ AdditiveMonoid.left-identity p₂′ ⟩
                                      p₂′         ∎)
  ... | result p₁′           p₁≅p₁′
      | result fail          p₂≅∅   = result _ (
                                      p₁  ∣ p₂    ≅⟨ p₁≅p₁′ ∣′ p₂≅∅ ⟩
                                      p₁′ ∣ fail  ≅⟨ AdditiveMonoid.right-identity p₁′ ⟩
                                      p₁′         ∎)
  ... | result (p₁₁ >>= p₁₂) p₁≅…
      | result (p₂₁ >>= p₂₂) p₂≅…   = let h = helper p₁₁ refl p₁₂ p₂₁ refl p₂₂ in
                                      result _ (
                                      p₁          ∣ p₂           ≅⟨ p₁≅… ∣′ p₂≅… ⟩
                                      p₁₁ >>= p₁₂ ∣ p₂₁ >>= p₂₂  ≅⟨ Simplify₁.correct h ⟩
                                      Simplify₁.parser h         ∎)
    where
    helper : ∀ {Tok R₁ R₂ R xs₁ xs₁′ xs₂ xs₂′ f₁ f₂}
             (p₁₁ : ∞⟨ f₁ ⟩Parser Tok R₁ xs₁′)
             (eq₁ : xs₁′ ≡ flatten xs₁)
             (p₁₂ : (x : R₁) → ∞⟨ xs₁ ⟩Parser Tok R (apply f₁ x))
             (p₂₁ : ∞⟨ f₂ ⟩Parser Tok R₂ xs₂′)
             (eq₂ : xs₂′ ≡ flatten xs₂)
             (p₂₂ : (x : R₂) → ∞⟨ xs₂ ⟩Parser Tok R (apply f₂ x)) →
             Simplify₁ (P.subst (∞⟨ f₁ ⟩Parser Tok R₁) eq₁ p₁₁ >>= p₁₂ ∣
                        P.subst (∞⟨ f₂ ⟩Parser Tok R₂) eq₂ p₂₁ >>= p₂₂)
    helper p₁₁ eq₁ p₁₂ p₂₁ eq₂ p₂₂
      with ♭? p₁₁ | P.inspect ♭? p₁₁ | ♭? p₂₁ | P.inspect ♭? p₂₁
    helper {Tok} {f₁ = f₁} {f₂} p₁₁ eq₁ p₁₂ p₂₁ eq₂ p₂₂
      | token | [ eq₁′ ] | token | [ eq₂′ ] = result _ (
      cast₁ p₁₁ >>= p₁₂ ∣ cast₂ p₂₁ >>= p₂₂          ≅⟨ [ forced? p₁₁ - ○ - forced?′ p₁₂ - ○ ] Subst.correct∞ eq₁ p₁₁ >>=
                                                                                (λ t → ♭? (p₁₂ t) ∎) ∣′
                                                        [ forced? p₂₁ - ○ - forced?′ p₂₂ - ○ ] Subst.correct∞ eq₂ p₂₁ >>=
                                                                                (λ t → ♭? (p₂₂ t) ∎) ⟩
      ♭? p₁₁ >>= (♭? ∘ p₁₂) ∣ ♭? p₂₁ >>= (♭? ∘ p₂₂)  ≅⟨ [ ○ - ○ - ○ - ○ ]
                                                          P.subst (λ p → p ≅P token) (P.sym eq₁′) (token ∎) >>= (λ t → ♭? (p₁₂ t) ∎) ∣′
                                                        [ ○ - ○ - ○ - ○ ]
                                                          P.subst (λ p → p ≅P token) (P.sym eq₂′) (token ∎) >>= (λ t → ♭? (p₂₂ t) ∎) ⟩
      token >>= (♭? ∘ p₁₂) ∣ token >>= (♭? ∘ p₂₂)    ≅⟨ sym $ Monad.left-distributive token (♭? ∘ p₁₂) (♭? ∘ p₂₂) ⟩
      token >>= (λ t → ♭? (p₁₂ t) ∣ ♭? (p₂₂ t))      ≅⟨ [ ○ - ○ - ○ - ◌ ] token ∎ >>= (λ t → ♭? (p₁₂ t) ∣ ♭? (p₂₂ t) ∎) ⟩
      token >>= (λ t → ♯ (♭? (p₁₂ t) ∣ ♭? (p₂₂ t)))  ∎)
      where
      cast₁ = P.subst (∞⟨ f₁ ⟩Parser Tok Tok) eq₁
      cast₂ = P.subst (∞⟨ f₂ ⟩Parser Tok Tok) eq₂
    helper _ _ _ _ _ _ | _ | _ | _ | _ = result _ (_ ∎)

  simplify₁ (p₁ ∣ p₂) | result p₁′ p₁≅p₁′ | result p₂′ p₂≅p₂′ =
    result _ (
    p₁  ∣ p₂   ≅⟨ p₁≅p₁′ ∣′ p₂≅p₂′ ⟩
    p₁′ ∣ p₂′  ∎)

  -- • _⊛_:

  simplify₁ (p₁ ⊛ p₂) =
    helper _ _ p₁ p₂ (simplify₁∞ p₁) (simplify₁∞ p₂) refl refl
    where
    -- token ⊛ token is never type correct, but Agda's case-splitting
    -- machinery cannot see this, so instead of a with clause the
    -- following ugly machinery is used.

    cast₁ : ∀ {Tok R R₁ R₁′ xs xs′} {ys : Maybe (List R)} →
            (R≡  : R₁ ≡ R₁′) → xs ≅H xs′ →
            ∞⟨ ys ⟩Parser Tok R₁′ (flatten xs′) →
            ∞⟨ ys ⟩Parser Tok R₁  (flatten xs)
    cast₁ refl refl p = p

    helper : ∀ {Tok R₁ R₁′ R₂} fs xs {xs′}
               (p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs))
               (p₂ : ∞⟨ fs ⟩Parser Tok  R₁′      (flatten xs′)) →
             Simplify₁ (♭? p₁) → Simplify₁ (♭? p₂) →
             (R≡ : R₁ ≡ R₁′) (xs≅ : xs ≅H xs′) →
             Simplify₁ (p₁ ⊛ cast₁ R≡ xs≅ p₂)
    helper fs xs p₁ p₂ (result fail p₁≅∅) _ refl refl = result _ (
      p₁   ⊛ p₂     ≅⟨ [ xs - ○ - fs - ○ ] p₁≅∅ ⊛ (♭? p₂ ∎) ⟩
      fail ⊛ ♭? p₂  ≅⟨ ApplicativeFunctor.left-zero (♭? p₂) ⟩
      fail          ∎)
    helper fs xs p₁ p₂ _ (result fail p₂≅∅) refl refl = result _ (
      p₁    ⊛ p₂    ≅⟨ [ xs - ○ - fs - ○ ] ♭? p₁ ∎ ⊛ p₂≅∅ ⟩
      ♭? p₁ ⊛ fail  ≅⟨ ApplicativeFunctor.right-zero (♭? p₁) ⟩
      fail          ∎)
    helper fs xs p₁ p₂ (result (return f) p₁≅ε) (result (return x) p₂≅ε)
           refl refl = result _ (
      p₁       ⊛ p₂        ≅⟨ [ xs - ○ - fs - ○ ] p₁≅ε ⊛ p₂≅ε ⟩
      return f ⊛ return x  ≅⟨ ApplicativeFunctor.homomorphism f x ⟩
      return (f x)         ∎)
    helper fs xs p₁ p₂ p₁′ p₂′ R≡ xs≅ =
      helper′ fs xs p₁ p₂ p₁′ p₂′ R≡ xs≅
      where
      helper′ :
        ∀ {Tok R₁ R₁′ R₂} fs xs {xs′}
          (p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs))
          (p₂ : ∞⟨ fs ⟩Parser Tok  R₁′      (flatten xs′)) →
        Simplify₁ (♭? p₁) → Simplify₁ (♭? p₂) →
        (R≡ : R₁ ≡ R₁′) (xs≅ : xs ≅H xs′) →
        Simplify₁ (p₁ ⊛ cast₁ R≡ xs≅ p₂)
      helper′ nothing nothing p₁ p₂ _ _ refl refl = result _ (
        p₁ ⊛ p₂  ∎)
      helper′ (just fs) nothing p₁ p₂ _ (result p₂′ p₂≅p₂′) refl refl
        with BSEq.empty-unique $ I.cong $ C.sound $ sym p₂≅p₂′
      helper′ (just fs) nothing p₁ p₂ _ (result p₂′ p₂≅p₂′) refl refl
        | refl = result _ (
                 p₁ ⊛ p₂   ≅⟨ [ ◌ - ◌ - ○ - ○ ] ♭ p₁ ∎ ⊛ p₂≅p₂′ ⟩
                 p₁ ⊛ p₂′  ∎)
      helper′ nothing (just xs) p₁ p₂ (result p₁′ p₁≅p₁′) _ refl refl
        with BSEq.empty-unique $ I.cong $ C.sound $ sym p₁≅p₁′
      helper′ nothing (just xs) p₁ p₂ (result p₁′ p₁≅p₁′) _ refl refl
        | refl = result _ (
                 p₁  ⊛ p₂  ≅⟨ [ ○ - ○ - ◌ - ◌ ] p₁≅p₁′ ⊛ (♭ p₂ ∎) ⟩
                 p₁′ ⊛ p₂  ∎)
      helper′ (just fs) (just xs)
              p₁ p₂ (result p₁′ p₁≅p₁′) (result p₂′ p₂≅p₂′) refl refl =
        result _ (
        p₁  ⊛ p₂   ≅⟨ [ ○ - ○ - ○ - ○ ] p₁≅p₁′ ⊛ p₂≅p₂′ ⟩
        p₁′ ⊛ p₂′  ∎)

  -- • _>>=_:

  simplify₁ (_>>=_ {xs = xs} {f = f} p₁ p₂) with simplify₁∞ p₁
  ... | result fail       p₁≅∅ = result _ (
                                 p₁   >>= p₂         ≅⟨ [ f - ○ - xs - ○ ] p₁≅∅ >>= (λ x → ♭? (p₂ x) ∎) ⟩
                                 fail >>= (♭? ∘ p₂)  ≅⟨ Monad.left-zero (♭? ∘ p₂) ⟩
                                 fail                ∎)
  ... | result (return x) p₁≅ε with simplify₁∞ (p₂ x)
  ...   | result p₂x′ p₂x≅p₂x′ = result _ (
                                 p₁       >>= p₂         ≅⟨ [ f - ○ - xs - ○ ] p₁≅ε >>= (λ x → ♭? (p₂ x) ∎) ⟩
                                 return x >>= (♭? ∘ p₂)  ≅⟨ Monad.left-identity x (♭? ∘ p₂) ⟩
                                 ♭? (p₂ x)               ≅⟨ p₂x≅p₂x′ ⟩
                                 p₂x′                    ∎)
  simplify₁ (p₁ >>= p₂) | result p₁′ p₁≅p₁′
    with forced? p₁ | forced?′ p₂
  ... | nothing | just xs = result _ (
                            p₁ >>= p₂                           ≅⟨ [ ◌ - ◌ - ○ - ○ ] ♭ p₁ ∎ >>= (λ x → simplify₁-[]-correct (p₂ x)) ⟩
                            p₁ >>= (λ x → simplify₁-[] (p₂ x))  ∎)
  ... | just f  | just xs = result _ (
                            p₁  >>= p₂                          ≅⟨ [ ○ - ○ - ○ - ○ ] p₁≅p₁′ >>=
                                                                                (λ x → Simplify₁.correct (simplify₁ (p₂ x))) ⟩
                            p₁′ >>= (λ x → Simplify₁.parser $
                                             simplify₁ (p₂ x))  ∎)
  ... | nothing | nothing = result _ (
                            p₁ >>= p₂ ∎)
  ... | just f  | nothing = result _ (
                            p₁          >>= p₂        ≅⟨ [ ○ - ○ - ◌ - ○ ] p₁≅p₁′ >>= (λ x → ♭ (p₂ x) ∎) ⟩
                            p₁′         >>= (♭ ∘ p₂)  ≅⟨ [ ○ - ○ - ○ - ◌ ] sym (Subst.correct lemma) >>= (λ x → ♭ (p₂ x) ∎) ⟩
                            cast-[] p₁′ >>= p₂        ∎)
    where
    lemma   = BSEq.empty-unique $ I.cong $ C.sound $ sym p₁≅p₁′
    cast-[] = P.subst (Parser _ _) lemma

  -- • nonempty:

  simplify₁ (nonempty p) with simplify₁ p
  ... | result fail       p≅∅  = result _ (
                                 nonempty p     ≅⟨ nonempty p≅∅ ⟩
                                 nonempty fail  ≅⟨ Nonempty.zero ⟩
                                 fail           ∎)
  ... | result (return x) p≅ε  = result _ (
                                 nonempty p           ≅⟨ nonempty p≅ε ⟩
                                 nonempty (return x)  ≅⟨ Nonempty.nonempty-return ⟩
                                 fail                 ∎)
  ... | result p′         p≅p′ = result _ (
                                 nonempty p   ≅⟨ nonempty p≅p′ ⟩
                                 nonempty p′  ∎)

  -- • cast:

  simplify₁ (cast xs₁≈xs₂ p) with simplify₁ p
  ... | result p′ p≅p′ = result _ (
                         cast xs₁≈xs₂ p  ≅⟨ Cast.correct ⟩
                         p               ≅⟨ p≅p′ ⟩
                         p′              ∎)

  private

    -- Note that if an argument parser is delayed, then simplification
    -- is not applied recursively (because this could lead to
    -- non-termination).

    simplify₁∞ : ∀ {Tok R R′ xs} {m : Maybe R′}
                 (p : ∞⟨ m ⟩Parser Tok R xs) → Simplify₁ (♭? p)
    simplify₁∞ {m = nothing} p = result _ (♭ p ∎)
    simplify₁∞ {m = just _}  p = simplify₁ p

    simplify₁-[] : ∀ {Tok R} → Parser Tok R [] → Parser Tok R []
    simplify₁-[] p = P.subst (Parser _ _) ([]-lemma p) $
                       Simplify₁.parser $ simplify₁ p

    simplify₁-[]-correct : ∀ {Tok R} (p : Parser Tok R []) →
                           p ≅P simplify₁-[] p
    simplify₁-[]-correct p =
      p                               ≅⟨ Simplify₁.correct (simplify₁ p) ⟩
      Simplify₁.parser (simplify₁ p)  ≅⟨ sym $ Subst.correct ([]-lemma p) ⟩
      simplify₁-[] p                  ∎

    []-lemma : ∀ {Tok R} (p : Parser Tok R []) →
               Simplify₁.bag (simplify₁ p) ≡ []
    []-lemma p = BSEq.empty-unique $ I.cong $ C.sound $
                   sym $ Simplify₁.correct $ simplify₁ p

------------------------------------------------------------------------
-- Deep simplification

-- The function simplify simplifies the first layer, then it traverses
-- the result and simplifies the following layers, and so on. The
-- extra traversals have been implemented to satisfy Agda's
-- termination checker; they could perhaps be avoided.
--
-- Note that simplifications in an upper layer do not get to take
-- advantage of simplifications performed in lower layers. Consider
-- ♯ p ⊛ token, for instance. If p can be simplified to fail, then one
-- might believe that ♯ p ⊛ token is simplified to fail as well.
-- However, this is only the case if p actually /computes/ to fail.
--
-- If simplification of the upper layer were dependent on complete
-- simplification of lower layers, then simplification could fail to
-- terminate. This does not mean that one cannot propagate /any/
-- information from lower layers to upper layers, though: one could
-- for instance perform partial simplification of lower layers, up to
-- a certain depth, before an upper layer is simplified.

mutual

  simplify : ∀ {Tok R xs} (p : Parser Tok R xs) →
             Parser Tok R (Simplify₁.bag $ simplify₁ p)
  simplify p = simplify↓ (Simplify₁.parser (simplify₁ p))

  private

    simplify↓ : ∀ {Tok R xs} → Parser Tok R xs → Parser Tok R xs
    simplify↓ (return x)       = return x
    simplify↓ fail             = fail
    simplify↓ token            = token
    simplify↓ (p₁ ∣ p₂)        = simplify↓ p₁ ∣ simplify↓ p₂
    simplify↓ (f <$> p)        = f <$> simplify↓ p
    simplify↓ (nonempty p)     = nonempty (simplify↓ p)
    simplify↓ (cast xs₁≈xs₂ p) = cast xs₁≈xs₂ (simplify↓ p)
    simplify↓ (p₁ ⊛ p₂)        with forced? p₁ | forced? p₂
    ... | just xs | just fs =   simplify↓      p₁  ⊛   simplify↓      p₂
    ... | just xs | nothing =   simplify↓      p₁  ⊛ ♯ simplify    (♭ p₂)
    ... | nothing | just fs = ♯ simplify    (♭ p₁) ⊛   simplify↓      p₂
    ... | nothing | nothing = ♯ simplify-[] (♭ p₁) ⊛ ♯ simplify-[] (♭ p₂)
    simplify↓ (p₁ >>= p₂)      with forced? p₁ | forced?′ p₂
    ... | just f  | just xs =   simplify↓      p₁  >>= λ x →   simplify↓      (p₂ x)
    ... | just f  | nothing =   simplify↓      p₁  >>= λ x → ♯ simplify    (♭ (p₂ x))
    ... | nothing | just xs = ♯ simplify    (♭ p₁) >>= λ x →   simplify↓      (p₂ x)
    ... | nothing | nothing = ♯ simplify-[] (♭ p₁) >>= λ x → ♯ simplify-[] (♭ (p₂ x))

    simplify-[] : ∀ {Tok R} → Parser Tok R [] → Parser Tok R []
    simplify-[] p = simplify↓ (simplify₁-[] p)

-- The simplifier is correct.

mutual

  correct : ∀ {Tok R xs} (p : Parser Tok R xs) → simplify p ≅P p
  correct p =
    simplify↓ (Simplify₁.parser $ simplify₁ p)  ≅⟨ correct↓ (Simplify₁.parser $ simplify₁ p) ⟩
    Simplify₁.parser (simplify₁ p)              ≅⟨ sym $ Simplify₁.correct $ simplify₁ p ⟩
    p                                           ∎

  private

    correct↓ : ∀ {Tok R xs} (p : Parser Tok R xs) → simplify↓ p ≅P p
    correct↓ (return x)       = return x ∎
    correct↓ fail             = fail ∎
    correct↓ token            = token ∎
    correct↓ (p₁ ∣ p₂)        = correct↓ p₁ ∣′ correct↓ p₂
    correct↓ (f <$> p)        = (λ _ → refl) <$> correct↓ p
    correct↓ (nonempty p)     = nonempty (correct↓ p)
    correct↓ (cast xs₁≈xs₂ p) = cast (correct↓ p)
    correct↓ (p₁ ⊛ p₂)        with forced? p₁ | forced? p₂
    ... | just xs | just fs = [ just (○ , ○) - just (○ , ○) ]   correct↓      p₁  ⊛   correct↓      p₂
    ... | just xs | nothing = [ just (○ , ○) - nothing      ]   correct↓      p₁  ⊛ ♯ correct    (♭ p₂)
    ... | nothing | just fs = [ nothing      - just (○ , ○) ] ♯ correct    (♭ p₁) ⊛   correct↓      p₂
    ... | nothing | nothing = [ nothing      - nothing      ] ♯ correct-[] (♭ p₁) ⊛ ♯ correct-[] (♭ p₂)
    correct↓ (p₁ >>= p₂)      with forced? p₁ | forced?′ p₂
    ... | just f  | just xs = [ just (○ , ○) - just (○ , ○) ]   correct↓      p₁  >>= λ x →   correct↓      (p₂ x)
    ... | just f  | nothing = [ just (○ , ○) - nothing      ]   correct↓      p₁  >>= λ x → ♯ correct    (♭ (p₂ x))
    ... | nothing | just xs = [ nothing      - just (○ , ○) ] ♯ correct    (♭ p₁) >>= λ x →   correct↓      (p₂ x)
    ... | nothing | nothing = [ nothing      - nothing      ] ♯ correct-[] (♭ p₁) >>= λ x → ♯ correct-[] (♭ (p₂ x))

    correct-[] : ∀ {Tok R} (p : Parser Tok R []) → simplify-[] p ≅P p
    correct-[] p =
      simplify-[] p   ≅⟨ correct↓ (simplify₁-[] p) ⟩
      simplify₁-[] p  ≅⟨ sym $ simplify₁-[]-correct p ⟩
      p               ∎


open import Data.ByteString.Primitive using ( ByteStringStrict ;  ByteStringStrict² ; ByteStringLazy ; ByteStringLazy² )
open import Data.Bool using ( Bool )
open import Data.Char using ( Char )
open import Data.Natural using ( Natural )
open import Data.String using  ( String )

module Data.ByteString.UTF8.Primitive where

postulate
  fromStringStrict : String → ByteStringStrict
  toStringStrict : ByteStringStrict → String
  lengthStrict : ByteStringStrict → Natural
  spanStrict : (Char → Bool) → ByteStringStrict →  ByteStringStrict²
  breakStrict : (Char → Bool) → ByteStringStrict →  ByteStringStrict²

{-# IMPORT Data.ByteString.UTF8 #-}
{-# COMPILED fromStringStrict Data.ByteString.UTF8.fromString #-}
{-# COMPILED toStringStrict Data.ByteString.UTF8.toString #-}
{-# COMPILED lengthStrict fromIntegral . Data.ByteString.UTF8.length #-}
{-# COMPILED spanStrict Data.ByteString.UTF8.span #-}
{-# COMPILED breakStrict Data.ByteString.UTF8.break #-}

postulate
  fromStringLazy : String → ByteStringLazy
  toStringLazy : ByteStringLazy → String
  lengthLazy : ByteStringLazy → Natural
  spanLazy : (Char → Bool) → ByteStringLazy →  ByteStringLazy²
  breakLazy : (Char → Bool) → ByteStringLazy →  ByteStringLazy²

{-# IMPORT Data.ByteString.Lazy.UTF8 #-}
{-# COMPILED fromStringLazy Data.ByteString.Lazy.UTF8.fromString #-}
{-# COMPILED toStringLazy Data.ByteString.Lazy.UTF8.toString #-}
{-# COMPILED lengthLazy fromIntegral . Data.ByteString.Lazy.UTF8.length #-}
{-# COMPILED spanLazy Data.ByteString.Lazy.UTF8.span #-}
{-# COMPILED breakLazy Data.ByteString.Lazy.UTF8.break #-}


{-# OPTIONS --rewriting #-}

module Luau.TypeCheck where

open import Agda.Builtin.Equality using (_≡_)
open import FFI.Data.Maybe using (Maybe; just)
open import Luau.Syntax using (Expr; Stat; Block; BinaryOperator; yes; nil; addr; number; bool; string; val; var; var_∈_; _⟨_⟩∈_; function_is_end; _$_; block_is_end; binexp; local_←_; _∙_; done; return; name; +; -; *; /; <; >; ==; ~=; <=; >=; ··)
open import Luau.Var using (Var)
open import Luau.Addr using (Addr)
open import Luau.Heap using (Heap; Object; function_is_end) renaming (_[_] to _[_]ᴴ)
open import Luau.Type using (Type; nil; unknown; number; boolean; string; _⇒_; src; tgt)
open import Luau.VarCtxt using (VarCtxt; ∅; _⋒_; _↦_; _⊕_↦_; _⊝_) renaming (_[_] to _[_]ⱽ)
open import FFI.Data.Vector using (Vector)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import Properties.Product using (_×_; _,_)

orUnknown : Maybe Type → Type
orUnknown nothing = unknown
orUnknown (just T) = T

srcBinOp : BinaryOperator → Type
srcBinOp + = number
srcBinOp - = number
srcBinOp * = number
srcBinOp / = number
srcBinOp < = number
srcBinOp > = number
srcBinOp == = unknown
srcBinOp ~= = unknown
srcBinOp <= = number
srcBinOp >= = number
srcBinOp ·· = string

tgtBinOp : BinaryOperator → Type
tgtBinOp + = number
tgtBinOp - = number
tgtBinOp * = number
tgtBinOp / = number
tgtBinOp < = boolean
tgtBinOp > = boolean
tgtBinOp == = boolean
tgtBinOp ~= = boolean
tgtBinOp <= = boolean
tgtBinOp >= = boolean
tgtBinOp ·· = string

data _⊢ᴮ_∈_ : VarCtxt → Block yes → Type → Set
data _⊢ᴱ_∈_ : VarCtxt → Expr yes → Type → Set

data _⊢ᴮ_∈_ where

  done : ∀ {Γ} →

    ---------------
    Γ ⊢ᴮ done ∈ nil

  return : ∀ {M B T U Γ} →

    Γ ⊢ᴱ M ∈ T →
    Γ ⊢ᴮ B ∈ U →
    ---------------------
    Γ ⊢ᴮ return M ∙ B ∈ T

  local : ∀ {x M B T U V Γ} →

    Γ ⊢ᴱ M ∈ U →
    (Γ ⊕ x ↦ T) ⊢ᴮ B ∈ V →
    --------------------------------
    Γ ⊢ᴮ local var x ∈ T ← M ∙ B ∈ V

  function : ∀ {f x B C T U V W Γ} →

    (Γ ⊕ x ↦ T) ⊢ᴮ C ∈ V →
    (Γ ⊕ f ↦ (T ⇒ U)) ⊢ᴮ B ∈ W →
    -------------------------------------------------
    Γ ⊢ᴮ function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B ∈ W

data _⊢ᴱ_∈_ where

  nil : ∀ {Γ} →

    --------------------
    Γ ⊢ᴱ (val nil) ∈ nil

  var : ∀ {x T Γ} →

    T ≡ orUnknown(Γ [ x ]ⱽ) →
    ----------------
    Γ ⊢ᴱ (var x) ∈ T

  addr : ∀ {a Γ} T →

    -----------------
    Γ ⊢ᴱ val(addr a) ∈ T

  number : ∀ {n Γ} →

    ---------------------------
    Γ ⊢ᴱ val(number n) ∈ number

  bool : ∀ {b Γ} →

    --------------------------
    Γ ⊢ᴱ val(bool b) ∈ boolean

  string : ∀ {x Γ} →

    ---------------------------
    Γ ⊢ᴱ val(string x) ∈ string

  app : ∀ {M N T U Γ} →

    Γ ⊢ᴱ M ∈ T →
    Γ ⊢ᴱ N ∈ U →
    ----------------------
    Γ ⊢ᴱ (M $ N) ∈ (tgt T)

  function : ∀ {f x B T U V Γ} →

    (Γ ⊕ x ↦ T) ⊢ᴮ B ∈ V →
    -----------------------------------------------------
    Γ ⊢ᴱ (function f ⟨ var x ∈ T ⟩∈ U is B end) ∈ (T ⇒ U)

  block : ∀ {b B T U Γ} →

    Γ ⊢ᴮ B ∈ U →
    ------------------------------------
    Γ ⊢ᴱ (block var b ∈ T is B end) ∈ T

  binexp : ∀ {op Γ M N T U} →

    Γ ⊢ᴱ M ∈ T →
    Γ ⊢ᴱ N ∈ U →
    ----------------------------------
    Γ ⊢ᴱ (binexp M op N) ∈ tgtBinOp op

data ⊢ᴼ_ : Maybe(Object yes) → Set where

  nothing :

    ---------
    ⊢ᴼ nothing

  function : ∀ {f x T U V B} →

    (x ↦ T) ⊢ᴮ B ∈ V →
    ----------------------------------------------
    ⊢ᴼ (just function f ⟨ var x ∈ T ⟩∈ U is B end)

⊢ᴴ_ : Heap yes → Set
⊢ᴴ H = ∀ a {O} → (H [ a ]ᴴ ≡ O) → (⊢ᴼ O)

_⊢ᴴᴱ_▷_∈_ : VarCtxt → Heap yes → Expr yes → Type → Set
(Γ ⊢ᴴᴱ H ▷ M ∈ T) = (⊢ᴴ H) × (Γ ⊢ᴱ M ∈ T)

_⊢ᴴᴮ_▷_∈_ : VarCtxt → Heap yes → Block yes → Type → Set
(Γ ⊢ᴴᴮ H ▷ B ∈ T) = (⊢ᴴ H) × (Γ ⊢ᴮ B ∈ T)


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Concrete.Obligations
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Impl.Consensus.Types
open        EpochConfig
open import LibraBFT.Concrete.System
open import LibraBFT.Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms PeerCanSignForPK (λ {st} {part} {pk} → PeerCanSignForPK-stable {st} {part} {pk})

-- In this module, we assume that the implementation meets its
-- obligations, and use this assumption to prove that, in any reachable
-- state, the implementatioon enjoys one of the per-epoch correctness
-- conditions proved in Abstract.Properties.  It can be extended to other
-- properties later.
module LibraBFT.Concrete.Properties
         (impl-correct : ImplObligations)
         (st : SystemState)
         (r : ReachableSystemState st)
         (𝓔 : EpochConfig)
         where
    open        ImplObligations impl-correct
    open        WithSPS sps-cor
    open        PerState st r
    open        PerEpoch 𝓔

    open import LibraBFT.Abstract.Abstract     UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Abs
    open import LibraBFT.Concrete.Intermediate                   𝓔 (ConcreteVoteEvidence 𝓔)
    import      LibraBFT.Concrete.Obligations.VotesOnce          𝓔 (ConcreteVoteEvidence 𝓔) as VO-obl
    import      LibraBFT.Concrete.Obligations.PreferredRound     𝓔 (ConcreteVoteEvidence 𝓔) as PR-obl
    open import LibraBFT.Concrete.Properties.VotesOnce                                       as VO
    open import LibraBFT.Concrete.Properties.PreferredRound                                  as PR

    --------------------------------------------------------------------------------------------
    -- * A /ValidSysState/ is one in which both peer obligations are obeyed by honest peers * --
    --------------------------------------------------------------------------------------------

    record ValidSysState {ℓ}(𝓢 : IntermediateSystemState ℓ) : Set (ℓ+1 ℓ0 ℓ⊔ ℓ) where
      field
        vss-votes-once      : VO-obl.Type 𝓢
        vss-preferred-round : PR-obl.Type 𝓢
    open ValidSysState public

    -- TODO-2 : This should be provided as a module parameter here, and the
    -- proofs provided to instantiate it should be refactored into LibraBFT.Impl.
    -- However, see the TODO-3 in LibraBFT.Concrete.Intermediate, which suggests
    -- that those proofs may change, perhaps some parts of them will remain in
    -- Concrete and others should be in Impl, depending on how that TODO-3 is
    -- addressed.  There is not much point in doing said refactoring until we
    -- make progress on that question.

    validState : ValidSysState IntSystemState
    validState = record
      { vss-votes-once      = VO.Proof.voo sps-cor vo₁ vo₂ st r 𝓔
      ; vss-preferred-round = PR.Proof.prr sps-cor pr₁     st r 𝓔
      }

    open IntermediateSystemState IntSystemState

    open All-InSys-props InSys
    open WithAssumptions InSys

    -- We can now invoke the various abstract correctness properties.  Note that the arguments are
    -- expressed in Abstract terms (RecordChain, CommitRule).  Proving the corresponding properties
    -- for the actual implementation will involve proving that the implementation decides to commit
    -- only if it has evidence of the required RecordChains and CommitRules such that the records in
    -- the RecordChains are all "InSys" according to the implementation's notion thereof (defined in
    -- Concrete.System.IntSystemState).
    ConcCommitsDoNotConflict :
       ∀{q q'}
       → {rc  : RecordChain (Abs.Q q)}  → All-InSys rc
       → {rc' : RecordChain (Abs.Q q')} → All-InSys rc'
       → {b b' : Abs.Block}
       → CommitRule rc  b
       → CommitRule rc' b'
       → NonInjective-≡ Abs.bId ⊎ ((Abs.B b) ∈RC rc' ⊎ (Abs.B b') ∈RC rc)
    ConcCommitsDoNotConflict = CommitsDoNotConflict
           (VO-obl.proof IntSystemState (vss-votes-once validState))
           (PR-obl.proof IntSystemState (vss-preferred-round validState))

    module _ (∈QC⇒AllSent : Complete InSys) where

      ConcCommitsDoNotConflict' :
        ∀{q q'}{rc  : RecordChain (Abs.Q q)}{rc' : RecordChain (Abs.Q q')}{b b' : Abs.Block}
        → InSys (Abs.Q q) → InSys (Abs.Q q')
        → CommitRule rc  b
        → CommitRule rc' b'
        → NonInjective-≡ Abs.bId ⊎ ((Abs.B b) ∈RC rc' ⊎ (Abs.B b') ∈RC rc)
      ConcCommitsDoNotConflict' = CommitsDoNotConflict'
           (VO-obl.proof IntSystemState (vss-votes-once validState))
           (PR-obl.proof IntSystemState (vss-preferred-round validState))
           ∈QC⇒AllSent

      ConcCommitsDoNotConflict''
        : ∀{o o' q q'}
        → {rcf  : RecordChainFrom o  (Abs.Q q)}
        → {rcf' : RecordChainFrom o' (Abs.Q q')}
        → {b b' : Abs.Block}
        → InSys (Abs.Q q)
        → InSys (Abs.Q q')
        → CommitRuleFrom rcf  b
        → CommitRuleFrom rcf' b'
        → NonInjective-≡ Abs.bId ⊎ Σ (RecordChain (Abs.Q q')) ((Abs.B b)  ∈RC_)
                                 ⊎ Σ (RecordChain (Abs.Q q))  ((Abs.B b') ∈RC_)
      ConcCommitsDoNotConflict'' = CommitsDoNotConflict''
           (VO-obl.proof IntSystemState (vss-votes-once validState))
           (PR-obl.proof IntSystemState (vss-preferred-round validState))
           ∈QC⇒AllSent