{-# OPTIONS --rewriting  #-}
open import Reflection hiding (return; _>>=_) renaming (_≟_ to _≟r_)

open import Data.List hiding (_++_)
open import Data.Vec as V using (Vec; updateAt)
open import Data.Unit
open import Data.Nat as N
open import Data.Nat.Properties
open import Data.Fin using (Fin; #_; suc; zero)
open import Data.Maybe hiding (_>>=_; map)
open import Function
open import Data.Bool
open import Data.Product hiding (map)
open import Data.String renaming (_++_ to _++s_; concat to sconc; length to slen)
open import Data.Char renaming (_≈?_ to _c≈?_; show to showChar)

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary
open import Relation.Nullary.Decidable hiding (map)
open import Data.Nat.Show renaming (show to showNat)

open import Level renaming (zero to lzero; suc to lsuc)

open import Category.Monad using (RawMonad)

open RawMonad {{...}} public

instance
  monadMB : ∀ {f} → RawMonad {f} Maybe
  monadMB = record { return = just ; _>>=_ = Data.Maybe._>>=_ }

  monadTC : ∀ {f} → RawMonad {f} TC
  monadTC = record { return = Reflection.return ; _>>=_ = Reflection._>>=_ }

data Err {a} (A : Set a) : Set a where
  error : String → Err A
  ok : A → Err A

instance
  monadErr : ∀ {f} → RawMonad {f} Err
  monadErr = record {
    return = ok ;
    _>>=_ = λ { (error s) f → error s ; (ok a) f → f a }
    }

record RawMonoid {a}(A : Set a) : Set a where
  field
    _++_ : A → A → A
    ε : A
  ++/_ : List A → A
  ++/ [] = ε
  ++/ (x ∷ a) = x ++ ++/ a

  infixr 5 _++_

open RawMonoid {{...}} public

instance
  monoidLst : ∀ {a}{A : Set a} → RawMonoid (List A)
  monoidLst {A = A} = record {
    _++_ = Data.List._++_;
    ε = []
    }

  monoidErrLst : ∀{a}{A : Set a} → RawMonoid (Err $ List A)
  monoidErrLst = record {
    _++_ =  λ where
      (error s) _ → error s
      _ (error s) → error s
      (ok s₁) (ok s₂) → ok (s₁ ++ s₂)
    ;
    ε = ok []
    }

defToTerm : Name → Definition → List (Arg Term) → Term
defToTerm _ (function cs) as = pat-lam cs as
defToTerm _ (constructor′ d) as = con d as
defToTerm _ _ _ = unknown

derefImmediate : Term → TC Term
derefImmediate (def f args) = getDefinition f >>= λ f' → return (defToTerm f f' args)
derefImmediate x = return x

derefT : Term → TC Term
derefT (def f args) = getType f
derefT (con f args) = getType f
derefT x = return x

Ctx = List $ Arg Type

drop-ctx' : Ctx → ℕ → Ctx
drop-ctx' l zero = l
drop-ctx' [] (suc n) = []
drop-ctx' (x ∷ l) (suc n) = drop-ctx' l n

take-ctx' : Ctx → ℕ → Ctx
take-ctx' [] zero = []
take-ctx' [] (suc p) = [] --error "take-ctx: ctx too short for the prefix"
take-ctx' (x ∷ l) zero = []
take-ctx' (x ∷ l) (suc p) = x ∷ take-ctx' l p

-- FIXME we probably want to error out on these two functions.
pi-to-ctx : Term → Ctx
pi-to-ctx (Π[ s ∶ a ] x) = (a ∷ pi-to-ctx x)
pi-to-ctx _ = []

ctx-to-pi : List (Arg Type) → Type
ctx-to-pi [] = def (quote ⊤) []
ctx-to-pi (a ∷ t) = Π[ "_" ∶  a ] ctx-to-pi t

ty-con-args : Arg Type → List $ Arg Type
ty-con-args (arg _ (con c args)) = args
ty-con-args (arg _ (def c args)) = args
ty-con-args _ = []

con-to-ctx : Term → Term × Ctx
con-to-ctx (Π[ s ∶ a ] x) = let t , args = con-to-ctx x in t , a ∷ args
con-to-ctx x = x , []

record Eq : Set where
  constructor _↦_
  field
    left  : Term
    right : Term

Eqs = List Eq

eqs-shift-vars : Eqs → ℕ → Eqs

mbeqs-eqs : Maybe Eqs → Eqs
mbeqs-eqs (just x) = x
mbeqs-eqs nothing = []

-- stupid name, this generates equalities for two terms being somewhat similar.
unify-eq : Term → Term → Eqs
unify-eq-map : List $ Arg Term → List $ Arg Term → Maybe Eqs

unify-eq (var x [])             y = [ var x [] ↦ y ]
unify-eq (var x args@(_ ∷ _))   t₂ = {!!}

unify-eq (con c args) (con c′ args′) with c ≟-Name c′
... | yes p = mbeqs-eqs $ unify-eq-map args args′
... | no ¬p = []
unify-eq (def f args) (def f′ args′) with f ≟-Name f′
              -- Generally speaking this is a lie of course, as
              -- not all the definitons are injective.  However,
              -- we mainly use these for types such as Vec, Nat, etc
              -- and for these cases it is fine.  How do I check whether
              -- the definition is a data type or not?
... | yes p = mbeqs-eqs $ unify-eq-map args args′
... | no ¬p = []
unify-eq (lam v t) t₂ = {!!}
unify-eq (pat-lam cs args) t₂ = {!!}
unify-eq (pi a b) t₂ = {!!}
unify-eq (sort s) t₂ = {!!}
unify-eq (lit l) y = [ lit l ↦ y ]
unify-eq (meta x x₁) t₂ = {!!}
unify-eq unknown t₂ = {!!}
unify-eq x              (var y []) = [ x ↦ var y [] ]
unify-eq x              (var y args@(_ ∷ _)) =  {!!} --[ x ↦ var y [] ]
unify-eq a b = []

test-unify₁ = unify-eq (var 0 []) (con (quote ℕ.suc) [ vArg $ con (quote ℕ.zero) [] ] )
test-unify₂ = unify-eq (con (quote ℕ.suc) [ vArg $ con (quote ℕ.zero) [] ] )   (var 0 [])

unify-eq-map [] [] = just []
unify-eq-map [] (y ∷ _) = nothing
unify-eq-map (x ∷ _) [] = nothing
unify-eq-map (arg _ x ∷ xs) (arg _ y ∷ ys) = do
  eqs ← unify-eq-map xs ys
  return $ unify-eq x y ++ eqs

eq-find-l : Eqs → Term → Term
eq-find-l [] t = t
eq-find-l (l ↦ r ∷ eqs) t with l ≟r t
... | yes l≡t = r
... | no  l≢t = eq-find-l eqs t

decvar : Term → (min off : ℕ) → Err Term
decvar-map : List $ Arg Term → (min off : ℕ) → Err $ List $ Arg Term

decvar (var x args) m o with x ≥? m
decvar (var x args) m o | yes x≥m with x ≥? o
decvar (var x args) m o | yes x≥m | yes x≥o = do
  args ← decvar-map args m o
  return $ var (x ∸ o) args
decvar (var x args) m o | yes x≥m | no x≱o = error "decvar: variable index is less than decrement"
decvar (var x args) m o | no x≱m = do
  args ← decvar-map args m o
  return $ var x args
decvar (con c args) m o = do
  args ← decvar-map args m o
  return $ con c args
decvar (def f args) m o = do
  args ← decvar-map args m o
  return $ def f args
decvar (lam v t) m o = {!!}
decvar (pat-lam cs args) m o = {!!}
decvar (Π[ s ∶ arg i a ] x) m o = do
  a ← decvar a m o
  x ← decvar x (1 + m) o
  return $ Π[ s ∶ arg i a ] x
decvar (sort (set t)) m o = do
  t ← decvar t m o
  return $ sort $ set t
decvar (sort (lit n)) m o =
  return $ sort $ lit n
decvar (sort unknown) m o =
  return $ sort $ unknown
decvar (lit l) m o = return $ lit l
decvar (meta x args) m o = do
  args ← decvar-map args m o
  return $ meta x args
decvar unknown m o = return unknown

decvar-map [] m o = ok []
decvar-map (arg i x ∷ l) m o = do
   x ← decvar x m o
   l ← decvar-map l m o
   return $ (arg i x) ∷ l

-- Note that we throw away the equality in case it didn't decvar'd correctly.
decvar-eqs : Eqs → (min off : ℕ) → Eqs
decvar-eqs [] m o = []
decvar-eqs (x ↦ y ∷ eqs) m o with (decvar x m o) | (decvar y m o)
decvar-eqs (x ↦ y ∷ eqs) m o | ok x′ | ok y′ = x′ ↦ y′ ∷ decvar-eqs eqs m o
decvar-eqs (x ↦ y ∷ eqs) m o | _     | _       = decvar-eqs eqs m o

check-var-pred : Term → (p : ℕ → Bool) → (min : ℕ) → Bool
check-var-pred-map : List $ Arg Term → (p : ℕ → Bool) (min : ℕ) → Bool
check-var-pred (var x args) p m with x ≥? m
check-var-pred (var x args) p m | yes x≥m with p x
check-var-pred (var x args) p m | yes x≥m | true = true
check-var-pred (var x args) p m | yes x≥m | false = check-var-pred-map args p m
check-var-pred (var x args) p m | no  x≱m = check-var-pred-map args p m
check-var-pred (con c args) p m = check-var-pred-map args p m
check-var-pred (def f args) p m = check-var-pred-map args p m
check-var-pred (lam v t) p m = {!!}
check-var-pred (pat-lam cs args) p m = {!!}
check-var-pred (Π[ s ∶ (arg i a) ] x) p m with check-var-pred a p m
... | true  = true
... | false = check-var-pred x p (1 + m)
check-var-pred (sort (set t)) p m = check-var-pred t p m
check-var-pred (sort (lit n)) p m = false
check-var-pred (sort unknown) p m = false
check-var-pred (lit l) p m = false
check-var-pred (meta x args) p m = check-var-pred-map args p m
check-var-pred unknown p m = false

check-var-pred-map [] p m = false
check-var-pred-map (arg _ x ∷ l) p m with check-var-pred x p m
... | true = true
... | false = check-var-pred-map l p m

-- eliminate equalities where we reverence variables that are greaterh than n
eqs-elim-vars-ge-l : Eqs → (n : ℕ) → Eqs
eqs-elim-vars-ge-l [] n = []
eqs-elim-vars-ge-l (l ↦ r ∷ eqs) n with check-var-pred l (isYes ∘ (_≥? n)) 0
... | true = eqs-elim-vars-ge-l eqs n
... | false = (l ↦ r) ∷ eqs-elim-vars-ge-l eqs n

subst-eq-var : Eqs → Type → (min : ℕ) → Type
subst-eq-var-map : Eqs → List $ Arg Type → (min : ℕ) → List $ Arg Type

-- Iterate over a reversed telescopic context and try to subsitute variables
-- from eqs, if we have some.
subst-eq-vars : Eqs → List $ Arg Type → List $ Arg Type

subst-eq-vars eqs [] = []
subst-eq-vars eqs ((arg i ty) ∷ tys) = let
  eqs = decvar-eqs eqs 0 1
  in (arg i $ subst-eq-var eqs ty 0) ∷ subst-eq-vars eqs tys

subst-eq-var eqs t@(var x []) m with x ≥? m
... | yes p = eq-find-l eqs t
... | no ¬p = t
subst-eq-var eqs (var x (x₁ ∷ args)) m = {!!}
subst-eq-var eqs (con c args) m =
      con c $ subst-eq-var-map eqs args m
subst-eq-var eqs (def f args) m =
      def f $ subst-eq-var-map eqs args m
subst-eq-var eqs (lam v t) m = {!!}
subst-eq-var eqs (pat-lam cs args) m = {!!}
subst-eq-var eqs (Π[ s ∶ (arg i a) ] x) m =
  Π[ s ∶ (arg i $ subst-eq-var eqs a m) ]
   -- We need to increase all the variables in
   -- eqs berfore entering x.
   subst-eq-var (eqs-shift-vars eqs 1) x (1 + m)
subst-eq-var eqs (sort s) m = {!!}
subst-eq-var eqs (lit l) m = lit l
subst-eq-var eqs (meta x x₁) m = {!!}
subst-eq-var eqs unknown m = unknown

subst-eq-var-map eqs [] m = []
subst-eq-var-map eqs (arg i x ∷ l) m =
  arg i (subst-eq-var eqs x m) ∷ subst-eq-var-map eqs l m

-- shift all the variables by n
shift-vars : Type → (min off : ℕ) → Type
shift-vars-map : List $ Arg Type → ℕ → ℕ → List $ Arg Type

shift-vars (var x args) m o with x ≥? m
... | yes p = var (o + x) (shift-vars-map args m o)
... | no ¬p = var x (shift-vars-map args m o)
shift-vars (con c args) m o = con c $ shift-vars-map args m o
shift-vars (def f args) m o = def f $ shift-vars-map args m o
shift-vars (lam v (abs s x)) m o = lam v $ abs s $ shift-vars x (1 + m) o

shift-vars (pat-lam cs args) m o = {!!}
shift-vars (Π[ s ∶ arg i a ] x) m o = Π[ s ∶ arg i (shift-vars a m o) ] shift-vars x (1 + m) o
shift-vars (sort (set t)) m o = sort $ set $ shift-vars t m o
shift-vars (sort (lit n)) m o = sort $ lit n
shift-vars (sort unknown) m o = sort unknown
shift-vars (lit l) m o = lit l
shift-vars (meta x args) m o = meta x $ shift-vars-map args m o
shift-vars unknown m o = unknown

shift-vars-map [] m o = []
shift-vars-map (arg i x ∷ l) m o = arg i (shift-vars x m o) ∷ shift-vars-map l m o

eqs-shift-vars [] n = []
eqs-shift-vars (l ↦ r ∷ eqs) n = let
  l′ = shift-vars l 0 n
  r′ = shift-vars r 0 n
  in l′ ↦ r′ ∷ eqs-shift-vars eqs n

trans-eqs : Eqs → Eq → Eqs
trans-eqs [] (l ↦ r) = []
trans-eqs ((l′ ↦ r′) ∷ eqs) eq@(l ↦ r) with l′ ≟r l
... | yes l′≡l = unify-eq r′ r ++ trans-eqs eqs eq
... | no _ with  l′ ≟r r
... | yes l′≡r = unify-eq r′ l ++ trans-eqs eqs eq
... | no _ with  r′ ≟r l
... | yes r′≡l = unify-eq l′ r ++ trans-eqs eqs eq
... | no _ with  r′ ≟r r
... | yes r′≡r = unify-eq l′ l ++ trans-eqs eqs eq
... | no _ = trans-eqs eqs eq

merge-eqs : (l r : Eqs) → (acc : Eqs) → Eqs
merge-eqs l [] acc = l ++ acc
merge-eqs l (x ∷ r) acc = merge-eqs l r (x ∷ acc ++ trans-eqs l x)

TyPat = Arg Type × Arg Pattern

merge-tys-pats : List $ Arg Type → List $ Arg Pattern → Err $ List TyPat
merge-tys-pats [] [] = ok []
merge-tys-pats [] (x ∷ ps) = error "merge-tys-pats: more patterns than types"
merge-tys-pats (x ∷ tys) [] = error "merge-tys-pats: more types than patterns"
merge-tys-pats (ty ∷ tys) (p ∷ ps) = ok [ ty , p ] ++ merge-tys-pats tys ps

shift-ty-vars-map : List TyPat → (min off : ℕ) → List TyPat
shift-ty-vars-map [] m o = []
shift-ty-vars-map ((arg i ty , p) ∷ l) m o = (arg i (shift-vars ty m o) , p) ∷ shift-ty-vars-map l m o

subst-typats : List TyPat → (min var : ℕ) → Type → List TyPat
subst-typats [] m v x = []
subst-typats ((arg tv ty , p) ∷ l) m v x = let
  ty′ = subst-eq-var [ (var v []) ↦ x ] ty m
  in (arg tv ty′ , p) ∷ subst-typats l (1 + m) (1 + v) (shift-vars x 0 1)

gen-n-vars : (count v : ℕ) → List $ Arg Term
gen-n-vars 0 _ = []
gen-n-vars (suc n) v = vArg (var v []) ∷ gen-n-vars n (1 + v)

{-# TERMINATING #-}
pats-ctx-open-cons : List TyPat → Eqs →  TC $ Eqs × (Err $ List TyPat)
pats-ctx-open-cons [] eqs = return $ eqs , ok []
pats-ctx-open-cons ((arg tv ty , arg pv (con c ps)) ∷ l) eqs = do
   con-type ← getType c
   let con-ret , con-ctx = con-to-ctx con-type
   -- bump indices in x by the length of ps
   let #ps = length ps
   let ty = shift-vars ty 0 #ps
   let con-eqs = unify-eq con-ret ty
   --let con-eqs = mbeqs-eqs $ unify-eq-map con-type-args ty-args
   let ctx = subst-eq-vars con-eqs (take-ctx' (reverse con-ctx) #ps)
   case #ps N.≟ 0 of λ where
     (no #ps≢0) → do
        -- Throw away substitutions that point further than the number
        -- of arguments to the constructor
        let con-eqs′ = eqs-elim-vars-ge-l con-eqs #ps
        let eqs′ = eqs-shift-vars eqs #ps
        let ctxl = merge-tys-pats (reverse ctx) ps
        -- substitute constructor into the rest of the context
        let l′ = subst-typats l 0 0 (con c $ gen-n-vars #ps 0)
        -- We eliminated 0 variable, so bump all the variables greater than 0
        let l′ = shift-ty-vars-map l′ 1 (#ps ∸ 1)
        eqs″ , ctxr ← pats-ctx-open-cons l′ (merge-eqs eqs′ con-eqs′ [])
        return $ eqs″ , ctxl ++ ctxr
     (yes  ps≡0) → do
        let con-eqs′ = eqs-elim-vars-ge-l con-eqs 0
        -- shift con-eqs′ by 1 to account for the newly inserted Dot.
        let con-eqs′ = eqs-shift-vars con-eqs′ 1
        -- Add equality of the newly inserted Dot and shift eqs by 1
        --let eqs′ = (var 0 [] ≜ con c []) ∷ eqs-shift-vars eqs 1
        let eqs′ = eqs-shift-vars eqs 1
        -- substitute constructor into the rest of the context
        let l′ = subst-typats l 0 0 (con c [])
        eqs″ , ctxr ← pats-ctx-open-cons l′ (merge-eqs eqs′ con-eqs′ [])
        return $ eqs″ , ok [ arg tv ty , arg pv dot ] ++ ctxr
pats-ctx-open-cons ((ty , arg i dot) ∷ l) eqs = do
  -- leave the dot and psas the equations further
  let eqs′ = eqs-shift-vars eqs 1
  eqs″ , ctx ← pats-ctx-open-cons l eqs′
  return $ eqs″ , ok [ ty , arg i dot ] ++ ctx
pats-ctx-open-cons ((ty , arg i (var s)) ∷ l) eqs = do
  -- pass the equations further and leave the variable as is
  let eqs′ = eqs-shift-vars eqs 1
  eqs″ , ctx ← pats-ctx-open-cons l eqs′
  return $ eqs″ , ok [ ty , arg i (var s) ] ++ ctx
pats-ctx-open-cons ((ty , arg i (lit x)) ∷ l) eqs = do
  -- we don't get any new equations from the literal so
  -- pass the equations further and insert the dot
  let eqs′ = eqs-shift-vars eqs 1
  let l′ = subst-typats l 0 0 (lit x)
  eqs″ , ctx ← pats-ctx-open-cons l′ eqs′
  return $ eqs″ , ok [ ty , arg i dot ] ++ ctx
pats-ctx-open-cons ((ty , arg i (proj f)) ∷ l) eqs =
  return $ eqs , error "pats-ctx-open-cons: projection found, fixme"
pats-ctx-open-cons ((ty , arg i absurd) ∷ l) eqs =
  return $ eqs , error "pats-ctx-open-cons: absurd pattern found, fixme"

-- Check whether the varibale (var 0) can be found in the tyspats
-- telescopic context.
check-ref : List TyPat → (v : ℕ) → Bool
check-ref [] v = false
check-ref ((arg _ ty , _) ∷ l) v with check-var-pred ty (isYes ∘ (N._≟ v)) 0
... | true  = true
... | false = check-ref l (1 + v)

-- XXX we are going to ignore the errors from the decvar, as we assume that
-- (var 0) is not referenced in the telescopic pattern.
dec-typats : List TyPat → (min : ℕ) → List TyPat
dec-typats [] m = []
dec-typats ((arg ti ty , p) ∷ l) m with decvar ty m 1
... | ok ty′  = (arg ti ty′ , p) ∷ dec-typats l (1 + m)
... | error _ = (arg ti ty , p) ∷ dec-typats l (1 + m)

-- Try to eliminate dots if there is no references in the rhs to this variable
{-# TERMINATING #-}  -- XXX this can be resolved, this function IS terminating
try-elim-dots : List TyPat → List TyPat
try-elim-dots [] = []
try-elim-dots ((ty , arg i dot) ∷ tyspats) with check-ref tyspats 0
... | true = (ty , arg i dot) ∷ try-elim-dots tyspats
... | false = try-elim-dots (dec-typats tyspats 1)
try-elim-dots ((ty , p) ∷ tyspats) = (ty , p) ∷ try-elim-dots tyspats

-- Look at the ctx list in *reverse* and get the list of variables that
-- correspond to dot patterns
get-dots : List TyPat → ℕ → List ℕ
get-dots [] o = []
get-dots ((_ , arg _ dot) ∷ l) o = o ∷ get-dots l (1 + o)
get-dots (_ ∷ l) o = get-dots l (1 + o)

-- Check if a given term contains any variable from the list
check-refs : Term → List ℕ → Bool
check-refs t [] = false
check-refs t (v ∷ vs) with check-var-pred t (isYes ∘ (N._≟ v)) 0
... | true = true
... | false = check-refs t vs

-- Eliminate the rhs of each eq in case it references dot patterns.
eqs-elim-nondots : Eqs → List ℕ → Eqs
eqs-elim-nondots [] _ = []
eqs-elim-nondots (eq@(_ ↦ r) ∷ eqs) vs with check-refs r vs
... | true = eqs-elim-nondots eqs vs
... | false = eq ∷ eqs-elim-nondots eqs vs

-- Substitute the variables from eqs into the *reversed* telescopic
-- context.
subst-eq-typats : Eqs → List TyPat → List TyPat
subst-eq-typats eqs [] = []
subst-eq-typats []  l  = l
subst-eq-typats eqs ((arg ti ty , p) ∷ typats) = let
  eqs = decvar-eqs eqs 0 1
  in (arg ti (subst-eq-var eqs ty 0) , p) ∷ subst-eq-typats eqs typats

check-no-dots : List TyPat → Bool
check-no-dots [] = true
check-no-dots ((_ , arg _ dot) ∷ l) = false
check-no-dots (_ ∷ l) = check-no-dots l

check-all-vars : List TyPat → Bool
check-all-vars [] = true
check-all-vars ((_ , arg _ (var _)) ∷ l) = check-all-vars l
check-all-vars (_ ∷ l) = false

check-conlit : List TyPat → Bool
check-conlit [] = false
check-conlit ((_ , arg _ (con _ _)) ∷ l) = true
check-conlit ((_ , arg _ (lit _)) ∷ l) = true
check-conlit (_ ∷ l) = check-conlit l

{-# TERMINATING #-}
compute-ctx : List TyPat → TC $ Err $ List TyPat
compute-ctx typats with check-no-dots typats ∧ check-all-vars typats
... | true = return $ ok typats
... | false with check-conlit typats
... | true = do
      eqs , typats ← pats-ctx-open-cons typats []
      case typats of λ where
        (error s) → return $ error s
        (ok t) → let
          sub = eqs-elim-nondots (eqs ++ map (λ { (l ↦ r) → r ↦ l}) eqs) (get-dots (reverse t) 0)
          t = subst-eq-typats sub (reverse t)
          t = try-elim-dots (reverse t)
          in compute-ctx t
... | false = return $ error "compute-ctx: can't eliminate dots in the context"

-- try normalising every clause of the pat-lam, given
-- the context passed as an argument.  Propagate error that
-- can be produced by pats-ctx.
pat-lam-norm : Term → Ctx → TC $ Err Term
pat-lam-norm (pat-lam cs args) ctx = do
  cs ← hlpr ctx cs
  case cs of λ where
    (ok cs) → return $ ok (pat-lam cs args)
    (error s) → return $ error s
  --return $ ok (pat-lam cs args)
  where
    hlpr : Ctx → List Clause → TC $ Err (List Clause)
    hlpr ctx [] = return $ ok []
    hlpr ctx (clause ps t ∷ l) = do
      case merge-tys-pats ctx ps of λ where
        (error s) → return $ error s
        (ok typats) → do
           typats ← compute-ctx typats
           case typats of λ where
             (ok typats) → do
               let ctx′ = map proj₁ typats
               t ← inContext (reverse ctx′) (normalise t)
               l ← hlpr ctx l
               return $ ok [ clause ps t ] ++ l
             (error s) →
               --return $ clause ps t ∷ l
               -- Make sure that we properly error out
               -- Uncomment above line, in case you want to skip the error.
               return $ error s
    hlpr ctx (a ∷ l) = do
      l' ← hlpr ctx l
      return (ok [ a ] ++ l')
      --return (a ∷ l')
pat-lam-norm x ctx = return $ error "pat-lam-norm: Shouldn't happen" --return $ ok x

macro
  reflect : Term → Term → TC ⊤
  reflect f a = -- not sure I need this
                --withNormalisation true
                normalise f >>=
                (derefImmediate)
                >>= quoteTC >>= unify a

  reflect-ty : Name → Type → TC ⊤
  reflect-ty f a = getType f >>= quoteTC >>= normalise >>= unify a

  tstctx : Name → Type → TC ⊤
  tstctx f a = do
    t ← getType f
    q ← quoteTC (con-to-ctx t)
    unify a q

  rtest : Term → Term → TC ⊤
  rtest f a = do
     t ← derefT f
     v ← derefImmediate f
     v ← pat-lam-norm v (pi-to-ctx t)
     q ← quoteTC v
     --q ← quoteTC (con-to-ctx t)
     unify a q

  norm-test : Term → Term → TC ⊤
  norm-test tm a = do
    t ← derefT tm
    v ← derefImmediate tm
    --let vec-and'-pat-[] = (hArg dot ∷ vArg (con (quote nil) []) ∷ vArg (var "_") ∷ [])
    {-
    let add-2v-pat = (hArg (var "_") ∷
                      vArg (con (quote imap) (hArg dot ∷ vArg (var "a") ∷ [])) ∷
                      vArg (con (quote imap) (hArg dot ∷ vArg (var "b") ∷ [])) ∷ [])
    -}
    {-
    let vec-sum-pat = (hArg dot ∷
                       vArg
                       (con (quote V._∷_)
                        (hArg (var "_") ∷ vArg (var "x") ∷ vArg (var "a") ∷ []))
                       ∷
                       vArg
                       (con (quote V._∷_)
                        (hArg dot ∷ vArg (var "y") ∷ vArg (var "b") ∷ []))
                       ∷ [])
    -}
    let vec-sum-pat-[] = (hArg dot ∷ vArg (con (quote V.[]) []) ∷ vArg (var "_") ∷ [])

    {-
    let ty-args = args-to-ctx vec-args 0
    t ← getType (quote V._∷_)
    let t = subst-args 2 (reverse $ take-ctx' ty-args 2) 0 t
    -}
    let ctx = pi-to-ctx t
    case merge-tys-pats ctx vec-sum-pat-[] of λ where
      (error s) → unify a (lit (string s))
      (ok typats) → do
         eqs , t ← pats-ctx-open-cons typats []
         --let t = ok typats
         case t of λ where
           (error s) → unify a (lit (string s))
           (ok t) → do
              -- let sub = eqs-elim-nondots (eqs ++ map (λ { (l ≜ r) → r ≜ l}) eqs) (get-dots (reverse t) 0)
              -- let t = subst-eq-typats sub (reverse t)
              -- let t = try-elim-dots (reverse t)
              q ← quoteTC t
              unify a q

    --t ← inferType v -- (vArg n ∷ [ vArg lz ]))
    --let v = plug-new-args v (vArg n ∷ [ vArg lz ])
    --t ← inContext (reverse $ hArg lz ∷ [ hArg n ]) (normalise v)
    --t ← reduce t
    --t ← getType t
    --t ← inContext [] (normalise t)
    --q ← quoteTC (pi-to-ctx t)

  infert : Type → Term → TC ⊤
  infert t a = inferType t >>= quoteTC >>= unify a

-- {-
open import Data.Vec
vec-and : ∀ {n} → Vec Bool n → Vec Bool n → Vec Bool n
vec-and (x ∷ a) (y ∷ b) = x ∧ y ∷ vec-and a b
vec-and [] _ = []

-- explicit length
vec-and-nd : ∀ {n} → Vec Bool n → Vec Bool n → Vec Bool n
vec-and-nd {0}     []      _ = []
vec-and-nd {suc n} (_∷_ {n = n} x a) (_∷_ {n = n} y b) = x ∧ y ∷ vec-and-nd a b

data Vec' {l : Level} (A : Set l) : ℕ → Set l where
  nil  : Vec' A 0
  cons : A → {n : ℕ} → Vec' A n → Vec' A (1 + n)

vec-and' : ∀ {n} → Vec' Bool n → Vec' Bool n → Vec' Bool n
vec-and' nil _ = nil
vec-and' (cons x a) (cons y b) = cons (x ∧ y) (vec-and' a b)

{-# BUILTIN REWRITE _≡_ #-}
{-# REWRITE +-identityʳ #-}

a = 1 + 0

xx : ℕ → Bool → ℕ → ℕ
xx x true y = let a = x * x in a + y
xx x false y = x + 2 + 0

postulate
  rev-rev : ∀ {a}{X : Set a}{n}{xs : Vec X n} →
            let rev = V.foldl (Vec X) (λ rev x → x ∷ rev) [] in
            rev (rev xs) ≡ xs

{-# REWRITE rev-rev #-}

test-reverse : ∀ {a}{X : Set a}{n} → X → Vec X n → Vec X (suc n)
test-reverse x xs =  x ∷ V.reverse (V.reverse xs)

test-rev-pat : ∀ {a}{X : Set a}{n} → X → Vec X n → Vec X (suc n)
test-rev-pat x [] = x ∷ []
test-rev-pat x xs = x ∷ V.reverse (V.reverse xs)

open import Array
add-2v : ∀ {n} → let X = Ar ℕ 1 (n ∷ []) in X → X → X
add-2v (imap a) (imap b) = imap λ iv → a iv + b iv

postulate
  asum : ∀ {n} → Ar ℕ 1 (n ∷ []) → ℕ

mm : ∀ {m n k} → let Mat a b = Ar ℕ 2 (a ∷ b ∷ []) in
                 Mat m n → Mat n k → Mat m k
mm (imap a) (imap b) = imap λ iv → let i = ix-lookup iv (# 0)
                                       j = ix-lookup iv (# 1)
                                   in asum (imap λ kv → let k = ix-lookup kv (# 0)
                                                        in a (i ∷ k ∷ []) * b (k ∷ j ∷ []))

data P (x : ℕ) : Set where
  c : P x

data TT : ℕ → Set where
  tc : ∀ {n} → P (suc n) → TT (suc n)

foo : ∀ {n} → TT (suc n) → ℕ
foo (tc x) = 5

xxx = 3 N.< 5


module Esterel.Lang.CanFunction.Plug where

open import Data.Nat using (_+_ ; suc)
open import Function using (_∋_ ; _∘_ ; id ; _$_)
open import Data.Nat.Properties.Simple using ( +-comm ; +-assoc)
open import utility
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
open import Esterel.Environment as Env
open import Esterel.Context
open import Esterel.Context.Properties
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; sym ; subst ; cong ; trans ; module ≡-Reasoning ; cong₂ ; subst₂ ; inspect)
open import Data.Empty
open import Esterel.Lang.Binding
open import Data.Maybe using ( nothing ; just )
open import Data.List.Any
open import Data.List.Any.Properties
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ )
open import Esterel.Lang.CanFunction.SetSigMonotonic

open ≡-Reasoning using (_≡⟨_⟩_ ; _≡⟨⟩_ ; _∎)

open import Relation.Nullary.Decidable
  using (⌊_⌋)
open import Data.FiniteMap
import Data.OrderedListMap as OMap
open import Data.Nat as Nat using (ℕ)
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ ; _≟ₛₜ_)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ)
open import Esterel.CompletionCode as Code renaming (CompletionCode to Code)

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 ListSet Code._≟_
module NSet = ListSet Nat._≟_

canθₖ-plug : ∀ S' sigs → ∀ C p q
             → (Canₖq⊆Canₖp : ∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
             → (Canₛq⊆Canₛp : ∀ θ S → S ∈ (Canₛ q θ) → S ∈ (Canₛ p θ))
             → (∀ θ k → k ∈ (Canθₖ sigs S' (C ⟦ q ⟧c) θ) → k ∈ (Canθₖ sigs S' (C ⟦ p ⟧c) θ))

canθₛ-plug : ∀ S' sigs → ∀ C p q
             → (Canₛq⊆Canₛp : ∀ θ S → S ∈ (Canₛ q θ) → S ∈ (Canₛ p θ))
             → (Canₖq⊆Canₖp : ∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
             → (∀ θ k → k ∈ (Canθₛ sigs S' (C ⟦ q ⟧c) θ) → k ∈ (Canθₛ sigs S' (C ⟦ p ⟧c) θ))
canθₛₕ-plug : ∀ S' sigs → ∀ C p q
              → (Canₛₕq⊆Canₛₕp : ∀ θ → (Canₛₕ q θ) ⊆¹ (Canₛₕ p θ))
              → (Canₛq⊆Canₛp : ∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
              → (Canₖq⊆Canₖp : ∀ θ S → S ∈ (Canₛ q θ) → S ∈ (Canₛ p θ))
              → (∀ θ k → k ∈ (Canθₛₕ sigs S' (C ⟦ q ⟧c) θ) → k ∈ (Canθₛₕ sigs S' (C ⟦ p ⟧c) θ))

canₛₕ-plug : ∀ C p q
           → (Canₛₕq⊆Canₛₕp : ∀ θ → (Canₛₕ q θ) ⊆¹ (Canₛₕ p θ))
           → (∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
           → (Canₛq⊆Canₛp : ∀ θ → (Canₛ q θ) ⊆¹ (Canₛ p θ))
           → (∀ θ → (Canₛₕ (C ⟦ q ⟧c) θ) ⊆¹ (Canₛₕ (C ⟦ p ⟧c) θ))

canₖ-plug : ∀ C p q
            → (Canₖq⊆Canₖp : ∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
            → (Canₛq⊆Canₛp : ∀ θ S → S ∈ (Canₛ q θ) → S ∈ (Canₛ p θ))
            → (∀ θ k → k ∈ (Canₖ (C ⟦ q ⟧c) θ) → k ∈ (Canₖ (C ⟦ p ⟧c) θ))
canₛ-plug : ∀ C p q
            → (Canₛq⊆Canₛp : ∀ θ → (Canₛ q θ) ⊆¹ (Canₛ p θ))
            → (∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
            → (∀ θ → (Canₛ (C ⟦ q ⟧c) θ) ⊆¹ (Canₛ (C ⟦ p ⟧c) θ))

canθₖ-plug S' [] C p q Canₖq⊆Canₖp Canₛq⊆Canₛp = canₖ-plug C p q Canₖq⊆Canₖp Canₛq⊆Canₛp
canθₖ-plug S' (just Signal.present ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp θ = canθₖ-plug (suc S') sigs C p q Canₖq⊆Canₖp Canₛq⊆Canₛp (θ ← _)
canθₖ-plug S' (just Signal.absent ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp θ = canθₖ-plug (suc S') sigs C p q Canₖq⊆Canₖp Canₛq⊆Canₛp (θ ← _)
canθₖ-plug S' (nothing ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp = canθₖ-plug (suc S') sigs C p q Canₖq⊆Canₖp Canₛq⊆Canₛp
canθₖ-plug S' (just Signal.unknown ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp θ
  with any (Nat._≟_ S') (Canθₛ sigs (suc S') (C ⟦ p ⟧c) (θ ← ([S]-env (S' ₛ))))
     | any (Nat._≟_ S') (Canθₛ sigs (suc S') (C ⟦ q ⟧c) (θ ← ([S]-env (S' ₛ))))
canθₖ-plug S' (just Signal.unknown ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp θ | yes p₁ | (yes p₂) = canθₖ-plug (suc S') sigs C p q Canₖq⊆Canₖp Canₛq⊆Canₛp (θ ← _)
canθₖ-plug S' (just Signal.unknown ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp θ | yes p₁ | (no ¬p)
  with sig-←-monoʳ (S' ₛ) ([S]-env (S' ₛ)) θ (sig-∈-single (S' ₛ) Signal.unknown)
... | S'∈θ←[S]env
  rewrite ((θ ← [S]-env-absent (S' ₛ)) ≡ (set-sig{S' ₛ} (θ ← [S]-env (S' ₛ)) S'∈θ←[S]env Signal.absent)
            ∋
            (θ ← [S]-env-absent (S' ₛ))
             ≡⟨ cong (θ ←_) (sym (←-single-overwrite-sig (S' ₛ) Signal.unknown
                                    ([S]-env-absent (S' ₛ)) ((sig-∈-single (S' ₛ) Signal.absent)))) ⟩
             (θ ← (([S]-env (S' ₛ)) ← [S]-env-absent (S' ₛ)))
             ≡⟨ ←-assoc θ ([S]-env (S' ₛ)) ([S]-env-absent (S' ₛ)) ⟩
             ((θ ← ([S]-env (S' ₛ))) ← ([S]-env-absent (S' ₛ)))
             ≡⟨ sym (sig-set=← (θ ← [S]-env (S' ₛ)) (S' ₛ) Signal.absent  S'∈θ←[S]env) ⟩
             (set-sig{S' ₛ} (θ ← [S]-env (S' ₛ)) S'∈θ←[S]env Signal.absent) ∎)

  with canθₖ-set-sig-monotonic sigs (suc S') (C ⟦ q ⟧c) (S' ₛ) (θ ← [S]-env (S' ₛ))
                               S'∈θ←[S]env Signal.absent
                               (trans (sig-stats-←-right-irr' (S' ₛ) θ ([S]-env (S' ₛ)) (sig-∈-single (S' ₛ) Signal.unknown) S'∈θ←[S]env) (sig-stats-1map' (S' ₛ) Signal.unknown ((sig-∈-single (S' ₛ) Signal.unknown))))
                               (n∉map-suc-n-+ S' (SigM.Dom' sigs))
... | Canabsq⊂Canunq
   = λ k x → (canθₖ-plug (suc S') sigs C p q Canₖq⊆Canₖp Canₛq⊆Canₛp (θ ← _)) k (Canabsq⊂Canunq k x)
canθₖ-plug S' (just Signal.unknown ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp θ | no ¬p | (yes p₁)
  = ⊥-elim (¬p ((canθₛ-plug (suc S') sigs C p q Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)) _ p₁ ))
canθₖ-plug S' (just Signal.unknown ∷ sigs) C p q Canₖq⊆Canₖp Canₛq⊆Canₛp θ | no ¬p | (no ¬p₁) = canθₖ-plug (suc S') sigs C p q Canₖq⊆Canₖp Canₛq⊆Canₛp (θ ← _)

canθₛ-plug S' [] C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ
canθₛ-plug S' (nothing ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canθₛ-plug (suc S') sigs C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ
canθₛ-plug S' (just Signal.present ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canθₛ-plug (suc S') sigs C p q Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)
canθₛ-plug S' (just Signal.absent ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canθₛ-plug (suc S') sigs C p q Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)
canθₛ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ
  with any (Nat._≟_ S') (Canθₛ sigs (suc S') (C ⟦ p ⟧c) (θ ← ([S]-env (S' ₛ))))
     | any (Nat._≟_ S') (Canθₛ sigs (suc S') (C ⟦ q ⟧c) (θ ← ([S]-env (S' ₛ))))
canθₛ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ | yes p₁ | (yes p₂) = canθₛ-plug (suc S') sigs C p q Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)
canθₛ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ | yes p₁ | (no ¬p)
  with sig-←-monoʳ (S' ₛ) ([S]-env (S' ₛ)) θ (sig-∈-single (S' ₛ) Signal.unknown)
... | S'∈θ←[S]env
  rewrite ((θ ← [S]-env-absent (S' ₛ)) ≡ (set-sig{S' ₛ} (θ ← [S]-env (S' ₛ)) S'∈θ←[S]env Signal.absent)
            ∋
            (θ ← [S]-env-absent (S' ₛ))
             ≡⟨ cong (θ ←_) (sym (←-single-overwrite-sig (S' ₛ) Signal.unknown
                                    ([S]-env-absent (S' ₛ)) ((sig-∈-single (S' ₛ) Signal.absent)))) ⟩
             (θ ← (([S]-env (S' ₛ)) ← [S]-env-absent (S' ₛ)))
             ≡⟨ ←-assoc θ ([S]-env (S' ₛ)) ([S]-env-absent (S' ₛ)) ⟩
             ((θ ← ([S]-env (S' ₛ))) ← ([S]-env-absent (S' ₛ)))
             ≡⟨ sym (sig-set=← (θ ← [S]-env (S' ₛ)) (S' ₛ) Signal.absent  S'∈θ←[S]env) ⟩
             (set-sig{S' ₛ} (θ ← [S]-env (S' ₛ)) S'∈θ←[S]env Signal.absent) ∎)
   with canθₛ-set-sig-monotonic sigs (suc S') (C ⟦ q ⟧c) (S' ₛ) (θ ← [S]-env (S' ₛ))
                               S'∈θ←[S]env Signal.absent
                               (trans (sig-stats-←-right-irr' (S' ₛ) θ ([S]-env (S' ₛ)) (sig-∈-single (S' ₛ) Signal.unknown) S'∈θ←[S]env) (sig-stats-1map' (S' ₛ) Signal.unknown ((sig-∈-single (S' ₛ) Signal.unknown))))
                               (n∉map-suc-n-+ S' (SigM.Dom' sigs))
... | Canabsq⊂Canunq
   = λ k x → (canθₛ-plug (suc S') sigs C p q Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)) k (Canabsq⊂Canunq k x)

canθₛ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ | no ¬p | (yes p₁)
  = ⊥-elim (¬p ((canθₛ-plug (suc S') sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _) _ p₁))
canθₛ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ | no ¬p | (no ¬p₁) = canθₛ-plug (suc S') sigs C p q Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)

canθₛₕ-plug S' [] C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ
canθₛₕ-plug S' (nothing ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canθₛₕ-plug (suc S') sigs C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ
canθₛₕ-plug S' (just Signal.present ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canθₛₕ-plug (suc S') sigs C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)
canθₛₕ-plug S' (just Signal.absent ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canθₛₕ-plug (suc S') sigs C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)
canθₛₕ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ
  with any (Nat._≟_ S') (Canθₛ sigs (suc S') (C ⟦ p ⟧c) (θ ← ([S]-env (S' ₛ))))
     | any (Nat._≟_ S') (Canθₛ sigs (suc S') (C ⟦ q ⟧c) (θ ← ([S]-env (S' ₛ))))
canθₛₕ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ | yes p₁ | (yes p₂) =  canθₛₕ-plug (suc S') sigs C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)
canθₛₕ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp Canₛq⊆Canₛp θ | yes p₁ | (no ¬p)
  with sig-←-monoʳ (S' ₛ) ([S]-env (S' ₛ)) θ (sig-∈-single (S' ₛ) Signal.unknown)
... | S'∈θ←[S]env
  rewrite ((θ ← [S]-env-absent (S' ₛ)) ≡ (set-sig{S' ₛ} (θ ← [S]-env (S' ₛ)) S'∈θ←[S]env Signal.absent)
            ∋
            (θ ← [S]-env-absent (S' ₛ))
             ≡⟨ cong (θ ←_) (sym (←-single-overwrite-sig (S' ₛ) Signal.unknown
                                    ([S]-env-absent (S' ₛ)) ((sig-∈-single (S' ₛ) Signal.absent)))) ⟩
             (θ ← (([S]-env (S' ₛ)) ← [S]-env-absent (S' ₛ)))
             ≡⟨ ←-assoc θ ([S]-env (S' ₛ)) ([S]-env-absent (S' ₛ)) ⟩
             ((θ ← ([S]-env (S' ₛ))) ← ([S]-env-absent (S' ₛ)))
             ≡⟨ sym (sig-set=← (θ ← [S]-env (S' ₛ)) (S' ₛ) Signal.absent  S'∈θ←[S]env) ⟩
             (set-sig{S' ₛ} (θ ← [S]-env (S' ₛ)) S'∈θ←[S]env Signal.absent) ∎)
                with canθₛₕ-set-sig-monotonic sigs (suc S') (C ⟦ q ⟧c) (S' ₛ) (θ ← [S]-env (S' ₛ))
                               S'∈θ←[S]env Signal.absent
                               (trans (sig-stats-←-right-irr' (S' ₛ) θ ([S]-env (S' ₛ)) (sig-∈-single (S' ₛ) Signal.unknown) S'∈θ←[S]env) (sig-stats-1map' (S' ₛ) Signal.unknown ((sig-∈-single (S' ₛ) Signal.unknown))))
                               (n∉map-suc-n-+ S' (SigM.Dom' sigs))
... |  Canabsq⊂Canunq
   = λ k x → (canθₛₕ-plug (suc S') sigs C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp Canₛq⊆Canₛp (θ ← _)) k (Canabsq⊂Canunq k x)

canθₛₕ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ | no ¬p | (yes p₁)
  = ⊥-elim (¬p (canθₛ-plug (suc S') sigs C p q Canₖq⊆Canₖp Canₛq⊆Canₛp (θ ← _) _ p₁))
canθₛₕ-plug S' (just Signal.unknown ∷ sigs) C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp θ | no ¬p | (no ¬p₁) = canθₛₕ-plug (suc S') sigs C p q Canₛₕq⊆Canₛₕp Canₛq⊆Canₛp Canₖq⊆Canₖp (θ ← _)

canₖ-plug [] p q Canₖq⊆Canₖp _ = Canₖq⊆Canₖp
canₖ-plug (ceval (epar₁ q) ∷ C) p q₁ Canₖq⊆Canₖp ⊂s θ = map-mono² Code._⊔_ (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ) (λ x y → y)
canₖ-plug (ceval (epar₂ p) ∷ C) p₁ q Canₖq⊆Canₖp ⊂s θ = map-mono²{xs = Canₖ p θ} Code._⊔_ (λ x y → y) (canₖ-plug C p₁ q Canₖq⊆Canₖp ⊂s θ)
canₖ-plug (ceval (eloopˢ q) ∷ C) p q₁ Canₖq⊆Canₖp ⊂s θ = canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ
canₖ-plug (ceval (eseq q) ∷ C) p q₁ Canₖq⊆Canₖp ⊂s θ with any (Code.nothin Code.≟_) (Canₖ (C ⟦ p ⟧c) θ) | any (Code.nothin Code.≟_) (Canₖ (C ⟦ q₁ ⟧c) θ)
... | yes 0∈CanC⟦p⟧ | yes 0∈CanC⟦q⟧ = codesub++both ((codesub- Code.nothin (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ))) (λ x y → y)
... | yes 0∈CanC⟦p⟧ | no  0∉CanC⟦q⟧ = λ k x → ++ˡ (set-remove-not-removed{Code.nothin}{k} (λ {refl → 0∉CanC⟦q⟧ x}) (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ _ x))
... | no  0∉CanC⟦p⟧ | yes 0∈CanC⟦q⟧ = ⊥-elim (0∉CanC⟦p⟧ (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ _ 0∈CanC⟦q⟧))
... | no  0∉CanC⟦p⟧ | no  0∉CanC⟦q⟧ = canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ
canₖ-plug (ceval (esuspend S) ∷ C) p q Canₖq⊆Canₖp ⊂s = canₖ-plug C p q Canₖq⊆Canₖp ⊂s
canₖ-plug (ceval etrap ∷ C) p q Canₖq⊆Canₖp ⊂s =   λ θ →  map-mono Code.↓* (canₖ-plug C p q Canₖq⊆Canₖp ⊂s θ)
canₖ-plug (csignl S ∷ C) p q Canₖq⊆Canₖp ⊂s θ = canθₖ-plug 0 (sig ([S]-env S)) C p q Canₖq⊆Canₖp ⊂s θ
canₖ-plug (cpresent₁ S q ∷ C) p q₁ Canₖq⊆Canₖp ⊂s θ with Sig∈ S θ
... | no  S∉Domθ = codesub++both (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ) (λ x y → y)
... | yes S∈Domθ with (Signal.present ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ
... | no  _ with (Signal.absent ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = λ k z → z
... | no  _ = codesub++both (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ) (λ x y → y)
canₖ-plug (cpresent₂ S p₁ ∷ C) p q Canₖq⊆Canₖp ⊂s θ with Sig∈ S θ
... | no  S∉Domθ = codesub++both{a = Canₖ p₁ θ} (λ x y → y) (canₖ-plug C p q Canₖq⊆Canₖp ⊂s θ)
... | yes S∈Domθ with (Signal.present ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = λ x y → y
... | no  _ with (Signal.absent ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = canₖ-plug C p q Canₖq⊆Canₖp ⊂s θ
... | no  _ = codesub++both{a = Canₖ p₁ θ} (λ x y → y) (canₖ-plug C p q Canₖq⊆Canₖp ⊂s θ)
canₖ-plug (cloop ∷ C) p q Canₖq⊆Canₖp ⊂s = (canₖ-plug C p q Canₖq⊆Canₖp ⊂s)
canₖ-plug (cloopˢ₂ p ∷ C) p₁ q Canₖq⊆Canₖp ⊂s θ = λ k z → z
canₖ-plug (cseq₂ p ∷ C) p₁ q Canₖq⊆Canₖp ⊂s θ with any (Code.nothin Code.≟_) (Canₖ p θ)
... | yes 0∈Canp = codesub++both{a = set-remove (Canₖ p θ) Code.nothin } (λ x y → y) (canₖ-plug C p₁ q Canₖq⊆Canₖp ⊂s θ)
... | no  0∉Canp = λ x y → y
canₖ-plug (cshared s e ∷ C) p q Canₖq⊆Canₖp ⊂s = (canₖ-plug C p q Canₖq⊆Canₖp ⊂s)
canₖ-plug (cvar x e ∷ C) p q Canₖq⊆Canₖp ⊂s = (canₖ-plug C p q Canₖq⊆Canₖp ⊂s)
canₖ-plug (cif₁ x q ∷ C) p q₁ Canₖq⊆Canₖp ⊂s θ = codesub++both (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂s θ) (λ x y → y)
canₖ-plug (cif₂ x p ∷ C) p₁ q Canₖq⊆Canₖp ⊂s θ = codesub++both{a = Canₖ p θ} (λ x y → y) (canₖ-plug C p₁ q Canₖq⊆Canₖp ⊂s θ)
canₖ-plug (cenv θ₁ A ∷ C) p q Canₖq⊆Canₖp ⊂s θ = canθₖ-plug 0 (sig θ₁) C p q Canₖq⊆Canₖp ⊂s θ

canₛ-plug [] p q Canₛq⊆Canₛp Canₖq⊆Canₖp = Canₛq⊆Canₛp
canₛ-plug (ceval (epar₁ q) ∷ C) p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ = ∪¹-respect-⊆¹-left (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
canₛ-plug (ceval (epar₂ p) ∷ C) p₁ q Canₛq⊆Canₛp Canₖq⊆Canₖp θ = ∪¹-respect-⊆¹-right (Canₛ p θ) (canₛ-plug C p₁ q Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
canₛ-plug (ceval (eloopˢ q) ∷ C) p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ = canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ
canₛ-plug (ceval (eseq q) ∷ C) p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ with any (Code.nothin Code.≟_) (Canₖ (C ⟦ p ⟧c) θ) | any (Code.nothin Code.≟_) (Canₖ (C ⟦ q₁ ⟧c) θ)
... | yes 0∈CanC⟦p⟧ | yes 0∈CanC⟦q⟧ = ∪¹-respect-⊆¹-left (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
... | yes 0∈CanC⟦p⟧ | no  0∉CanC⟦q⟧ = λ S x → (++ˡ (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ S x))
... | no  0∉CanC⟦p⟧ | yes 0∈CanC⟦q⟧ =  ⊥-elim (0∉CanC⟦p⟧ (canₖ-plug C p q₁ Canₖq⊆Canₖp Canₛq⊆Canₛp θ _ 0∈CanC⟦q⟧))
... | no  0∉CanC⟦p⟧ | no  0∉CanC⟦q⟧ = (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ)

--  set-subtract-merge : ∀ {xs ys z} → z ∈ set-subtract xs ys → (z ∈ xs) × (z ∉ ys)

canₛ-plug (ceval (esuspend S) ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp = (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp)
canₛ-plug (ceval etrap ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp = (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp)
canₛ-plug (csignl (S ₛ) ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ S' S'∈CanC⟦q⟧
   = NSet.set-remove-not-removed ((¬ S ≡ S') ∋ NSet.set-remove-not-eq{S'}{S}{Canθₛ (sig ([S]-env (S ₛ))) 0 (C ⟦ q ⟧c) θ} S'∈CanC⟦q⟧)
                                  ((canθₛ-plug 0 (sig ([S]-env (S ₛ))) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ) S' ( (NSet.set-remove-mono-∈ S S'∈CanC⟦q⟧) ))

canₛ-plug (cpresent₁ S q ∷ C) p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ with Sig∈ S θ
... | no  S∉Domθ = ∪¹-respect-⊆¹-left (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
... | yes S∈Domθ with (Signal.present ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
... | no  _ with (Signal.absent ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = λ k z → z
... | no  _ = ∪¹-respect-⊆¹-left (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
canₛ-plug (cpresent₂ S p₁ ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ with Sig∈ S θ
... | no  S∉Domθ = ∪¹-respect-⊆¹-right (Canₛ p₁ θ) (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
... | yes S∈Domθ with (Signal.present ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = λ x y → y
... | no  _ with (Signal.absent ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
... | no  _ = ∪¹-respect-⊆¹-right (Canₛ p₁ θ) (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
canₛ-plug (cloop ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp = (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp)
canₛ-plug (cloopˢ₂ p ∷ C) p₁ q Canₛq⊆Canₛp Canₖq⊆Canₖp θ = λ x z → z
canₛ-plug (cseq₂ p ∷ C) p₁ q Canₛq⊆Canₛp Canₖq⊆Canₖp θ with any (Code.nothin Code.≟_) (Canₖ p θ)
... | yes 0∈Canp = ∪¹-respect-⊆¹-right (Canₛ p θ) (canₛ-plug C p₁ q Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
... | no  0∉Canp = λ x y → y
canₛ-plug (cshared s e ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp = (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp)
canₛ-plug (cvar x e ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp = (canₛ-plug C p q Canₛq⊆Canₛp Canₖq⊆Canₖp)
canₛ-plug (cif₁ x q ∷ C) p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ = ∪¹-respect-⊆¹-left (canₛ-plug C p q₁ Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
canₛ-plug (cif₂ x p ∷ C) p₁ q Canₛq⊆Canₛp Canₖq⊆Canₖp θ = ∪¹-respect-⊆¹-right (Canₛ p θ) (canₛ-plug C p₁ q Canₛq⊆Canₛp Canₖq⊆Canₖp θ)
canₛ-plug (cenv θ₁ A ∷ C) p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ =   ⊆¹-respect-|¹ (fst $ Dom θ₁) (canθₛ-plug 0 (sig θ₁) C p q Canₛq⊆Canₛp Canₖq⊆Canₖp θ)

canₛₕ-plug [] p q Canₛₕq⊆Canₛₕp Canₖₕq⊆Canₖₕp ⊂S = Canₛₕq⊆Canₛₕp
canₛₕ-plug (ceval (epar₁ q) ∷ C) p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ = ∪¹-respect-⊆¹-left (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
canₛₕ-plug (ceval (epar₂ p) ∷ C) p₁ q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ = ∪¹-respect-⊆¹-right (Canₛₕ p θ) (canₛₕ-plug C p₁ q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
canₛₕ-plug (ceval (eloopˢ q) ∷ C) p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ = canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ
canₛₕ-plug (ceval (eseq q) ∷ C) p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ with any (Code.nothin Code.≟_) (Canₖ (C ⟦ p ⟧c) θ) | any (Code.nothin Code.≟_) (Canₖ (C ⟦ q₁ ⟧c) θ)
... | yes 0∈CanC⟦p⟧ | yes 0∈CanC⟦q⟧ = ∪¹-respect-⊆¹-left (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
... | yes 0∈CanC⟦p⟧ | no  0∉CanC⟦q⟧ = λ S x → (++ˡ (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ S x))
... | no  0∉CanC⟦p⟧ | yes 0∈CanC⟦q⟧ =  ⊥-elim (0∉CanC⟦p⟧ (canₖ-plug C p q₁ Canₖq⊆Canₖp ⊂S θ _ 0∈CanC⟦q⟧))
... | no  0∉CanC⟦p⟧ | no  0∉CanC⟦q⟧ = (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)

canₛₕ-plug (ceval (esuspend S) ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S = (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S)
canₛₕ-plug (ceval etrap ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S = (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S)
canₛₕ-plug (csignl S ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ = canθₛₕ-plug 0 (sig ([S]-env S)) C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ
canₛₕ-plug (cpresent₁ S q ∷ C) p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ with Sig∈ S θ
... | no  S∉Domθ = ∪¹-respect-⊆¹-left (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
... | yes S∈Domθ with (Signal.present ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
... | no  _ with (Signal.absent ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = λ k z → z
... | no  _ = ∪¹-respect-⊆¹-left (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
canₛₕ-plug (cpresent₂ S p₁ ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ with Sig∈ S θ
... | no  S∉Domθ = ∪¹-respect-⊆¹-right (Canₛₕ p₁ θ) (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
... | yes S∈Domθ with (Signal.present ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = λ x y → y
... | no  _ with (Signal.absent ≟ₛₜ (sig-stats{S} θ S∈Domθ))
... | yes _ = (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
... | no  _ = ∪¹-respect-⊆¹-right (Canₛₕ p₁ θ) (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
canₛₕ-plug (cloop ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S = (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S)
canₛₕ-plug (cloopˢ₂ p ∷ C) p₁ q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ = λ x z → z
canₛₕ-plug (cseq₂ p ∷ C) p₁ q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ with any (Code.nothin Code.≟_) (Canₖ p θ)
... | yes 0∈Canp = ∪¹-respect-⊆¹-right (Canₛₕ p θ) (canₛₕ-plug C p₁ q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
... | no  0∉Canp = λ x y → y
canₛₕ-plug (cshared (s ₛₕ) e ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ s' s'∈CanC⟦q⟧
   = NSet.set-remove-not-removed ((¬ s ≡ s') ∋ NSet.set-remove-not-eq{s'}{s}{Canₛₕ (C ⟦ q ⟧c) θ} s'∈CanC⟦q⟧) (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ s' (NSet.set-remove-mono-∈ s s'∈CanC⟦q⟧))
canₛₕ-plug (cvar x e ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S = (canₛₕ-plug C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S)
canₛₕ-plug (cif₁ x q ∷ C) p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ = ∪¹-respect-⊆¹-left (canₛₕ-plug C p q₁ Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
canₛₕ-plug (cif₂ x p ∷ C) p₁ q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ = ∪¹-respect-⊆¹-right (Canₛₕ p θ) (canₛₕ-plug C p₁ q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)
canₛₕ-plug (cenv θ₁ A ∷ C) p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ =  ⊆¹-respect-|¹ (snd $ Dom θ₁) (canθₛₕ-plug 0 (sig θ₁) C p q Canₛₕq⊆Canₛₕp Canₖq⊆Canₖp ⊂S θ)

canθₖ-plugE : ∀ S' sigs → ∀ E p q
              → (Canₖq⊆Canₖp : ∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
              → (Canₛq⊆Canₛp : ∀ θ S → S ∈ (Canₛ q θ) → S ∈ (Canₛ p θ))
              → (∀ θ k → k ∈ (Canθₖ sigs S' (E ⟦ q ⟧e) θ) → k ∈ (Canθₖ sigs S' (E ⟦ p ⟧e) θ))
canθₖ-plugE S' sigs E p q
  with canθₖ-plug S' sigs (Data.List.map ceval E) p q
... | r rewrite unplugc (⟦⟧e-to-⟦⟧c (Erefl{E}{q}))
              | unplugc (⟦⟧e-to-⟦⟧c (Erefl{E}{p}))
  = r

canθₛ-plugE : ∀ S' sigs → ∀ E p q
              → (Canₛq⊆Canₛp : ∀ θ S → S ∈ (Canₛ q θ) → S ∈ (Canₛ p θ))
              → (Canₖq⊆Canₖp : ∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
              → (∀ θ k → k ∈ (Canθₛ sigs S' (E ⟦ q ⟧e) θ) → k ∈ (Canθₛ sigs S' (E ⟦ p ⟧e) θ))
canθₛ-plugE S' sigs E p q
  with canθₛ-plug S' sigs (Data.List.map ceval E) p q
... | r rewrite unplugc (⟦⟧e-to-⟦⟧c (Erefl{E}{q}))
              | unplugc (⟦⟧e-to-⟦⟧c (Erefl{E}{p}))
  = r

canθₛₕ-plugE : ∀ S' sigs → ∀ E p q
              → (Canₛₕq⊆Canₛₕp : ∀ θ → (Canₛₕ q θ) ⊆¹ (Canₛₕ p θ))
              → (Canₛq⊆Canₛp : ∀ θ k → k ∈ (Canₖ q θ) → k ∈ (Canₖ p θ))
              → (Canₖq⊆Canₖp : ∀ θ S → S ∈ (Canₛ q θ) → S ∈ (Canₛ p θ))
              → (∀ θ k → k ∈ (Canθₛₕ sigs S' (E ⟦ q ⟧e) θ) → k ∈ (Canθₛₕ sigs S' (E ⟦ p ⟧e) θ))
canθₛₕ-plugE S' sigs E p q
  with canθₛₕ-plug S' sigs (Data.List.map ceval E) p q
... | r rewrite unplugc (⟦⟧e-to-⟦⟧c (Erefl{E}{q}))
              | unplugc (⟦⟧e-to-⟦⟧c (Erefl{E}{p}))
  = r


module Selective.EnvironmentOperations where
open import Selective.ActorMonad
open import Selective.SimulationEnvironment
open import Prelude

open import Data.List.All.Properties using (++⁺ ; drop⁺)
open import Data.List.Properties using (map-++-commute)
open import Data.Nat.Properties using (≤-reflexive)
open import Data.Product using (Σ ; _,_ ; _×_ ; Σ-syntax)

open Actor
open ValidActor
open Env
open NamedInbox
open NameSupplyStream

-- We can create a new Actor from an ActorM if we know its name.
-- This is used when spawning an actor.
new-actor : ∀ {IS A post} → ActorM ∞ IS A [] post → Name → Actor
new-actor {IS} {A} {post} m name = record
                                        { inbox-shape = IS
                                        ; A = A
                                        ; references = []
                                        ; pre = []
                                        ; pre-eq-refs = refl
                                        ; post = post
                                        ; computation = m ⟶ []
                                        ; name = name
                                        }

-- An actor can be lifted to run sub-programs that need less references
lift-actor : (actor : Actor) → {pre : TypingContext} →
             (references : Store) →
             (pre-eq-refs : (map shape references) ≡ pre) →
             ActorState ∞ (inbox-shape actor) (A actor) pre (post actor) →
             Actor
lift-actor actor {pre} references pre-eq-refs m = record
                                              { inbox-shape = inbox-shape actor
                                              ; A = actor .A
                                              ; references = references
                                              ; pre = pre
                                              ; pre-eq-refs = pre-eq-refs
                                              ; post = actor .post
                                              ; computation = m
                                              ; name = actor .name
                                              }

-- Replace the monadic part of an actor
-- Many of the bind-operations don't change anything except what the next step should be.
replace-actorM : (actor : Actor) → ActorState ∞ (inbox-shape actor) (A actor) (pre actor) (post actor) → Actor
replace-actorM actor m = record
                           { inbox-shape = inbox-shape actor
                           ; A = A actor
                           ; references = references actor
                           ; pre = pre actor
                           ; pre-eq-refs = pre-eq-refs actor
                           ; post = post actor
                           ; computation = m
                           ; name = name actor
                           }

-- Add one reference to an actor.
-- Used when receiving a reference, spawn, or self.
-- The precondition and references are equal via the congruence relation on consing the shape of the reference.
add-reference : (actor : Actor) → (nm : NamedInbox) → ActorState ∞ (inbox-shape actor) (A actor) (shape nm ∷ pre actor) (post actor) → Actor
add-reference actor nm m = record
                             { inbox-shape = inbox-shape actor
                             ; A = A actor
                             ; references = nm ∷ references actor
                             ; pre = shape nm ∷ pre actor
                             ; pre-eq-refs = cong (_∷_ (shape nm)) (pre-eq-refs actor)
                             ; post = post actor
                             ; computation = m
                             ; name = name actor
                             }

add-references-to-actor : (actor : Actor) → (nms : List NamedInbox) → ActorState ∞ (inbox-shape actor) (A actor) ((map shape nms) ++ pre actor) (post actor) → Actor
add-references-to-actor actor nms m = record
                                        { inbox-shape = inbox-shape actor
                                        ; A = A actor
                                        ; references = nms ++ references actor
                                        ; pre = map shape nms ++ pre actor
                                        ; pre-eq-refs = trans (map-++-commute shape nms (references actor)) (cong (_++_ (map shape nms)) (pre-eq-refs actor))
                                        ; post = post actor
                                        ; computation = m
                                        ; name = name actor
                                        }
add-references-rewrite : (actor : Actor) → (nms : List NamedInbox) → {x : Message (inbox-shape actor)} →
  map shape nms ++ pre actor ≡ add-references (pre actor) x →
  ActorState ∞ (inbox-shape actor) (A actor) (add-references (pre actor) x) (post actor) →
  Actor
add-references-rewrite actor nms {x} p m = record
                             { inbox-shape = inbox-shape actor
                             ; A = A actor
                             ; references = nms ++ references actor
                             ; pre = add-references (pre actor) x
                             ; pre-eq-refs = trans (trans (map-++-commute shape nms (references actor)) (cong (_++_ (map shape nms)) (pre-eq-refs actor))) p
                             ; post = post actor
                             ; computation = m
                             ; name = name actor
                             }

data SameValidityProof : Actor → Actor → Set₁ where
  AreSame :
    ∀ {A A' pre pre' post post'}
    {IS name references}
    {per per'}
    {computation computation'} →
    SameValidityProof
    (record
    { inbox-shape = IS
    ; A = A
    ; references = references
    ; pre = pre
    ; pre-eq-refs = per
    ; post = post
    ; computation = computation
    ; name = name
    })
    (record
    { inbox-shape = IS
    ; A = A'
    ; references = references
    ; pre = pre'
    ; pre-eq-refs = per'
    ; post = post'
    ; computation = computation'
    ; name = name
    })

-- A proof of an actor being valid is also valid for another actor if
-- * they have the same name
-- * they have the same references
-- * they have the same inbox type
rewrap-valid-actor : {store : Store} → {actorPre : Actor} → {actorPost : Actor} →
                     SameValidityProof actorPre actorPost →
                     ValidActor store actorPre →
                     ValidActor store actorPost
rewrap-valid-actor AreSame va = record { actor-has-inbox = va .actor-has-inbox ; references-have-pointer = va .references-have-pointer }

data ReferenceAdded (ref : NamedInbox) : Actor → Actor → Set₁ where
  RefAdded :
    ∀ {A A' pre pre' post post'}
    {IS name references}
    {per per'}
    {computation computation'} →
    ReferenceAdded ref
    (record
    { inbox-shape = IS
    ; A = A
    ; references = references
    ; pre = pre
    ; pre-eq-refs = per
    ; post = post
    ; computation = computation
    ; name = name
    })
    (record
    { inbox-shape = IS
    ; A = A'
    ; references = ref ∷ references
    ; pre = pre'
    ; pre-eq-refs = per'
    ; post = post'
    ; computation = computation'
    ; name = name
    })

add-reference-valid : {store : Store} → {actorPre : Actor} → {actorPost : Actor} →
                    {ref : NamedInbox} →
                    ReferenceAdded ref actorPre actorPost →
                    ValidActor store actorPre →
                    reference-has-pointer store ref →
                    ValidActor store actorPost
add-reference-valid RefAdded va p = record { actor-has-inbox = va .actor-has-inbox ; references-have-pointer = p ∷ (va .references-have-pointer) }

record ValidMessageList (store : Store) (S : InboxShape) : Set₁ where
  field
    inbox : Inbox S
    valid : All (message-valid store) inbox

InboxUpdater : (store : Store) (IS : InboxShape) → Set₁
InboxUpdater store IS = ValidMessageList store IS → ValidMessageList store IS

record UpdatedInbox (store : Store) {store' : Store} (original : Inboxes store') (name : Name) : Set₂ where
  field
    updated-inboxes : Inboxes store'
    inboxes-valid : InboxesValid store updated-inboxes
    others-unaffected : ∀ {name' IS' inb} → ¬ name ≡ name' → {p' : name' ↦ IS' ∈ store'} → InboxForPointer inb store' original p' → InboxForPointer inb store' updated-inboxes p'

open ValidMessageList
open UpdatedInbox
open NameSupply

-- Update one of the inboxes in a list of inboxes.
-- All the inboxes have been proven to be valid in the context of a store,
-- and the goal is to return a new list of inboxes which are also valid for the same store.
-- We know what inbox to update via an index using the inbox name into the list.
-- The update function receives both a list of messages from the inbox we pointed out,
-- and a proof that all the messages are valid for the store.
-- The update function returns a new list of the same type,
-- and has to provide a proof that this list is also valid for the store
update-inbox : {name : Name} → {IS : InboxShape} →
  (store : Store) →
  {store' : Store} →
  (inboxes : Inboxes store') →
  (InboxesValid store inboxes) →
  (name ↦ IS ∈ store') →
  (f : InboxUpdater store IS) →
  UpdatedInbox store inboxes name
update-inbox _ _ [] () _
update-inbox {name} store {store'} (x ∷ inboxes) (px ∷ proofs) zero f =
  record { updated-inboxes = inbox updated ∷ inboxes ; inboxes-valid = (valid updated) ∷ proofs ; others-unaffected = unaffected }
  where
    updated = (f (record { inbox = x ; valid = px }))
    unaffected : ∀ {name' IS' inb} → ¬ name ≡ name' → {p' : name' ↦ IS' ∈ store'} → InboxForPointer inb store' (x ∷ inboxes) p' → InboxForPointer inb store' (inbox updated ∷ inboxes) p'
    unaffected pr zero = ⊥-elim (pr refl)
    unaffected pr (suc ifp) = suc ifp
update-inbox {name} store {store'} (x ∷ inboxes) (px ∷ proofs) (suc p) f =
  record { updated-inboxes = x ∷ updated-inboxes updated ; inboxes-valid = px ∷ inboxes-valid updated ; others-unaffected = unaffected }
  where
    updated = (update-inbox store inboxes proofs p f)
    unaffected : ∀ {name' IS' inb} → ¬ name ≡ name' → {p' : name' ↦ IS' ∈ store'} → InboxForPointer inb store' (x ∷ inboxes) p' → InboxForPointer inb store' (x ∷ updated-inboxes updated) p'
    unaffected pr  zero = zero
    unaffected pr (suc ifp) = suc (others-unaffected updated pr ifp)

-- Move the actor that is at the top of the list, to the back of the list
-- This is done to create a round-robin system for the actors, since run-env always picks the actor at the top
-- Uses the insight that the order of the inboxes soes not correspond to the order of the Actors,
-- and that moving an actor to the back doesn't change any of the proofs about actors being valid.
top-actor-to-back : Env → Env
top-actor-to-back env with (acts env) | (actors-valid env)
top-actor-to-back env | [] | _ = env
top-actor-to-back env | x ∷ acts | (y ∷ prfs) = record
                             { acts = acts ++ [ x ]ˡ
                             ; blocked = blocked env
                             ; env-inboxes = env-inboxes env
                             ; store = store env
                             ; actors-valid = ++⁺ prfs [ y ]ᵃ
                             ; blocked-valid = blocked-valid env
                             ; messages-valid = messages-valid env
                             ; name-supply = name-supply env
                             ; blocked-no-progress = blocked-no-progress env
                             }

-- An actor is still valid if we add a new inbox to the store, as long as that name is not used in the store before
valid-actor-suc : ∀ {store actor IS} → (ns : NameSupply store) → ValidActor store actor → ValidActor (inbox# ns .name [ IS ] ∷ store) actor
valid-actor-suc ns va =
  let open ValidActor
      open _comp↦_∈_
  in record {
    actor-has-inbox = suc {pr = ns .name-is-fresh (actor-has-inbox va)} (actor-has-inbox va)
    ; references-have-pointer = ∀map (λ p → suc-p (ns .name-is-fresh (actual-has-pointer p)) p) (references-have-pointer va)
    }

valid-references-suc : ∀ {store references IS} →
                     (ns : NameSupply store) →
                     All (reference-has-pointer store) references →
                     All (reference-has-pointer (inbox# (ns .name) [ IS ] ∷ store)) references
valid-references-suc ns pointers =
  let open _comp↦_∈_
  in ∀map (λ p → suc-p (ns .name-is-fresh (actual-has-pointer p)) p) pointers

-- All the messages in an inbox are still valid if we add a new inbox to the store, as long as that name is not used in the store before
messages-valid-suc : ∀ {store IS x} {inb : Inbox IS} → (ns : NameSupply store) → all-messages-valid store inb → all-messages-valid (inbox# ns .name [ x ] ∷ store) inb
messages-valid-suc {store} {IS} {x} ns [] = []
messages-valid-suc {store} {IS} {x} {nx ∷ _} ns (px ∷ vi) = message-valid-suc nx px ∷ (messages-valid-suc ns vi)
  where
    open _comp↦_∈_
    fields-valid-suc : ∀ {MT} {fields : All named-field-content MT} →
      FieldsHavePointer store fields →
      FieldsHavePointer (inbox# ns .name [ x ] ∷ store) fields
    fields-valid-suc [] = []
    fields-valid-suc (FhpV ∷ valid) = FhpV ∷ fields-valid-suc valid
    fields-valid-suc (FhpR x ∷ valid) = FhpR (suc-p (ns .name-is-fresh (actual-has-pointer x)) x) ∷ (fields-valid-suc valid)
    message-valid-suc : (nx : NamedMessage IS) → message-valid store nx → message-valid (inbox# ns .name [ x ] ∷ store) nx
    message-valid-suc (NamedM x₁ x₂) px = fields-valid-suc px

is-blocked-suc : ∀ {store actor IS} {inbs : Inboxes store} {inb : Inbox IS} → (ns : NameSupply store) → IsBlocked store inbs actor → IsBlocked (inbox# ns .name [ IS ] ∷ store) (inb ∷ inbs) actor
is-blocked-suc ns (BlockedReturn at-return no-cont) = BlockedReturn at-return no-cont
is-blocked-suc ns (BlockedReceive at-receive p inbox-for-pointer) = BlockedReceive at-receive (suc {pr = ns .name-is-fresh p} p) (suc inbox-for-pointer)
is-blocked-suc ns (BlockedSelective at-selective p inb inbox-for-pointer filter-empty) = BlockedSelective at-selective (suc {pr = ns .name-is-fresh p} p) inb (suc inbox-for-pointer) filter-empty

-- Add a new actor to the environment.
-- The actor is added to the top of the list of actors.
add-top : ∀ {IS A post} → ActorState ∞ IS A [] post → Env → Env
add-top {IS} {A} {post} m env = record
                 { acts = record
                        { inbox-shape = IS
                        ; A = A
                        ; references = []
                        ; pre = []
                        ; pre-eq-refs = refl
                        ; post = post
                        ; computation = m
                        ; name = env .name-supply .supply .name
                        } ∷ acts env
                   ; blocked = blocked env
                   ; env-inboxes = [] ∷ env-inboxes env
                   ; store = inbox# env .name-supply .supply .name [ IS ] ∷ store env
                   ; actors-valid = record { actor-has-inbox = zero ; references-have-pointer = [] } ∷ ∀map (valid-actor-suc (env .name-supply .supply)) (actors-valid env)
                   ; blocked-valid = ∀map (valid-actor-suc (env .name-supply .supply)) (blocked-valid env)
                   ; messages-valid = [] ∷ map-suc (store env) (messages-valid env) (env .name-supply .supply)
                   ; name-supply = env .name-supply .next IS
                   ; blocked-no-progress = ∀map (is-blocked-suc (env .name-supply .supply)) (env .blocked-no-progress)
                   }
  where
    -- ad-hoc ∀map, because we are not using All here
    map-suc : (store : Store) → {store' : Store} → {inbs : Inboxes store'} → InboxesValid store inbs → (ns : NameSupply store) → InboxesValid (inbox# ns .name [ IS ] ∷ store) inbs
    map-suc store [] _ = []
    map-suc store (x ∷ valid) ns = messages-valid-suc ns x ∷ (map-suc store valid ns)

record GetInbox (store : Store) {store' : Store} (inboxes : Inboxes store') {name : Name} {S : InboxShape} (p : name ↦ S ∈ store') : Set₂ where
  field
    messages : Inbox S
    valid : all-messages-valid store messages
    right-inbox : InboxForPointer messages store' inboxes p

-- Get the messages of an inbox pointed to in the environment.
-- This is just a simple lookup into the list of inboxes.
get-inbox : ∀ {name IS} → (env : Env) → (p : name ↦ IS ∈ (store env)) → GetInbox (env .store) (env .env-inboxes) p
get-inbox env point = loop (env-inboxes env) (messages-valid env) point
  where
    loop : {store store' : Store} → (inbs : Inboxes store') → InboxesValid store inbs → ∀ {name IS} → (p : name ↦ IS ∈ store') → GetInbox store inbs p
    loop _ [] ()
    loop (x ∷ _) (px ∷ _) zero = record { messages = x ; valid = px ; right-inbox = zero }
    loop (_ ∷ inbs) (_ ∷ inb-valid) (suc point) =
      let rec = loop inbs inb-valid point
          open GetInbox
      in record { messages = rec .messages ; valid = rec .valid ; right-inbox = suc (rec .right-inbox) }

open GetInbox

record UnblockedActors {store store' : Store} {original : Inboxes store'} {n : Name} (updated : UpdatedInbox store original n) : Set₂ where
  field
    unblocked : List Actor
    unblocked-updated : All (λ act → n ≡ name act) unblocked
    unblocked-valid : All (ValidActor store) unblocked
    still-blocked : List Actor
    blocked-no-prog : All (IsBlocked store' (updated-inboxes updated)) still-blocked
    blocked-valid : All (ValidActor store) still-blocked

open UnblockedActors

unblock-actors :
  {store : Store} →
  {original : Inboxes store} →
  {n : Name} →
  (updated : UpdatedInbox store original n) →
  (blocked : List Actor) →
  All (ValidActor store) blocked →
  All (IsBlocked store original) blocked →
  UnblockedActors updated
unblock-actors updated [] [] [] = record
                                            { unblocked = []
                                            ; unblocked-updated = []
                                            ; unblocked-valid = []
                                            ; still-blocked = []
                                            ; blocked-no-prog = []
                                            ; blocked-valid = []
                                            }
unblock-actors {store} {original} {n} updated (x ∷ blckd) (v ∷ blckd-valid) (ib ∷ is-blocked) with (n ≟ (name x))
... | yes p =
  let rec = unblock-actors updated blckd blckd-valid is-blocked
  in record
       { unblocked = x ∷ rec .unblocked
       ; unblocked-updated = p ∷ rec .unblocked-updated
       ; unblocked-valid = v ∷ rec .unblocked-valid
       ; still-blocked = rec .still-blocked
       ; blocked-no-prog = rec .blocked-no-prog
       ; blocked-valid = rec .blocked-valid
       }
... | no ¬p =
  let rec = unblock-actors updated blckd blckd-valid is-blocked
  in record
       { unblocked = rec .unblocked
       ; unblocked-updated = rec .unblocked-updated
       ; unblocked-valid = rec .unblocked-valid
       ; still-blocked = x ∷ rec .still-blocked
       ; blocked-no-prog = blocked-unaffected ib ∷ rec .blocked-no-prog
       ; blocked-valid = v ∷ rec .blocked-valid
       }
    where
      blocked-unaffected : IsBlocked store original x → IsBlocked store (updated-inboxes updated) x
      blocked-unaffected (BlockedReturn x y) = BlockedReturn x y
      blocked-unaffected (BlockedReceive x p y) = BlockedReceive x p (others-unaffected updated ¬p y)
      blocked-unaffected (BlockedSelective x p a b c) = BlockedSelective x p a (others-unaffected updated ¬p b) c

update-inbox-env : ∀ {name IS} → (env : Env) → name ↦ IS ∈ (store env) →
                 (f : ValidMessageList (store env) IS → ValidMessageList (store env) IS) → Env
update-inbox-env {name} {IS} env p f =
  let
    updated = update-inbox (store env) (env-inboxes env) (messages-valid env) p f
    unblock-split = unblock-actors updated (blocked env) (blocked-valid env) (blocked-no-progress env)
  in record {
    acts = (unblocked unblock-split) ++ acts env
    ; blocked = still-blocked unblock-split
    ; env-inboxes = updated-inboxes updated
    ; store = store env
    ; actors-valid = ++⁺ (unblock-split .unblocked-valid) (env .actors-valid)
    ; blocked-valid = unblock-split .blocked-valid
    ; messages-valid = inboxes-valid updated
    ; name-supply = env .name-supply
    ; blocked-no-progress = unblock-split .blocked-no-prog
    }

record FoundReference (store : Store) (S : InboxShape) : Set₂ where
  field
    name : Name
    reference : name comp↦ S ∈ store

lookup-reference : ∀ {store ToIS} → (pre : TypingContext) → (refs : List NamedInbox) → All (reference-has-pointer store) refs → map shape refs ≡ pre → ToIS ∈ pre → FoundReference store ToIS
lookup-reference [] refs prfs eq ()
lookup-reference (x ∷ pre₁) [] prfs () Z
lookup-reference (x ∷ pre₁) [] prfs () (S px)
lookup-reference _ (inbox# name [ shape ] ∷ refs) (reference ∷ prfs) refl Z = record { name = name ; reference = reference }
lookup-reference _ (_ ∷ refs) (_ ∷ prfs) refl (S px) = lookup-reference _ refs prfs refl px

-- looks up the pointer for one of the references known by an actor
lookup-reference-act : ∀ {store actor ToIS} → ValidActor store actor → ToIS ∈ (pre actor) → FoundReference store ToIS
lookup-reference-act {store} {actor} {ToIS} va ref = lookup-reference (pre actor) (Actor.references actor) (ValidActor.references-have-pointer va) (pre-eq-refs actor) ref

open _comp↦_∈_
open FoundReference

-- Extract the found pointer
underlying-pointer : ∀ {IS store} → (ref : FoundReference store IS) → (name ref ↦ actual (reference ref) ∈ store )
underlying-pointer ref = actual-has-pointer (reference ref)

translate-message-pointer : ∀ {ToIS A store} →
  (w : FoundReference store ToIS) →
  A ∈ ToIS →
  A ∈ (actual (reference w))
translate-message-pointer w x = translate-⊆ (actual-handles-wanted (reference w)) x

record LiftedReferences (lss gss : TypingContext) (references : List NamedInbox) : Set₂ where
  field
    subset-inbox : lss ⊆ gss
    contained : List NamedInbox
    subset : contained ⊆ references
    contained-eq-inboxes : map shape contained ≡ lss

open LiftedReferences

-- Convert a subset for preconditions to a subset for references
lift-references : ∀ {lss gss} → lss ⊆ gss → (references : List NamedInbox) → map shape references ≡ gss → LiftedReferences lss gss references
lift-references [] refs refl = record {
  subset-inbox = []
  ; contained = []
  ; subset = []
  ; contained-eq-inboxes = refl
  }
lift-references (_∷_ {y} {xs} x₁ subs) refs refl with (lift-references subs refs refl)
... | q  = record {
  subset-inbox = x₁ ∷ subs
  ; contained = contained-el ∷ contained q
  ; subset = (translate-∈ x₁ refs shape refl) ∷ (subset q)
  ; contained-eq-inboxes = combine contained-el-shape y (map shape (contained q)) xs (sym contained-el-ok) (contained-eq-inboxes q)
  }
  where
    contained-el : NamedInbox
    contained-el = lookup-parallel x₁ refs shape refl
    contained-el-shape = shape contained-el
    contained-el-ok : y ≡ contained-el-shape
    contained-el-ok = lookup-parallel-≡ x₁ refs shape refl
    combine : (a b : InboxShape) → (as bs : TypingContext) → (a ≡ b) → (as ≡ bs) → (a ∷ as ≡ b ∷ bs)
    combine a .a as .as refl refl = refl

data LiftActor : Actor → Actor → Set₂ where
  CanBeLifted :
    ∀ {A A' post post'}
    {IS name references}
    {lss gss}
    {per}
    {computation computation'} →
    (lr : LiftedReferences lss gss references) →
    LiftActor
    (record
    { inbox-shape = IS
    ; A = A
    ; references = references
    ; pre = gss
    ; pre-eq-refs = per
    ; post = post
    ; computation = computation
    ; name = name
    })
    (record
    { inbox-shape = IS
    ; A = A'
    ; references = lr .contained
    ; pre = lss
    ; pre-eq-refs = lr .contained-eq-inboxes
    ; post = post'
    ; computation = computation'
    ; name = name
    })

lift-valid-actor : ∀ {store} {act act' : Actor} →
                   LiftActor act act' →
                   ValidActor store act →
                   ValidActor store act'
lift-valid-actor (CanBeLifted lr) va =
  record {
    actor-has-inbox = va .actor-has-inbox
    ; references-have-pointer = All-⊆ (lr .subset) (va .references-have-pointer)
    }

-- We can replace the actors in an environment if they all are valid for the current store.
replace-actors : (env : Env) → (actors : List Actor) → All (ValidActor (store env)) actors → Env
replace-actors env actors actorsValid = record {
  acts = actors
  ; blocked = env .blocked
  ; env-inboxes = env .env-inboxes
  ; store = env .store
  ; actors-valid = actorsValid
  ; blocked-valid = env .blocked-valid
  ; messages-valid = env .messages-valid
  ; name-supply = env .name-supply
  ; blocked-no-progress = env .blocked-no-progress
  }

replace-focused : {act : Actor} → (env : Env) → Focus act env →
                  (act' : Actor) →
                  (valid' : ValidActor (env .store) act') →
                  Env
replace-focused env@record {
  acts = _ ∷ rest
  ; actors-valid = _ ∷ rest-valid
  } Focused act' valid' =
  replace-actors env (act' ∷ rest) (valid' ∷ rest-valid)

block-focused : {act : Actor} → (env : Env) → Focus act env → IsBlocked (env .store) (env .env-inboxes) act → Env
block-focused env@record {
  acts = actor ∷ rest
  ; blocked = blocked
  ; actors-valid = actor-valid ∷ rest-valid
  ; blocked-valid = blocked-valid
  } Focused blckd = record {
  acts = rest
  ; blocked = actor ∷ blocked
  ; store = env .store
  ; env-inboxes = env .env-inboxes
  ; name-supply = env .name-supply
  ; actors-valid = rest-valid
  ; blocked-valid = actor-valid ∷ blocked-valid
  ; messages-valid = env .messages-valid
  ; blocked-no-progress = blckd ∷ env .blocked-no-progress
  }

-- Takes a named message and a proof that the named message is valid for the store.
-- Values are valid for any store and references need a proof that the pointer is valid.
add-message : {S : InboxShape} → {store : Store} → (message : NamedMessage S) → message-valid store message → (ValidMessageList store S → ValidMessageList store S)
add-message message valid vml = record {
  inbox = inbox vml ++ [ message ]ˡ
  ; valid = ++⁺ (ValidMessageList.valid vml) [ valid ]ᵃ
  }

-- Removes the next message from an inbox.
-- This is a no-op if there are no messages in the inbox.
remove-message : {S : InboxShape} → {store : Store} → (ValidMessageList store S → ValidMessageList store S)
remove-message vml = record { inbox = drop 1 (inbox vml) ; valid = drop⁺ 1 (ValidMessageList.valid vml) }

name-fields : ∀ {MT store} → (pre : TypingContext) →
               (refs : List NamedInbox) →
               All (reference-has-pointer store) refs →
               All (send-field-content pre) MT →
               map shape refs ≡ pre →
               All named-field-content MT
name-fields pre refs rhp [] eq = []
name-fields _ refs rhp (_∷_ {ValueType x} (lift lower) sfc) refl = lower ∷ (name-fields _ refs rhp sfc refl)
name-fields {store = store} _ refs rhp (_∷_ {ReferenceType x} px sfc) refl = name (lookup-reference _ refs rhp refl (_⊢>:_.actual-is-sendable px)) ∷ (name-fields _ refs rhp sfc refl)

name-fields-act : ∀ {MT} store → ∀ actor →
              All (send-field-content (pre actor)) MT →
              ValidActor store actor → All named-field-content MT
name-fields-act store actor sfc valid = name-fields (pre actor) (Actor.references actor) (references-have-pointer valid) sfc (pre-eq-refs actor)

unname-field : ∀ {x} → named-field-content x → receive-field-content x
unname-field {ValueType x₁} nfc = nfc
unname-field {ReferenceType x₁} nfc = _

extract-inboxes : ∀ {MT} → All named-field-content MT → List NamedInbox
extract-inboxes [] = []
extract-inboxes (_∷_ {ValueType _} _ ps) = extract-inboxes ps
extract-inboxes (_∷_ {ReferenceType x} name ps) = inbox# name [ x ] ∷ extract-inboxes ps

named-inboxes : ∀ {S} → (nm : NamedMessage S) → List NamedInbox
named-inboxes (NamedM x x₁) = extract-inboxes x₁

reference-names : {MT : MessageType} → All named-field-content MT → List Name
reference-names [] = []
reference-names (_∷_ {ValueType x} px ps) = reference-names ps
reference-names (_∷_ {ReferenceType x} name ps) = name ∷ reference-names ps

++-diff : (a b c : List InboxShape) → a ≡ b → a ++ c ≡ b ++ c
++-diff [] .[] c refl = refl
++-diff (x ∷ a) .(x ∷ a) c refl = refl

add-fields++ : ∀ MT → (x₁ : All named-field-content MT) → map shape (extract-inboxes x₁) ≡ extract-references MT
add-fields++ [] [] = refl
add-fields++ (ValueType x ∷ MT) (px ∷ x₁) = add-fields++ MT x₁
add-fields++ (ReferenceType x ∷ MT) (px ∷ x₁) = cong (_∷_ x) (add-fields++ MT x₁)

add-references++ : ∀ {S store} → (nm : NamedMessage S) → message-valid store nm → ∀ w → map shape (named-inboxes nm) ++ w ≡ add-references w (unname-message nm)
add-references++ msg@(NamedM {MT} x x₁) p w = halp (add-fields++ MT x₁)
  where
    halp : map shape (extract-inboxes x₁) ≡ extract-references MT → map shape (extract-inboxes x₁) ++ w ≡ extract-references MT ++ w
    halp p = ++-diff (map shape (extract-inboxes x₁)) (extract-references MT) w p

valid++ : ∀ {S store} → (nm : NamedMessage S) → message-valid store nm → ∀ {w} →
        All (reference-has-pointer store) w →
        All (reference-has-pointer store) (named-inboxes nm ++ w)
valid++ (NamedM x x₁) v = valid-fields v
  where
    valid-fields : ∀ {MT store} →
                   {fields : All named-field-content MT} →
                   FieldsHavePointer store fields → ∀ {p} →
                   All (reference-has-pointer store) p →
                   All (reference-has-pointer store) (extract-inboxes fields ++ p)
    valid-fields [] ps = ps
    valid-fields (FhpV ∷ fhp) ps = valid-fields fhp ps
    valid-fields (FhpR px ∷ fhp) ps = px ∷ (valid-fields fhp ps)

open _⊢>:_

compatible-handles : ∀ store x refs
                     (px : (map shape refs) ⊢>: x)
                     (w : FoundReference store (actual px)) →
                     x ⊆ actual (reference w)
compatible-handles store x refs px w =
  let a = actual-handles-requested px
      b = actual-handles-wanted (reference w)
  in ⊆-trans a b

make-pointer-compatible : ∀ store x refs
                       (px : (map shape refs) ⊢>: x) →
                       (All (reference-has-pointer store) refs) →
                       (w : FoundReference store (actual px)) →
                       name w comp↦ x ∈ store
make-pointer-compatible store x refs px rhp w = [p: actual-has-pointer (reference w) ][handles: compatible-handles store x refs px w ]

open FieldsHavePointer

make-pointers-compatible : ∀ {MT} store pre refs (eq : map shape refs ≡ pre)
                           (fields : All (send-field-content pre) MT)
                           (rhp : All (reference-has-pointer store) refs) →
                         FieldsHavePointer store (name-fields pre refs rhp fields eq)
make-pointers-compatible store pre refs eq [] rhp = []
make-pointers-compatible store _ refs refl (_∷_ {ValueType x} px fields) rhp = FhpV ∷ make-pointers-compatible store _ refs refl fields rhp
make-pointers-compatible store _ refs refl (_∷_ {ReferenceType x} px fields) rhp =
  let foundFw = lookup-reference _ refs rhp refl (actual-is-sendable px)
  in FhpR (make-pointer-compatible store x refs px rhp foundFw) ∷ (make-pointers-compatible store _ refs refl fields rhp)

-- Removes the next message from an inbox.
-- This is a no-op if there are no messages in the inbox.
remove-found-message : {S : InboxShape} → {store : Store} → (filter : MessageFilter S) → (ValidMessageList store S → ValidMessageList store S)
remove-found-message f record { inbox = [] ; valid = [] } = record { inbox = [] ; valid = [] }
remove-found-message {s} {store} f record { inbox = (x ∷ inbox₁) ; valid = vx ∷ valid₁ } with (f (unname-message x))
... | false =
  let vml = remove-found-message f (record { inbox = inbox₁ ; valid = valid₁ })
      open ValidMessageList
  in record { inbox = x ∷ vml .inbox ; valid = vx ∷ vml .valid }
... | true = record { inbox = inbox₁ ; valid = valid₁ }