{-# OPTIONS --safe #-}
module Generics.Reflection where

open import Function.Base
import Data.Unit    as ⊤
import Data.Product as Product
import Relation.Binary.PropositionalEquality as Eq
open import Data.Nat.Base hiding (_⊔_)
open import Data.List.Base   as List hiding (_++_)
import Data.Vec.Base as Vec
open import Data.String as S using (String; _++_)
open import Data.Bool.Base
open import Data.Maybe.Base using (Maybe; just; nothing; maybe)
open import Agda.Builtin.Reflection renaming ( primQNameEquality to _Name≈_
                                             )
open import Reflection.Abstraction using (unAbs)
open import Reflection.Argument    using (_⟨∷⟩_; _⟅∷⟆_)
open import Reflection.Term hiding (Telescope; var)
open import Relation.Nullary using (yes; no)

open import Category.Monad   as Monad

import Data.List.Categorical as List
import Data.Nat.Induction    as Nat
import Data.Char             as C

open import Reflection.TypeChecking.Monad.Instances using (tcMonad)
open import Reflection.Traversal hiding (_,_)

open import Generics.Prelude
open import Generics.Telescope
open import Generics.Desc renaming (_,_ to _,ω_)
import Generics.Accessibility as Accessibility
open import Generics.HasDesc
import Function.Identity.Categorical as Identity

open List.TraversableM ⦃...⦄
open Monad.RawMonad    ⦃...⦄

tErr : Term → TC ⊤
tErr = typeError ∘ [_] ∘ termErr

sErr : String → TC ⊤
sErr = typeError ∘ [_] ∘ strErr

open Actions

-- `liftN n f` maps numbers 0..(n-1) to themselves, and numbers
-- `n + k` to `n + (f k)`
liftN : ℕ → (ℕ → ℕ) → (ℕ → ℕ)
liftN zero    f k       = f k
liftN (suc n) f zero    = zero
liftN (suc n) f (suc k) = suc (liftN n f k)

mapVars : (ℕ → ℕ) → Term → Term
mapVars f = traverseTerm Identity.applicative actions (0 Reflection.Traversal., [])
  where
    actions : Actions Identity.applicative
    actions .onVar  ctx = liftN (ctx .Cxt.len) f
    actions .onMeta _   = id
    actions .onCon  _   = id
    actions .onDef  _   = id

prettyName : Name → String
prettyName f = maybe id "" (List.last (S.wordsBy ('.' C.≟_) (showName f)))

{-
When converting types to telescopes
variables are converted to context lookups:
Given K := [(oₒ : Oₒ) ⋯ (o₁ : O₁)] "forced" arguments (reversed)
      P := [A₁ ⋯ Aₙ] parameters
      I := [B₁ ⋯ Bₘ] indices,

we want to replace a term in context (Γ , O₁ , ⋯ , Oₒ , A₁ , ⋯ , Aₙ , B₁ , ⋯ , Bₘ , C₁ , ⋯ , Cₚ)
into a term in context               (Γ , Σ P I , C₁ , ⋯ , Cₚ)

 A term (var k) should be replaced by:
   - (var k)                                 if k < p

   - (proj₂ (proj₂ (var p)))                 if p         <= k < p + m      (inside I)
     (proj₂ (proj₁ (proj₂ (var p))))         ...
     (proj₂ (proj₁ (proj₁ (proj₂ (var p))))) ...

   - (proj₂ (proj₁ (var p))                  if p + m     <= k < p + m + n  (inside P)
   - (proj₂ (proj₁ (proj₁ (var p)))          ...
   - (proj₂ (proj₁ (proj₁ (proj₁ (var p))))  ...

   - K[k - (n + m + p)]                      if p + m + n <= k < p + m + n + o

   - var (k + 1 - n - m - o)                 if p + m + n + o <= k
-}

-- o: position of (PI : Σ P I) in the context
--    (i.e number of locally bound variables)
mkVar : (o k : ℕ) → Name → List (Arg Term) → Term
mkVar o k t args = def (quote proj₂) (aux o k ⟨∷⟩ args)
  where
    aux : (o k : ℕ) → Term
    aux o zero    = def t (var o [] ⟨∷⟩ [])
    aux o (suc k) = def (quote proj₁) (aux o k ⟨∷⟩ [])

mkPVar : (o k : ℕ) → List (Arg Term) → Term
mkPVar o k = mkVar o k (quote proj₁)

mkIVar : (o k : ℕ) → List (Arg Term) → Term
mkIVar o k = mkVar o k (quote proj₂)

-- TODO: telescopize should account for forced arguments

module _ (fargs : List Term) (nP nI : ℕ) where

    telescopize       : ℕ → Term → Term
    telescopizeSort   : ℕ → Sort → Sort
    telescopizeArgs   : ℕ → List (Arg Term) → List (Arg Term)
    telescopizeTel    : ℕ → List (String × Arg Type) → List (String × Arg Type)
    telescopizeClause : ℕ → List Clause → List Clause

    lookupForced : List Term → ℕ → ℕ → List (Arg Term) → Term
    lookupForced [] n o = var (suc (n + o))
    -- WARN: we ignore args, this should go alright
    --       ALSO, we might/should lift everything up, probably
    lookupForced (x ∷ xs) zero o = const (mapVars (λ n → n + suc o) x)
    lookupForced (x ∷ xs) (suc n) o = lookupForced xs n o

    telescopize o (var k args) =
      let args′ = telescopizeArgs o args in
           if k <ᵇ o           then var k args′
      else if k ∸ o <ᵇ nI      then mkIVar o (k ∸ o     ) args′
      else if k ∸ o <ᵇ nI + nP then mkPVar o (k ∸ o ∸ nI) args′
      else                          lookupForced fargs (k ∸ (nI + nP + o)) o args
  --  else                          var (k ∸ pred (nP + nI)) args′

    telescopize o (con c args) = con c (telescopizeArgs o args)
    telescopize o (def f args) = def f (telescopizeArgs o args)
    telescopize o (lam v (abs s t)) = lam v (abs s (telescopize (suc o) t))
    telescopize o (pat-lam cs args) = pat-lam (telescopizeClause o cs) (telescopizeArgs o args)
    telescopize o (Π[ s ∶ arg i a ] b) = Π[ s ∶ arg i (telescopize o a) ] telescopize (suc o) b
    telescopize o (sort s) = sort (telescopizeSort o s)
    telescopize o (lit l) = lit l
    telescopize o (meta x args) = meta x (telescopizeArgs o args)
    telescopize o unknown = unknown

    telescopizeSort o (set t)  = set  (telescopize o t)
    telescopizeSort o (prop t) = prop (telescopize o t)
    telescopizeSort o x = x

    telescopizeArgs o [] = []
    telescopizeArgs o (arg i x ∷ xs) = arg i (telescopize o x) ∷ telescopizeArgs o xs

    telescopizeTel o [] = []
    telescopizeTel o ((s , arg i t) ∷ xs) = (s , arg i (telescopize o t))
                                          ∷ telescopizeTel (suc o) xs

    telescopizeClause o [] = []
    telescopizeClause o (clause tel ps t ∷ xs)
      -- careful: telescopes bring (length tel) variables in scope
      = clause (telescopizeTel o tel) ps (telescopize (o + length tel) t)
      ∷ telescopizeClause o xs
    telescopizeClause o (absurd-clause tel ps ∷ xs) =
      absurd-clause (telescopizeTel o tel) ps ∷ telescopizeClause o xs

-- sanity check
private
  module TelescopizeTests where
    t : Term
    t = var 4 []

    -- locally bound variable
    t₁ : Term
    t₁ = telescopize [] 0 0 5 t

    t₁-ok : t₁ ≡ var 4 []
    t₁-ok = refl

    -- retrieving var in index telescope, 4 variable locally-bound
    t₂ : Term
    t₂ = telescopize [] 2 1 4 t

    t₂-ok : t₂ ≡ def (quote proj₂) (def (quote proj₂) (var 4 [] ⟨∷⟩ []) ⟨∷⟩ [])
    t₂-ok = refl

    -- retrieving var in parameter telescope, 2 variable locally-bound
    t₃ : Term
    t₃ = telescopize [] 1 2 2 t

    t₃-ok : t₃ ≡ def (quote proj₂) (def (quote proj₁) (var 2 [] ⟨∷⟩ []) ⟨∷⟩ [])
    t₃-ok = refl

    -- retrieving var outside parameter & index telescope
    t₄ : Term
    t₄ = telescopize [] 1 1 2 t

    t₄-ok : t₄ ≡ var 3 []
    t₄-ok = refl

    -- retrieving 4th var in index telescope
    t₅ : Term
    t₅ = telescopize [] 0 5 1 t

    t₅-ok : t₅ ≡ def (quote proj₂)
                   (def (quote proj₁)
                    (def (quote proj₁)
                     (def (quote proj₁) (def (quote proj₂) (var 1 [] ⟨∷⟩ []) ⟨∷⟩ []) ⟨∷⟩
                      [])
                     ⟨∷⟩ [])
                    ⟨∷⟩ [])
    t₅-ok = refl

-----------------------------
-- Deriving telescopes

getIndexTel : List Term → ℕ → Type → TC Term
getIndexTel fargs nP ty = aux ty 0 (con (quote ε) [])
  where aux : Type → ℕ → Term → TC Term
        aux (agda-sort s) n I = return I
        aux (Π[ s ∶ arg i a ] b) n I = do
          i′ ← quoteTC i >>= normalise
          aux b (suc n) (con (quote _⊢<_>_)
              (I ⟨∷⟩ con (quote Product._,_) (lit (string s) ⟨∷⟩ i′ ⟨∷⟩ [])
                 ⟨∷⟩ vLam "PI" (telescopize fargs nP n 0 a)
                 ⟨∷⟩ []))
        aux _ _ _ = typeError [ strErr "ill-formed type signature when deriving index telescope" ]

getTels : List Term → ℕ → Type → TC (Term × Term)
getTels fargs nP ty = aux nP ty 0 (quoteTerm (ε {A = ⊤}))
  where aux : ℕ → Type → ℕ → Term → TC (Term × Term)
        aux zero ty _ P = (P ,_) <$> getIndexTel fargs nP ty
        aux (suc nP) (Π[ s ∶ arg i a ] b) n P = do
          i′ ← quoteTC i >>= normalise
          aux nP b (suc n) (con (quote _⊢<_>_)
              (P ⟨∷⟩ con (quote Product._,_) (lit (string s) ⟨∷⟩ i′ ⟨∷⟩ [])
                 ⟨∷⟩ vLam "PI" (telescopize fargs 0 n 0 a)
                 ⟨∷⟩ []))
        aux _ _ _ _ = typeError [ strErr "ill-formed type signature when deriving parameter telescope" ]

-----------------------------
-- Deriving descriptions

-- we cannot unquote things in Setω directly
-- so we can't unquote Terms of type Telescope directly
-- instead we produce skeletons to ease code generation
data Skel : Set where
  Cκ   : Skel
  Cπ   : ArgInfo → Skel → Skel
  _C⊗_ : Skel → Skel → Skel

dropPis : ℕ → Type → Type
dropPis (suc n) (pi a (abs _ b)) = dropPis n b
dropPis _ t = t

module _ (fargs : List Term) (dt : Name) (nP : ℕ) where

  toIndex : ℕ → List (Arg Term) → Term
  toIndex nV xs = vLam "PV" $ foldl cons (quoteTerm ⊤.tt) (drop (nP + List.length fargs) xs)
    where cons : Term → Arg Term → Term
          cons x (arg _ y) =
            con (quote Product._,_) ( x
                          ⟨∷⟩ telescopize fargs nP nV 0 y
                          ⟨∷⟩ [])

  getRecDesc : ℕ → Type → TC (Maybe (Term × Skel))
  getRecDesc n (def nm args) = do
    if nm Name≈ dt
      then return (just (con (quote ConDesc.var) (toIndex n args ⟨∷⟩ []) , Cκ))
      else return nothing
  getRecDesc n (Π[ s ∶ arg i a ] b) = do
    getRecDesc (suc n) b >>= λ where
      (just (right , skright)) → do
        i′ ← quoteTC i >>= normalise
        return $ just ( con (quote ConDesc.π) (con (quote Product._,_) (lit (string s) ⟨∷⟩ i′ ⟨∷⟩ [])
                                          ⟨∷⟩ vLam "PV" (telescopize fargs nP n 0 a) ⟨∷⟩ right ⟨∷⟩ [])
                      , Cπ i skright
                      )
      nothing  → return nothing
  getRecDesc n ty = return nothing

  getDesc : (ℕ → ℕ) → ℕ → Type → TC (Term × Skel)
  getDesc f n (def nm args) =
    -- we're gonna assume nm == dt
    -- TODO: why does this work???
    --       surely args contain parameters
    return (con (quote ConDesc.var) (toIndex n (List.map (Arg.map (mapVars f)) args) ⟨∷⟩ []) , Cκ)
  getDesc f n (Π[ s ∶ arg i a ] b) =
    getRecDesc n (mapVars f a) >>= λ where
      -- (possibly higher order) inductive argument
      (just (left , skleft)) → do
        -- we cannot depend on inductive argument (for now)
        -- note: inductive arguments are relevant (for now)
        -- /!\ inductive arguments to not bind a variable, so we strengthen the term
        (right , skright) ← getDesc ((_- 1) ∘ f) n b
        return (con (quote ConDesc._⊗_) (left ⟨∷⟩ right ⟨∷⟩ []) , (skleft C⊗ skright))
      -- plain old argument
      nothing → do
        (right , skright) ← getDesc (liftN 1 f) (suc n) b
        i′    ← quoteTC i >>= normalise
        return ( con (quote ConDesc.π) (con (quote Product._,_) (lit (string s) ⟨∷⟩ i′ ⟨∷⟩ [])
                                    ⟨∷⟩ vLam "PV" (telescopize fargs nP n 0 a)
                                    ⟨∷⟩ right
                                    ⟨∷⟩ [])
               , Cπ i skright
               )
  getDesc _ _ _ = typeError [ strErr "ill-formed constructor type" ]

-- TODO: the reason we do this is that I've failed to make the PI arguments
--       implicit in the reflection code
record HD {P} {I : ExTele P} {ℓ} (A : Indexed P I ℓ) : Setω where
  constructor mkHD

  A′ : ⟦ P , I ⟧xtel → Set ℓ
  A′ = uncurry P I A

  field
    {n} : ℕ
    D : DataDesc P I n
    names : Vec String n
    constr : ∀ pi → ⟦ D ⟧Data A′ pi → A′ pi
    split  : ∀ pi → A′ pi → ⟦ D ⟧Data A′ pi
    split∘constr : ∀ pi → (x : ⟦ D ⟧Data A′ pi) → split pi (constr pi x) ≡ω x
    constr∘split : ∀ pi → (x : A′ pi          ) → constr pi (split pi x) ≡  x

  open Accessibility A D (λ {pi} → split pi)

  field wf : ∀ pi (x : A′ pi) → Acc x

badconvert : ∀ {P} {I : ExTele P} {ℓ} {A : Indexed P I ℓ}
           → HD {P} {I} {ℓ} A → HasDesc {P} {I} {ℓ} A
badconvert d = record
  { D            = HD.D d
  ; names        = HD.names d
  ; constr       = λ {PI} → HD.constr d PI
  ; split        = λ {PI} → HD.split d PI
  ; split∘constr = λ {PI} → HD.split∘constr d PI
  ; constr∘split = λ {PI} → HD.constr∘split d PI
  ; wf           = λ {PI} → HD.wf d PI
  }

withAI : ArgInfo → Term → Term
withAI i t with relevance i
... | relevant   = t
... | irrelevant = con (quote irrv) [ vArg t ]

patAI : ArgInfo → Pattern → Pattern
patAI i t with relevance i
... | relevant   = t
... | irrelevant = con (quote irrv) [ vArg t ]

deriveThings : (gargs : List (Arg Term)) (nP : ℕ)
               (qconstr qsplit qsplitconstr qconstrsplit qwf : Name)
               (cons : List (Name × Skel))
             → TC ⊤
deriveThings gargs nP qconstr qsplit qsplitconstr qconstrsplit  qwf cons = do
  let clauses = deriveDef cons
  -- TODO: use some n-ary magic
  let (constr_cls      , rest  ) = unzip clauses
  let (split_cls       , rest  ) = unzip rest
  let (splitconstr_cls , rest  ) = unzip rest
  let (constrsplit_cls , wf_cls) = unzip rest
  defineFun qconstr       constr_cls
  defineFun qsplit        split_cls
  defineFun qsplitconstr  splitconstr_cls
  defineFun qconstrsplit  constrsplit_cls
  defineFun qwf           wf_cls
  where
    deriveIndArg : Skel → ℕ × List (String × Arg Type) × List (Arg Pattern) × List (Arg Term)
    deriveIndArg Cκ = 0 , [] , [] , []
    deriveIndArg (Cπ ia C) =
      let (o , tel , pat , args) = deriveIndArg C
      in suc o
       , ("x" , vArg unknown) ∷ tel
       , arg ia (var o) ∷ pat
       , arg ia (var o []) ∷ args

    -- WARNING: intentionally wrong, never used when deriving descriptions
    deriveIndArg (A C⊗ B) = 0 , [] , [] , []

    deriveCon : Skel → ℕ × List (String × Arg Type) -- variable types
                         × Pattern            -- pattern for ⟦_⟧Data
                         × List (Arg Pattern) -- pattern for arguments of A′ cons
                         × List (Arg Term)    -- arguments for constructor
                         × Term               -- return value for split
                         × Term               -- body of wf
    deriveCon Cκ
      = 0 , [] -- we bind zero vars
      , con (quote Eq.refl) []
      , []
      , []
      , con (quote Eq.refl) []
      , def (quote ttω) []
    deriveCon (Cπ ia C) =
      let (o , vars , datapat , apat , cargs , sval , wfval) = deriveCon C
      in suc o
       , ("s" , arg ia unknown) ∷ vars -- TODO: unsure about ia here
       , con (quote Product._,_) (patAI ia (var o) ⟨∷⟩ datapat ⟨∷⟩ [])
       , arg ia (var o) ∷ apat
       , arg ia (var o []) ∷ cargs
       , con (quote Product._,_) (withAI ia (var o []) ⟨∷⟩ sval ⟨∷⟩ [])
       , wfval
    deriveCon (A C⊗ B) =
      let (ro , rtel , rpat , rargs)  = deriveIndArg A in
      let (o , vars , datapat , apat , cargs , sval , wfval) = deriveCon B
      in suc o
       , ("x" , vArg unknown) ∷ vars -- we only support visible relevant inductive args
       , con (quote Product._,_) (var o ⟨∷⟩ datapat ⟨∷⟩ [])
       , var o ⟨∷⟩ apat
       , var o [] ⟨∷⟩ cargs
       , con (quote Product._,_) (var o [] ⟨∷⟩ sval ⟨∷⟩ [])
       , def (quote _ω,ω_)
             (pat-lam [ clause rtel rpat
                          (def qwf (unknown  -- PI of inductive argument
                                     ⟨∷⟩ var (o + ro) rargs
                                     ⟨∷⟩ []))
                      ] []
             ⟨∷⟩ wfval ⟨∷⟩ []) -- TODOOOO
    deriveClause : Pattern → Term → Name × Skel
                 → Clause × Clause × Clause × Clause × Clause
    deriveClause kp kt (consname , shape) =
      let (o , vars , datapat , apat , cargs , sval , wfval) = deriveCon shape
      in clause (("pi" , vArg unknown) ∷ vars)
                (var o ⟨∷⟩ con (quote _,ω_) (kp ⟨∷⟩ datapat ⟨∷⟩ []) ⟨∷⟩ [])
                (con consname (nP ⋯⟅∷⟆ cargs)) -- TODO: maybe forced args go here
       , clause (("pi" , vArg unknown) ∷ vars)
                (var o ⟨∷⟩ con consname apat ⟨∷⟩ [])
                (con (quote _,ω_) (kt ⟨∷⟩ sval ⟨∷⟩ []))
       , clause (("pi" , vArg unknown) ∷ vars)
                (var o ⟨∷⟩ con (quote _,ω_) (kp ⟨∷⟩ datapat ⟨∷⟩ []) ⟨∷⟩ [])
                (def (quote reflω) [])
       , clause (("pi" , vArg unknown) ∷ vars)
                (var o ⟨∷⟩ con consname apat ⟨∷⟩ [])
                (con (quote Eq.refl) [])
       , clause (("pi" , vArg unknown) ∷ vars)
                (var o ⟨∷⟩ con consname apat ⟨∷⟩ [])
                (con (quote Accessibility.Acc.acc) (wfval ⟨∷⟩ []))

    deriveClauses : Pattern -- pattern for index of constructor
                  → Term    -- term for index constructor
                  → List (Name × Skel)
                  → List (Clause × Clause × Clause × Clause × Clause)
    deriveClauses _ _ [] = []
    deriveClauses kp kt (x ∷ xs)
      = deriveClause kp kt x
      ∷ deriveClauses (con (quote Fin.suc) (kp ⟨∷⟩ []))
                      (con (quote Fin.suc) (kt ⟨∷⟩ []))
                      xs

    deriveDef : List (Name × Skel) → List (Clause × Clause × Clause × Clause × Clause)
    deriveDef [] = [ cls , cls , cls , cls , cls ]
      where cls = absurd-clause (("PI" , hArg unknown) ∷ ("x" , vArg unknown) ∷ [])
                                (var 1 ⟨∷⟩ absurd 0 ⟨∷⟩ [] )
    deriveDef xs = deriveClauses (con (quote Fin.zero) [])
                                 (con (quote Fin.zero) [])
                                 xs

macro
  deriveDesc : Term → Term → TC ⊤
  deriveDesc t hole = do
    -- Arguments are used for enabling universe-polymorphic defintions
    -- these arguments should be prepended to every use of nm as a type
    def nm gargs ← return t
      where _ → typeError [ strErr "Expected name with arguments." ]

    let fargs = reverse (List.map Arg.unArg gargs)

    data-type nP cs ← getDefinition nm
      where _ → typeError [ strErr "Name given is not a datatype." ]

    let nCons = List.length cs
    let nArgs = List.length gargs

    names ← quoteTC (Vec.fromList (List.map prettyName cs))

    -- we get the type of the family, with the provided arguments removed
    ty ← getType nm >>= normalise <&> dropPis nArgs >>= normalise

    -- (nP - nArgs) is the amount of actual parameters we consider in our encoding
    -- the remaining Pi types are indices
    (P , I) ← getTels fargs (nP - nArgs) ty

    descs&skels ← forM cs λ cn → do
      -- get the type of current constructor, with explicit arguments and parameters stripped
      conTyp ← getType cn >>= normalise <&> dropPis nP
      (desc , skel) ← getDesc fargs nm (nP - nArgs) id 0 conTyp
      return $ (cn , skel) , desc

    let descs = List.map proj₂ descs&skels
    let skels = List.map proj₁ descs&skels

    let D = foldr (λ C D → con (quote DataDesc._∷_) (C ⟨∷⟩ D ⟨∷⟩ []))
                  (con (quote DataDesc.[]) [])
                  descs

    qconstr      ← freshName "constr"
    qsplit       ← freshName "split"
    qsplitconstr ← freshName "split∘constr"
    qconstrsplit ← freshName "constr∘split"
    qwf          ← freshName "wf"

    declareDef (vArg qconstr)
      (pi (vArg (def (quote ⟦_,_⟧xtel) (P ⟨∷⟩ I ⟨∷⟩ [])))
          (abs "PI" (pi (vArg unknown) (abs "x" unknown))))

    declareDef (vArg qsplit)
      (pi (vArg (def (quote ⟦_,_⟧xtel) (P ⟨∷⟩ I ⟨∷⟩ [])))
          (abs "PI" (pi (vArg unknown) (abs "x" unknown))))

    declareDef (vArg qconstrsplit)
      (pi (vArg (def (quote ⟦_,_⟧xtel) (P ⟨∷⟩ I ⟨∷⟩ [])))
          (abs "PI" (pi (vArg unknown) (abs "x" unknown))))

    declareDef (vArg qsplitconstr)
      (pi (vArg (def (quote ⟦_,_⟧xtel) (P ⟨∷⟩ I ⟨∷⟩ [])))
          (abs "PI" (pi (vArg unknown) (abs "x" unknown))))

    declareDef (vArg qwf)
      (pi (vArg (def (quote ⟦_,_⟧xtel) (P ⟨∷⟩ I ⟨∷⟩ [])))
          (abs "PI" (pi (vArg unknown) (abs "x" unknown))))

    deriveThings gargs (nP - nArgs) qconstr qsplit qsplitconstr qconstrsplit qwf skels

    unify hole (def (quote badconvert) ((con (quote mkHD)
      (   P                 -- P
      ⟅∷⟆ I                 -- I
      ⟅∷⟆ unknown           -- ℓ
      ⟅∷⟆ def nm gargs      -- A
      ⟅∷⟆ lit (nat nCons)   -- n
      ⟅∷⟆ D                 -- D
      ⟨∷⟩ names             -- names
      ⟨∷⟩ def qconstr      []
      ⟨∷⟩ def qsplit       []
      ⟨∷⟩ def qsplitconstr []
      ⟨∷⟩ def qconstrsplit []
      ⟨∷⟩ def qwf          []
      ⟨∷⟩ [])) ⟨∷⟩ []))


module DSession where

open import Data.Bool
open import Data.Fin
open import Data.Empty
open import Data.List
open import Data.List.All
open import Data.Maybe hiding (All)
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Data.Unit
open import Function using (_$_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Typing
open import Syntax
open import Global
open import Channel
open import Values

-- this is really just a Kleisli arrow
data Cont (G : SCtx) (φ : TCtx) (t : Type) : Type → Set where
  ident :
    (ina-G : Inactive G)
    → (unr-φ : All Unr φ)
    → Cont G φ t t

  bind : ∀ {φ₁ φ₂ G₁ G₂ t₂ t₃}
    → (ts : Split φ φ₁ φ₂)
    → (ss : SSplit G G₁ G₂)
    → (e₂ : Expr (t ∷ φ₁) t₂)
    → (ϱ₂ : VEnv G₁ φ₁)
    → (κ₂ : Cont G₂ φ₂ t₂ t₃)
    → Cont G φ t t₃

  subsume : ∀ {t₁ t₂}
    → (t≤t1 : SubT t t₁)
    → (κ : Cont G φ t₁ t₂)
    → Cont G φ t t₂

compose : ∀ {G G₁ G₂ φ φ₁ φ₂ t₁ t₂ t₃}
  → Split φ φ₁ φ₂
  → SSplit G G₁ G₂
  → Cont G₁ φ₁ t₁ t₂
  → Cont G₂ φ₂ t₂ t₃
  → Cont G φ t₁ t₃
compose ss ssp (ident ina-G unr-φ) (ident ina-G₁ unr-φ₁) =
  ident (ssplit-inactive ssp ina-G ina-G₁) (split-unr ss unr-φ unr-φ₁)
compose ss ssp (ident ina-G unr-φ) (bind ts ss₁ e₂ ϱ₂ κ₂) = bind {!!} {!!} e₂ ϱ₂ κ₂
compose ss ssp (ident ina-G unr-φ) (subsume t≤t1 κ₂)
  with inactive-left-ssplit ssp ina-G
... | refl
  = subsume t≤t1 {!!}
compose ss ssp (bind ts ss₁ e₂ ϱ₂ κ₁) (ident ina-G unr-φ) = {!!}
compose ss ssp (bind ts ss₁ e₂ ϱ₂ κ₁) (bind ts₁ ss₂ e₃ ϱ₃ κ₂) = {!!}
compose ss ssp (bind ts ss₁ e₂ ϱ₂ κ₁) (subsume t≤t1 κ₂) = {!!}
compose ss ssp (subsume t≤t1 κ₁) (ident ina-G unr-φ) = {!!}
compose ss ssp (subsume t≤t1 κ₁) (bind ts ss₁ e₂ ϱ₂ κ₂) = {!!}
compose ss ssp (subsume t≤t1 κ₁) (subsume t≤t2 κ₂) = {!!}

-- command is a monad
data Command (G : SCtx) (t : Type) : Set where

  Return : (v : Val G t)
    → Command G t

  Fork : ∀ {φ₁ φ₂ G₁ G₂}
    → (ss : SSplit G G₁ G₂)
    → (κ₁ : Cont G₁ φ₁ TUnit TUnit)
    → (κ₂ : Cont G₂ φ₂ TUnit t)
    → Command G t

  New : ∀ {φ}
    → (s : SType)
    → (κ : Cont G φ (TPair (TChan (SType.force s)) (TChan (SType.force (dual s)))) t)
    → Command G t

  Close : ∀ {φ G₁ G₂}
    → (ss : SSplit G G₁ G₂)
    → (v : Val G₁ (TChan send!))
    → (κ : Cont G₂ φ TUnit t)
    → Command G t

  Wait  : ∀ {φ G₁ G₂}
    → (ss : SSplit G G₁ G₂)
    → (v : Val G₁ (TChan send?))
    → (κ : Cont G₂ φ TUnit t)
    → Command G t

  Send : ∀ {φ G₁ G₂ G₁₁ G₁₂ tv s}
    → (ss : SSplit G G₁ G₂)
    → (ss-args : SSplit G₁ G₁₁ G₁₂)
    → (vch : Val G₁₁ (TChan (send tv s)))
    → (v : Val G₁₂ tv)
    → (κ : Cont G₂ φ (TChan (SType.force s)) t)
    → Command G t

  Recv : ∀ {φ G₁ G₂ tv s}
    → (ss : SSplit G G₁ G₂)
    → (vch : Val G₁ (TChan (recv tv s)))
    → (κ : Cont G₂ φ (TPair (TChan (SType.force s)) tv) t)
    → Command G t

  Select : ∀ {φ G₁ G₂ s₁ s₂}
    → (ss : SSplit G G₁ G₂)
    → (lab : Selector)
    → (vch : Val G₁ (TChan (sintern s₁ s₂)))
    → (κ : Cont G₂ φ (TChan (selection lab (SType.force s₁) (SType.force s₂))) t)
    → Command G t

  Branch : ∀ {φ G₁ G₂ s₁ s₂}
    → (ss : SSplit G G₁ G₂)
    → (vch : Val G₁ (TChan (sextern s₁ s₂)))
    → (dcont : (lab : Selector) → Cont G₂ φ (TChan (selection lab (SType.force s₁) (SType.force s₂))) t)
    → Command G t

  NSelect : ∀ {φ G₁ G₂ m alt}
    → (ss : SSplit G G₁ G₂)
    → (lab : Fin m)
    → (vch : Val G₁ (TChan (sintN m alt)))
    → (κ : Cont G₂ φ (TChan (SType.force (alt lab))) t)
    → Command G t

  NBranch : ∀ {φ G₁ G₂ m alt}
    → (ss : SSplit G G₁ G₂)
    → (vch : Val G₁ (TChan (sextN m alt)))
    → (dcont : (lab : Fin m) → Cont G₂ φ (TChan (SType.force (alt lab))) t)
    → Command G t

-- cont G = ∀ G' → G ≤ G' → SSplit G' Gval Gcont → Val Gval t →

data _≼_ G : SCtx → Set where
  ≼-rfl : G ≼ G
  ≼-ext : ∀ {G'} → G ≼ G' → G ≼ (nothing ∷ G')

{-
mbindf : ∀ {Gin G1in G2in G1out G2out t t'} → SSplit Gin G1in G2in
  → Command G1in G1out t
  → (∀ G2in' G1out' G2out' → G2in ≼ G2in' → G1out ≼ G1out' → G2out ≼ G2out'
    → Val G1out' t → Command G2in' G2out' t')
  → Command Gin G2out t'
mbindf = {!!}
-}

mbind : ∀ {G G₁ G₂ Φ t t'} → SSplit G G₁ G₂ → Command G₁ t → Cont G₂ Φ t t' → Command G t'
mbind ssp (Return v) (ident x x₁)
  with inactive-right-ssplit ssp x
... | refl
  = Return v
mbind ssp (Return v) (bind ts ss e₂ ϱ₂ cont) = {!!}
mbind ssp (Return v) (subsume t≤t1 cont) = {!!}
mbind ssp (Fork ss κ₁ κ₂) cont = Fork {!!} κ₁ {!!}
mbind ssp (New s κ) cont = {!!}
mbind ssp (Close ss v κ) cont = {!!}
mbind ssp (Wait ss v κ) cont = {!!}
mbind ssp (Send ss ss-args vch v κ) cont = {!!}
mbind ssp (Recv ss vch κ) cont = {!!}
mbind ssp (Select ss lab vch κ) cont = {!!}
mbind ssp (Branch ss vch dcont) cont = {!!}
mbind ssp (NSelect ss lab vch κ) cont = {!!}
mbind ssp (NBranch ss vch dcont) cont = {!!}


module HeapPropertiesDefs where
  open import Silica

  import Relation.Binary.PropositionalEquality as Eq
  import Context

  open import Data.List.Relation.Unary.All
  import Relation.Unary
  import Data.List.Properties
  import Data.List

  open import Data.Sum
  open import Data.Maybe

  open import Data.List.Membership.DecSetoid ≡-decSetoid
  open import Data.List.Relation.Unary.Any

  open import Data.Empty

  open TypeEnvContext

  --============= Consistency ==============
  -- Relates typing environments and object references to lists of all types of possible references.
  -- For now, this is ordered; perhaps that is too strong and I should use <Set> instead.

  data _⟷_ : Type → Type → Set where
    symCompat : ∀ {T₁ T₂ : Type}
                → T₁ ⟷ T₂
                ---------
                → T₂ ⟷ T₁

    unownedCompat :  ∀ {C C' : Id}
                    → ∀ {perm perm' : Perm}
                    → perm ≡ Unowned
                    → C ≡ C'
                    --------------------------------------------------------------
                    → contractType (tc C perm) ⟷ contractType (tc C' perm')

    sharedCompat : ∀ {t t' : Tc}
                   → Tc.perm t ≡ Shared
                   → Tc.perm t' ≡ Shared
                   → Tc.contractName t ≡ Tc.contractName t'
                   ----------------
                   → contractType t ⟷ contractType t'

    voidCompat : ----------------------
                 base Void ⟷ base Void

    booleanCompat : ----------------------
                    base Boolean ⟷ base Boolean

                    -- ============= DEFINITIONS OF HEAP CONSISTENCY ===============

  ctxTypes : TypeEnv → ObjectRef → List Type
  ctxTypes ∅ _ = []
  ctxTypes (Δ , o' ⦂ T) o with o ≟ o'
  ...                    | yes eq = [ T ]
  ...                    | no nEq = ctxTypes Δ o

  envTypesHelper : IndirectRefEnv → TypeEnv → ObjectRef → List Type
  envTypesHelper IndirectRefContext.∅  Δ o = []

  envTypesHelper (IndirectRefContext._,_⦂_ ρ l (objVal o')) Δ o with (o' ≟ o) | (TypeEnvContext.lookup Δ l)
  ...                                             | yes _ | just T =  (T ∷ (envTypesHelper ρ Δ o))
  ...                                             | _ | _ = envTypesHelper ρ Δ o

  envTypesHelper (IndirectRefContext._,_⦂_ ρ l v) Δ o = envTypesHelper ρ Δ o

  makeEnvTypesList : RuntimeEnv → StaticEnv → ObjectRef → List Type
  makeEnvTypesList Σ Δ o = envTypesHelper (RuntimeEnv.ρ Σ) (StaticEnv.locEnv Δ) o

  -- The List IndirectRef is a list of locations that have already been used in previous calls (and are forbidden to be used again).
  data EnvTypes : RuntimeEnv → StaticEnv → ObjectRef → List IndirectRef → List Type → Set where
    envTypesConcatMatchFound : ∀ {R l T μ ρ φ ψ forbiddenRefs}
                               → (Δ : StaticEnv)
                               → (o : ObjectRef)
                               → EnvTypes (re μ ρ φ ψ) Δ o (l ∷ forbiddenRefs) R
                               → (StaticEnv.locEnv Δ) ∋ l ⦂ T
                               → l ∉ forbiddenRefs
                               → EnvTypes (re μ (ρ IndirectRefContext., l ⦂ (objVal o)) φ ψ) Δ o forbiddenRefs (T ∷ R)

    envTypesConcatMatchNotFound : ∀ {R l μ ρ φ ψ forbiddenRefs}
                                  → (Δ : StaticEnv)
                                  → (o : ObjectRef)
                                  → EnvTypes (re μ ρ φ ψ) Δ o forbiddenRefs R
                                  → l ∉dom (StaticEnv.locEnv Δ)
                                  → EnvTypes (re μ (ρ IndirectRefContext., l ⦂ (objVal o)) φ ψ) Δ o forbiddenRefs R

    envTypesConcatMismatch : ∀ {R l μ ρ φ ψ forbiddenRefs}
                             → (Δ : StaticEnv)
                             → (o o' : ObjectRef)
                             → o ≢ o'
                             → EnvTypes (re μ ρ φ ψ) Δ o forbiddenRefs R -- Mismatch in ρ, so keep looking in the rest of ρ
                             → EnvTypes (re μ (ρ IndirectRefContext., l ⦂ (objVal o')) φ ψ) Δ o forbiddenRefs R

    envTypesEmpty : ∀ {μ φ ψ Δ o forbiddenRefs}
                    → EnvTypes  (re μ Context.∅ φ ψ) Δ o forbiddenRefs []

  record RefTypes (Σ : RuntimeEnv) (Δ : StaticEnv) (o : ObjectRef) : Set where
    field
      oTypesList : List Type -- Corresponds to types from the o's in Δ.
      oTypes : ctxTypes (StaticEnv.objEnv Δ) o ≡ oTypesList
      envTypesList : List Type
      envTypes : EnvTypes Σ Δ o [] envTypesList
      fieldTypesList : List Type -- Corresponds to types from fields inside μ

  data IsConnectedTypeList : List Type → Set where
    emptyTypeList : ∀ {D}
                    → D ≡ []
                    ----------
                    → IsConnectedTypeList D

    consTypeList : ∀ {T D}
                   → All (λ T' → (T ⟷ T')) D
                   → IsConnectedTypeList D
                   ------------------------
                   → IsConnectedTypeList (T ∷ D)

  data IsConnectedEnvAndField  (Σ : RuntimeEnv) (Δ : StaticEnv) (o : ObjectRef) : RefTypes Σ Δ o → Set where
    envTypesConnected : (R : RefTypes Σ Δ o)
                        → IsConnectedTypeList (RefTypes.envTypesList R)
                        → IsConnectedTypeList (RefTypes.fieldTypesList R)
                        → All (λ T → All (λ T' → T ⟷ T') (RefTypes.fieldTypesList R)) (RefTypes.envTypesList R) -- all of the l types are connected to all of the field types
                        ----------------------------------------------
                        → IsConnectedEnvAndField Σ Δ o R

  envFieldInversion1 : ∀ {Σ Δ o R}
                       → IsConnectedEnvAndField Σ Δ o R
                       → IsConnectedTypeList (RefTypes.envTypesList R)
  envFieldInversion1 (envTypesConnected R env f envField) = env

  envFieldInversion2 :  ∀ {Σ Δ o R}
                        → IsConnectedEnvAndField Σ Δ o R
                        → IsConnectedTypeList (RefTypes.fieldTypesList R)
  envFieldInversion2 (envTypesConnected R env f envField) = f

  envFieldInversion3 :  ∀ {Σ Δ o R}
                        → IsConnectedEnvAndField Σ Δ o R
                        → All (λ T → All (λ T' → T ⟷ T') (RefTypes.fieldTypesList R)) (RefTypes.envTypesList R)
  envFieldInversion3 (envTypesConnected R env f envField) = envField

  data IsConnected (Σ : RuntimeEnv) (Δ : StaticEnv) (o : ObjectRef) : RefTypes Σ Δ o → Set where
    isConnected : (R : RefTypes Σ Δ o)
                  → IsConnectedTypeList (RefTypes.oTypesList R)
                  → All (λ T → All (λ T' → T ⟷ T') (RefTypes.fieldTypesList R)) (RefTypes.oTypesList R) -- all of the o types are connected to all of the field types
                  → All (λ T → All (λ T' → T ⟷ T') (RefTypes.envTypesList R)) (RefTypes.oTypesList R) -- all of the o types are connected to all of the l types
                  → IsConnectedEnvAndField Σ Δ o R
                  ----------------------------------------------
                  → IsConnected Σ Δ o R

  refFieldTypesHelper : ObjectRefEnv → StaticEnv → ObjectRef → List Type
  refFieldTypesHelper ObjectRefContext.∅ Δ o = []
  refFieldTypesHelper (ObjectRefContext._,_⦂_ μ o' obj) Δ o = refFieldTypesHelper μ Δ o  -- TODO; this is bogus!

  refFieldTypes : RuntimeEnv → StaticEnv → ObjectRef → List Type
  refFieldTypes Σ Δ o = refFieldTypesHelper (RuntimeEnv.μ Σ) Δ o

-- ================================ OVERALL HEAP CONSISTENCY ===========================

  data ReferenceConsistency : RuntimeEnv → StaticEnv → ObjectRef → Set where
    referencesConsistent : ∀ {Σ : RuntimeEnv}
                         → ∀ {Δ : StaticEnv}
                         → ∀ {o : ObjectRef}
                         → ∃[ RT ] (IsConnected Σ Δ o RT)
                           -- TODO: add subtype constraint: C <: (refTypes Σ Δ o)
                         ---------------------------
                         → ReferenceConsistency Σ Δ o

  -- Inversion for reference consistency: connectivity
  referencesConsistentImpliesConnectivity : ∀ {Σ Δ o}
                                            → ReferenceConsistency Σ Δ o
                                            → ∃[ RT ] (IsConnected Σ Δ o RT)

  referencesConsistentImpliesConnectivity (referencesConsistent ic) = ic

  ------------ Global Consistency -----------
  -- I'm going to need the fact that if an expression typechecks, and I find a location in it, then the location can be looked
  -- up in the runtime environment. But every location in the expression has to also be in the typing context, so I can state this
  -- without talking about expressions at all.
  data _&_ok : RuntimeEnv → StaticEnv → Set where
    ok : ∀ {Σ : RuntimeEnv}
         → ∀ (Δ : StaticEnv)
         → (∀ (l : IndirectRef) → ((StaticEnv.locEnv Δ) ∋ l ⦂ base Void → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l ⦂ voidVal)))
         → (∀ (l : IndirectRef) → ((StaticEnv.locEnv Δ) ∋ l ⦂ base Boolean → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l ⦂ boolVal b)))
         → (∀ (l : IndirectRef)
           → ∀ (T : Tc)
           → (StaticEnv.locEnv Δ) ∋ l ⦂ (contractType T)         -- If a location is in Δ and has contract reference type...
           → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ))) -- then location can be looked up in Σ...
           )
         → (∀ o → o ObjectRefContext.∈dom (RuntimeEnv.μ Σ) → ReferenceConsistency Σ Δ o)
         -- TODO: add remaining antecedents
         ---------------------------
         → Σ & Δ ok

  -- Inversion for global consistency: reference consistency
  refConsistency : ∀ {Σ : RuntimeEnv}
                   → ∀ {Δ : StaticEnv}
                   → ∀ {o : ObjectRef}
                   → ∀ {l : IndirectRef}
                   → Σ & Δ ok
                   → (∀ o → o ObjectRefContext.∈dom RuntimeEnv.μ Σ → ReferenceConsistency Σ Δ o)
  refConsistency (ok Δ _ _ _ rc) =  rc

  -- Inversion for global consistency : location lookup for a particular location
  -- If l is in Δ and Σ & Δ ok, then l can be found in Σ.ρ.
  locLookup : ∀ {Σ : RuntimeEnv}
              → ∀ {Δ : StaticEnv}
              → ∀ {l : IndirectRef}
              → ∀ {T : Tc}
              → Σ & Δ ok
              → (StaticEnv.locEnv Δ) ∋ l ⦂ (contractType T)
              → ∃[ o ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l ⦂ objVal o × (o ObjectRefContext.∈dom (RuntimeEnv.μ Σ)))

  locLookup (ok Δ _ _ lContainment rc) lInDelta@(Z {Δ'} {x} {contractType a}) = lContainment x a lInDelta
  locLookup (ok Δ _ _ lContainment rc) lInDelta@(S {Δ'} {x} {y} {contractType a} {b} nEq xInRestOfDelta) = lContainment x a lInDelta

  voidLookup : ∀ {Σ : RuntimeEnv}
              → ∀ {Δ : StaticEnv}
              → ∀ {l : IndirectRef}
              → Σ & Δ ok
              → (StaticEnv.locEnv Δ) ∋ l ⦂ base Void
              → (RuntimeEnv.ρ Σ IndirectRefContext.∋ l ⦂ voidVal)
  voidLookup (ok Δ voidContainment _ _ _) voidType@(Z {Δ'} {l} {a}) = voidContainment l voidType
  voidLookup (ok Δ voidContainment _ _ _) voidType@(S {Δ'} {l} {y} {a} {b} nEq lInRestOfDelta) = voidContainment l voidType

  boolLookup : ∀ {Σ : RuntimeEnv}
              → ∀ {Δ : StaticEnv}
              → ∀ {l : IndirectRef}
              → Σ & Δ ok
              → (StaticEnv.locEnv Δ) ∋ l ⦂ base Boolean
              → ∃[ b ] (RuntimeEnv.ρ Σ IndirectRefContext.∋ l ⦂ boolVal b)
  boolLookup (ok Δ _ boolContainment _ _) boolType@(Z {Δ'} {l} {a}) = boolContainment l boolType
  boolLookup (ok Δ _ boolContainment _ _) boolType@(S {Δ'} {l} {y} {a} {b} nEq lInRestOfDelta) = boolContainment l boolType


module nodcap.NF.Cut where

open import Algebra
open import Data.Environment
open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺
open import Data.List as L using (List; []; _∷_; _++_)
open import Data.List.Any as LA using (Any; here; there)
open import Data.List.Any.BagAndSetEquality as B
open import Data.Product as PR using (∃; _×_; _,_; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_; flip)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as I using ()
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)

open import nodcap.Base
open import nodcap.NF.Typing
open import nodcap.NF.Contract
open import nodcap.NF.Expand

open I.Inverse using (to; from)
private module ++ {a} {A : Set a} = Monoid (L.monoid A)

{-# TERMINATING #-}
-- Theorem:
--   Cut elimination.
mutual
  cut : {Γ Δ : Environment} {A : Type} →

    ⊢ⁿᶠ A ∷ Γ → ⊢ⁿᶠ A ^ ∷ Δ →
    ---------------------
    ⊢ⁿᶠ Γ ++ Δ

  cut {_} {Δ} {A = 𝟏} halt (wait y)
    = y
  cut {Γ} {_} {A = ⊥} (wait x) halt
    = P.subst ⊢ⁿᶠ_ (P.sym (proj₂ ++.identity Γ)) x
  cut {_} {Θ} {A = A ⊗ B} (send {Γ} {Δ} x y) (recv z)
    = P.subst ⊢ⁿᶠ_ (P.sym (++.assoc Γ Δ Θ))
    $ exch (swp [] Γ Δ)
    $ cut y
    $ exch (fwd [] Γ)
    $ cut x z
  cut {Θ} {_} {A = A ⅋ B} (recv x) (send {Γ} {Δ} y z)
    = P.subst ⊢ⁿᶠ_ (++.assoc Θ Γ Δ)
    $ cut (cut x y) z
  cut {Γ} {Δ} {A = A ⊕ B} (sel₁ x) (case y z)
    = cut x y
  cut {Γ} {Δ} {A = A ⊕ B} (sel₂ x) (case y z)
    = cut x z
  cut {Γ} {Δ} {A = A & B} (case x y) (sel₁ z)
    = cut x z
  cut {Γ} {Δ} {A = A & B} (case x y) (sel₂ z)
    = cut y z
  cut {Γ} {Δ} {A = ![ n ] A} x y
    = interleaveIn (here P.refl) x (expand y)
  cut {Γ} {Δ} {A = ?[ n ] A} x y
    = exch (swp₂ Γ)
    $ interleaveIn {_ ∷ Δ} {Γ} (here P.refl) y
    $ P.subst (λ A → ⊢ⁿᶠ replicate⁺ n A ++ Γ) (P.sym $ ^-inv A)
    $ expand x
  cut {Γ} {Δ} {A} (exch b x) y
    = exch (B.++-cong {ys₁ = Δ} (del-from b (here P.refl)) I.id)
    $ cutIn (from b ⟨$⟩ here P.refl) (here P.refl) x y
  cut {Γ} {Δ} {A} x (exch b y)
    = exch (B.++-cong {xs₁ = Γ} I.id (del-from b (here P.refl)))
    $ cutIn (here P.refl) (from b ⟨$⟩ here P.refl) x y

  cutIn : {Γ Δ : Environment} {A : Type} (i : A ∈ Γ) (j : A ^ ∈ Δ) →

    ⊢ⁿᶠ Γ → ⊢ⁿᶠ Δ →
    ----------------
    ⊢ⁿᶠ Γ - i ++ Δ - j

  cutIn (here P.refl) (here P.refl) x y = cut x y

  cutIn {_} {Θ} (there i) j (send {Γ} {Δ} x y) z
    with split Γ i
  ... | inj₁ (k , p) rewrite p
      = P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ - k) Δ (Θ - j)))
      $ exch (swp₃ (_ ∷ Γ - k) Δ)
      $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Γ - k) (Θ - j) Δ)
      $ flip send y
      $ cutIn (there k) j x z
  ... | inj₂ (k , p) rewrite p
      = P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ) (Δ - k) (Θ - j)))
      $ send x
      $ cutIn (there k) j y z
  cutIn (there i) j (recv x) y
    = recv
    $ cutIn (there (there i)) j x y
  cutIn (there i) j (sel₁ x) y
    = sel₁
    $ cutIn (there i) j x y
  cutIn (there i) j (sel₂ x) y
    = sel₂
    $ cutIn (there i) j x y
  cutIn (there i) j (case x y) z
    = case
    ( cutIn (there i) j x z )
    ( cutIn (there i) j y z )
  cutIn (there ()) j halt y
  cutIn (there i) j (wait x) y
    = wait
    $ cutIn i j x y
  cutIn (there i) j loop y
    = loop
  cutIn {Γ} {Δ} (there i) j (mk?₁ x) y
    = mk?₁
    $ cutIn (there i) j x y
  cutIn {Γ} {Δ} (there i) j (mk!₁ x) y
    = mk!₁
    $ cutIn (there i) j x y
  cutIn {Γ} {Δ} (there i) j (cont x) y
    = cont
    $ cutIn (there (there i)) j x y
  cutIn {_} {Θ} (there i) j (pool {Γ} {Δ} x y) z
    with split Γ i
  ... | inj₁ (k , p) rewrite p
      = P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ - k) Δ (Θ - j)))
      $ exch (swp₃ (_ ∷ Γ - k) Δ)
      $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Γ - k) (Θ - j) Δ)
      $ flip pool y
      $ cutIn (there k) j x z
  ... | inj₂ (k , p) rewrite p
      = P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ) (Δ - k) (Θ - j)))
      $ pool x
      $ cutIn (there k) j y z

  cutIn {Θ} {_} i (there j) x (send {Γ} {Δ} y z)
    with split Γ j
  ... | inj₁ (k , p) rewrite p
      = exch (bwd [] (Θ - i))
      $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Θ - i) (Γ - k) Δ)
      $ flip send z
      $ exch (fwd [] (Θ - i))
      $ cutIn i (there k) x y
  ... | inj₂ (k , p) rewrite p
      = exch (swp [] (Θ - i) (_ ∷ Γ))
      $ send y
      $ exch (fwd [] (Θ - i))
      $ cutIn i (there k) x z
  cutIn {Γ} i (there j) x (recv {Δ} y)
    = exch (bwd [] (Γ - i))
    $ recv
    $ exch (swp [] (_ ∷ _ ∷ []) (Γ - i))
    $ cutIn i (there (there j)) x y
  cutIn {Γ} {Δ} i (there j) x (sel₁ y)
    = exch (bwd [] (Γ - i))
    $ sel₁
    $ exch (fwd [] (Γ - i))
    $ cutIn i (there j) x y
  cutIn {Γ} {Δ} i (there j) x (sel₂ y)
    = exch (bwd [] (Γ - i))
    $ sel₂
    $ exch (fwd [] (Γ - i))
    $ cutIn i (there j) x y
  cutIn {Γ} {Δ} i (there j) x (case y z)
    = exch (bwd [] (Γ - i))
    $ case
    ( exch (fwd [] (Γ - i)) $ cutIn i (there j) x y )
    ( exch (fwd [] (Γ - i)) $ cutIn i (there j) x z )
  cutIn {Γ} i (there ()) x halt
  cutIn {Γ} {Δ} i (there j) x (wait y)
    = exch (bwd [] (Γ - i))
    $ wait
    $ cutIn i j x y
  cutIn {Γ} {Δ} i (there j) x loop
    = exch (bwd [] (Γ - i)) loop
  cutIn {Γ} {Δ} i (there j) x (mk?₁ y)
    = exch (bwd [] (Γ - i))
    $ mk?₁
    $ exch (fwd [] (Γ - i))
    $ cutIn i (there j) x y
  cutIn {Γ} {Δ} i (there j) x (mk!₁ y)
    = exch (bwd [] (Γ - i))
    $ mk!₁
    $ exch (fwd [] (Γ - i))
    $ cutIn i (there j) x y
  cutIn {Γ} {Δ} i (there j) x (cont y)
    = exch (bwd [] (Γ - i))
    $ cont
    $ exch (swp [] (_ ∷ _ ∷ []) (Γ - i))
    $ cutIn i (there (there j)) x y
  cutIn {Θ} {_} i (there j) x (pool {Γ} {Δ} y z)
    with split Γ j
  ... | inj₁ (k , p) rewrite p
      = exch (bwd [] (Θ - i))
      $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Θ - i) (Γ - k) Δ)
      $ flip pool z
      $ exch (fwd [] (Θ - i))
      $ cutIn i (there k) x y
  ... | inj₂ (k , p) rewrite p
      = exch (swp [] (Θ - i) (_ ∷ Γ))
      $ pool y
      $ exch (fwd [] (Θ - i))
      $ cutIn i (there k) x z

  cutIn {Γ} {Δ} i j (exch b x) y
    = exch (B.++-cong {ys₁ = Δ - j} (del-from b i ) I.id)
    $ cutIn (from b ⟨$⟩ i) j x y
  cutIn {Γ} {Δ} i j x (exch b y)
    = exch (B.++-cong {xs₁ = Γ - i} I.id (del-from b j))
    $ cutIn i (from b ⟨$⟩ j) x y

  interleaveIn : {Γ Δ : Environment} {A : Type} {n : ℕ⁺} (i : ![ n ] A ∈ Γ) →

    ⊢ⁿᶠ Γ → ⊢ⁿᶠ replicate⁺ n (A ^) ++ Δ →
    -----------------------------------------------
    ⊢ⁿᶠ Γ - i ++ Δ

  interleaveIn (here P.refl) (mk!₁ {Γ} x) z
    = cut x z
  interleaveIn {._} {Θ} (here P.refl) (pool {Γ} {Δ} {A} {m} {n} x y) z
    = P.subst ⊢ⁿᶠ_ (P.sym $ ++.assoc Γ Δ Θ)
    $ interleaveIn (here P.refl) x
    $ exch (swp [] (replicate⁺ m _) Δ)
    $ interleaveIn (here P.refl) y
    $ exch (swp [] (replicate⁺ n _) (replicate⁺ m _))
    $ P.subst ⊢ⁿᶠ_ (++.assoc (replicate⁺ m _) (replicate⁺ n _) Θ)
    $ P.subst (λ Γ → ⊢ⁿᶠ Γ ++ Θ) (P.sym $ replicate⁺-++-commute m n) z
  interleaveIn {._} {Θ} (there i) (send {Γ} {Δ} {A} {B} x y) z
    with split Γ i
  ... | inj₁ (j , p) rewrite p
    = P.subst ⊢ⁿᶠ_ (P.sym $ ++.assoc (_ ∷ Γ - j) Δ Θ)
    $ exch (swp₃ (_ ∷ Γ - j) Δ {Θ})
    $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Γ - j) Θ Δ)
    $ flip send y
    $ interleaveIn (there j) x z
  ... | inj₂ (j , p) rewrite p
    = P.subst ⊢ⁿᶠ_ (P.sym $ ++.assoc (_ ∷ Γ) (Δ - j) Θ)
    $ send x
    $ interleaveIn (there j) y z
  interleaveIn (there i) (recv x)   z
    = recv
    $ interleaveIn (there (there i)) x z
  interleaveIn (there i) (sel₁ x)   z
    = sel₁
    $ interleaveIn (there i) x z
  interleaveIn (there i) (sel₂ x)   z
    = sel₂
    $ interleaveIn (there i) x z
  interleaveIn (there i) (case x y) z
    = case (interleaveIn (there i) x z) (interleaveIn (there i) y z)
  interleaveIn (there ()) halt z
  interleaveIn (there i) (wait x)   z
    = wait
    $ interleaveIn i x z
  interleaveIn (there i)  loop      z
    = loop
  interleaveIn (there i) (mk?₁ x)   z
    = mk?₁
    $ interleaveIn (there i) x z
  interleaveIn (there i) (mk!₁ x)   z
    = mk!₁
    $ interleaveIn (there i) x z
  interleaveIn (there i) (cont x)   z
    = cont
    $ interleaveIn (there (there i)) x z
  interleaveIn {._} {Θ} (there i) (pool {Γ} {Δ} x y) z
    with split Γ i
  ... | inj₁ (j , p) rewrite p
    = P.subst ⊢ⁿᶠ_ (P.sym $ ++.assoc (_ ∷ Γ - j) Δ Θ)
    $ exch (swp₃ (_ ∷ Γ - j) Δ {Θ})
    $ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Γ - j) Θ Δ)
    $ flip pool y
    $ interleaveIn (there j) x z
  ... | inj₂ (j , p) rewrite p
    = P.subst ⊢ⁿᶠ_ (P.sym $ ++.assoc (_ ∷ Γ) (Δ - j) Θ)
    $ pool x
    $ interleaveIn (there j) y z
  interleaveIn {Γ} {Δ} i (exch b x) z
    = exch (B.++-cong {ys₁ = Δ} (del-from b i) I.id)
    $ interleaveIn (from b ⟨$⟩ i) x z

-- -}
-- -}
-- -}
-- -}
-- -}


module par-swap.confluent where

open import par-swap
open import par-swap.properties
open import Data.Nat using (_+_ ;  _≤′_ ; _<′_ ; suc ; zero ; ≤′-refl)
open import Esterel.Lang.CanFunction
open import utility
open import Esterel.Lang
open import Esterel.Context
open import Data.Product
open import Data.Sum
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; subst ; cong ; trans ;
         module ≡-Reasoning ; cong₂ ; subst₂ ; inspect)
open import sn-calculus
open import context-properties -- get view, E-views
open import Esterel.Lang.Binding
open import binding-preserve using (sn⟶-maintains-binding ; sn⟶*-maintains-binding)

open import sn-calculus-props

∥R-confluent : CB-CONFLUENT _∥R_
∥R-confluent CBp
  (∥Rstep dchole)
  (∥Rstep dchole) =
  _ , ∥Rstep dchole , ∥Rstep dchole
∥R-confluent CBp
  (∥Rstep dchole)
  (∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₂) , ∥Rstep dchole
∥R-confluent CBp
  (∥Rstep dchole)
  (∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₂) , ∥Rstep dchole
∥R-confluent CBp
  (∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep dchole) =
  _ , ∥Rstep dchole , ∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₁)
∥R-confluent (CBpar CBs _ _ _ _ _)
  (∥Rstep {c₁ ∷ C₁} (dcpar₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcpar₁ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent CBp
  (∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₂)) =
  _ ,  ∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₁)
∥R-confluent CBp
  (∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep dchole) =
  _ , ∥Rstep dchole , ∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₁)
∥R-confluent CBp
  (∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcpar₁ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcpar₂ d≐C⟦p∥q⟧c₁)
∥R-confluent (CBpar _ CBs _ _ _ _)
  (∥Rstep {c₁ ∷ C₁} (dcpar₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcpar₂ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBseq CBs _ _)
  (∥Rstep {c₁ ∷ C₁} (dcseq₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcseq₁ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent CBp
  (∥Rstep (dcseq₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcseq₂ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcseq₂ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcseq₁ d≐C⟦p∥q⟧c₁)
∥R-confluent CBp
  (∥Rstep (dcseq₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcseq₁ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcseq₁ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcseq₂ d≐C⟦p∥q⟧c₁)
∥R-confluent (CBseq _ CBs _)
  (∥Rstep {c₁ ∷ C₁} (dcseq₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcseq₂ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBsusp CBs _)
  (∥Rstep {c₁ ∷ C₁} (dcsuspend d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcsuspend d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBtrap CBs)
  (∥Rstep {c₁ ∷ C₁} (dctrap d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dctrap d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBsig CBs)
  (∥Rstep {c₁ ∷ C₁} (dcsignl d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcsignl d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBpresent CBs _)
  (∥Rstep {c₁ ∷ C₁} (dcpresent₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcpresent₁ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent CBp
  (∥Rstep (dcpresent₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcpresent₂ d≐C⟦p∥q⟧c₂)) =
   _ , ∥Rstep (dcpresent₂ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcpresent₁ d≐C⟦p∥q⟧c₁)
∥R-confluent CBp
  (∥Rstep (dcpresent₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcpresent₁ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcpresent₁ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcpresent₂ d≐C⟦p∥q⟧c₁)
∥R-confluent (CBpresent _ CBs)
  (∥Rstep {c₁ ∷ C₁} (dcpresent₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcpresent₂ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBloop CBs _)
  (∥Rstep {c₁ ∷ C₁} (dcloop d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcloop d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBloopˢ CBs _ _ _)
  (∥Rstep {c₁ ∷ C₁} (dcloopˢ₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcloopˢ₁ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent CBp
  (∥Rstep (dcloopˢ₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcloopˢ₂ d≐C⟦p∥q⟧c₂)) =
   _ , ∥Rstep (dcloopˢ₂ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcloopˢ₁ d≐C⟦p∥q⟧c₁)
∥R-confluent CBp
  (∥Rstep (dcloopˢ₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcloopˢ₁ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcloopˢ₁ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcloopˢ₂ d≐C⟦p∥q⟧c₁)
∥R-confluent (CBloopˢ _ CBs _ _)
  (∥Rstep {c₁ ∷ C₁} (dcloopˢ₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcloopˢ₂ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBshared CBs)
  (∥Rstep {c₁ ∷ C₁} (dcshared d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcshared d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBvar CBs)
  (∥Rstep {c₁ ∷ C₁} (dcvar d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcvar d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBif CBs _)
  (∥Rstep {c₁ ∷ C₁} (dcif₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcif₁ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent _
  (∥Rstep (dcif₁ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcif₂ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcif₂ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcif₁ d≐C⟦p∥q⟧c₁)
∥R-confluent CBp
  (∥Rstep (dcif₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep (dcif₁ d≐C⟦p∥q⟧c₂)) =
  _ , ∥Rstep (dcif₁ d≐C⟦p∥q⟧c₂) , ∥Rstep (dcif₂ d≐C⟦p∥q⟧c₁)
∥R-confluent (CBif _ CBs)
  (∥Rstep {c₁ ∷ C₁} (dcif₂ d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcif₂ d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz
∥R-confluent (CBρ CBs)
  (∥Rstep {c₁ ∷ C₁} (dcenv d≐C⟦p∥q⟧c₁))
  (∥Rstep {c₂ ∷ C₂} (dcenv d≐C⟦p∥q⟧c₂))
  with ∥R-confluent CBs (∥Rstep d≐C⟦p∥q⟧c₁) (∥Rstep d≐C⟦p∥q⟧c₂)
... | z , C₁⟦q₁∥p₁⟧c∥Rz , C₂⟦q₂∥p₂⟧c∥Rz  =
  _ , Context1-∥R c₁ C₁⟦q₁∥p₁⟧c∥Rz , Context1-∥R c₂ C₂⟦q₂∥p₂⟧c∥Rz

∥R-maintains-binding :
  ∀ {p BV FV q} →
  CorrectBinding p BV FV →
  p ∥R q →
  CorrectBinding q (BVars q) (FVars q)
∥R-maintains-binding = thm where

  thm :
    ∀ {p BV FV q} →
     CorrectBinding p BV FV →
     p ∥R q →
     CorrectBinding q (BVars q) (FVars q)
  thm{p}{BVp}{FVp}{q} CBp (∥Rstep{C}{r₁}{r₂}{d} d≐C⟦p∥q⟧c)
    with binding-extractc' CBp d≐C⟦p∥q⟧c
  ... | (BVr₁∥r₂ , FVr₁∥r₂) ,
        CBpar{.r₁}{.r₂}{BVr₁}{FVr₁}{BVr₂}{FVr₂}
             CBr₁ CBr₂ BVr₁≠BVr₂ FVr₁≠BVr₂ BVr₁≠FVr₂ Xr₁≠Xr₂
     with CBpar{r₂}{r₁}{BVr₂}{FVr₂}{BVr₁}{FVr₁}
               CBr₂ CBr₁
               (distinct-sym BVr₁≠BVr₂) (distinct-sym BVr₁≠FVr₂)
               (distinct-sym FVr₁≠BVr₂) (dist'-sym Xr₁≠Xr₂)
  ... | CBr₂∥r₁
    with binding-substc' CBp d≐C⟦p∥q⟧c
            (CBpar CBr₁ CBr₂ BVr₁≠BVr₂ FVr₁≠BVr₂
                   BVr₁≠FVr₂ Xr₁≠Xr₂)
            (∪-comm-⊆-right BVr₁ ⊆-refl)
            (∪-comm-⊆-right FVr₁ ⊆-refl)
            CBr₂∥r₁
  ... | (BVq , FVq) , (_ , CBq)
    with BVFVcorrect _ BVq FVq CBq
  ... | (refl , refl) = CBq

∥R*-maintains-binding :
  ∀ {p BV FV q} →
  CorrectBinding p BV FV →
  p ∥R* q →
  CorrectBinding q (BVars q) (FVars q)
∥R*-maintains-binding = thm where

  thm : ∀ {p BV FV q} →
   CorrectBinding p BV FV →
   p ∥R* q →
   CorrectBinding q (BVars q) (FVars q)
  thm CBp ∥R0 with BVFVcorrect _ _ _ CBp
  ... | refl , refl = CBp
  thm CBp (∥Rn p∥Rq₁ q₁∥R*q)
    with ∥R-maintains-binding CBp p∥Rq₁
  ... | CBq₁ = thm CBq₁ q₁∥R*q

∥R*-semi-confluent :
  ∀ {p q r BV FV} ->
  CorrectBinding p BV FV ->
  p ∥R q ->
  p ∥R* r ->
 ∃ λ {z → (q ∥R* z × r ∥R* z)}
∥R*-semi-confluent CBp p∥Rq ∥R0 = _ , ∥R0 , (∥Rn p∥Rq ∥R0)
∥R*-semi-confluent CBp p∥Rq (∥Rn p∥Rq₁ q₁∥R*r)
  with ∥R-confluent CBp p∥Rq p∥Rq₁
... | z , q∥Rz , q₁∥Rz
  with ∥R*-semi-confluent (∥R-maintains-binding CBp p∥Rq₁) q₁∥Rz q₁∥R*r
... | z₁ , z∥R*z₁ , r∥R*z₁ = z₁ , ∥Rn q∥Rz z∥R*z₁ , r∥R*z₁

∥R*-confluent : CB-CONFLUENT _∥R*_
∥R*-confluent CBp ∥R0 p∥R*r = _ , p∥R*r , ∥R0
∥R*-confluent CBp (∥Rn p∥Rp₁ p₁∥R*q) p∥R*r
  with ∥R*-semi-confluent CBp p∥Rp₁ p∥R*r
... | z₁ , p₁∥R*z₁ , r∥R*z₁
  with ∥R*-confluent (∥R-maintains-binding CBp p∥Rp₁) p₁∥R*q p₁∥R*z₁
... | z  , q∥R*z , z₁∥R*z = z , q∥R*z , ∥R*-concat r∥R*z₁ z₁∥R*z


module _ where

open import utility
open import sn-calculus
  using (all-ready ; bound-ready)

open import Data.Product using (∃ ; Σ ; _,_ ; _×_ ; _,′_ ; proj₁ ; proj₂)
open import Relation.Binary.PropositionalEquality using (sym ; inspect ; Reveal_·_is_ ; trans)
open import Data.Empty
open import Data.Sum using (_⊎_ ; inj₁ ; inj₂)
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Context
open import Esterel.Environment as Env
open import Esterel.Lang.CanFunction
  using (Canₖ ; module CodeSet ; Canₛ ; Canₛₕ ; Canθₛ ; Canθₛₕ)
open import Esterel.Lang.CanFunction.Base
  using (can-shr-var-irr)
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ) renaming (_≟ₛₜ_ to _≟ₛₜₛ_)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ) renaming (_≟ₛₜ_ to _≟ₛₜₛₕ_)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ)

open import Esterel.Lang.CanFunction using (Canₖ)

open import Data.Product using (_,_)
open import Relation.Nullary using (Dec ; yes ; no ; ¬_)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; trans ; sym)
import Data.FiniteMap
open import Data.List
  using (List ; [] ; _∷_ ; [_] ; _++_ ; map ; concatMap ; filter)
open import Data.List.Any using (Any ; any ; here ; there)
open import Data.List.All using (All ; [] ; _∷_)
open import Data.OrderedListMap

open all-ready
open bound-ready

data blocked-s : Env → s/l → Set where
   bbshr-old : ∀{θ s} →
     (s∈ : Env.isShr∈ s θ) →
     Env.shr-stats{s} θ s∈ ≡ SharedVar.old →
     blocked-s θ (shr-ref s)
   bbshr-new : ∀{θ s} →
     (s∈ : Env.isShr∈ s θ) →
     Env.shr-stats{s} θ s∈ ≡ SharedVar.new →
     blocked-s θ (shr-ref s)

-- Note: θ and e are in the opposite order of all-ready definition.
-- We directly used Any here as a synonym. Should all-ready be the same?
blocked-e : Env → Expr → Set
blocked-e θ (plus operators) = Any (blocked-s θ) operators

data blocked : Env → Ctrl → Term → Set where
  bsig-exists : ∀{θ p q A} S S∈ → (sig-stats{S} θ S∈ ≡ Signal.unknown) →
                ------------------------
                blocked θ A (present S ∣⇒ p ∣⇒ q)
  bpar-both  : ∀{θ p q A} → blocked θ A p → blocked θ A q → blocked θ A (p ∥ q)
  bpar-left  : ∀{θ p q A} → blocked θ A p → done q → blocked θ A (p ∥ q)
  bpar-right : ∀{θ p q A} → done p → blocked θ A q → blocked θ A (p ∥ q)
  bseq       : ∀{θ p q A} → blocked θ A p → blocked θ A (p >> q)
  bloopˢ     : ∀{θ p q A} → blocked θ A p → blocked θ A (loopˢ p q)
  bsusp      : ∀{θ p S A} → blocked θ A p → blocked θ A (suspend p S)
  btrap      : ∀{θ p A}   → blocked θ A p → blocked θ A (trap p)
  bwset      : ∀{θ s e} → blocked θ WAIT (s ⇐ e)
  bwemit      : ∀{θ S} → blocked θ WAIT (emit S)
  bshared    : ∀{θ s e p A} → blocked-e θ e → blocked θ A (shared s ≔ e in: p)
  bsset      : ∀{θ s e A} → blocked-e θ e → blocked θ A (s ⇐ e)
  bvar       : ∀{θ x e p A} → blocked-e θ e → blocked θ A (var x ≔ e in: p)
  bxset      : ∀{θ x e A} → blocked-e θ e → blocked θ A (x ≔ e)

data manifests-as-non-constructive : Env → Ctrl → Term → Set where
  mnc : ∀{p θ A} → (blocked-p : blocked θ A p)
              -- absent rule cannot fire: unknown signals might be emitted at some point
              → (θS≡unknown→S∈can-p-θ :
                 ∀ S →
                  (S∈Domθ        : Signal.unwrap S ∈ fst (Dom θ)) →
                  (θS≡unknown    : sig-stats {S} θ S∈Domθ ≡ Signal.unknown) →
                  Signal.unwrap S ∈ Canθₛ (sig θ) 0 p []env)
              -- readyness rule cannot fire: unready variables might become ready
              → (θs≡old⊎θs≡new→s∈can-p-θ :
                 ∀ s →
                  (s∈Domθ        : SharedVar.unwrap s ∈ snd (Dom θ)) →
                  (θs≡old⊎θs≡new : shr-stats {s} θ s∈Domθ ≡ SharedVar.old ⊎
                                   shr-stats {s} θ s∈Domθ ≡ SharedVar.new) →
                  SharedVar.unwrap s ∈ Canθₛₕ (sig θ) 0 p []env)
              → manifests-as-non-constructive θ A p

halted-blocked-disjoint : ∀ {θ p A} → halted p → blocked θ A p → ⊥
halted-blocked-disjoint hnothin   ()
halted-blocked-disjoint (hexit n) ()

paused-blocked-disjoint : ∀ {θ A p} → paused p → blocked θ A p → ⊥
paused-blocked-disjoint ppause ()
paused-blocked-disjoint (pseq p/paused) (bseq p/blocked) =
  paused-blocked-disjoint p/paused p/blocked
paused-blocked-disjoint (ploopˢ p/paused) (bloopˢ p/blocked) =
  paused-blocked-disjoint p/paused p/blocked
paused-blocked-disjoint (ppar p/paused q/paused) (bpar-both  p/blocked q/blocked) =
  paused-blocked-disjoint q/paused q/blocked
paused-blocked-disjoint (ppar p/paused q/paused) (bpar-left  p/blocked q/done) =
  paused-blocked-disjoint p/paused p/blocked
paused-blocked-disjoint (ppar p/paused q/paused) (bpar-right p/done q/blocked) =
  paused-blocked-disjoint q/paused q/blocked
paused-blocked-disjoint (psuspend p/paused) (bsusp p/blocked) =
  paused-blocked-disjoint p/paused p/blocked
paused-blocked-disjoint (ptrap p/paused) (btrap p/blocked) =
  paused-blocked-disjoint p/paused p/blocked

done-blocked-disjoint : ∀ {θ A p} → done p → blocked θ A p → ⊥
done-blocked-disjoint (dhalted p/halted) p/blocked = halted-blocked-disjoint p/halted p/blocked
done-blocked-disjoint (dpaused p/paused) p/blocked = paused-blocked-disjoint p/paused p/blocked

-- An expression cannot be both all-ready and blocked-e, i.e.
-- all-ready and blocked-e characterize disjoint subsets of e.
all-ready-blocked-disjoint : ∀ {e θ} → ¬ (all-ready e θ × blocked-e θ e)
all-ready-blocked-disjoint {θ = θ}
  (aplus (brshr {s = s} s∈ θs≡ready ∷ e/all-ready) ,
   here (bbshr-old {s = .s} s∈' θs≡old))
  with trans (sym θs≡ready) (trans (Env.shr-stats-∈-irr {s} {θ} s∈ s∈') θs≡old)
... | ()
all-ready-blocked-disjoint {θ = θ}
  (aplus (brshr {s = s} s∈ θs≡ready ∷ e/all-ready) ,
   here (bbshr-new {s = .s} s∈' θs≡new))
  with trans (sym θs≡ready) (trans (Env.shr-stats-∈-irr {s} {θ} s∈ s∈') θs≡new)
... | ()
all-ready-blocked-disjoint {θ = θ}
  (aplus (px ∷ e/all-ready) ,
   there e/blocked) =
  all-ready-blocked-disjoint (aplus e/all-ready ,′ e/blocked)

-- A subexpression in the hole in a blocked program must be either blocked or done.
blocked-⟦⟧e : ∀ {θ p p' E A} → blocked θ A p → p ≐ E ⟦ p' ⟧e → blocked θ A p' ⊎ done p'
blocked-⟦⟧e p/blocked dehole = inj₁ p/blocked
blocked-⟦⟧e (bseq p/blocked)  (deseq p≐E⟦p'⟧)     = blocked-⟦⟧e p/blocked p≐E⟦p'⟧
blocked-⟦⟧e (bloopˢ p/blocked) (deloopˢ p≐E⟦p'⟧)    = blocked-⟦⟧e p/blocked p≐E⟦p'⟧
blocked-⟦⟧e (bsusp p/blocked) (desuspend p≐E⟦p'⟧) = blocked-⟦⟧e p/blocked p≐E⟦p'⟧
blocked-⟦⟧e (btrap p/blocked) (detrap p≐E⟦p'⟧)    = blocked-⟦⟧e p/blocked p≐E⟦p'⟧
blocked-⟦⟧e (bpar-both  p/blocked q/blocked) (depar₁ p≐E⟦p'⟧) =
  blocked-⟦⟧e p/blocked p≐E⟦p'⟧
blocked-⟦⟧e (bpar-left  p/blocked q/done)    (depar₁ p≐E⟦p'⟧) =
  blocked-⟦⟧e p/blocked p≐E⟦p'⟧
blocked-⟦⟧e (bpar-right p/done    q/blocked) (depar₁ p≐E⟦p'⟧) =
  inj₂ (done-⟦⟧e p/done p≐E⟦p'⟧)
blocked-⟦⟧e (bpar-both  p/blocked q/blocked) (depar₂ q≐E⟦p'⟧) =
  blocked-⟦⟧e q/blocked q≐E⟦p'⟧
blocked-⟦⟧e (bpar-left  p/blocked q/done)    (depar₂ q≐E⟦p'⟧) =
  inj₂ (done-⟦⟧e q/done q≐E⟦p'⟧)
blocked-⟦⟧e (bpar-right p/done    q/blocked) (depar₂ q≐E⟦p'⟧) =
  blocked-⟦⟧e q/blocked q≐E⟦p'⟧

blocked-el-dec : ∀ θ l -> Dec (Any (blocked-s θ) l)
blocked-el-dec θ [] = no (λ ())
blocked-el-dec θ (num n ∷ l) with blocked-el-dec θ l
blocked-el-dec θ (num n ∷ l) | yes p = yes (there p)
blocked-el-dec θ (num n ∷ l) | no ¬p = no (λ { (here ()) ; (there x) → ¬p x } )
blocked-el-dec θ (seq-ref x ∷ l) with blocked-el-dec θ l
blocked-el-dec θ (seq-ref x ∷ l) | yes p = yes (there p)
blocked-el-dec θ (seq-ref x ∷ l) | no ¬p = no (λ { (here ()) ; (there x) → ¬p x })
blocked-el-dec θ (shr-ref s ∷ l) with blocked-el-dec θ l
blocked-el-dec θ (shr-ref s ∷ l) | yes p = yes (there p)
blocked-el-dec θ (shr-ref s ∷ l) | no ¬p with Env.Shr∈ s θ
blocked-el-dec θ (shr-ref s ∷ l) | no ¬p | yes s∈θ with Env.shr-stats{s} θ s∈θ | inspect (Env.shr-stats {s} θ) s∈θ
blocked-el-dec θ (shr-ref s ∷ l) | no ¬p | yes s∈θ | SharedVar.ready | Reveal_·_is_.[ eq ] =
  no (λ { (here (bbshr-old s∈θ₂ eq₂)) → lookup-s-eq θ s s∈θ s∈θ₂ eq eq₂ (λ ()) ;
          (here (bbshr-new s∈θ₂ eq₂)) → lookup-s-eq θ s s∈θ s∈θ₂ eq eq₂ (λ ()) ;
          (there x) → ¬p x })
blocked-el-dec θ (shr-ref s ∷ l) | no ¬p | yes s∈θ | SharedVar.new   | Reveal_·_is_.[ eq ] = yes (here (bbshr-new s∈θ eq))
blocked-el-dec θ (shr-ref s ∷ l) | no ¬p | yes s∈θ | SharedVar.old   | Reveal_·_is_.[ eq ] = yes (here (bbshr-old s∈θ eq))
blocked-el-dec θ (shr-ref s ∷ l) | no ¬p | no ¬s∈θ =
  no (λ { (here (bbshr-old s∈ x)) → ¬s∈θ s∈ ;
          (here (bbshr-new s∈ x)) → ¬s∈θ s∈ ;
          (there x) → ¬p x })

blocked-e-dec : ∀ θ e -> Dec (blocked-e θ e)
blocked-e-dec θ (plus l) = blocked-el-dec θ l

blocked-dec : ∀ θ A p -> Dec (blocked θ A p)
blocked-dec θ A nothin = no (λ ())
blocked-dec θ A pause = no (λ ())
blocked-dec θ A (signl S p) = no (λ ())
blocked-dec θ A (present S ∣⇒ p ∣⇒ q) with Sig∈ S θ
blocked-dec θ A (present S ∣⇒ p ∣⇒ q) | yes SigS∈θ
   with Env.sig-stats{S} θ SigS∈θ | inspect (Env.sig-stats{S} θ) SigS∈θ
blocked-dec θ A (present S ∣⇒ p ∣⇒ q) | yes SigS∈θ₁ | Signal.present | Reveal_·_is_.[ eq₁ ] =
  no (λ { (bsig-exists .S SigS∈θ₂ eq₂) → lookup-S-eq θ S SigS∈θ₁ SigS∈θ₂ eq₁ eq₂ (λ ()) })
blocked-dec θ A (present S ∣⇒ p ∣⇒ q) | yes SigS∈θ₁ | Signal.absent | Reveal_·_is_.[ eq₁ ] =
  no (λ { (bsig-exists .S SigS∈θ₂ eq₂) → lookup-S-eq θ S SigS∈θ₁ SigS∈θ₂ eq₁ eq₂ (λ ()) } )
blocked-dec θ A (present S ∣⇒ p ∣⇒ q) | yes SigS∈θ | Signal.unknown | Reveal_·_is_.[ eq ] =
  yes (bsig-exists S SigS∈θ eq)
blocked-dec θ A (present S ∣⇒ p ∣⇒ q) | no ¬SigS∈θ =
  no (λ { (bsig-exists .S S∈ _) → ¬SigS∈θ S∈ })
blocked-dec θ GO (emit S) = no (λ ())
blocked-dec θ WAIT (emit S) = yes bwemit
blocked-dec θ A (p ∥ q) with blocked-dec θ A p | blocked-dec θ A q
blocked-dec θ A (p ∥ q) | yes blockedp | yes blockedq =
  yes (bpar-both blockedp blockedq)
blocked-dec θ A (p ∥ q) | yes blockedp | no ¬blockedq with done-dec q
blocked-dec θ A (p ∥ q) | yes blockedp | no ¬blockedq | yes donep =
  yes (bpar-left blockedp donep)
blocked-dec θ A (p ∥ q) | yes blockedp | no ¬blockedq | no ¬donep =
  no (λ { (bpar-both  _ x) → ¬blockedq x ;
          (bpar-left  _ x) → ¬donep x ;
          (bpar-right _ x) → ¬blockedq x })
blocked-dec θ A (p ∥ q) | no ¬blockedp | yes blockedq with done-dec p
blocked-dec θ A (p ∥ q) | no ¬blockedp | yes blockedq | yes donep =
  yes (bpar-right donep blockedq)
blocked-dec θ A (p ∥ q) | no ¬blockedp | yes blockedq | no ¬donep =
  no (λ { (bpar-both  x _) → ¬blockedp x ;
          (bpar-left  x _) → ¬blockedp x ;
          (bpar-right x _) → ¬donep x })
blocked-dec θ A (p ∥ q) | no ¬blockedp | no ¬blockedq =
  no (λ { (bpar-both  _ x) → ¬blockedq x ;
          (bpar-left  x _) → ¬blockedp x ;
          (bpar-right _ x) → ¬blockedq x })
blocked-dec θ A (loop p) = no (λ ())
blocked-dec θ A (p >> q) with blocked-dec θ A p
blocked-dec θ A (p >> q) | yes blockedp = yes (bseq blockedp)
blocked-dec θ A (p >> q) | no ¬blockedp = no (λ { (bseq x) → ¬blockedp x })
blocked-dec θ A (loopˢ p q) with blocked-dec θ A p
blocked-dec θ A (loopˢ p q) | yes blockedp = yes (bloopˢ blockedp)
blocked-dec θ A (loopˢ p q) | no ¬blockedp = no (λ { (bloopˢ x) → ¬blockedp x })
blocked-dec θ A (suspend p S) with blocked-dec θ A p
blocked-dec θ A (suspend p S) | yes blockedp = yes (bsusp blockedp)
blocked-dec θ A (suspend p S) | no ¬blockedp = no (λ { (bsusp x) → ¬blockedp x })
blocked-dec θ A (trap p) with blocked-dec θ A p
blocked-dec θ A (trap p) | yes blockedp = yes (btrap blockedp)
blocked-dec θ A (trap p) | no ¬blockedp = no (λ { (btrap x) → ¬blockedp x })
blocked-dec θ A (exit x) = no (λ ())
blocked-dec θ A (shared s ≔ e in: p) with blocked-e-dec θ e
blocked-dec θ A (shared s ≔ e in: p) | yes blockede = yes (bshared blockede)
blocked-dec θ A (shared s ≔ e in: p) | no ¬blockede = no (λ { (bshared x) → ¬blockede x })
blocked-dec θ A (s ⇐ e) with blocked-e-dec θ e
blocked-dec θ A (s ⇐ e) | yes p = yes (bsset p)
blocked-dec θ GO (s ⇐ e) | no ¬p = no (λ { (bsset x) → ¬p x })
blocked-dec θ WAIT (s ⇐ e) | no ¬p = yes bwset
blocked-dec θ A (var x ≔ e in: p) with blocked-e-dec θ e
blocked-dec θ A (var x ≔ e in: p₁) | yes p = yes (bvar p)
blocked-dec θ A (var x ≔ e in: p) | no ¬p = no (λ { (bvar x₁) → ¬p x₁ })
blocked-dec θ A (x ≔ e) with blocked-e-dec θ e
blocked-dec θ A (x ≔ e) | yes p = yes (bxset p)
blocked-dec θ A (x ≔ e) | no ¬p = no (λ { (bxset x₁) → ¬p x₁ })
blocked-dec θ A (if x ∣⇒ p ∣⇒ p₁) = no (λ ())
blocked-dec θ A (ρ⟨ θ₁ , A₁ ⟩· p) = no (λ ())


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

module Definition.Conversion.Lift where

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.Conversion
open import Definition.Conversion.Whnf
open import Definition.Conversion.Soundness
open import Definition.Conversion.Weakening
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Fundamental.Reducibility
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Reduction

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Lifting of algorithmic equality of types from WHNF to generic types.
liftConv : ∀ {A B Γ}
          → Γ ⊢ A [conv↓] B
          → Γ ⊢ A [conv↑] B
liftConv A<>B =
  let ⊢A , ⊢B = syntacticEq (soundnessConv↓ A<>B)
      whnfA , whnfB = whnfConv↓ A<>B
  in  [↑] _ _ (id ⊢A) (id ⊢B) whnfA whnfB A<>B

-- Lifting of algorithmic equality of terms from WHNF to generic terms.
liftConvTerm : ∀ {t u A Γ}
             → Γ ⊢ t [conv↓] u ∷ A
             → Γ ⊢ t [conv↑] u ∷ A
liftConvTerm t<>u =
  let ⊢A , ⊢t , ⊢u = syntacticEqTerm (soundnessConv↓Term t<>u)
      whnfA , whnfT , whnfU = whnfConv↓Term t<>u
  in  [↑]ₜ _ _ _ (id ⊢A) (id ⊢t) (id ⊢u) whnfA whnfT whnfU t<>u

mutual
  -- Helper function for lifting from neutrals to generic terms in WHNF.
  lift~toConv↓′ : ∀ {t u A A′ Γ l}
                → Γ ⊩⟨ l ⟩ A′
                → Γ ⊢ A′ ⇒* A
                → Γ ⊢ t ~ u ↓ A
                → Γ ⊢ t [conv↓] u ∷ A
  lift~toConv↓′ (Uᵣ′ .⁰ 0<1 ⊢Γ) D ([~] A D₁ whnfB k~l)
                rewrite PE.sym (whnfRed* D Uₙ) =
    let _ , ⊢t , ⊢u = syntacticEqTerm (conv (soundness~↑ k~l) (subset* D₁))
    in  univ ⊢t ⊢u (ne ([~] A D₁ Uₙ k~l))
  lift~toConv↓′ (ℕᵣ D) D₁ ([~] A D₂ whnfB k~l)
                rewrite PE.sym (whrDet* (red D , ℕₙ) (D₁ , whnfB)) =
    ℕ-ins ([~] A D₂ ℕₙ k~l)
  lift~toConv↓′ (Emptyᵣ D) D₁ ([~] A D₂ whnfB k~l)
                rewrite PE.sym (whrDet* (red D , Emptyₙ) (D₁ , whnfB)) =
    Empty-ins ([~] A D₂ Emptyₙ k~l)
  lift~toConv↓′ (Unitᵣ D) D₁ ([~] A D₂ whnfB k~l)
                rewrite PE.sym (whrDet* (red D , Unitₙ) (D₁ , whnfB)) =
    Unit-ins ([~] A D₂ Unitₙ k~l)
  lift~toConv↓′ (ne′ K D neK K≡K) D₁ ([~] A D₂ whnfB k~l)
                rewrite PE.sym (whrDet* (red D , ne neK) (D₁ , whnfB)) =
    let _ , ⊢t , ⊢u = syntacticEqTerm (soundness~↑ k~l)
        A≡K = subset* D₂
    in  ne-ins (conv ⊢t A≡K) (conv ⊢u A≡K) neK ([~] A D₂ (ne neK) k~l)
  lift~toConv↓′ (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) D₁ ([~] A D₂ whnfB k~l)
                rewrite PE.sym (whrDet* (red D , Πₙ) (D₁ , whnfB)) =
    let ⊢ΠFG , ⊢t , ⊢u = syntacticEqTerm (soundness~↓ ([~] A D₂ Πₙ k~l))
        ⊢F , ⊢G = syntacticΠ ⊢ΠFG
        neT , neU = ne~↑ k~l
        ⊢Γ = wf ⊢F
        var0 = neuTerm ([F] (step id) (⊢Γ ∙ ⊢F)) (var 0) (var (⊢Γ ∙ ⊢F) here)
                       (refl (var (⊢Γ ∙ ⊢F) here))
        0≡0 = lift~toConv↑′ ([F] (step id) (⊢Γ ∙ ⊢F)) (var-refl (var (⊢Γ ∙ ⊢F) here) PE.refl)
        k∘0≡l∘0 = lift~toConv↑′ ([G] (step id) (⊢Γ ∙ ⊢F) var0)
                                (app-cong (wk~↓ (step id) (⊢Γ ∙ ⊢F) ([~] A D₂ Πₙ k~l))
                                          0≡0)
    in  η-eq ⊢t ⊢u (ne neT) (ne neU)
             (PE.subst (λ x → _ ⊢ _ [conv↑] _ ∷ x)
                       (wkSingleSubstId _)
                       k∘0≡l∘0)
  lift~toConv↓′ (Σᵣ′ F G D ⊢F ⊢G Σ≡Σ [F] [G] G-ext) D₁ ([~] A″ D₂ whnfA t~u)
                rewrite PE.sym (whrDet* (red D , Σₙ) (D₁ , whnfA)) {- Σ F ▹ G ≡ A -} =
    let neT , neU = ne~↑ t~u
        t~u↓ = [~] A″ D₂ Σₙ t~u
        ⊢ΣFG , ⊢t , ⊢u = syntacticEqTerm (soundness~↓ t~u↓)
        ⊢F , ⊢G = syntacticΣ ⊢ΣFG
        ⊢Γ = wf ⊢F

        wkId = wk-id F
        wkLiftId = PE.cong (λ x → x [ fst _ ]) (wk-lift-id G)

        wk[F] = [F] id ⊢Γ
        wk⊢fst = PE.subst (λ x → _ ⊢ _ ∷ x) (PE.sym wkId) (fstⱼ ⊢F ⊢G ⊢t)
        wkfst≡ = PE.subst (λ x → _ ⊢ _ ≡ _ ∷ x) (PE.sym wkId) (fst-cong ⊢F ⊢G (refl ⊢t))
        wk[fst] = neuTerm wk[F] (fstₙ neT) wk⊢fst wkfst≡
        wk[Gfst] = [G] id ⊢Γ wk[fst]

        wkfst~ = PE.subst (λ x → _ ⊢ _ ~ _ ↑ x) (PE.sym wkId) (fst-cong t~u↓)
        wksnd~ = PE.subst (λ x → _ ⊢ _ ~ _ ↑ x) (PE.sym wkLiftId) (snd-cong t~u↓)
    in  Σ-η ⊢t ⊢u (ne neT) (ne neU)
            (PE.subst (λ x → _ ⊢ _ [conv↑] _ ∷ x) wkId
                      (lift~toConv↑′ wk[F] wkfst~))
            (PE.subst (λ x → _ ⊢ _ [conv↑] _ ∷ x) wkLiftId
                      (lift~toConv↑′ wk[Gfst] wksnd~))
  lift~toConv↓′ (emb 0<1 [A]) D t~u = lift~toConv↓′ [A] D t~u

  -- Helper function for lifting from neutrals to generic terms.
  lift~toConv↑′ : ∀ {t u A Γ l}
                → Γ ⊩⟨ l ⟩ A
                → Γ ⊢ t ~ u ↑ A
                → Γ ⊢ t [conv↑] u ∷ A
  lift~toConv↑′ [A] t~u =
    let B , whnfB , D = whNorm′ [A]
        t~u↓ = [~] _ (red D) whnfB t~u
        neT , neU = ne~↑ t~u
        _ , ⊢t , ⊢u = syntacticEqTerm (soundness~↓ t~u↓)
    in  [↑]ₜ _ _ _ (red D) (id ⊢t) (id ⊢u) whnfB
             (ne neT) (ne neU) (lift~toConv↓′ [A] (red D) t~u↓)

-- Lifting of algorithmic equality of terms from neutrals to generic terms in WHNF.
lift~toConv↓ : ∀ {t u A Γ}
             → Γ ⊢ t ~ u ↓ A
             → Γ ⊢ t [conv↓] u ∷ A
lift~toConv↓ ([~] A₁ D whnfB k~l) =
  lift~toConv↓′ (reducible (proj₁ (syntacticRed D))) D ([~] A₁ D whnfB k~l)

-- Lifting of algorithmic equality of terms from neutrals to generic terms.
lift~toConv↑ : ∀ {t u A Γ}
             → Γ ⊢ t ~ u ↑ A
             → Γ ⊢ t [conv↑] u ∷ A
lift~toConv↑ t~u =
  lift~toConv↑′ (reducible (proj₁ (syntacticEqTerm (soundness~↑ t~u)))) t~u


module sn-calculus-compatconf.in-lift where

open import sn-calculus-compatconf.base

open import sn-calculus
open import utility renaming (_U̬_ to _∪_)
open import context-properties
  using (get-view ; wrap-rho ; unwrap-rho
       ; ->E-view ; E-view-main-bind ; _a~_
       ; ->E-view-term ; ->E-view-inner-term ; done-E-view-term-disjoint)

open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.Binding
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Context.Properties
  using (plug)
open import Esterel.Environment as Env
  using (Env ; []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 Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; cong ; trans ; subst ; module ≡-Reasoning)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; _∷_ ; [] ; _++_ ; map)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; _,′_ ; proj₁ ; proj₂ ; _×_ ; ∃)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)

open ->E-view

open EvaluationContext1
open _≐_⟦_⟧e
open Context1
open _≐_⟦_⟧c

{-
Base case where (E , C) = (_∷_ , []). LHS is arbitrary ->E-view reduction
and RHS is a merge. This case is delegated to R-confluence.

     p
  ρθ. E⟦E₁⟦qin⟧⟧       -- sn⟶₁ ->    ρθq. E⟦E₁⟦qo⟧⟧
 (ρθ) E⟦E₂⟦ρθ'.rin⟧⟧   -- sn⟶₁ ->   (ρθ)  E⟦ρθ'.E₂⟦rin⟧⟧
-}
1-steplρ-E-view-ecin-lift : ∀{E E₁ Ei p qin q qo rin r ro θ θq BV FV A Aq} →
  {ρθ·psn⟶₁ρθq·q  :  ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θq  , Aq ⟩· q} →
  CorrectBinding p BV FV →

  (p≐E⟦qin⟧  :  p ≐ (E ++ (E₁ ∷ Ei)) ⟦ qin ⟧e) →
  (q≐E⟦qo⟧   :  q ≐ (E ++ (E₁ ∷ Ei)) ⟦ qo ⟧e) →
  ->E-view  ρθ·psn⟶₁ρθq·q  p≐E⟦qin⟧  q≐E⟦qo⟧ →

  (p≐E⟦rin⟧  :  p ≐ (map ceval E) ⟦ rin ⟧c) →
  (r≐E⟦ro⟧   :  r ≐ (map ceval E) ⟦ ro ⟧c) →
  (rinsn⟶₁ro  :  rin sn⟶₁ ro) →

  ⊥

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (depar₁ p'≐E⟦qin⟧) q≐E⟦qo⟧ e-view dchole dchole
  (rpar-done-right p'/halted q'/done) =
         (done-E-view-term-disjoint
           (dhalted (halted-⟦⟧e p'/halted p'≐E⟦qin⟧))
           (->E-view-inner-term e-view))

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (depar₂ q'≐E⟦qin⟧) q≐E⟦qo⟧ e-view dchole dchole
  (rpar-done-right p'/halted q'/done) =
         (done-E-view-term-disjoint
           (done-⟦⟧e q'/done q'≐E⟦qin⟧)
           (->E-view-inner-term e-view))

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (depar₁ p'≐E⟦qin⟧) q≐E⟦qo⟧ e-view dchole dchole
  (rpar-done-left p'/done q'/halted) =
         (done-E-view-term-disjoint
           (done-⟦⟧e p'/done p'≐E⟦qin⟧)
           (->E-view-inner-term e-view))

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (depar₂ q'≐E⟦qin⟧) q≐E⟦qo⟧ e-view dchole dchole
  (rpar-done-left p'/done q'/halted) =
         (done-E-view-term-disjoint
           (dhalted (halted-⟦⟧e q'/halted q'≐E⟦qin⟧))
           (->E-view-inner-term e-view))

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (deseq dehole) q≐E⟦qo⟧ () dchole dchole
  rseq-done

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (deseq dehole) q≐E⟦qo⟧ () dchole dchole
  rseq-exit

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (deloopˢ dehole) q≐E⟦qo⟧ () dchole dchole
  rloopˢ-exit

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (desuspend p≐E⟦qin⟧) q≐E⟦qo⟧ e-view dchole dchole
  (rsuspend-done p/halted) =
         (done-E-view-term-disjoint
           (dhalted (halted-⟦⟧e p/halted p≐E⟦qin⟧))
           (->E-view-inner-term e-view))

1-steplρ-E-view-ecin-lift {[]} {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  (detrap p≐E⟦qin⟧) q≐E⟦qo⟧ e-view dchole dchole
  (rtrap-done p/halted) =
         (done-E-view-term-disjoint
           (dhalted (halted-⟦⟧e p/halted p≐E⟦qin⟧))
           (->E-view-inner-term e-view))

1-steplρ-E-view-ecin-lift {E₁ ∷ E} {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBpar cbp cbq _ _ _ _)
  (depar₁ p≐E⟦qin⟧) (depar₁ q≐E⟦qo⟧) e-view-E₁
  (dcpar₁ p≐E⟦rin⟧) (dcpar₁ r≐E⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧ (depar₁ p≐E⟦qin⟧) (depar₁ q≐E⟦qo⟧)
         p≐E⟦qin⟧ q≐E⟦qo⟧ e-view-E₁
... | (ρθ·psn⟶₁ρθq·q , e-view) =
  1-steplρ-E-view-ecin-lift cbp p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐E⟦rin⟧ r≐E⟦ro⟧ rinsn⟶₁ro

1-steplρ-E-view-ecin-lift {E₁ ∷ E} {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBpar cbp cbq _ _ _ _)
  (depar₂ p≐E⟦qin⟧) (depar₂ q≐E⟦qo⟧) e-view-E₁
  (dcpar₂ p≐E⟦rin⟧) (dcpar₂ r≐E⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧ (depar₂ p≐E⟦qin⟧) (depar₂ q≐E⟦qo⟧)
         p≐E⟦qin⟧ q≐E⟦qo⟧ e-view-E₁
... | (ρθ·psn⟶₁ρθq·q , e-view) =
  1-steplρ-E-view-ecin-lift cbq p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐E⟦rin⟧ r≐E⟦ro⟧ rinsn⟶₁ro

1-steplρ-E-view-ecin-lift {E₁ ∷ E} {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBseq cbp cbq _)
  (deseq p≐E⟦qin⟧) (deseq q≐E⟦qo⟧) e-view-E₁
  (dcseq₁ p≐E⟦rin⟧) (dcseq₁ r≐E⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧ (deseq p≐E⟦qin⟧) (deseq q≐E⟦qo⟧)
         p≐E⟦qin⟧ q≐E⟦qo⟧ e-view-E₁
... | (ρθ·psn⟶₁ρθq·q , e-view) =
  1-steplρ-E-view-ecin-lift cbp p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐E⟦rin⟧ r≐E⟦ro⟧ rinsn⟶₁ro

1-steplρ-E-view-ecin-lift {E₁ ∷ E} {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBloopˢ cbp cbq _ _)
  (deloopˢ p≐E⟦qin⟧) (deloopˢ q≐E⟦qo⟧) e-view-E₁
  (dcloopˢ₁ p≐E⟦rin⟧) (dcloopˢ₁ r≐E⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧ (deloopˢ p≐E⟦qin⟧) (deloopˢ q≐E⟦qo⟧)
         p≐E⟦qin⟧ q≐E⟦qo⟧ e-view-E₁
... | (ρθ·psn⟶₁ρθq·q , e-view) =
  1-steplρ-E-view-ecin-lift cbp p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐E⟦rin⟧ r≐E⟦ro⟧ rinsn⟶₁ro

1-steplρ-E-view-ecin-lift {E₁ ∷ E} {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBsusp cb' _)
  (desuspend p≐E⟦qin⟧) (desuspend q≐E⟦qo⟧) e-view-E₁
  (dcsuspend p≐E⟦rin⟧) (dcsuspend r≐E⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧ (desuspend p≐E⟦qin⟧) (desuspend q≐E⟦qo⟧)
         p≐E⟦qin⟧ q≐E⟦qo⟧ e-view-E₁
... | (ρθ·psn⟶₁ρθq·q , e-view) =
  1-steplρ-E-view-ecin-lift cb' p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐E⟦rin⟧ r≐E⟦ro⟧ rinsn⟶₁ro

1-steplρ-E-view-ecin-lift {E₁ ∷ E} {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBtrap cb')
  (detrap p≐E⟦qin⟧) (detrap q≐E⟦qo⟧) e-view-E₁
  (dctrap p≐E⟦rin⟧) (dctrap r≐E⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧ (detrap p≐E⟦qin⟧) (detrap q≐E⟦qo⟧)
         p≐E⟦qin⟧ q≐E⟦qo⟧ e-view-E₁
... | (ρθ·psn⟶₁ρθq·q , e-view) =
  1-steplρ-E-view-ecin-lift cb' p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐E⟦rin⟧ r≐E⟦ro⟧ rinsn⟶₁ro


module _ where

open import utility

open import Function using (_∘_)
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
  using (Canₛ ; Canₛₕ)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; module SigMap ; module ShrMap ; module VarMap ; []env ; sig-stats ; Dom)
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Context.Properties
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 Relation.Nullary
  using (¬_ ; yes ; no)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl)
open import Data.Empty
  using (⊥ ; ⊥-elim)
import Data.FiniteMap
open import Data.List
  using (List ; _∷_ ; [] ; _++_)
open import Data.List.All as All
  using (All ; _∷_ ; [])
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; proj₁ ; proj₂ ; _×_ ; _,′_ ; ∃ )
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Relation.Binary.PropositionalEquality
open import Esterel.Lang.Binding
-- open import coherence
open import blocked
open import sn-calculus
open import par-swap
open import calculus

open _≐_⟦_⟧e
open _≐_⟦_⟧c

open EvaluationContext1
open Context1

open import Data.Maybe

sn≡ₑ-context : ∀ p q C ->
             (∀ p BVp FVp -> CorrectBinding p BVp FVp -> CB (C ⟦ p ⟧c)) ->
             p sn≡ₑ q -> (C ⟦ p ⟧c) sn≡ₑ (C ⟦ q ⟧c)
sn≡ₑ-context p q C CBfill (rstp psn⟶q) = rstp (Context-sn⟶⟦⟧ C psn⟶q)
sn≡ₑ-context p q C CBfill (rsym{p = .q}{BV = BV} {FV} psn≡ₑq CBq) with sn≡ₑ-context q p C CBfill psn≡ₑq
... | C⟦q⟧csn≡ₑC⟦p⟧c = rsym C⟦q⟧csn≡ₑC⟦p⟧c (CBfill q BV FV CBq)
sn≡ₑ-context p .p C _ rref = rref
sn≡ₑ-context p q C CBfill (rtrn{r = r} psn≡ₑr rsn≡ₑq) with
    sn≡ₑ-context p r C CBfill psn≡ₑr | sn≡ₑ-context r q C CBfill rsn≡ₑq
... | C⟦p⟧csn≡ₑC⟦r⟧c | C⟦r⟧csn≡ₑC⟦q⟧c = rtrn {r = C ⟦ r ⟧c} C⟦p⟧csn≡ₑC⟦r⟧c C⟦r⟧csn≡ₑC⟦q⟧c

sn≡ₑ-sn⟶* : ∀ {p q} -> p sn⟶* q -> p sn≡ₑ q
sn≡ₑ-sn⟶* rrefl = rref
sn≡ₑ-sn⟶* (rstep psn⟶q psn⟶*q) = rtrn (rstp psn⟶q) (sn≡ₑ-sn⟶* psn⟶*q)

≡ₑ-context :
  ∀ {p q} -> ∀ C1 C2 ->
   (∀ {r r′ BVp FVp} -> CorrectBinding r BVp FVp -> r′ ≐ C2 ⟦ r ⟧c -> CB r′) ->
   p ≡ₑ q # C1 ->
   p ≡ₑ q # (C2 ++ C1)
≡ₑ-context C C′ CBfill ≡ₑrefl = ≡ₑrefl
≡ₑ-context C C′ CBfill (≡ₑtran p≡ₑr r≡ₑq)
  with ≡ₑ-context C C′ CBfill p≡ₑr
... | p≡ₑr#C
  with ≡ₑ-context C C′ CBfill r≡ₑq
... | r≡ₑq#C = ≡ₑtran p≡ₑr#C r≡ₑq#C
≡ₑ-context C C′ CBfill (≡ₑsymm{q = q} CBq p≡ₑq)
  with ≡ₑ-context C C′ CBfill p≡ₑq
... | q≡ₑp#C = ≡ₑsymm (CBfill CBq (++-is-nesting C′ C _)) q≡ₑp#C
≡ₑ-context C1 C2 CBfill (≡ₑctxt{_}{C''} C′⟦p⟧≐C′⟦p⟧c C′⟦q⟧≐C′⟦q⟧c p≡ₑq)
  with ≡ₑ-context (C1 ++ C'') C2  wrapCBfill p≡ₑq where
      wrapCBfill : ∀ {r r′ BVp FVp} ->
        CorrectBinding r BVp FVp ->
        r′ ≐ C2 ⟦ r ⟧c ->
        CB r′
      wrapCBfill{r} CB C′⟦r⟧c = CBfill CB C′⟦r⟧c
... | p≡ₑq#[C′++C++C''] rewrite sym (++-assoc C2 C1 C'')
  =  ≡ₑctxt C′⟦p⟧≐C′⟦p⟧c C′⟦q⟧≐C′⟦q⟧c p≡ₑq#[C′++C++C'']
≡ₑ-context C C′ CBfill (≡ₑstep p⟶₁q)
  = ≡ₑstep p⟶₁q

θ-present-signals : Env → List Signal
θ-present-signals θ = Data.List.mapMaybe (f ∘ _ₛ) DomS
  where
    DomS = (fst (Env.Dom θ))
    f : Signal → Maybe Signal
    f S with (Env.Sig∈ S θ)
    ... | (no S∈) = nothing
    ... | (yes S∈) with sig-stats{S} θ S∈
    ... | Signal.present = just S
    ... | Signal.absent = nothing
    ... | Signal.unknown = nothing

get-signals : Term → List Signal
get-signals nothin = []
get-signals pause = []
get-signals (signl S p) = []
get-signals (present S ∣⇒ p ∣⇒ p₁) = []
get-signals (emit S) = []
get-signals (p ∥ p₁) = []
get-signals (loop p) = []
get-signals (loopˢ p q) = []
get-signals (p >> p₁) = []
get-signals (suspend p S) = []
get-signals (trap p) = []
get-signals (exit x) = []
get-signals (shared s ≔ e in: p) = []
get-signals (s ⇐ e) = []
get-signals (var x ≔ e in: p) = []
get-signals (x ≔ e) = []
get-signals (if x ∣⇒ p ∣⇒ p₁) = []
get-signals (ρ⟨ θ , A ⟩· p) = θ-present-signals θ

data eval-result : Set where
   output : List Signal → eval-result

data non-constructive : Env → Term → Set where
  nc : ∀{p θ} → (Σ (Env × Term) λ {(θq , q) → (ρ⟨ θ , GO ⟩· p) sn≡ₑ (ρ⟨ θq , GO ⟩· q) × (manifests-as-non-constructive θq GO q)})
              → non-constructive θ p

data evalsn≡ₑ : Term → Env → eval-result → Set where
   evalsn-complete : ∀{p q θ θq} →
     (ρθ·p≡q : (ρ⟨ θ , GO ⟩· p) sn≡ₑ (ρ⟨ θq , GO ⟩· q)) →
     (complete-q : complete (ρ⟨ θq , GO ⟩· q)) →
     evalsn≡ₑ p θ (output (get-signals (ρ⟨ θq , GO ⟩· q)))

data eval∥R∪sn≡ₑ : Term → Env → eval-result → Set where
   eval∥R∪sn-complete : ∀{p q θ θq} →
     (ρθ·p≡q : (ρ⟨ θ , GO ⟩· p) ∥R∪sn≡ₑ (ρ⟨ θq , GO ⟩· q)) →
     (complete-q : complete (ρ⟨ θq , GO ⟩· q)) →
     eval∥R∪sn≡ₑ p θ (output (get-signals (ρ⟨ θq , GO ⟩· q)))

data eval≡ₑ : Term → Env → eval-result → Set where
   eval-complete : ∀{p q θ θq} →
     (ρθ·p≡q : (ρ⟨ θ , GO ⟩· p) ≡ₑ (ρ⟨ θq , GO ⟩· q) # []) →
     (complete-q : complete (ρ⟨ θq , GO ⟩· q)) →
     eval≡ₑ p θ (output (get-signals (ρ⟨ θq , GO ⟩· q)))


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

open import lib.Basics
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.CommutingSquare

module lib.types.Span where

record Span {i j k : ULevel} : Type (lsucc (lmax (lmax i j) k)) where
  constructor span
  field
    A : Type i
    B : Type j
    C : Type k
    f : C → A
    g : C → B

private
  span=-raw : ∀ {i j k} {A A' : Type i} (p : A == A')
    {B B' : Type j} (q : B == B') {C C' : Type k} (r : C == C')
    {f : C → A} {f' : C' → A'}
    (s : f == f' [ (λ CA → fst CA → snd CA) ↓ pair×= r p ])
    {g : C → B} {g' : C' → B'}
    (t : g == g' [ (λ CB → fst CB → snd CB) ↓ pair×= r q ])
    → (span A B C f g) == (span A' B' C' f' g')
  span=-raw idp idp idp idp idp = idp

abstract
  span= : ∀ {i j k} {A A' : Type i} (p : A ≃ A')
    {B B' : Type j} (q : B ≃ B') {C C' : Type k} (r : C ≃ C')
    {f : C → A} {f' : C' → A'} (s : (a : C) → (–> p) (f a) == f' (–> r a))
    {g : C → B} {g' : C' → B'} (t : (b : C) → (–> q) (g b) == g' (–> r b))
    → (span A B C f g) == (span A' B' C' f' g')
  span= p q r {f} {f'} s {g} {g'} t = span=-raw
    (ua p)
    (ua q)
    (ua r)
    (↓-→-in (λ α → ↓-snd×-in (ua r) (ua p) (↓-idf-ua-in p (
                   s _
                   ∙ ap f' (↓-idf-ua-out r (↓-fst×-out (ua r) (ua p) α))))))
    (↓-→-in (λ β → ↓-snd×-in (ua r) (ua q) (↓-idf-ua-in q (
                   t _
                   ∙ ap g' (↓-idf-ua-out r (↓-fst×-out (ua r) (ua q) β))))))

record ⊙Span {i j k : ULevel} : Type (lsucc (lmax (lmax i j) k)) where
  constructor ⊙span
  field
    X : Ptd i
    Y : Ptd j
    Z : Ptd k
    f : Z ⊙→ X
    g : Z ⊙→ Y

⊙Span-to-Span : ∀ {i j k} → ⊙Span {i} {j} {k} → Span {i} {j} {k}
⊙Span-to-Span (⊙span X Y Z f g) = span (de⊙ X) (de⊙ Y) (de⊙ Z) (fst f) (fst g)

{- Helper for path induction on pointed spans -}
⊙span-J : ∀ {i j k l} (P : ⊙Span {i} {j} {k} → Type l)
  → ({A : Type i} {B : Type j} {Z : Ptd k} (f : de⊙ Z → A) (g : de⊙ Z → B)
     → P (⊙span ⊙[ A , f (pt Z) ] ⊙[ B , g (pt Z) ] Z (f , idp) (g , idp)))
  → Π ⊙Span P
⊙span-J P t (⊙span ⊙[ A , ._ ] ⊙[ B , ._ ] Z (f , idp) (g , idp)) = t f g

{- Span-flipping functions -}
Span-flip : ∀ {i j k} → Span {i} {j} {k} → Span {j} {i} {k}
Span-flip (span A B C f g) = span B A C g f

⊙Span-flip : ∀ {i j k} → ⊙Span {i} {j} {k} → ⊙Span {j} {i} {k}
⊙Span-flip (⊙span X Y Z f g) = ⊙span Y X Z g f

record SpanMap {i₀ j₀ k₀ i₁ j₁ k₁} (span₀ : Span {i₀} {j₀} {k₀}) (span₁ : Span {i₁} {j₁} {k₁})
  : Type (lmax (lmax (lmax i₀ j₀) k₀) (lmax (lmax i₁ j₁) k₁)) where
  constructor span-map
  module span₀ = Span span₀
  module span₁ = Span span₁
  field
    hA : span₀.A → span₁.A
    hB : span₀.B → span₁.B
    hC : span₀.C → span₁.C
    f-commutes : CommSquare span₀.f span₁.f hC hA
    g-commutes : CommSquare span₀.g span₁.g hC hB

SpanMap-∘ : ∀ {i₀ j₀ k₀ i₁ j₁ k₁ i₂ j₂ k₂} {span₀ : Span {i₀} {j₀} {k₀}}
  {span₁ : Span {i₁} {j₁} {k₁}} {span₂ : Span {i₂} {j₂} {k₂}}
  → SpanMap span₁ span₂ → SpanMap span₀ span₁ → SpanMap span₀ span₂
SpanMap-∘ span-map₁₂ span-map₀₁ = record {
  hA = span-map₁₂.hA ∘ span-map₀₁.hA;
  hB = span-map₁₂.hB ∘ span-map₀₁.hB;
  hC = span-map₁₂.hC ∘ span-map₀₁.hC;
  f-commutes = CommSquare-∘v span-map₁₂.f-commutes span-map₀₁.f-commutes;
  g-commutes = CommSquare-∘v span-map₁₂.g-commutes span-map₀₁.g-commutes}
  where module span-map₀₁ = SpanMap span-map₀₁
        module span-map₁₂ = SpanMap span-map₁₂

SpanEquiv : ∀ {i₀ j₀ k₀ i₁ j₁ k₁} (span₀ : Span {i₀} {j₀} {k₀}) (span₁ : Span {i₁} {j₁} {k₁})
  → Type (lmax (lmax (lmax i₀ j₀) k₀) (lmax (lmax i₁ j₁) k₁))
SpanEquiv span₀ span₁ = Σ (SpanMap span₀ span₁)
  (λ span-map → is-equiv (SpanMap.hA span-map)
              × is-equiv (SpanMap.hB span-map)
              × is-equiv (SpanMap.hC span-map))

SpanEquiv-inverse : ∀ {i₀ j₀ k₀ i₁ j₁ k₁} {span₀ : Span {i₀} {j₀} {k₀}} {span₁ : Span {i₁} {j₁} {k₁}}
  → SpanEquiv span₀ span₁ → SpanEquiv span₁ span₀
SpanEquiv-inverse (span-map hA hB hC f-commutes g-commutes , hA-ise , hB-ise , hC-ise)
  = ( span-map hA.g hB.g hC.g
      (CommSquare-inverse-v f-commutes hC-ise hA-ise)
      (CommSquare-inverse-v g-commutes hC-ise hB-ise)
    , ( is-equiv-inverse hA-ise
      , is-equiv-inverse hB-ise
      , is-equiv-inverse hC-ise))
  where module hA = is-equiv hA-ise
        module hB = is-equiv hB-ise
        module hC = is-equiv hC-ise


module sn-calculus-compatconf.eview where

open import sn-calculus-compatconf.base
open import sn-calculus-compatconf.in-lift  using (1-steplρ-E-view-ecin-lift)
open import sn-calculus-compatconf.split    using (1-steplρ-E-view-ecsplit)
open import sn-calculus-compatconf.same     using (1-steplρ-E-view-ecsame)

open import sn-calculus
open import utility renaming (_U̬_ to _∪_)
open import context-properties
  using (get-view ; ->E-view ; ->pot-view)

open import sn-calculus-confluence
  using (R-confluent)

open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.Binding
open import Esterel.Lang.CanFunction
  using (Can ; Canₛ ; Canₛₕ ; Canₖ ; module CodeSet)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; Dom ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Context.Properties
  using (plugc)
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
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 Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; cong ; trans ; subst ; module ≡-Reasoning)
open import Data.Bool
  using (Bool ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; _∷_ ; [] ; _++_)
open import Data.List.Any
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties
  using ()
  renaming ( ++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ )
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_) renaming (_⊔_ to _⊔ℕ_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; _,′_ ; proj₁ ; proj₂ ; _×_ ; ∃ ; map)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function using (_∘_ ; id ; _∋_)

open import Data.OrderedListMap Signal Signal.unwrap Signal.Status as SigM
open import Data.OrderedListMap SharedVar SharedVar.unwrap (Σ SharedVar.Status (λ _ → ℕ)) as ShrM
open import Data.OrderedListMap SeqVar SeqVar.unwrap ℕ as SeqM

open ->E-view
open ->pot-view

open EvaluationContext1
open _≐_⟦_⟧e
open Context1
open _≐_⟦_⟧c

open ListSet Data.Nat._≟_

{-
     p
  ρθ. E⟦qin⟧   -- sn⟶₁ ->    ρθq. E⟦qo⟧
 (ρθ) C⟦rin⟧   -- sn⟶  ->   (ρθ)  C⟦ro⟧
-}
1-steplρ-E-view : ∀{E C p qin q qo rin ro θ θq BV FV A Aq} →
  {ρθ·psn⟶₁ρθq·q  :  ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θq , Aq ⟩· q} →
  CorrectBinding (ρ⟨ θ , A ⟩· p) BV FV →

  (p≐E⟦qin⟧  :  p ≐ E ⟦ qin ⟧e) →
  (q≐E⟦qo⟧   :  q ≐ E ⟦ qo ⟧e) →
  ->E-view  ρθ·psn⟶₁ρθq·q  p≐E⟦qin⟧  q≐E⟦qo⟧ →

  (p≐E⟦rin⟧  :  p ≐ C ⟦ rin ⟧c) →
  (rinsn⟶₁ro  :  rin sn⟶₁ ro) →

  ∃ λ { (θo , Ao , po) →
    (ρ⟨ θq , Aq ⟩· q        sn⟶* ρ⟨ θo , Ao ⟩· po) ×
    (ρ⟨ θ , A ⟩· C ⟦ ro ⟧c sn⟶* ρ⟨ θo , Ao ⟩· po) }

1-steplρ-E-view (CBρ cb) p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ rinsn⟶₁ro
  with get-context-prefix p≐E⟦qin⟧ p≐C⟦rin⟧
1-steplρ-E-view (CBρ cb) p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ rinsn⟶₁ro | ecsame =
  map proj₁ (map (sn⟶*-inclusion ∘ sn⟶-inclusion) (sn⟶*-inclusion ∘ sn⟶-inclusion ∘ proj₁))
    (1-steplρ-E-view-ecsame cb p≐E⟦qin⟧ q≐E⟦qo⟧ e-view
      p≐C⟦rin⟧ (plugc refl) rinsn⟶₁ro)
1-steplρ-E-view (CBρ cb) p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ rinsn⟶₁ro | ecin-lift =
  ⊥-elim
   (1-steplρ-E-view-ecin-lift cb p≐E⟦qin⟧ q≐E⟦qo⟧ e-view
     p≐C⟦rin⟧ (plugc refl) rinsn⟶₁ro)
1-steplρ-E-view (CBρ cb) p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ rinsn⟶₁ro | ecsplit div
  with 1-steplρ-E-view-ecsplit cb div p≐E⟦qin⟧ q≐E⟦qo⟧ e-view
                                            p≐C⟦rin⟧ (plugc refl) rinsn⟶₁ro
... | po , inj₁ refl  , _ , _ , _ , ρθ·rsn⟶₁ρθq·po , e-view' =
  _ , rrefl ,′ sn⟶*-inclusion (sn⟶-inclusion ρθ·rsn⟶₁ρθq·po)
... | po , inj₂ qsn⟶po , _ , _ , _ , ρθ·rsn⟶₁ρθq·po , e-view' =
   _ , sn⟶*-inclusion (Context1-sn⟶ (cenv _ _) qsn⟶po) ,′ sn⟶*-inclusion (sn⟶-inclusion ρθ·rsn⟶₁ρθq·po)