module Async where

open import Data.Fin
open import Data.List hiding (drop)
open import Data.List.All

open import Typing renaming (send to ssend ; recv to srecv)
open import Syntax
open import Values

-- an asynchronous channel is a promise for a channel
ASession DSession : STypeF SType → STypeF SType
ASession s = srecv (TChan s) (delay send!)
DSession s = dualF (ASession s)

AChan DChan : STypeF SType → Type
AChan s = TChan (ASession s)
DChan s = TChan (DSession s)

Promise : (s : SType) → Type
Promise s = TPair (AChan (SType.force s)) (DChan (SType.force s))

new-promise : ∀ {Φ} → All Unr Φ → (s : SType) → Expr Φ (Promise s)
new-promise unr-Φ s = new unr-Φ (delay (ASession (SType.force s)))

-- create an async channel
anew : ∀ {Φ}
  → (unr-Φ : All Unr Φ)
  → (s : SType)
  → Expr Φ (TPair (AChan (SType.force s)) (AChan (SType.force (dual s))))
anew unr-Φ s =
  letbind (split-all-unr unr-Φ) (new unr-Φ s)
  (letpair (left (split-all-unr unr-Φ)) (here unr-Φ)
  (letbind (rght (rght (split-all-unr unr-Φ))) (new-promise unr-Φ s)
  (letpair (left (rght (rght (split-all-unr unr-Φ)))) (here unr-Φ)
  (letbind (rght (rght (rght (rght (split-all-unr unr-Φ))))) (new-promise unr-Φ (dual s))
  (letpair (left (rght (rght (rght (rght (split-all-unr unr-Φ)))))) (here unr-Φ)
  (letbind (rght (rght (rght (left (left (rght (split-all-unr unr-Φ)))))))
           (fork (letbind (left (left (split-all-unr unr-Φ))) (send (left (rght (split-all-unr unr-Φ))) (here unr-Φ) (here unr-Φ))
                 (wait (here unr-Φ))))
  (letbind (drop UUnit (rght (left (rght (left (split-all-unr unr-Φ))))))
           (fork (letbind (left (left (split-all-unr unr-Φ))) (send (left (rght (split-all-unr unr-Φ))) (here unr-Φ) (here unr-Φ))
                 (wait (here unr-Φ))))
  (pair (drop UUnit (rght (left (split-all-unr unr-Φ))))
        (here unr-Φ) (here unr-Φ)))))))))

asend : ∀ {Φ Φ₁ Φ₂ s t}
  → (sp : Split Φ Φ₁ Φ₂)
  → (ch : (AChan (ssend t s)) ∈ Φ₁)
  → (vt : t ∈ Φ₂)
  → Expr Φ (AChan (SType.force s))
asend {Φ} {s = s} sp ch vt =
  letbind (split-all-right Φ) (new-promise [] s)
  (letpair (left (split-all-right Φ)) (here [])
  (letbind (rght (left (split-all-left Φ)))
           -- read actual channel & actual send & send depleted channel & close
           (fork (letbind (rght sp) (recv ch)
                 (letpair (left (split-all-right _)) (here [])
                 (letbind (left (split-all-right _)) (close (here []))
                 (letbind (drop UUnit (left (rght (split-all-left _)))) (send (left (split-all-right _)) (here []) vt)
                 (letbind (left (left [])) (send (rght (left [])) (here []) (here []))
                 (letbind (left []) (wait (here []))
                 (var (here [])))))))))
  (var (there UUnit (here [])))))

-- receive is a blocking operation!
arecv : ∀ {Φ s t}
      → (ch : (AChan (srecv t s)) ∈ Φ)
      → Expr Φ (TPair (AChan (SType.force s)) t)
arecv {s = s} ch =
  letbind (split-all-right _) (new-promise [] s)
  (letpair (left (split-all-right _)) (here [])
  (letbind (rght (rght (split-all-left _))) (recv ch)
  (letpair (left (rght (rght (split-all-right _)))) (here [])
  (letbind (left (rght (rght (rght [])))) (close (here []))
  (letbind (drop UUnit (left (rght (rght [])))) (recv (here []))
  (letpair (left (rght (rght []))) (here [])
  (letbind (left (rght (rght (left []))))
           (fork (letbind (left (left []))
                          (send (rght (left [])) (here []) (here []))
                          (wait (here []))))
  (pair (drop UUnit (rght (left []))) (here []) (here [])))))))))

aclose : ∀ {Φ}
      → (ch : AChan send! ∈ Φ)
      → Expr Φ TUnit
aclose ch =
  fork (letbind (split-all-left _) (recv ch)
       (letpair (left []) (here [])
       (letbind (left (rght [])) (close (here []))
       (close (there UUnit (here []))))))

await : ∀ {Φ}
      → (ch : AChan send? ∈ Φ)
      → Expr Φ TUnit
await ch =
  fork (letbind (split-all-left _) (recv ch)
       (letpair (left []) (here [])
       (letbind (left (rght [])) (close (here []))
       (wait (there UUnit (here []))))))

anselect : ∀ {Φ m alt}
      → (lab : Fin m)
      → (ch : AChan (sintN m alt) ∈ Φ)
      → Expr Φ (AChan (SType.force (alt lab)))
anselect {alt = alt} lab ch =
  letbind (split-all-right _)
          (new-promise [] (alt lab))
  (letpair (left (split-all-right _)) (here [])
  (letbind (rght (left (split-all-left _)))
           (fork (letbind (rght (split-all-left _)) (recv ch)
                 (letpair (left (rght [])) (here [])
                 (letbind (left (rght (rght []))) (close (here []))
                 (letbind (drop UUnit (left (rght []))) (nselect lab (here []))
                 (letbind (left (left [])) (send (rght (left [])) (here []) (here []))
                 (wait (here []))))))))
  (var (there UUnit (here [])))))

-- branching is a blocking operation!
anbranch : ∀ {Φ m alt Φ₁ Φ₂ t}
      → (sp : Split Φ Φ₁ Φ₂)
      → (ch : AChan (sextN m alt) ∈ Φ₁)
      → (ealts : (i : Fin m) → Expr (AChan (SType.force (alt i)) ∷ Φ₂) t)
      → Expr Φ t
anbranch{alt = alt} sp ch ealts =
  letbind sp (recv ch)
  (letpair (left (split-all-right _)) (here [])
  (letbind (left (split-all-right _)) (close (here []))
  (nbranch (drop UUnit (left (split-all-right _))) (here [])
  (λ i → letbind (split-all-right _) (new-promise [] (alt i))
         (letpair (left (split-all-right _)) (here [])
         (letbind (rght (left (left (split-all-right _))))
                  (fork (letbind (left (left [])) (send (left (rght [])) (here []) (here []))
                        (wait (here []))))
         (letbind (drop UUnit (left (split-all-right _))) (var (here []))
                  (ealts i))))))))


module Esterel.Context where

open import Esterel.Lang
open import Esterel.Environment
  using (Env)
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 Data.List
  using (List ; _∷_ ; [])

infix   7 _⟦_⟧e
infix   7 _⟦_⟧c
infix   4 _≐_⟦_⟧e
infix   4 _≐_⟦_⟧c

data EvaluationContext1 : Set where
  epar₁    : (q : Term)    → EvaluationContext1
  epar₂    : (p : Term)    → EvaluationContext1
  eseq     : (q : Term)    → EvaluationContext1
  eloopˢ   : (q : Term)    → EvaluationContext1
  esuspend : (S : Signal)  → EvaluationContext1
  etrap    :                 EvaluationContext1

EvaluationContext : Set
EvaluationContext = List EvaluationContext1

_⟦_⟧e : EvaluationContext → Term → Term
[]               ⟦ p ⟧e = p
(epar₁ q ∷ E)    ⟦ p ⟧e = (E ⟦ p ⟧e) ∥  q
(epar₂ p ∷ E)    ⟦ q ⟧e = p          ∥  (E ⟦ q ⟧e)
(eseq q ∷ E)     ⟦ p ⟧e = (E ⟦ p ⟧e) >> q
(eloopˢ q ∷ E)   ⟦ p ⟧e = loopˢ (E ⟦ p ⟧e) q
(esuspend S ∷ E) ⟦ p ⟧e = suspend (E ⟦ p ⟧e) S
(etrap ∷ E)      ⟦ p ⟧e = trap (E ⟦ p ⟧e)

data _≐_⟦_⟧e : Term → EvaluationContext → Term → Set where
  dehole    : ∀{p}                        → (p           ≐  []               ⟦ p ⟧e)
  depar₁    : ∀{p r q E} → (p ≐ E ⟦ r ⟧e) → (p ∥ q       ≐  (epar₁ q ∷ E)    ⟦ r ⟧e)
  depar₂    : ∀{p r q E} → (q ≐ E ⟦ r ⟧e) → (p ∥ q       ≐  (epar₂ p ∷ E)    ⟦ r ⟧e)
  deseq     : ∀{p r q E} → (p ≐ E ⟦ r ⟧e) → (p >> q      ≐  (eseq q ∷ E)     ⟦ r ⟧e)
  deloopˢ   : ∀{p r q E} → (p ≐ E ⟦ r ⟧e) → (loopˢ p q   ≐  (eloopˢ q ∷ E)   ⟦ r ⟧e)
  desuspend : ∀{p E r S} → (p ≐ E ⟦ r ⟧e) → (suspend p S ≐  (esuspend S ∷ E) ⟦ r ⟧e)
  detrap    : ∀{p E r}   → (p ≐ E ⟦ r ⟧e) → (trap p      ≐  (etrap ∷ E)      ⟦ r ⟧e)

-- Should we just not use inclusion from EvaluationContext?
data Context1 : Set where
  ceval     : (E1 : EvaluationContext1) → Context1
  csignl    : (S : Signal) → Context1
  cpresent₁ : (S : Signal) → (q : Term) → Context1
  cpresent₂ : (S : Signal) → (p : Term) → Context1
  cloop     : Context1
  cloopˢ₂   : (p : Term) → Context1
  cseq₂     : (p : Term) → Context1
  cshared   : (s : SharedVar) → (e : Expr) → Context1
  cvar      : (x : SeqVar) → (e : Expr) → Context1
  cif₁      : (x : SeqVar) → (q : Term) → Context1
  cif₂      : (x : SeqVar) → (p : Term) → Context1
  cenv      : (θ : Env) →  (A : Ctrl) → Context1

Context : Set
Context = List Context1

_⟦_⟧c : Context → Term → Term
[]                       ⟦ p ⟧c = p
(ceval (epar₁ q) ∷ C)    ⟦ p ⟧c = (C ⟦ p ⟧c) ∥ q
(ceval (epar₂ p) ∷ C)    ⟦ q ⟧c = p          ∥ (C ⟦ q ⟧c)
(ceval (eseq q) ∷ C)     ⟦ p ⟧c = (C ⟦ p ⟧c) >> q
(ceval (eloopˢ q) ∷ C)   ⟦ p ⟧c = loopˢ (C ⟦ p ⟧c) q
(cseq₂ p ∷ C)            ⟦ q ⟧c = p          >> (C ⟦ q ⟧c)
(ceval (esuspend S) ∷ C) ⟦ p ⟧c = suspend (C ⟦ p ⟧c) S
(ceval etrap ∷ C)        ⟦ p ⟧c = trap (C ⟦ p ⟧c)
(csignl S ∷ C)           ⟦ p ⟧c = signl S (C ⟦ p ⟧c)
(cpresent₁ S q ∷ C)      ⟦ p ⟧c = present S ∣⇒ (C ⟦ p ⟧c) ∣⇒ q
(cpresent₂ S p ∷ C)      ⟦ q ⟧c = present S ∣⇒ p          ∣⇒ (C ⟦ q ⟧c)
(cloop ∷ C)              ⟦ p ⟧c = loop (C ⟦ p ⟧c)
(cloopˢ₂ p ∷ C)          ⟦ q ⟧c = loopˢ p (C ⟦ q ⟧c)
(cshared s e ∷ C)        ⟦ p ⟧c = shared s ≔ e in: (C ⟦ p ⟧c)
(cvar x e ∷ C)           ⟦ p ⟧c = var x ≔ e in: (C ⟦ p ⟧c)
(cif₁ x q ∷ C)           ⟦ p ⟧c = if x ∣⇒ (C ⟦ p ⟧c) ∣⇒ q
(cif₂ x p ∷ C)           ⟦ q ⟧c = if x ∣⇒ p          ∣⇒ (C ⟦ q ⟧c)
(cenv θ A ∷ C)           ⟦ p ⟧c = ρ⟨ θ , A ⟩· (C ⟦ p ⟧c)

data _≐_⟦_⟧c : Term → Context → Term → Set where
  dchole     : ∀{p}                            → (p                    ≐  []                       ⟦ p ⟧c)
  dcpar₁     : ∀{p r q C}     → (p ≐ C ⟦ r ⟧c) → (p ∥ q                ≐  (ceval (epar₁ q) ∷ C)    ⟦ r ⟧c)
  dcpar₂     : ∀{p r q C}     → (q ≐ C ⟦ r ⟧c) → (p ∥ q                ≐  (ceval (epar₂ p) ∷ C)    ⟦ r ⟧c)
  dcseq₁     : ∀{p r q C}     → (p ≐ C ⟦ r ⟧c) → (p >> q               ≐  (ceval (eseq q) ∷ C)     ⟦ r ⟧c)
  dcseq₂     : ∀{p r q C}     → (q ≐ C ⟦ r ⟧c) → (p >> q               ≐  (cseq₂ p ∷ C)            ⟦ r ⟧c)
  dcsuspend  : ∀{p C r S}     → (p ≐ C ⟦ r ⟧c) → (suspend p S          ≐  (ceval (esuspend S) ∷ C) ⟦ r ⟧c)
  dctrap     : ∀{p C r}       → (p ≐ C ⟦ r ⟧c) → (trap p               ≐  (ceval etrap ∷ C)        ⟦ r ⟧c)
  dcsignl    : ∀{p C r S}     → (p ≐ C ⟦ r ⟧c) → (signl S p            ≐  (csignl S ∷ C)           ⟦ r ⟧c)
  dcpresent₁ : ∀{p r q C S}   → (p ≐ C ⟦ r ⟧c) → (present S ∣⇒ p ∣⇒ q   ≐  (cpresent₁ S q ∷ C)      ⟦ r ⟧c)
  dcpresent₂ : ∀{p r q C S}   → (q ≐ C ⟦ r ⟧c) → (present S ∣⇒ p ∣⇒ q   ≐  (cpresent₂ S p ∷ C)      ⟦ r ⟧c)
  dcloop     : ∀{p C r}       → (p ≐ C ⟦ r ⟧c) → (loop p               ≐  (cloop ∷ C)              ⟦ r ⟧c)
  dcloopˢ₁   : ∀{p q C r}     → (p ≐ C ⟦ r ⟧c) → (loopˢ p q            ≐  (ceval (eloopˢ q) ∷ C)   ⟦ r ⟧c)
  dcloopˢ₂   : ∀{p q C r}     → (q ≐ C ⟦ r ⟧c) → (loopˢ p q            ≐  (cloopˢ₂ p ∷ C)          ⟦ r ⟧c)
  dcshared   : ∀{p C r s e}   → (p ≐ C ⟦ r ⟧c) → (shared s ≔ e in: p   ≐  (cshared s e ∷ C)        ⟦ r ⟧c)
  dcvar      : ∀{p C r x e}   → (p ≐ C ⟦ r ⟧c) → (var x ≔ e in: p      ≐  (cvar x e ∷ C)           ⟦ r ⟧c)
  dcif₁      : ∀{p r q x C}   → (p ≐ C ⟦ r ⟧c) → (if x ∣⇒ p ∣⇒ q        ≐  (cif₁ x q ∷ C)           ⟦ r ⟧c)
  dcif₂      : ∀{p r q x C}   → (q ≐ C ⟦ r ⟧c) → (if x ∣⇒ p ∣⇒ q        ≐  (cif₂ x p ∷ C)           ⟦ r ⟧c)
  dcenv      : ∀{p C r θ A}     → (p ≐ C ⟦ r ⟧c) → (ρ⟨ θ , A ⟩· p       ≐  (cenv θ A ∷ C)             ⟦ r ⟧c)


open import Reflection hiding (return; _>>=_)

open import Data.List renaming (_++_ to _++l_)
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≈?_)

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 {
    _++_ = _++l_;
    ε = []
    }

  monoidStr : RawMonoid String
  monoidStr = record {
    _++_ = _++s_;
    ε = ""
    }

  monoidErrStr : RawMonoid (Err String)
  monoidErrStr = record {
    _++_ =  λ where
      (error s) _ → error s
      _ (error s) → error s
      (ok s₁) (ok s₂) → ok (s₁ ++ s₂)
    ;
    ε = ok ""
    }

  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

defName : Term → Maybe Name
defName (def f args) = just f
defName _ = nothing

Ctx = List $ Arg Type

pi-to-ctx : Term → Ctx

-- we have a Ctx for the entire function, now we want to build
-- a context for the given variables in the clause.  To do so
-- we merge function's ctx with patterns of the given clause
-- and we grab the types that correspond to the variables within
-- the patterns.
--pats-ctx : Ctx → (List $ Arg Pattern) → TC $ Maybe Ctx

macro
  reflect : Term → Term → TC ⊤
  reflect f a = (derefImmediate f)
                >>= quoteTC >>= unify a

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

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

  rmkstring : Term → Term → TC ⊤
  rmkstring f a = unify (lit (string "Test")) a

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

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

Prog = Err $ List String
infixl 5 _#p_
_#p_ = _++_

okl : String → Prog
okl s = ok ([ s ])

-- reduce a list of Progs with a delimiter
_/#p_ : List Prog → (delim : String) → Prog
[] /#p d = ok []
(x ∷ []) /#p d = x
(x ∷ xs@(_ ∷ _)) /#p d = x #p okl d #p xs /#p d

-- Normalise the name of functions that we obtain from showName,
-- i.e. remove dots, replace weird symbols by ascii.
nnorm : String → Prog
nnorm s = okl
        $ replace '.' '_'
        $ replace '-' '_'
        $ s
  where
    repchar : (t f x : Char) → Char
    repchar f t x with x c≈? f
    ... | yes _ = t
    ... | no  _ = x

    replace : (from to : Char) → String → String
    replace f t s = fromList $ map (repchar f t) $ toList s

data NumClauses : Set where
  Many One : NumClauses

record State : Set where
  constructor st
  field
    --arg-ctx     : Ctx
    --ret-typ     : String
    var-names   : List String
    retvar      : String
    cls         : NumClauses
open State

--compile-clause : Clause → State → Prog

-- Pack the information about new variables generated
-- by patterns in the clause, assignments to these,
-- and the list of conditions.  E.g.
--   foo : List ℕ → ℕ
--   foo (x ∷ xs) 2 = ...
--
-- Assume that we named top-level arguments [a, b]
-- Then, new variables for this clause are going to be
--     [x, xs]
-- Assignments are:
--     [x = hd a, xs = tl a]
-- Conditions are:
--     [is-cons a, b = 2]
record ClCond : Set where
  constructor clcond
  field
    vars    : List String
    assigns : List String
    conds   : List String

data MbClCond : Set where
  ok     : ClCond → MbClCond
  error  : String → MbClCond

_#c_ : MbClCond → MbClCond → MbClCond
error s #c _ = error s
_ #c error s = error s
ok (clcond a b c) #c ok (clcond a' b' c') = ok (clcond (a ++ a') (b ++ b') (c ++ c'))

{-# TERMINATING #-}
clause-ctx-vars : (pats : List $ Arg Pattern) → (vars : List String) → (counter : ℕ) → MbClCond

showLitProg : Literal → Prog

comp-term : Term → (varctx : List String) → Prog

sjoin : List String → String → String
sjoin [] delim = ""
sjoin (x ∷ []) delim = x
sjoin (x ∷ xs@(_ ∷ _)) delim = x ++s delim ++s sjoin xs delim

join' : List String → (delim : String) → (empty : String) → String
join' []        _ e = e
join' x@(_ ∷ _) d _ = sjoin x d

compile-cls : List Clause → State → Prog
compile-cls [] s = error "comile-cls: expected at least one clause"
compile-cls (clause ps t ∷ []) s with clause-ctx-vars ps (var-names s) 0
... | error msg = error msg
... | ok (clcond vars assgns conds) = let
        as = sconc (map (_++s "\n") assgns)
        rv = retvar s ++s " = "
    in okl (as ++s rv) #p comp-term t vars #p okl ";"
compile-cls (absurd-clause ps ∷ []) s with clause-ctx-vars ps (var-names s) 0
... | error msg = error msg
... | ok (clcond vars assgns conds) = okl "unreachable ();"
compile-cls (clause ps t ∷ xs@(_ ∷ _)) s with clause-ctx-vars ps (var-names s) 0
... | error msg = error msg
... | ok (clcond vars assgns conds) = let
        cs = join' conds " && " "true"
        as = sconc (map (_++s "\n") assgns)
        rv = retvar s ++s " = "
    in okl ("if (" ++s cs ++s ") {" ++s as ++s rv) #p comp-term t vars #p okl "; }"
       #p okl "else {"
       #p compile-cls xs s
       #p okl "}"
compile-cls (absurd-clause ps ∷ xs@(_ ∷ _)) s with clause-ctx-vars ps (var-names s) 0
... | error msg = error msg
... | ok (clcond vars assgns conds) = let
        -- XXX it would be weird if conds were empty... catch it?
        cs = join' conds " && " "true"
    in okl ("if (" ++s cs ++s ") { unreachable (); } else {" )
       #p compile-cls xs s
       #p okl "}"

clause-ctx-vars (arg i (con c ps) ∷ l) (v ∷ vars) vcnt with showName c
... | "Agda.Builtin.List.List.[]" =
           ok (clcond [] [] [ "emptyvec_p (" ++s v ++s ")" ])
           #c clause-ctx-vars l vars vcnt
... | "Agda.Builtin.List.List._∷_" =
           ok (clcond [] [] [ "nonemptyvec_p (" ++s v ++s ")" ])
           #c clause-ctx-vars (ps ++ l) (("hd (" ++s v ++s ")") ∷ ("tl (" ++s v ++s ")") ∷ vars) vcnt
... | "Agda.Builtin.Bool.Bool.true" =
           ok (clcond [] [] [ v {- == true -} ])
           #c clause-ctx-vars l vars vcnt
... | "Agda.Builtin.Bool.Bool.false" =
           ok (clcond [] [] [ "! " ++s v ])
           #c clause-ctx-vars l vars vcnt
... | "Agda.Builtin.Nat.Nat.suc" =
           ok (clcond [] [] [ v ++s " > 0" ])
           #c clause-ctx-vars (ps ++ l) ((v ++s " - 1") ∷ vars) vcnt
... | "Agda.Builtin.Nat.Nat.zero" =
           ok (clcond [] [] [ v ++s " == 0" ])
           #c clause-ctx-vars l vars vcnt
... | "Data.Fin.Base.Fin.zero" =
           ok (clcond [] [] [ v ++s " == 0" ])  -- XXX can also add v < u
           #c clause-ctx-vars l vars vcnt
... | "Data.Fin.Base.Fin.suc" =
           ok (clcond [] [] [ v ++s " > 0" ])  -- XXX can also add v < u
           #c clause-ctx-vars l vars vcnt
... | "Data.Vec.Base.Vec.[]"  =
           ok (clcond [] [] [ "emptyvec_p (" ++s v ++s ")" ])
           #c clause-ctx-vars l vars vcnt
... | "Data.Vec.Base.Vec._∷_" =
           ok (clcond [] [] [ "nonemptyvec_p (" ++s v ++s ")" ])
           #c clause-ctx-vars (ps ++ l) (("len (" ++s v ++s ") - 1") ∷ ("hd (" ++s v ++s ")") ∷ ("tl (" ++s v ++s ")") ∷ vars) vcnt
      -- Well, let's see how far we can go with this hack
... | "Array.Base.Ar.imap" =
--... | "test-extract.Ar'.imap" =
           ok (clcond [ "IMAP_" ++s v ] [ "\n#define IMAP_" ++s v ++s "(__x) " ++s v ++s "[__x]\n" ] [ "true" ])
           #c clause-ctx-vars l vars vcnt
... | x = error ("clause-ctx-vars: don't know what to do with `" ++s x ++s "` constructor in patterns")
clause-ctx-vars (arg i dot ∷ l) (v ∷ vars) vcnt =
           -- Dot patterns are skipped.
           clause-ctx-vars l vars vcnt
clause-ctx-vars (arg (arg-info visible r) (var s) ∷ l) (v ∷ vars) vcnt =
           -- If we have "_" as a variable, we need  to insert it
           -- into the list, but we don't generate an assignment for it.
           let asgn = case s ≈? "_" of λ where
                          -- XXX hopefully this is fine, otherwise
                          -- we can do the same thing as for hidden
                          -- vars.
                (yes p) → []
                (no ¬p) → [ s ++s " = " ++s v ++s ";" ]
           in ok (clcond [ s ] asgn [])
           #c clause-ctx-vars l vars vcnt
clause-ctx-vars (arg (arg-info hidden r) (var s) ∷ l) (v ∷ vars) vcnt =
           -- Hidden variables are simply added to the context
           -- as regular variables
           let s , vcnt = case s ≈? "_" of λ where
                (yes p) → s ++ "_" ++ showNat vcnt , 1 + vcnt
                (no ¬p) → s , vcnt
           in ok (clcond [ s ] [ s ++ " = " ++ v ++ ";" ] [])
           #c clause-ctx-vars l vars vcnt

clause-ctx-vars (arg (arg-info instance′ r) (var s) ∷ l) (v ∷ vars) vcnt =
           error "FIXME handle instance variables"
clause-ctx-vars (arg i (lit x) ∷ l) (v ∷ vars) vcnt =
           case showLitProg x of λ where
                (error s) → error s
                (ok s) → ok (clcond [] [] [ v ++s " == " ++s (sconc s) ])
                         #c clause-ctx-vars l vars vcnt
clause-ctx-vars (arg i (proj f) ∷ l) (v ∷ vars) vcnt =
           error "FIXME proj pattern"
clause-ctx-vars (arg i absurd ∷ l)  (v ∷ vars) vcnt =
           -- I assume that absurd can only appear in the
           -- absurd clause, therefore, we don't need a condition
           -- for this pattern, so we just skip it.
           clause-ctx-vars l vars vcnt
clause-ctx-vars [] [] _ =
           ok (clcond [] [] [])
clause-ctx-vars _  _  _ =
           error "mismatching number of patterns and types"

showLitProg (name x) = error ("Found name `" ++s (showName x) ++s "` as literal")
showLitProg (meta x) = error ("Found meta `" ++s (showMeta x) ++s "` as literal")
showLitProg x = okl (showLiteral x)

var-lkup : List String → ℕ → Prog
var-lkup [] n = error ("Variable not found")
var-lkup (x ∷ l) zero = okl x
var-lkup (x ∷ l) (suc n) = var-lkup l n

-- Compile each arg and join them with ", "
comp-arglist : List $ Arg Term → (varctx : List String) → Prog
comp-arglist args varctx = map (λ {(arg i x) → comp-term x varctx}) args /#p ", "

-- Helper for comp-arglist-mask
mk-mask : (n : ℕ) → List (Fin n) → List Bool
mk-mask n xs = V.toList $ go (V.replicate {n = n} false) xs
  where go : _ → _ → _
        go e [] = e
        go e (x ∷ xs) = go (updateAt x (λ _ → true) e) xs

comp-arglist-mask : List $ Arg Term → (mask : List Bool) → (varctx : List String) → Prog
comp-arglist-mask args mask varctx = go args mask varctx /#p ", "
  where
     go : List $ Arg Term → (mask : List Bool) → (varctx : List String) → List Prog
     go [] [] _ = []
     go [] (x ∷ mask) _ = [ error "Incorrect argument mask" ]
     go (x ∷ args) [] _ = [ error "Incorrect argument mask" ]
     go (x ∷ args) (false ∷ mask) vars = go args mask vars
     go (arg i x ∷ args) (true ∷ mask) vars = comp-term x vars ∷ go args mask vars

comp-term (var x []) vars = var-lkup (reverse vars) x
comp-term (var x args@(_ ∷ _)) vars = var-lkup (reverse vars) x #p okl "(" #p comp-arglist args vars #p okl ")"
--comp-term (var x (x₁ ∷ args)) vars with var-lkup (reverse vars) x
--comp-term (var x (x₁ ∷ args)) vars | ok l = error ("Variable " ++s (sconc l) ++s " used as a function call")
--comp-term (var x (x₁ ∷ args)) vars | error s = error s
comp-term (lit l) vars = showLitProg l
comp-term exp@(con c args) vars with showName c
... | "Data.Vec.Base.Vec.[]" =
      okl "[]"
... | "Data.Vec.Base.Vec._∷_" =
      okl "cons (" #p comp-arglist-mask args (mk-mask 5 $ # 3 ∷ # 4 ∷ []) vars #p okl ")"
... | "Agda.Builtin.Nat.Nat.suc" =
      okl "(1 + " #p comp-arglist-mask args (mk-mask 1 $ # 0 ∷ []) vars #p okl ")"
... | "Data.Fin.Base.Fin.zero" =
      okl "0"
... | "Data.Fin.Base.Fin.suc" =
      okl "(1 + " #p comp-arglist-mask args (mk-mask 2 $ # 1 ∷ []) vars #p okl ")"
... | "Array.Base.Ar.imap" =
--... | "test-extract.Ar'.imap" =
      case args of λ where
        (_ ∷ _ ∷ _ ∷ arg _ s ∷ arg _ (vLam x e) ∷ []) → let
             p = comp-term e (vars ++ [ x ])
             sh = comp-term s vars --infert exp
           in okl ("with { (. <= " ++s x ++s " <= .): ") #p p #p okl "; }:  genarray (" #p sh #p okl ")"
        _                               →
           error "comp-term: don't recognize arguments to imap"
... | "Array.Base.Ix.[]" =
      okl "[]"
... | "Array.Base.Ix._∷_" =
      okl "cons (" #p comp-arglist-mask args (mk-mask 5 $ # 3 ∷ # 4 ∷ []) vars #p okl ")"
... | n = error ("comp-term: don't know constructor `" ++s n ++s "`")
comp-term (def f args) vars with showName f
... | "Agda.Builtin.Nat._+_" =
      okl "_add_SxS_ (" #p comp-arglist args vars #p okl ")"
... | "Agda.Builtin.Nat._*_" =
      okl "_mul_SxS_ (" #p comp-arglist args vars #p okl ")"
... | "Data.Nat.DivMod._/_" =
      okl "_div_SxS_ (" #p comp-arglist-mask args (mk-mask 3 $ # 0 ∷ # 1 ∷ []) vars #p okl ")"
... | "Data.Fin.#_" =
      comp-arglist-mask args (mk-mask 3 $ # 0 ∷ []) vars
... | "Array.Base.ix-lookup" =
      case args of λ where
        (_ ∷ _ ∷ arg _ iv ∷ arg _ el ∷ []) → let
             iv′ = comp-term iv vars
             el′ = comp-term el vars
           in iv′ #p okl "[" #p el′ #p okl "]"
        _                                  →
           error "comp-term: don't recognize arguments to ix-lookup"
... | "Data.Vec.Base.[_]" =
      case args of λ where
        (_ ∷ _ ∷ arg _ x ∷ []) → okl "[" #p comp-term x vars #p  okl "]"
        _                      →
           error "comp-term: don't recognize arguments to Vec.[_]"

... | "Data.Fin.Base.raise" =
      -- Note that "raise" is a total junk, as it only makes sure that the
      -- Fin value is valid in some context; all we are interested in is the
      -- value of that Fin.
      case args of λ where
        (_ ∷ _ ∷ arg _ x ∷ []) → comp-term x vars
        _                      →
           error "comp-term: don't recognize arguments to Data.Fin.raise"

-- XXX we need to figure out what are we going to do with recursive functions,
--     as clearly its name can't be known in advance.  Probably add it to the
--     state?  Or maintain a list of functions?
... | n = nnorm n #p okl " ("  #p comp-arglist args vars #p okl ")"
--... | n = error ("comp-term: don't know definition `" ++s n ++s "`")
comp-term (lam v t) vars = error "comp-term: lambdas are not supported"
comp-term (pat-lam cs args) vars = error "comp-term: pattern-matching lambdas are not supported"
comp-term (pi a b) vars = error "comp-term: pi types are not supported"
comp-term (sort s) vars = error "comp-term: sorts are not supported"
comp-term (meta x x₁) vars = error "comp-term: metas are not supported"
comp-term unknown vars = error "comp-term: unknowns are not supported"

record Pistate : Set where
  constructor pist-vc=_cv=_vctx=_tctx=_rv=_ret=_cons=_
  field
    var-counter : ℕ
    cur-var : String
    var-ctx : List String
    type-ctx : List String
    ret-var : String
    ret : Prog
    -- XXX come up with a better type for
    -- constraints on variables.
    cons : List (String × Prog)
open Pistate

trav-pi : Type → Pistate → Pistate
trav-pi (Π[ s ∶ arg i x ] y) pst
          = let
              varname = case s of λ where
                          "_" → "x_" ++s (showNat $ var-counter pst)
                          n   → n
              tp = trav-pi x (record pst {cur-var = varname}) -- ; cons = []})
            in case ret tp of λ where
              (error s) → tp
              (ok l)    → trav-pi y (record pst {var-counter = 1 + var-counter pst ;
                                                 cur-var = ret-var pst ;
                                                 var-ctx = var-ctx pst ++ [ varname ] ;
                                                 type-ctx = type-ctx pst ++ [ (sjoin l "") ] ;
                                                 cons =  cons tp}) --cons pst ++ cons tp })
trav-pi (con c args) pst with showName c
... | x = record pst {ret = error ("trav-pi: don't know how to handle `" ++s x ++s "` constructor")}
trav-pi (def f args) pst with showName f
... | "Agda.Builtin.Nat.ℕ" = record pst {ret = okl "int"}
... | "Agda.Builtin.Nat.Nat" = record pst {ret = okl "int"}
... | "Agda.Builtin.Bool.Bool" = record pst {ret = okl "bool"}
... | "Agda.Builtin.List.List" =
         -- We encode lists as 1-d arrays of their argument type.
         case args of λ where
           (_ ∷ arg i x ∷ _) → let tp = trav-pi x (record pst {cons = []})
                               in case ret tp of λ where
                                   (error s) → tp
                                   (ok l)    → record tp {ret = okl $ (sjoin l "") ++s "[.]"}
           _                 → record pst {ret = error "trav-pi: incorrect arguments to List"}

... | "Data.Vec.Base.Vec" =
         -- Vectors are also 1-d arrays (such as lists) but we extract
         -- a bit of extra infromation from these.
         case args of λ where
           (_ ∷ arg _ t ∷ arg _ x ∷ []) → let tp = trav-pi t (record pst {cur-var = "" {- XXX well, typeof (cur-var pst) is the thing -}
                                                                          }) --cons = []})
                                              p = comp-term x (var-ctx pst)
                                          in record tp {ret = ret tp #p okl "[.]" ;
                                                        cons = (cons tp)
                                                            ++ [ cur-var pst ,
                                                                 okl ("/* assert (shape (" ++s (cur-var pst) ++s ")[[0]] == ") #p p #p okl ") */" ]
                                                       }
           _                            → record pst {ret = error "trav-pi: incorrect arguments to Vec"}
... | "Data.Fin.Base.Fin" =
         case args of λ where
           (arg _ x ∷ []) → let
                p = comp-term x (var-ctx pst)
                in record pst {
                     ret  = okl "int";
                     cons = (cons pst)
                         ++ [ cur-var pst ,
                              okl ("/* assert (" ++s (cur-var pst) ++s " < ") #p p #p okl ") */"]
                   }
           _              →
                record pst {ret = error "trav-pi: incorrect arguments to Fin"}
... | "Array.Base.Ar" =
--... | "test-extract.Ar'" =
         case args of λ where
           (_ ∷ arg _ ty ∷ arg _ dim ∷ arg _ sh ∷ []) → let
                  ty′  = trav-pi ty pst
                  dim′ = comp-term dim (var-ctx pst)
                  sh′  = comp-term sh (var-ctx pst)
                in record ty′ {
                     ret = ret ty′ #p okl "[*]" ;
                     cons = cons ty′
                         ++ [ cur-var pst ,
                              okl ("/* assert (dim (" ++s (cur-var pst) ++s ") == ") #p dim′ #p okl " )*/" ]
                         ++ [ cur-var pst ,
                              okl ("/* assert (shape (" ++s (cur-var pst) ++s ") == ") #p sh′ #p okl " )*/" ]
                   }
           _                                     →
                record pst {ret = error "trav-pi: incorrect arguments to Ar"}

... | x = record pst {ret = error ("trav-pi: don't know the `" ++s x ++s "` type")}
trav-pi _ pst = record pst {ret = error "trav-pi ERRR"}

find : List String → String → Bool
find [] x = false
find (y ∷ l) x with x ≈? y
... | yes _ = true
... | no _  = find l x

collect-var-cons : List (String × Prog) → (accum : List String) → List (String × Prog)
collect-var-cons [] acc = []
collect-var-cons ((x , v) ∷ l) acc with find acc x
... | true  = collect-var-cons l acc
... | false = (x , v #p collect l x) ∷ collect-var-cons l (x ∷ acc)
  where
     collect : _ → _ → _
     collect [] x = ok []
     collect ((y , v) ∷ l) x with y ≈? x
     ... | yes _ = v #p collect l x
     ... | no _ = collect l x

-- Get the value bound to the given variable or return (ok [])
lkup-var-cons : List (String × Prog) → String → Prog
lkup-var-cons [] s = ok []
lkup-var-cons ((x , v) ∷ xs) s with x ≈? s
... | yes _ = v
... | no  _ = lkup-var-cons xs s

fltr : List (String × Prog) → (var : String) → List (String × Prog)
fltr [] x = []
fltr ((y , v) ∷ l) x with x ≈? y
... | yes _ = fltr l x
... | no _ = (y , v) ∷ fltr l x

mkfun : Name → _ → Pistate → NumClauses → Prog
mkfun n cls ps nc = let
     rv = (ret-var ps)
     cs = collect-var-cons (cons ps) []
     arg-cons = map proj₂ $ fltr cs rv
     ret-cons = lkup-var-cons cs rv
  in (okl $ "// Function " ++s (showName n) ++s "\n")
  #p ret ps #p okl "\n"
  #p (nnorm $ showName n ++s "(")
  #p tvl (var-ctx ps) (type-ctx ps)
  #p okl ") {\n"
  --#p (cons ps) /#p "\n"
  #p arg-cons /#p "\n"
  #p ret ps #p okl (" " ++s rv ++s ";\n")
  #p compile-cls cls (st (var-ctx ps) rv nc)
  #p ret-cons
  #p okl ("return " ++s rv ++s ";\n}\n\n")
  where
    tvl : List String → List String → Prog
    tvl [] [] = ok []
    tvl [] (t ∷ typs) = error "more types than variables"
    tvl (x ∷ vars) [] = error "more variables than types"
    tvl (x ∷ []) (t ∷ []) = okl (t ++s " " ++s x)
    tvl (x ∷ []) (_ ∷ _ ∷ _) = error "more types than variables"
    tvl (_ ∷ _ ∷ _) (_ ∷ []) = error "more variables than types"
    tvl (x ∷ xs@(_ ∷ _)) (t ∷ ts@(_ ∷ _)) = okl (t ++s " " ++s x ++s ", ") #p tvl xs ts

compile' : (lam : Term) → (sig : Type) → (name : Maybe Name) → TC Prog
compile' (pat-lam cs args) t nm with nm
compile' (pat-lam cs args) t nm | nothing =
  return $ error "compile' got invalid function name"
compile' (pat-lam [] args) t nm | just x =
  return $ error "compile' got zero clauses in the lambda term"
compile' (pat-lam cs@(_ ∷ []) args) t nm | just x =
  -- XXX currently the name `__ret` is hardcoded.
  let ps = trav-pi t (pist-vc= 1 cv= "" vctx= [] tctx= [] rv= "__ret" ret= error "" cons= [])
  in return (mkfun x cs ps One)
compile' (pat-lam cs@(_ ∷ _ ∷ _) args) t nm | just x =
  -- XXX currently the name `__ret` is hardcoded.
  let ps = trav-pi t (pist-vc= 1 cv= "" vctx= [] tctx= [] rv= "__ret" ret= error "" cons= [])
  in return (mkfun x cs ps Many)
compile' x _ _  =
  return (error "compile' expected pattern-matching lambda")

macro
  compile : Term → Term → TC ⊤
  compile f a = do
     t ← derefT f
     v ← derefImmediate f
     let ctx = pi-to-ctx t
     let n = defName f
     --v ← pat-lam-norm v ctx
     let v = return v
     case v of λ where
       (ok v) → do
          v ← compile' v t n
          q ← quoteTC v
          unify a q
       e@(error s) →
          return e >>= quoteTC >>= unify a

---===== These are just all examples to play around ====---

tst-triv : ℕ → ℕ
tst-triv x = x + 1

-- Test pattern contraction
tst-ss : ℕ → ℕ
tst-ss (suc (suc x)) = x
tst-ss _ = 0

-- Here we have the (+ 0) in the last clause that
-- stays in the generated code.
tst-rew0 : ℕ → Bool → ℕ → ℕ
tst-rew0 x true y = let a = x * x in a + y
tst-rew0 x false y = x + 2 + 0

-- XXX can't do with clauses yet, but that shouldn
tst-with : ℕ → ℕ
tst-with x with x >? 0
tst-with x | yes p = 0
tst-with x | no ¬p = 1

-- Trivial test with Lists
lst-test : List ℕ → ℕ
lst-test [] = 0
lst-test (_∷_ x y) = x + 1

data Test : Set where
  cstctr : {x : ℕ} → x > 0 → Test

test-test : Test → ℕ
test-test (cstctr p) = 1

test-dot : (a : ℕ) → a > 0 → ℕ
test-dot a@(.(suc _)) (s≤s pf) = a

data Square : ℕ → Set where
  sq : (m : ℕ) → Square (m * m)

root : (m : ℕ) (n : ℕ) → Square n → ℕ
root a .(m * m) (sq m) =
  -- This is to show that square pattern is skipped
  -- from the context.  In the above case, the clause is
  -- represetned as: a , . , (sq m) ==ctx==> a , m
  -- and the expression is (var 0) + (var 1)
  m + a

open import Data.Vec hiding (concat)
tst-vec : ∀ {n} → Vec ℕ n → Vec ℕ (n + n * n) → ℕ
tst-vec [] _      = 0
tst-vec (x ∷ a) b = x

a = (reflect-ty tst-vec)

tst-undsc : _ → ℕ
tst-undsc n = 1 + n

vec-sum : ∀ {n} → Vec ℕ n → Vec ℕ (n) → Vec ℕ n
vec-sum [] _ = []
vec-sum (x ∷ a) (y ∷ b) = x + y ∷ vec-sum a b

vec-and-1 : ∀ {n} → Vec Bool n → Bool
vec-and-1 (x ∷ xs) = x ∧ vec-and-1 xs
vec-and-1 _ = true

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

vec-+ : ∀ {n} → Vec ℕ n → ℕ
vec-+ (x ∷ xs) = x + vec-+ xs
vec-+ _ = 0

f : ℕ → ℕ
f x = x * x

vec-tst : ∀ n → Vec ℕ (n) → ℕ
vec-tst 0 [] = 0
vec-tst (suc n) x = n * 2 -- (x ∷ xs) = n * 2

def-pst = (pist-vc= 1 cv= "" vctx= [] tctx= [] rv= "__ret" ret= error "" cons= []) --pist 1 [] [] (error "")

q : List String × List String × Prog
q = let (pist-vc= _ cv= _ vctx= v tctx= t rv= _ ret= r cons= _) = (trav-pi (reflect-ty vec-sum) def-pst) in (v , t , r)

--open import Data.Fin

xxx : Fin 5 → Fin 6
xxx zero = suc zero
xxx (suc _) = zero

fun-in-ty : (f : ℕ → ℕ) → Vec ℕ (f 3) → ℕ
fun-in-ty f x = 1 -- V.replicate 1

open import Array

data Ar' {a} (X : Set a) (d : ℕ) :  (Vec ℕ d) → Set a where
  imap : ∀ s → (Ix d s → X) → Ar' X d s

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 ∷ []) → ℕ
  asum' : ∀ {n} → Ar' ℕ 1 (n ∷ []) → ℕ
  --sum (imap a)

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 ∷ []))

conv : ∀ {n} → let Ar1d n = Ar ℕ 1 V.[ n ] in
               Ar1d (3 + n) → Ar1d 3 → Ar1d (1 + n)
conv (imap inp) (imap ker) = imap λ iv → let i = ix-lookup iv (# 0)
                                         in (  inp (raise 2 i ∷ []) * ker (# 0 ∷ [])
                                             + inp (raise 1 (suc i) ∷ []) * ker (# 1 ∷ [])
                                             + inp (raise 0 (suc (suc i)) ∷ []) * ker (# 2 ∷ [])
                                            ) / 3
                                          where open import Data.Fin using (raise)
                                                open import Data.Nat.DivMod

test-fin : Fin 3 → Fin 4
test-fin x = suc x

w : String
w = case compile mm of λ where
     (error s) → s
     (ok l) → sjoin l ""


-- Andreas, 2021-08-19, issue #5291 reported by gergoerdi
-- https://stackoverflow.com/q/66816547/477476

open import Agda.Builtin.Char
open import Agda.Builtin.String

works : Char
works = '\SOH'

-- This used to fail as the matcher was committed to finding SOH after SO.
-- (Worked only for prefix-free matching.)

test : Char
test = '\SO'

-- Here, all the silly legacy ASCII escape sequences in their glorious detail...

all : String
all = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\BS\HT\LF\VT\FF\CR\SO\SI\DEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US"


module conversion where

open import constants
open import cedille-types
open import ctxt
open import free-vars
open import rename
open import subst
open import syntax-util
open import general-util
open import type-util

record unfolding : Set where
  constructor unfold
  field
    unfold-all : 𝔹
    unfold-defs : 𝔹
    unfold-erase : 𝔹

unfold-all : unfolding
unfold-all = unfold tt tt tt

unfold-head : unfolding
unfold-head = unfold ff tt tt

unfold-head-elab : unfolding
unfold-head-elab = unfold ff tt ff

unfold-no-defs : unfolding
unfold-no-defs = unfold tt ff ff

unfold-head-no-defs : unfolding
unfold-head-no-defs = unfold ff ff ff

unfold-dampen : unfolding → unfolding
unfold-dampen (unfold a d e) = unfold a (a && d) e

conv-t : Set → Set
conv-t T = ctxt → T → T → 𝔹

{-# TERMINATING #-}

-- main entry point
-- does not assume erased
conv-term : conv-t term
conv-type : conv-t type
conv-kind : conv-t kind

-- assume erased
conv-terme : conv-t term
conv-argse : conv-t (𝕃 term)
conv-typee : conv-t type
conv-kinde : conv-t kind

-- call hnf, then the conv-X-norm functions
conv-term' : conv-t term
conv-type' : conv-t type

hnf : ∀ {ed : exprd} → ctxt → (u : unfolding) → ⟦ ed ⟧ → ⟦ ed ⟧

-- assume head normalized inputs
conv-term-norm : conv-t term
conv-type-norm : conv-t type
conv-kind-norm : conv-t kind

-- does not assume erased
conv-tpkd : conv-t tpkd
conv-tmtp : conv-t tmtp
conv-tmtp* : conv-t (𝕃 tmtp)

-- assume erased
conv-tpkde : conv-t tpkd
conv-tmtpe : conv-t tmtp
conv-tmtpe* : conv-t (𝕃 tmtp)

conv-ctr-ps : ctxt → var → var → maybe (ℕ × ℕ)
conv-ctr-args : conv-t (var × args)
conv-ctr : conv-t var

conv-term Γ t t' = conv-terme Γ (erase t) (erase t')

conv-terme Γ t t' with decompose-apps t | decompose-apps t'
conv-terme Γ t t' | Var x , args | Var x' , args' =
     ctxt-eq-rep Γ x x' && conv-argse Γ (erase-args args) (erase-args args')
  || conv-ctr-args Γ (x , args) (x' , args')
  || conv-term' Γ t t'
conv-terme Γ t t' | _ | _ = conv-term' Γ t t'

conv-argse Γ [] [] = tt
conv-argse Γ (a :: args) (a' :: args') = conv-terme Γ a a' && conv-argse Γ args args'
conv-argse Γ _ _ = ff

conv-type Γ t t' = conv-typee Γ (erase t) (erase t')

conv-typee Γ t t' with decompose-tpapps t | decompose-tpapps t'
conv-typee Γ t t' | TpVar x , args | TpVar x' , args' =
     ctxt-eq-rep Γ x x' && conv-tmtp* Γ args args'
  || conv-type' Γ t t'
conv-typee Γ t t' | _ | _ = conv-type' Γ t t'

conv-kind Γ k k' = conv-kinde Γ (erase k) (erase k')
conv-kinde Γ k k' = conv-kind-norm Γ (hnf Γ unfold-head k) (hnf Γ unfold-head k')

conv-term' Γ t t' = conv-term-norm Γ (hnf Γ unfold-head t) (hnf Γ unfold-head t')
conv-type' Γ t t' = conv-type-norm Γ (hnf Γ unfold-head t) (hnf Γ unfold-head t')

hnf {TERM} Γ u (AppE t T) = hnf Γ u t
hnf {TERM} Γ u (Beta _ t) = hnf Γ u t
hnf {TERM} Γ u (Delta b? T t) = id-term
hnf {TERM} Γ u (Hole pi) = Hole pi
hnf {TERM} Γ u (IotaPair t₁ t₂ x Tₓ) = hnf Γ u t₁
hnf {TERM} Γ u (IotaProj t n) = hnf Γ u t
hnf {TERM} Γ u (Lam tt x T t) = hnf Γ u t
hnf {TERM} Γ u (LetTp x k T t) = hnf Γ u t
hnf {TERM} Γ u (Phi tₑ t₁ t₂) = hnf Γ u t₂
hnf {TERM} Γ u (Rho tₑ x Tₓ t) = hnf Γ u t
hnf {TERM} Γ u (VarSigma t) = hnf Γ u t
hnf {TERM} Γ u (App t t') with hnf Γ u t
...| Lam ff x nothing t'' = hnf Γ u ([ Γ - t' / x ] t'')
...| t'' = App t'' (hnf Γ (unfold-dampen u) t')
hnf {TERM} Γ u (Lam ff x _ t) with hnf (ctxt-var-decl x Γ) u t
...| App t' (Var x') = if x' =string x && ~ is-free-in x t' then t' else Lam ff x nothing (App t' (Var x'))
...| t' = Lam ff x nothing t'
hnf {TERM} Γ u (LetTm me x T t t') = hnf Γ u ([ Γ - t / x ] t')
hnf {TERM} Γ u (Var x) with
   ifMaybe (unfolding.unfold-defs u) $ ctxt-lookup-term-var-def Γ x
...| nothing = Var x
...| just t = hnf Γ (unfold-dampen u) t
hnf {TERM} Γ u (Mu f tₒ _ t~ cs') =
  let t = hnf Γ u tₒ
      Γ' = ctxt-var-decl f Γ
      cs = erase-cases cs'
      t-else = λ t → Mu f t nothing t~ $ flip map cs λ where
                 (Case x cas t T) → Case x cas
                   (hnf (add-caseArgs-to-ctxt cas Γ') (unfold-dampen u) t) T
      case-matches : var → args → case → maybe (term × case-args × args)
      case-matches = λ {cₓ as (Case cₓ' cas t T) →
                          conv-ctr-ps Γ cₓ' cₓ ≫=maybe uncurry λ ps' ps →
                          ifMaybej (length as =ℕ length cas + ps) (t , cas , drop ps as)}
      matching-case = λ cₓ as → foldr (_||-maybe_ ∘ case-matches cₓ as) nothing cs
      sub-mu = let x = fresh-var Γ "x" in , Lam ff x nothing (t-else (Var x))
      sub = λ Γ → substs Γ (trie-insert (trie-single f sub-mu) (data-to/ f) (, id-term)) in
  maybe-else' (decompose-var-headed t ≫=maybe uncurry matching-case) (t-else t) λ where
    (tₓ , cas , as) → hnf Γ u (recompose-apps as (case-args-to-lams cas (sub (add-caseArgs-to-ctxt cas Γ') tₓ)))
hnf {TERM} Γ u (Sigma mt tₒ _ t~ cs') =
  let t = hnf Γ u tₒ
      cs = erase-cases cs'
      t-else = λ t → Sigma nothing t nothing t~ $ flip map cs λ where
                 (Case x cas t T) → Case x cas
                   (hnf (add-caseArgs-to-ctxt cas Γ) (unfold-dampen u) t) T
      case-matches : var → args → case → maybe (term × case-args × args)
      case-matches = λ {cₓ as (Case cₓ' cas t T) →
                          conv-ctr-ps Γ cₓ' cₓ ≫=maybe uncurry λ ps' ps →
                          ifMaybej (length as =ℕ length cas + ps) (t , cas , drop ps as)}
      matching-case = λ cₓ as → foldr (_||-maybe_ ∘ case-matches cₓ as) nothing cs
      sub = λ Γ → id {A = term} in
  maybe-else' (decompose-var-headed t ≫=maybe uncurry matching-case) (t-else t) λ where
    (tₓ , cas , as) → hnf Γ u (recompose-apps as (case-args-to-lams cas (sub (add-caseArgs-to-ctxt cas Γ) tₓ)))

hnf{TYPE} Γ u (TpAbs me x tk tp) = TpAbs me x (hnf Γ (unfold-dampen u) -tk tk) (hnf (ctxt-var-decl x Γ) (unfold-dampen u) tp)
hnf{TYPE} Γ u (TpIota x tp₁ tp₂) = TpIota x (hnf Γ (unfold-dampen u) tp₁) (hnf (ctxt-var-decl x Γ) (unfold-dampen u) tp₂)
hnf{TYPE} Γ u (TpAppTp tp tp') with hnf Γ u tp
...| TpLam x _ tp'' = hnf Γ u ([ Γ - tp' / x ] tp'')
...| tp'' = TpAppTp tp'' (hnf Γ (unfold-dampen u) tp')
hnf{TYPE} Γ u (TpAppTm tp tm) with hnf Γ u tp
...| TpLam x _ tp'' = hnf Γ u ([ Γ - tm / x ] tp'')
...| tp'' = TpAppTm tp''
              (if unfolding.unfold-erase u then hnf Γ (unfold-dampen u) tm else tm)
hnf{TYPE} Γ u (TpEq tm₁ tm₂) = TpEq (hnf Γ (unfold-dampen u) tm₁) (hnf Γ (unfold-dampen u) tm₂)
hnf{TYPE} Γ u (TpHole pi) = TpHole pi
hnf{TYPE} Γ u (TpLam x tk tp) = TpLam x (hnf Γ (unfold-dampen u) -tk tk) (hnf (ctxt-var-decl x Γ) (unfold-dampen u) tp)
hnf{TYPE} Γ u (TpVar x) with
   ifMaybe (unfolding.unfold-defs u) $ ctxt-lookup-type-var-def Γ x
...| nothing = TpVar x
...| just t = hnf Γ (unfold-dampen u) t

hnf{KIND} Γ u (KdAbs x tk kd) =
  KdAbs x (hnf Γ (unfold-dampen u) -tk tk) (hnf (ctxt-var-decl x Γ) u kd)
hnf{KIND} Γ u (KdHole pi) = KdHole pi
hnf{KIND} Γ u KdStar = KdStar

hanf : ctxt → (erase : 𝔹) → term → term
hanf Γ e t with erase-if e t
...| t' = maybe-else t' id
  (decompose-var-headed t' ≫=maybe uncurry λ x as →
   ctxt-lookup-term-var-def Γ x ≫=maybe λ t'' →
   just (recompose-apps as t''))

-- unfold across the term-type barrier
hnf-term-type : ctxt → (erase : 𝔹) → type → type
hnf-term-type Γ e (TpEq t₁ t₂) = TpEq (hanf Γ e t₁) (hanf Γ e t₂)
hnf-term-type Γ e (TpAppTm tp t) = hnf Γ (record unfold-head {unfold-erase = e}) (TpAppTm tp (hanf Γ e t))
hnf-term-type Γ e tp = hnf Γ unfold-head tp

conv-cases : conv-t cases
conv-cases Γ cs₁ cs₂ = isJust $ foldl (λ c₂ x → x ≫=maybe λ cs₁ → conv-cases' Γ cs₁ c₂) (just cs₁) cs₂ where
  conv-cases' : ctxt → cases → case → maybe cases
  conv-cases' Γ [] (Case x₂ as₂ t₂ T₂) = nothing
  conv-cases' Γ (c₁ @ (Case x₁ as₁ t₁ T₁) :: cs₁) c₂ @ (Case x₂ as₂ t₂ T₂) with conv-ctr Γ x₁ x₂
  ...| ff = conv-cases' Γ cs₁ c₂ ≫=maybe λ cs₁ → just (c₁ :: cs₁)
  ...| tt = ifMaybej (length as₂ =ℕ length as₁ && conv-term Γ (expand-case c₁) (expand-case (Case x₂ as₂ t₂ T₂))) cs₁

ctxt-term-udef : posinfo → defScope → opacity → var → term → ctxt → ctxt

conv-term-norm Γ (Var x) (Var x') = ctxt-eq-rep Γ x x' || conv-ctr Γ x x'
-- hnf implements erasure for terms, so we can ignore some subterms for App and Lam cases below
conv-term-norm Γ (App t1 t2) (App t1' t2') = conv-term-norm Γ t1 t1' && conv-term Γ t2 t2'
conv-term-norm Γ (Lam ff x _ t) (Lam ff x' _ t') = conv-term (ctxt-rename x x' (ctxt-var-decl-if x' Γ)) t t'
conv-term-norm Γ (Hole _) _ = tt
conv-term-norm Γ _ (Hole _) = tt
conv-term-norm Γ (Mu x₁ t₁ _ _ cs₁) (Mu x₂ t₂ _ _ cs₂) =
  let Γ' = ctxt-rename x₁ x₂ $ ctxt-var-decl x₂ Γ in
  conv-term Γ t₁ t₂ && conv-cases Γ' cs₁ cs₂
conv-term-norm Γ (Sigma _ t₁ _ _ cs₁) (Sigma _ t₂ _ _ cs₂) = conv-term Γ t₁ t₂ && conv-cases Γ cs₁ cs₂
{- it can happen that a term is equal to a lambda abstraction in head-normal form,
   if that lambda-abstraction would eta-contract following some further beta-reductions.
   We implement this here by implicitly eta-expanding the variable and continuing
   the comparison.

   A simple example is

       λ v . t ((λ a . a) v) ≃ t
 -}
conv-term-norm Γ (Lam ff x _ t) t' =
  let x' = fresh-var Γ x in
  conv-term (ctxt-rename x x' Γ) t (App t' (Var x'))
conv-term-norm Γ t' (Lam ff x _ t) =
  let x' = fresh-var Γ x in
  conv-term (ctxt-rename x x' Γ) (App t' (Var x')) t
conv-term-norm Γ _ _ = ff

conv-type-norm Γ (TpVar x) (TpVar x') = ctxt-eq-rep Γ x x'
conv-type-norm Γ (TpApp t1 t2) (TpApp t1' t2') = conv-type-norm Γ t1 t1' && conv-tmtp Γ t2 t2'
conv-type-norm Γ (TpAbs me x tk tp) (TpAbs me' x' tk' tp') =
  (me iff me') && conv-tpkd Γ tk tk' && conv-type (ctxt-rename x x' (ctxt-var-decl-if x' Γ)) tp tp'
conv-type-norm Γ (TpIota x m tp) (TpIota x' m' tp') =
  conv-type Γ m m' && conv-type (ctxt-rename x x' (ctxt-var-decl-if x' Γ)) tp tp'
conv-type-norm Γ (TpEq t₁ t₂) (TpEq t₁' t₂') = conv-term Γ t₁ t₁' && conv-term Γ t₂ t₂'
conv-type-norm Γ (TpLam x tk tp) (TpLam x' tk' tp') =
  conv-tpkd Γ tk tk' && conv-type (ctxt-rename x x' (ctxt-var-decl-if x' Γ)) tp tp'
conv-type-norm Γ _ _ = ff

{- even though hnf turns Pi-kinds where the variable is not free in the body into arrow kinds,
   we still need to check off-cases, because normalizing the body of a kind could cause the
   bound variable to be erased (hence allowing it to match an arrow kind). -}
conv-kind-norm Γ (KdAbs x tk k) (KdAbs x' tk' k'') =
    conv-tpkd Γ tk tk' && conv-kind (ctxt-rename x x' (ctxt-var-decl-if x' Γ)) k k''
conv-kind-norm Γ KdStar KdStar = tt
conv-kind-norm Γ _ _ = ff

conv-tpkd Γ tk tk' = conv-tpkde Γ (erase -tk tk) (erase -tk tk')
conv-tmtp Γ tT tT' = conv-tmtpe Γ (erase -tT tT) (erase -tT tT')

conv-tpkde Γ (Tkk k) (Tkk k') = conv-kind Γ k k'
conv-tpkde Γ (Tkt t) (Tkt t') = conv-type Γ t t'
conv-tpkde Γ _ _ = ff

conv-tmtpe Γ (Ttm t) (Ttm t') = conv-term Γ t t'
conv-tmtpe Γ (Ttp T) (Ttp T') = conv-type Γ T T'
conv-tmtpe Γ _ _ = ff

conv-tmtp* = =𝕃 ∘ conv-tmtp

conv-tmtpe* = =𝕃 ∘ conv-tmtpe

conv-ctr Γ x₁ x₂ = conv-ctr-args Γ (x₁ , []) (x₂ , [])

conv-ctr-ps Γ x₁ x₂ with env-lookup Γ x₁ | env-lookup Γ x₂
...| just (ctr-def ps₁ T₁ n₁ i₁ a₁ , _) | just (ctr-def ps₂ T₂ n₂ i₂ a₂ , _) =
  ifMaybej (n₁ =ℕ n₂ && i₁ =ℕ i₂ && a₁ =ℕ a₂) (length (erase-params ps₁) , length (erase-params ps₂))
...| _ | _ = nothing

conv-ctr-args Γ (x₁ , as₁) (x₂ , as₂) =
  maybe-else' (conv-ctr-ps Γ x₁ x₂) ff $ uncurry λ ps₁ ps₂ →
  let as₁ = erase-args as₁; as₂ = erase-args as₂ in
  ps₁ ∸ length as₁ =ℕ ps₂ ∸ length as₂ &&
  conv-argse Γ (drop ps₁ as₁) (drop ps₂ as₂)

{-# TERMINATING #-}
inconv : ctxt → term → term → 𝔹
inconv Γ t₁ t₂ = inconv-lams empty-renamectxt empty-renamectxt
                   (hnf Γ unfold-all t₁) (hnf Γ unfold-all t₂)
  where
  fresh : var → renamectxt → renamectxt → var
  fresh x ρ₁ ρ₂ = fresh-h (λ x → ctxt-binds-var Γ x || renamectxt-in-field ρ₁ x || renamectxt-in-field ρ₂ x) x

  make-subst : renamectxt → renamectxt → 𝕃 var → 𝕃 var → term → term → (renamectxt × renamectxt × term × term)
  make-subst ρ₁ ρ₂ [] [] t₁ t₂ = ρ₁ , ρ₂ , t₁ , t₂
  make-subst ρ₁ ρ₂ (x₁ :: xs₁) [] t₁ t₂ =
    let x = fresh x₁ ρ₁ ρ₂ in
    make-subst (renamectxt-insert ρ₁ x₁ x) (renamectxt-insert ρ₂ x x) xs₁ [] t₁ (App t₂ $ Var x)
  make-subst ρ₁ ρ₂ [] (x₂ :: xs₂) t₁ t₂ =
    let x = fresh x₂ ρ₁ ρ₂ in
    make-subst (renamectxt-insert ρ₁ x x) (renamectxt-insert ρ₂ x₂ x) [] xs₂ (App t₁ $ Var x) t₂
  make-subst ρ₁ ρ₂ (x₁ :: xs₁) (x₂ :: xs₂) t₁ t₂ =
    let x = fresh x₁ ρ₁ ρ₂ in
    make-subst (renamectxt-insert ρ₁ x₁ x) (renamectxt-insert ρ₂ x₂ x) xs₁ xs₂ t₁ t₂

  inconv-lams : renamectxt → renamectxt → term → term → 𝔹
  inconv-apps : renamectxt → renamectxt → var → var → args → args → 𝔹
  inconv-ctrs : renamectxt → renamectxt → var → var → args → args → 𝔹
  inconv-mu : renamectxt → renamectxt → maybe (var × var) → cases → cases → 𝔹
  inconv-args : renamectxt → renamectxt → args → args → 𝔹

  inconv-args ρ₁ ρ₂ a₁ a₂ =
    let a₁ = erase-args a₁; a₂ = erase-args a₂ in
    ~  length a₁ =ℕ length a₂
    || list-any (uncurry $ inconv-lams ρ₁ ρ₂) (zip a₁ a₂)

  inconv-lams ρ₁ ρ₂ t₁ t₂ =
    elim-pair (decompose-lams t₁) λ l₁ b₁ →
    elim-pair (decompose-lams t₂) λ l₂ b₂ →
    elim-pair (make-subst ρ₁ ρ₂ l₁ l₂ b₁ b₂) λ ρ₁ ρ₂b₁₂ →
    elim-pair ρ₂b₁₂ λ ρ₂ b₁₂ →
    elim-pair b₁₂ λ b₁ b₂ →
    case (decompose-apps b₁ , decompose-apps b₂) of uncurry λ where
      (Var x₁ , a₁) (Var x₂ , a₂) →
        inconv-apps ρ₁ ρ₂ x₁ x₂ a₁ a₂ || inconv-ctrs ρ₁ ρ₂ x₁ x₂ a₁ a₂
      (Mu x₁ t₁ _ _ ms₁ , a₁) (Mu x₂ t₂ _ _ ms₂ , a₂) →
        inconv-mu ρ₁ ρ₂ (just $ x₁ , x₂) ms₁ ms₂ ||
        inconv-lams ρ₁ ρ₂ t₁ t₂ || inconv-args ρ₁ ρ₂ a₁ a₂
      (Sigma _ t₁ _ _ ms₁ , a₁) (Sigma _ t₂ _ _ ms₂ , a₂) →
        inconv-mu ρ₁ ρ₂ nothing ms₁ ms₂ ||
        inconv-lams ρ₁ ρ₂ t₁ t₂ || inconv-args ρ₁ ρ₂ a₁ a₂
      _ _ → ff

  inconv-apps ρ₁ ρ₂ x₁ x₂ a₁ a₂ =
    maybe-else' (renamectxt-lookup ρ₁ x₁) ff λ x₁ →
    maybe-else' (renamectxt-lookup ρ₂ x₂) ff λ x₂ →
    ~ x₁ =string x₂
    || inconv-args ρ₁ ρ₂ a₁ a₂

  inconv-ctrs ρ₁ ρ₂ x₁ x₂ as₁ as₂ with env-lookup Γ x₁ | env-lookup Γ x₂
  ...| just (ctr-def ps₁ _ n₁ i₁ a₁ , _) | just (ctr-def ps₂ _ n₂ i₂ a₂ , _) =
    let ps₁ = erase-params ps₁; ps₂ = erase-params ps₂
        as₁ = erase-args   as₁; as₂ = erase-args   as₂ in
    length as₁ ≤ length ps₁ + a₁ && -- Could use of "≤" here conflict with η-equality?
    length as₂ ≤ length ps₂ + a₂ &&
    (~ n₁ =ℕ n₂ ||
    ~ i₁ =ℕ i₂ ||
    ~ a₁ =ℕ a₂ ||
    ~ length as₁ + length ps₂ =ℕ length as₂ + length ps₁ ||
    -- ^ as₁ ∸ ps₁ ≠ as₂ ∸ ps₂, + ps₁ + ps₂ to both sides ^
    list-any (uncurry $ inconv-lams ρ₁ ρ₂)
      (zip (drop (length ps₁) as₁) (drop (length ps₂) as₂)))
  ...| _ | _ = ff

  inconv-mu ρ₁ ρ₂ xs? ms₁ ms₂ =
    ~ length ms₁ =ℕ length ms₂ ||
    maybe-else ff id
      (foldr {B = maybe 𝔹} (λ c b? → b? ≫=maybe λ b → inconv-case c ≫=maybe λ b' → just (b || b')) (just ff) ms₁)
    where
    matching-case : case → maybe (term × ℕ × ℕ)
    matching-case (Case x _ _ _) = foldl (λ where
      (Case xₘ cas tₘ _) m? → m? ||-maybe
        (conv-ctr-ps Γ xₘ x ≫=maybe uncurry λ psₘ ps →
         just (case-args-to-lams cas tₘ , length cas , ps)))
      nothing ms₂

    inconv-case : case → maybe 𝔹
    inconv-case c₁ @ (Case x cas₁ t₁ _) =
      matching-case c₁ ≫=maybe λ c₂ →
      just (inconv-lams ρ₁ ρ₂ (case-args-to-lams cas₁ t₁) (fst c₂))

ctxt-kind-def : posinfo → var → params → kind → ctxt → ctxt
ctxt-kind-def pi v ps2 k Γ =
  record Γ {
    qual = qualif-insert-params (ctxt.qual Γ) (ctxt.mn Γ # v) v (ctxt.ps Γ);
    syms = trie-insert-append2 (ctxt.syms Γ) (ctxt.fn Γ) (ctxt.mn Γ) v;
    i = trie-insert (ctxt.i Γ) (ctxt.mn Γ # v)
          (kind-def (ctxt.ps Γ ++ ps2) (hnf Γ unfold-head-elab k) , ctxt.fn Γ , pi)
  }

ctxt-datatype-decl : var → var → args → ctxt → ctxt
ctxt-datatype-decl vₒ vᵣ as Γ =
  record Γ {
    μ' = trie-insert (ctxt.μ' Γ) (mu-Type/ vᵣ) (vₒ , as);
    μ̲ = stringset-insert (ctxt.μ̲ Γ) (mu-Type/ vᵣ)
  }

ctxt-datatype-undef : var → ctxt → ctxt
ctxt-datatype-undef v Γ =
  record Γ {
    μ = trie-remove (ctxt.μ Γ) v;
    μ' = trie-remove (ctxt.μ' Γ) v;
    Is/μ = trie-remove (ctxt.Is/μ Γ) v;
    μ~ = trie-remove (ctxt.μ~ Γ) v;
    μ̲ = trie-remove (ctxt.μ̲ Γ) v
  }

ctxt-datatype-def : posinfo → var → params → kind → kind → ctrs → encoding-defs → ctxt → ctxt
ctxt-datatype-def pi D psᵢ kᵢ k cs eds Γ =
  let D' = ctxt.mn Γ # D
      ecds = record {
        Is/D = data-Is/ D';
        is/D = data-is/ D';
        to/D = data-to/ D';
        TypeF/D = data-TypeF/ D';
        fmap/D = data-fmap/ D';
        IndF/D = data-IndF/ D'} in
  record Γ {
    qual = qualif-insert-params (ctxt.qual Γ) D' D (ctxt.ps Γ);
    syms = trie-insert-append2 (ctxt.syms Γ) (ctxt.fn Γ) (ctxt.mn Γ) D;
    i = trie-insert (ctxt.i Γ) D' (type-def (just (ctxt.ps Γ)) tt nothing (abs-expand-kind psᵢ k) , ctxt.fn Γ , pi);
    μ = trie-insert (ctxt.μ Γ) D' (ctxt.ps Γ ++ psᵢ , kᵢ , k , cs , eds , ecds);
    Is/μ = trie-insert (ctxt.Is/μ Γ) (data-Is/ D') D';
    μ~ = trie-insert (ctxt.μ~ Γ) D' (foldl pull-defs [] (encoding-defs.ecs eds ++ encoding-defs.gcs eds));
    μᵤ = just eds;
    μ̲ = stringset-insert (ctxt.μ̲ Γ) D'
  }
  where
  pull-defs : cmd → 𝕃 (var × tmtp) → 𝕃 (var × tmtp)
  pull-defs (CmdDefTerm x t) μ~ = ((ctxt.mn Γ # x) , Ttm t) :: μ~
  pull-defs (CmdDefType x k T) μ~ = ((ctxt.mn Γ # x) , Ttp T) :: μ~
  pull-defs _ μ~ = μ~

ctxt-type-def : posinfo → defScope → opacity → var → maybe type → kind → ctxt → ctxt
ctxt-type-def _  _ _ ignored-var _ _  Γ = Γ
ctxt-type-def pi s op v t k Γ =
  let v' = if s iff localScope then pi % v else ctxt.mn Γ # v in
  record Γ {
    qual = qualif-insert-params (ctxt.qual Γ) v' v (if s iff localScope then [] else ctxt.ps Γ);
    i = trie-insert (ctxt.i Γ) v' (type-def (def-params s (ctxt.ps Γ)) op (hnf Γ unfold-head-elab <$> t) k , ctxt.fn Γ , pi)
  }

ctxt-ctr-def : posinfo → var → type → params → (ctrs-length ctr-index : ℕ) → ctxt → ctxt
ctxt-ctr-def pi c t ps' n i Γ =
  let c' = ctxt.mn Γ # c in
  record Γ {
    qual = qualif-insert-params (ctxt.qual Γ) c' c (ctxt.ps Γ);
    syms = trie-insert-append2 (ctxt.syms Γ) (ctxt.fn Γ) (ctxt.mn Γ) c;
    i = trie-insert (ctxt.i Γ) c' (ctr-def ps' t n i (unerased-arrows t) , ctxt.fn Γ , pi)
  }

ctxt-term-def : posinfo → defScope → opacity → var → maybe term → type → ctxt → ctxt
ctxt-term-def _  _ _  ignored-var _ _ Γ = Γ
ctxt-term-def pi s op v t tp Γ =
  let v' = if s iff localScope then pi % v else ctxt.mn Γ # v in
  record Γ {
    qual = qualif-insert-params (ctxt.qual Γ) v' v (if s iff localScope then [] else ctxt.ps Γ);
    syms = if s iff localScope then ctxt.syms Γ else trie-insert-append2 (ctxt.syms Γ) (ctxt.fn Γ) (ctxt.mn Γ) v;
    i = trie-insert (ctxt.i Γ) v' (term-def (def-params s (ctxt.ps Γ)) op (hnf Γ unfold-head <$> t) tp , ctxt.fn Γ , pi)
  }

ctxt-term-udef _ _ _ ignored-var _ Γ = Γ
ctxt-term-udef pi s op v t Γ =
  let v' = if s iff localScope then pi % v else ctxt.mn Γ # v in
  record Γ {
    qual = qualif-insert-params (ctxt.qual Γ) v' v (if s iff localScope then [] else ctxt.ps Γ);
    syms = if s iff localScope then ctxt.syms Γ else trie-insert-append2 (ctxt.syms Γ) (ctxt.fn Γ) (ctxt.mn Γ) v;
    i = trie-insert (ctxt.i Γ) v' (term-udef (def-params s (ctxt.ps Γ)) op (hnf Γ unfold-head t) , ctxt.fn Γ , pi)
  }


module par-swap.dpg-e-view where

open import par-swap
open import par-swap.properties
open import par-swap.confluent
open import par-swap.dpg-pot
open import utility
open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
open import Esterel.Lang.CanFunction.Plug
open import Esterel.Environment as Env
open import Esterel.Context
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Data.Empty
open import sn-calculus
open import context-properties -- get view, E-views

DPG-E-view :
 ∀ {E C r₁ r₂ p q θ θ' pin qin A A'} ->
  (peq : p ≐ E ⟦ pin ⟧e) ->
  (qeq : q ≐ E ⟦ qin ⟧e) ->
  p ≐ C ⟦ r₁ ∥ r₂ ⟧c ->
  (psn⟶₁q : ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θ' , A' ⟩· q) ->
  ->E-view psn⟶₁q peq qeq ->
  Σ[ d ∈ Term ]
  Σ[ sn⟶₁d ∈ ρ⟨ θ , A ⟩· C ⟦ r₂ ∥ r₁ ⟧c sn⟶₁ ρ⟨ θ' , A' ⟩· d ]
  Σ[ ∥Rd ∈ q ∥R* d ]
  Σ[ E′ ∈ List EvaluationContext1 ]
  Σ[ pin′ ∈ Term ]
  Σ[ qin′ ∈ Term ]
  Σ[ peq′ ∈ C ⟦ r₂ ∥ r₁ ⟧c ≐ E′ ⟦ pin′ ⟧e ]
  Σ[ qeq′ ∈ d ≐ E′ ⟦ qin′ ⟧e ]
  ->E-view sn⟶₁d peq′ qeq′

DPG-E-view dehole dehole dchole psn⟶₁q ()
DPG-E-view dehole dehole (dcpar₁ pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcpar₂ pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcseq₁ pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcseq₂ pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcsuspend pC) psn⟶₁q ()
DPG-E-view dehole dehole (dctrap pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcsignl pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcloop pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcloopˢ₁ pC) psn⟶₁q ()
DPG-E-view dehole dehole (dcloopˢ₂ pC) psn⟶₁q ()

DPG-E-view dehole dehole (dcpresent₁ pC)
           (ris-present S∈ s[θ]≡p dehole)
           vis-present
  =  _ , ris-present S∈ s[θ]≡p dehole , ∥Rn (∥Rstep pC) ∥R0 ,
    _ , _ , _ , dehole , dehole , vis-present

DPG-E-view dehole dehole (dcpresent₁ pC)
           (ris-absent S∈ s[θ]≡p dehole)
           vis-absent
 = _ , ris-absent S∈ s[θ]≡p dehole , ∥R0 ,
   _ , _ , _ , dehole , dehole , vis-absent

DPG-E-view dehole dehole (dcpresent₂ pC)
           (ris-present S∈ s[θ]≡a dehole)
           vis-present
 = _ , ris-present S∈ s[θ]≡a dehole , ∥R0 ,
   _ , _ , _ , dehole , dehole , vis-present

DPG-E-view dehole dehole (dcpresent₂ pC)
           (ris-absent S∈ s[θ]≡a dehole)
           vis-absent
 = _ ,  ris-absent S∈ s[θ]≡a dehole , ∥Rn (∥Rstep pC) ∥R0 ,
   _ , _ , _ , dehole , dehole , vis-absent

DPG-E-view dehole dehole (dcshared pC)
           (rraise-shared allready dehole)
           vraise-shared
 = _ , rraise-shared allready dehole ,
       Context1-∥R* (cenv _ _) (∥Rn (∥Rstep pC) ∥R0) ,
   _ , _ , _ , dehole , dehole , vraise-shared

DPG-E-view dehole dehole (dcvar pC)
           (rraise-var allready dehole)
           vraise-var
 = _ , rraise-var allready dehole ,
       Context1-∥R* (cenv _ _) (∥Rn (∥Rstep pC) ∥R0) ,
   _ , _ , _ , dehole , dehole , vraise-var

DPG-E-view dehole dehole (dcif₁ pC)
           (rif-false x∈ x[θ]≡0 dehole)
           vif-false
 = _ , rif-false x∈ x[θ]≡0 dehole , ∥R0 ,
   _ , _ , _ , dehole , dehole , vif-false

DPG-E-view dehole dehole (dcif₁ pC)
           (rif-true x∈ x[θ]≡s dehole)
           vif-true
 = _ , rif-true x∈ x[θ]≡s dehole , ∥Rn (∥Rstep pC) ∥R0 ,
   _ , _ , _ , dehole , dehole , vif-true

DPG-E-view dehole dehole (dcif₂ pC)
           (rif-false x∈ x[θ]≡0 dehole)
           vif-false
 = _ , rif-false x∈ x[θ]≡0 dehole , ∥Rn (∥Rstep pC) ∥R0 ,
   _ , _ , _ , dehole , dehole , vif-false

DPG-E-view dehole dehole (dcif₂ pC)
           (rif-true x∈ x[θ]≡s dehole)
           vif-true
 = _ , rif-true x∈ x[θ]≡s dehole , ∥R0 ,
   _ , _ , _ , dehole , dehole , vif-true

DPG-E-view dehole dehole (dcenv pC)
           (rmerge dehole)
           vmerge
 = _ , rmerge dehole , ∥Rn (∥Rstep pC) ∥R0 ,
   _ , _ , _ , dehole , dehole , vmerge

DPG-E-view (depar₁ pE) (depar₁ qE) dchole psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (depar₁ pE) (depar₁ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with wrap-rho redo-sub pE qE E-view-sub
               _ (depar₂ pE) (depar₂ qE)
... | (redo′ , E-view′)
 = _ , redo′ , ∥Rn (∥Rstep dchole) ∥R0 ,
   _ , _ , _ , depar₂ pE , depar₂ qE , E-view′

DPG-E-view (depar₂ pE) (depar₂ qE) dchole psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (depar₂ pE) (depar₂ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with wrap-rho redo-sub pE qE E-view-sub
               _ (depar₁ pE) (depar₁ qE)
... | (redo′ , E-view′)
 = _ , redo′ , ∥Rn (∥Rstep dchole) ∥R0 ,
   _ , _ , _ , depar₁ pE , depar₁ qE , E-view′

DPG-E-view {e ∷ _} (depar₁ pE) (depar₁ qE) (dcpar₁ pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (depar₁ pE) (depar₁ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with DPG-E-view pE qE pC redo-sub E-view-sub
... | (ds , pssn⟶₁ds , qs∥Rds , _ , _ , _ , pE′ , qE′ , E-view-sub′)
 with wrap-rho pssn⟶₁ds pE′ qE′ E-view-sub′ _ (depar₁ pE′) (depar₁ qE′)
... | (redo , E-view′)
 = _ , redo , Context1-∥R* (ceval e) qs∥Rds ,
   _ , _ , _ , depar₁ pE′ , depar₁ qE′ , E-view′

DPG-E-view {e ∷ _} (depar₂ pE) (depar₂ qE) (dcpar₂ pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (depar₂ pE) (depar₂ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with DPG-E-view pE qE pC redo-sub E-view-sub
... | (ds , pssn⟶₁ds , qs∥Rds , _ , _ , _ , pE′ , qE′ , E-view-sub′)
 with wrap-rho pssn⟶₁ds pE′ qE′ E-view-sub′ _ (depar₂ pE′) (depar₂ qE′)
... | (redo , E-view′)
 = _ , redo , Context1-∥R* (ceval e) qs∥Rds ,
   _ , _ , _ , depar₂ pE′ , depar₂ qE′ , E-view′

DPG-E-view {e ∷ _} (desuspend pE) (desuspend qE) (dcsuspend pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (desuspend pE) (desuspend qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with DPG-E-view pE qE pC redo-sub E-view-sub
... | (ds , pssn⟶₁ds , qs∥Rds , _ , _ , _ , pE′ , qE′ , E-view-sub′)
 with wrap-rho pssn⟶₁ds pE′ qE′ E-view-sub′ _ (desuspend pE′) (desuspend qE′)
... | (redo , E-view′)
 = _ , redo , Context1-∥R* (ceval e) qs∥Rds ,
   _ , _ , _ , desuspend pE′ , desuspend qE′ , E-view′

DPG-E-view {e ∷ _} (detrap pE) (detrap qE) (dctrap pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (detrap pE) (detrap qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with DPG-E-view pE qE pC redo-sub E-view-sub
... | (ds , pssn⟶₁ds , qs∥Rds , _ , _ , _ , pE′ , qE′ , E-view-sub′)
 with wrap-rho pssn⟶₁ds pE′ qE′ E-view-sub′ _ (detrap pE′) (detrap qE′)
... | (redo , E-view′)
 = _ , redo ,  Context1-∥R* (ceval e) qs∥Rds ,
   _ , _ , _ , detrap pE′ , detrap qE′ , E-view′

DPG-E-view {e ∷ _} (deseq pE) (deseq qE) (dcseq₁ pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (deseq pE) (deseq qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with DPG-E-view pE qE pC redo-sub E-view-sub
... | (ds , pssn⟶₁ds , qs∥Rds , _ , _ , _ , pE′ , qE′ , E-view-sub′)
 with wrap-rho pssn⟶₁ds pE′ qE′ E-view-sub′ _ (deseq pE′) (deseq qE′)
... | (redo , E-view′)
 = _ , redo , Context1-∥R* (ceval e) qs∥Rds ,
   _ , _ , _ , deseq pE′ , deseq qE′ , E-view′

DPG-E-view {e ∷ _} (deloopˢ pE) (deloopˢ qE) (dcloopˢ₁ pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (deloopˢ pE) (deloopˢ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with DPG-E-view pE qE pC redo-sub E-view-sub
... | (ds , pssn⟶₁ds , qs∥Rds , _ , _ , _ , pE′ , qE′ , E-view-sub′)
 with wrap-rho pssn⟶₁ds pE′ qE′ E-view-sub′ _ (deloopˢ pE′) (deloopˢ qE′)
... | (redo , E-view′)
 = _ , redo , Context1-∥R* (ceval e) qs∥Rds ,
   _ , _ , _ , deloopˢ pE′ , deloopˢ qE′ , E-view′

DPG-E-view{_}{_}{r₁}{r₂} (depar₁ pE) (depar₁ qE) (dcpar₂{C = C} pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (depar₁ pE) (depar₁ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with wrap-rho redo-sub pE qE E-view-sub
               (epar₁ (C ⟦ r₂ ∥ r₁ ⟧c))
               (depar₁ pE) (depar₁ qE)
... | (redo′ , E-view′)
 = _ , redo′ , ∥Rn (Context1-∥R (ceval (epar₂ _)) (∥Rstep pC)) ∥R0 ,
   _ , _ , _ , depar₁ pE , depar₁ qE , E-view′

DPG-E-view{_}{_}{r₁}{r₂} (depar₂ pE) (depar₂ qE) (dcpar₁{C = C} pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (depar₂ pE) (depar₂ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with wrap-rho redo-sub pE qE E-view-sub
               (epar₂ (C ⟦ r₂ ∥ r₁ ⟧c))
               (depar₂ pE) (depar₂ qE)
... | (redo′ , E-view′)
 = _ , redo′ , ∥Rn (Context1-∥R (ceval (epar₁ _)) (∥Rstep pC)) ∥R0 ,
   _ , _ , _ , depar₂ pE , depar₂ qE , E-view′

DPG-E-view{_}{_}{r₁}{r₂} (deseq pE) (deseq qE) (dcseq₂{C = C} pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (deseq pE) (deseq qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with wrap-rho redo-sub pE qE E-view-sub
               (eseq (C ⟦ r₂ ∥ r₁ ⟧c))
               (deseq pE) (deseq qE)
... | (redo′ , E-view′)
 = _ , redo′ , ∥Rn (Context1-∥R (cseq₂ _) (∥Rstep pC)) ∥R0 ,
   _ , _ , _ , deseq pE , deseq qE , E-view′

DPG-E-view{_}{_}{r₁}{r₂} (deloopˢ pE) (deloopˢ qE) (dcloopˢ₂{C = C} pC) psn⟶₁q E-view
 with unwrap-rho psn⟶₁q (deloopˢ pE) (deloopˢ qE) pE qE E-view
... | (redo-sub , E-view-sub)
 with wrap-rho redo-sub pE qE E-view-sub
               (eloopˢ (C ⟦ r₂ ∥ r₁ ⟧c))
               (deloopˢ pE) (deloopˢ qE)
... | (redo′ , E-view′)
 = _ , redo′ , ∥Rn (Context1-∥R (cloopˢ₂ _) (∥Rstep pC)) ∥R0 ,
   _ , _ , _ , deloopˢ pE , deloopˢ qE , E-view′


module par-swap.dpg where

open import par-swap
open import par-swap.properties
open import par-swap.confluent
open import par-swap.dpg-pot
open import par-swap.dpg-e-view
open import noetherian using (noetherian ; ∥_∥s)
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.Binding
open import Esterel.Environment as Env
open import Esterel.Context
open import Data.Product
open import Data.Bool
open import Data.Empty
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Data.Sum
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

DPG₁ : ∀ {p q r} ->
   (p ∥ q) sn⟶₁ r ->
   ∃ \ {(d , d₁) -> (q ∥ p) sn⟶ d₁ × d₁ sn⟶* d × r ∥R* d}
DPG₁{p} {q} {r} (rpar-done-right haltedp doneq) =
    (r , r) ,
    fixup-valuemax₁ doneq haltedp (rcontext [] dchole (rpar-done-left doneq haltedp)) ,
    rrefl , ∥R0 where
 fixup-valuemax₁ : ∀ {p q}  ->
   (doneq : done q) ->
   (haltedp : halted p) ->
   q ∥ p sn⟶ value-max doneq (dhalted haltedp) (inj₂ haltedp) ->
   q ∥ p sn⟶ value-max (dhalted haltedp) doneq (inj₁ haltedp)
 fixup-valuemax₁ donep haltedq rewrite value-max-sym donep haltedq = λ z → z

DPG₁{p}{q}{r} (rpar-done-left donep haltedq) =
    (r , r) ,
    fixup-valuemax₂ donep haltedq (rcontext [] dchole (rpar-done-right haltedq donep)) ,
    rrefl , ∥R0 where
 fixup-valuemax₂ : ∀ {p q} ->
  (donep : done p) ->
  (haltedq : halted q) ->
  q ∥ p sn⟶ value-max (dhalted haltedq) donep (inj₁ haltedq) ->
  q ∥ p sn⟶ value-max donep (dhalted haltedq) (inj₂ haltedq)
 fixup-valuemax₂ donep haltedq rewrite sym (value-max-sym donep haltedq) = λ z → z

par-not-halted : ∀ {p C q₁ q₂} -> halted p -> p ≐ C ⟦ q₁ ∥ q₂ ⟧c -> ⊥
par-not-halted hnothin ()
par-not-halted (hexit n) ()

swap-paused-is-paused :
  ∀ {p C q₁ q₂} ->
    paused p ->
    p ≐ C ⟦ q₁ ∥ q₂ ⟧c ->
    paused (C ⟦ q₂ ∥ q₁ ⟧c)
swap-paused-is-paused ppause ()
swap-paused-is-paused (pseq pausedp) (dcseq₁ dc)
 = pseq (swap-paused-is-paused pausedp dc)
swap-paused-is-paused (pseq pausedp) (dcseq₂ dc)
 = pseq pausedp
swap-paused-is-paused (ploopˢ pausedp) (dcloopˢ₁ dc)
 = ploopˢ (swap-paused-is-paused pausedp dc)
swap-paused-is-paused (ploopˢ pausedp) (dcloopˢ₂ dc)
 = ploopˢ pausedp
swap-paused-is-paused (ppar pausedp pausedp₁) dchole
 = ppar pausedp₁ pausedp
swap-paused-is-paused (ppar pausedp pausedp₁) (dcpar₁ dc)
 = ppar (swap-paused-is-paused pausedp dc) pausedp₁
swap-paused-is-paused (ppar pausedp pausedp₁) (dcpar₂ dc)
 = ppar pausedp (swap-paused-is-paused pausedp₁ dc)
swap-paused-is-paused (psuspend pausedp) (dcsuspend dc)
 = psuspend (swap-paused-is-paused pausedp dc)
swap-paused-is-paused (ptrap pausedp) (dctrap dc)
 = ptrap (swap-paused-is-paused pausedp dc)

DPG : ∀ {a b c} ->
      a ∥R b ->
      a sn⟶ c ->
      Σ (Term × Term) λ {(d , d₁) -> b sn⟶ d₁ × d₁ sn⟶* d × c ∥R* d}

DPG (∥Rstep dchole) (rcontext _ dchole psn⟶₁p')
  = DPG₁ psn⟶₁p'

DPG (∥Rstep dchole) (rcontext _ (dcpar₁ dcsn⟶) psn⟶₁p')
  =  _ ,  rcontext _ (dcpar₂ dcsn⟶) psn⟶₁p'  , rrefl , ∥Rn (∥Rstep dchole) ∥R0

DPG (∥Rstep dchole) (rcontext _ (dcpar₂ dcsn⟶) psn⟶₁p')
  = _ ,  rcontext _ (dcpar₁ dcsn⟶) psn⟶₁p'  , rrefl , ∥Rn (∥Rstep dchole) ∥R0

DPG (∥Rstep (dcpar₁ dc∥R)) (rcontext .[] dchole (rpar-done-right haltedp doneq))
 = ⊥-elim (par-not-halted haltedp dc∥R)

DPG (∥Rstep (dcpar₁ dc∥R)) (rcontext .[] dchole (rpar-done-left (dhalted p/halted) haltedq))
  = ⊥-elim (par-not-halted p/halted dc∥R)

DPG (∥Rstep (dcpar₁ dc∥R)) (rcontext .[] dchole (rpar-done-left (dpaused p/paused) hnothin))
  = _ ,
    rcontext [] dchole (rpar-done-left (dpaused (swap-paused-is-paused p/paused dc∥R)) hnothin) ,
    rrefl ,
    ∥Rn (∥Rstep dc∥R) ∥R0

DPG (∥Rstep (dcpar₁ dc∥R)) (rcontext .[] dchole (rpar-done-left (dpaused p/paused) (hexit n)))
  = _ ,
    rcontext [] dchole (rpar-done-left (dpaused (swap-paused-is-paused p/paused dc∥R)) (hexit n)) ,
    rrefl ,
    ∥R0

DPG (∥Rstep (dcpar₁ dc∥R)) (rcontext (ceval (epar₁ _) ∷ C) (dcpar₁ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ (ceval (epar₁ _)) sn⟶step ,
   Context1-sn⟶* (ceval (epar₁ _)) sn⟶*step ,
   Context1-∥R* (ceval (epar₁ _)) ∥R*step

DPG (∥Rstep (dcpar₁ dc∥R)) (rcontext _ (dcpar₂ dcsn⟶) psn⟶₁p')
 = _ ,
  rcontext _ (dcpar₂ dcsn⟶) psn⟶₁p' ,
  rrefl ,
  ∥Rn (∥Rstep (dcpar₁ dc∥R)) ∥R0

DPG (∥Rstep (dcpar₂ dc∥R)) (rcontext .[] dchole (rpar-done-right haltedp (dhalted p/halted)))
 = ⊥-elim (par-not-halted p/halted dc∥R)

DPG (∥Rstep (dcpar₂ dc∥R)) (rcontext .[] dchole (rpar-done-right hnothin (dpaused p/paused)))
 = _ ,
   rcontext [] dchole (rpar-done-right hnothin (dpaused (swap-paused-is-paused p/paused dc∥R))) ,
   rrefl ,
   ∥Rn (∥Rstep dc∥R) ∥R0

DPG (∥Rstep (dcpar₂ dc∥R)) (rcontext .[] dchole (rpar-done-right (hexit n) (dpaused p/paused)))
 =  _ ,
    rcontext [] dchole (rpar-done-right (hexit n) (dpaused (swap-paused-is-paused p/paused dc∥R))) ,
    rrefl ,
    ∥R0

DPG (∥Rstep (dcpar₂ dc∥R)) (rcontext .[] dchole (rpar-done-left donep haltedq))
 = ⊥-elim (par-not-halted haltedq dc∥R)

DPG (∥Rstep (dcpar₂ dc∥R)) (rcontext _ (dcpar₁ dcsn⟶) psn⟶₁p')
 = _ ,
   (rcontext _ (dcpar₁ dcsn⟶) psn⟶₁p') ,
   rrefl ,
   ∥Rn (∥Rstep (dcpar₂ dc∥R)) ∥R0

DPG (∥Rstep (dcpar₂ dc∥R)) (rcontext (c ∷ C) (dcpar₂ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcseq₁ ())) (rcontext .[] dchole rseq-done)

DPG (∥Rstep (dcseq₁ ())) (rcontext .[] dchole rseq-exit)

DPG (∥Rstep (dcseq₁ dc∥R)) (rcontext (c ∷ C) (dcseq₁ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcseq₁ dc∥R)) (rcontext _ (dcseq₂ dcsn⟶) psn⟶₁p')
 = _ ,
   rcontext _ (dcseq₂ dcsn⟶) psn⟶₁p' ,
   rrefl ,
   ∥Rn (∥Rstep (dcseq₁ dc∥R)) ∥R0

DPG (∥Rstep (dcseq₂ dc∥R)) (rcontext .[] dchole rseq-done)
 = _ , rcontext [] dchole rseq-done , rrefl , ∥Rn (∥Rstep dc∥R) ∥R0

DPG (∥Rstep (dcseq₂ dc∥R)) (rcontext .[] dchole rseq-exit)
 = _ , rcontext [] dchole rseq-exit , rrefl , ∥R0

DPG (∥Rstep (dcseq₂ dc∥R)) (rcontext _ (dcseq₁ dcsn⟶) psn⟶₁p')
 = _ ,
   rcontext _ (dcseq₁ dcsn⟶) psn⟶₁p' ,
   rrefl ,
   ∥Rn (∥Rstep (dcseq₂ dc∥R)) ∥R0

DPG (∥Rstep (dcseq₂ dc∥R)) (rcontext (c ∷ C) (dcseq₂ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcsuspend dc∥R)) (rcontext .[] dchole (rsuspend-done haltedp))
  = ⊥-elim (par-not-halted haltedp dc∥R)

DPG (∥Rstep (dcsuspend dc∥R)) (rcontext (c ∷ C) (dcsuspend dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dctrap dc∥R)) (rcontext .[] dchole (rtrap-done haltedp))
  = ⊥-elim (par-not-halted haltedp dc∥R)

DPG (∥Rstep (dctrap dc∥R)) (rcontext (c ∷ C) (dctrap dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcsignl dc∥R)) (rcontext .[] dchole rraise-signal)
 = _ ,
   (rcontext [] dchole rraise-signal) ,
   rrefl ,
   (∥Rn (∥Rstep (dcenv dc∥R)) ∥R0)

DPG (∥Rstep (dcsignl dc∥R)) (rcontext (c ∷ C) (dcsignl dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcpresent₁ dc∥R)) (rcontext .[] dchole ())

DPG (∥Rstep (dcpresent₁ dc∥R)) (rcontext (c ∷ C) (dcpresent₁ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcpresent₁ dc∥R)) (rcontext _ (dcpresent₂ dcsn⟶) psn⟶₁p')
  = _ ,
    rcontext _ (dcpresent₂ dcsn⟶) psn⟶₁p' ,
    rrefl ,
    ∥Rn (∥Rstep (dcpresent₁ dc∥R)) ∥R0

DPG (∥Rstep (dcpresent₂ dc∥R)) (rcontext .[] dchole ())

DPG (∥Rstep (dcpresent₂ dc∥R)) (rcontext _ (dcpresent₁ dcsn⟶) psn⟶₁p')
  = _ ,
    rcontext _ (dcpresent₁ dcsn⟶) psn⟶₁p' ,
    rrefl ,
    ∥Rn (∥Rstep (dcpresent₂ dc∥R)) ∥R0

DPG (∥Rstep (dcpresent₂ dc∥R)) (rcontext (c ∷ C) (dcpresent₂ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcloop dc∥R)) (rcontext .[] dchole rloop-unroll)
 = _ ,
   (rcontext [] dchole rloop-unroll) ,
   rrefl ,
   ∥Rn (∥Rstep (dcloopˢ₁ dc∥R)) (∥Rn (∥Rstep (dcloopˢ₂ dc∥R)) ∥R0)

DPG (∥Rstep (dcloop dc∥R)) (rcontext (c ∷ C) (dcloop dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcloopˢ₁ ())) (rcontext .[] dchole rloopˢ-exit)

DPG (∥Rstep (dcloopˢ₁ dc∥R)) (rcontext (c ∷ C) (dcloopˢ₁ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcloopˢ₁ dc∥R)) (rcontext _ (dcloopˢ₂ dcsn⟶) psn⟶₁p')
 = _ ,
   rcontext _ (dcloopˢ₂ dcsn⟶) psn⟶₁p' ,
   rrefl ,
   ∥Rn (∥Rstep (dcloopˢ₁ dc∥R)) ∥R0

DPG (∥Rstep (dcloopˢ₂ dc∥R)) (rcontext .[] dchole rloopˢ-exit)
 = _ ,
   (rcontext [] dchole rloopˢ-exit) ,
   rrefl ,
   ∥R0

DPG (∥Rstep (dcloopˢ₂ dc∥R)) (rcontext _ (dcloopˢ₁ dcsn⟶) psn⟶₁p')
 = _ ,
   rcontext _ (dcloopˢ₁ dcsn⟶) psn⟶₁p' ,
   rrefl ,
   ∥Rn (∥Rstep (dcloopˢ₂ dc∥R)) ∥R0

DPG (∥Rstep (dcloopˢ₂ dc∥R)) (rcontext (c ∷ C) (dcloopˢ₂ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcshared dc∥R)) (rcontext .[] dchole ())

DPG (∥Rstep (dcshared dc∥R)) (rcontext (c ∷ C) (dcshared dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcvar dc∥R)) (rcontext .[] dchole ())

DPG (∥Rstep (dcvar dc∥R)) (rcontext (c ∷ C) (dcvar dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcif₁ dc∥R)) (rcontext .[] dchole ())

DPG (∥Rstep (dcif₁ dc∥R)) (rcontext (c ∷ C) (dcif₁ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcif₁ dc∥R)) (rcontext _ (dcif₂ dcsn⟶) psn⟶₁p')
 = _ ,
   rcontext _ (dcif₂ dcsn⟶) psn⟶₁p' ,
   rrefl ,
   ∥Rn (∥Rstep (dcif₁ dc∥R)) ∥R0

DPG (∥Rstep (dcif₂ dc∥R)) (rcontext .[] dchole ())

DPG (∥Rstep (dcif₂ dc∥R)) (rcontext _ (dcif₁ dcsn⟶) psn⟶₁p')
 = _ ,
   rcontext _ (dcif₁ dcsn⟶) psn⟶₁p' ,
   rrefl ,
   ∥Rn (∥Rstep (dcif₂ dc∥R)) ∥R0

DPG (∥Rstep (dcif₂ dc∥R)) (rcontext (c ∷ C) (dcif₂ dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step

DPG (∥Rstep (dcenv dc∥R)) (rcontext{p' = p'} .[] dchole psn⟶₁p')
  with ρ-stays-ρ-sn⟶₁ psn⟶₁p'
... | θ' , q , A' , refl
  with get-view psn⟶₁p'
... | inj₂ (eq , eq2 , pot-view) = DPG-pot-view dc∥R psn⟶₁p' eq eq2 pot-view
... | inj₁ (E , pin , qin , peq , qeq , E-view) with
   DPG-E-view peq qeq dc∥R psn⟶₁p' E-view
... | (d , sn⟶step , ∥R*-step , _ )
  = _ ,
    rcontext [] dchole sn⟶step ,
    rrefl ,
    Context1-∥R* (cenv θ' _) ∥R*-step

DPG (∥Rstep (dcenv dc∥R)) (rcontext (c ∷ C) (dcenv dcsn⟶) psn⟶₁p')
 with DPG (∥Rstep dc∥R) (rcontext C dcsn⟶ psn⟶₁p')
... | _ , sn⟶step , sn⟶*step , ∥R*step
 = _ ,
   Context1-sn⟶ c sn⟶step ,
   Context1-sn⟶* c sn⟶*step ,
   Context1-∥R* c ∥R*step


module sn-calculus-compatconf.split where

open import sn-calculus-compatconf.base

open import sn-calculus
open import utility renaming (_U̬_ to _∪_)
open import context-properties
  using (unwrap-rho ; wrap-rho ; ->E-view ; plugc ; unplugc)

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.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₂ ; _×_ ; ∃)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂ ; map)
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 EvaluationContext1
open _≐_⟦_⟧e
open Context1
open _≐_⟦_⟧c

open ListSet Data.Nat._≟_

{-
Base case where (E, C) = ([], _∷_).

  Simply switch the reductions. Note that since E = [], the rmerge rule
  at LHS is actually  ρθ.ρθ'.qin sn⟶₁ ρ(θ←θ').qin.  Since C = _∷_, the
  reduction at RHS must go inside ρθ' so it's easy to handle.

     p
  ρθ. E⟦ qin ⟧   -- sn⟶₁ ->    ρθq. E⟦ qo ⟧
 (ρθ) E⟦C⟦rin⟧⟧   -- sn⟶₁ ->   (ρθ) E⟦C⟦ro⟧⟧
-}
1-steplρ-E-view-ecsplit : ∀{E C 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 →
  two-roads-diverged E C →

  (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) →
  (r≐E⟦ro⟧   :  r ≐ C ⟦ ro ⟧c) →
  (rinsn⟶₁ro  :  rin sn⟶₁ ro) →

  ∃ λ po →
    -- LHS: 0 or 1 step (ρθ) C⟦qo⟧ sn⟶* (ρθ) C⟦poq⟧ reduction inside ρθ [ ]
    (q ≡ po ⊎ q sn⟶ po)
    ×
    -- RHS: ρθ. E'⟦ro'⟧ sn⟶₁ ρθq. E'⟦por⟧
    Σ (EvaluationContext × Term × Term) λ { (E' , ro' , por) →
      Σ[ r≐E'⟦ro'⟧      ∈  r  ≐ E' ⟦ ro' ⟧e ]
      Σ[ po≐E'⟦por⟧     ∈  po ≐ E' ⟦ por ⟧e ]
      Σ[ ρθ·rsn⟶₁ρθq·po  ∈  ρ⟨ θ , A ⟩· r sn⟶₁ ρ⟨ θq , Aq ⟩· po ]
        ->E-view  ρθ·rsn⟶₁ρθq·po  r≐E'⟦ro'⟧  po≐E'⟦por⟧
      }

1-steplρ-E-view-ecsplit cb divout-disjoint dehole dehole
  vemit () r≐C⟦ro⟧ rinsn⟶₁ro
1-steplρ-E-view-ecsplit cb divout-disjoint dehole dehole
  vset-shared-value-old () r≐C⟦ro⟧ rinsn⟶₁ro
1-steplρ-E-view-ecsplit cb divout-disjoint dehole dehole
  vset-shared-value-new () r≐C⟦ro⟧ rinsn⟶₁ro
1-steplρ-E-view-ecsplit cb divout-disjoint dehole dehole
  vset-var () r≐C⟦ro⟧ rinsn⟶₁ro

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ρθ·psn⟶₁ρθq·q} cb
  divout-disjoint dehole dehole vmerge
  ρθp≐C⟦rin⟧ ρθr≐C⟦ro⟧ rinsn⟶₁ro
  with ρθp≐C⟦rin⟧ | ρθr≐C⟦ro⟧
... | dcenv p≐C⟦rin⟧ | dcenv r≐C⟦ro⟧  with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ p≐C⟦rin⟧ rinsn⟶₁ro) ,′
   _ , dehole , dehole , rmerge dehole , vmerge

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ris-present {_} {S} S∈ θS≡present dehole} cb
  divout-disjoint dehole dehole vis-present
  (dcpresent₁ p≐C⟦rin⟧) (dcpresent₁ r≐C⟦ro⟧) rinsn⟶₁ro with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ p≐C⟦rin⟧ rinsn⟶₁ro) ,′
   _ , dehole , dehole , ris-present {_} {S} S∈ θS≡present dehole , vis-present

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ris-present {_} {S} S∈ θS≡present dehole} cb
  divout-disjoint dehole dehole vis-present
  (dcpresent₂ p≐C⟦rin⟧) (dcpresent₂ r≐C⟦ro⟧) rinsn⟶₁ro =
  _ , inj₁ refl ,′
  _ , dehole , dehole , ris-present {_} {S} S∈ θS≡present dehole , vis-present

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ris-absent {_} {S} S∈ θS≡absent dehole} cb
  divout-disjoint dehole dehole vis-absent
  (dcpresent₁ p≐C⟦rin⟧) (dcpresent₁ r≐C⟦ro⟧) rinsn⟶₁ro =
  _ , inj₁ refl ,′
  _ , dehole , dehole , ris-absent {_} {S} S∈ θS≡absent dehole , vis-absent

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ris-absent {_} {S} S∈ θS≡absent dehole} cb
  divout-disjoint dehole dehole vis-absent
  (dcpresent₂ p≐C⟦rin⟧) (dcpresent₂ r≐C⟦ro⟧) rinsn⟶₁ro with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ p≐C⟦rin⟧ rinsn⟶₁ro) ,′
   _ , dehole , dehole , ris-absent {_} {S} S∈ θS≡absent dehole , vis-absent

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = rraise-shared {_} {_} {s} _ _} cb
  divout-disjoint dehole dehole vraise-shared
  (dcshared p≐C⟦rin⟧) (dcshared r≐C⟦ro⟧) rinsn⟶₁ro with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ (dcenv p≐C⟦rin⟧) rinsn⟶₁ro) ,′
   _ , dehole , dehole , rraise-shared {_} {_} {s} _ _ , vraise-shared

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = rraise-var {_} {_} {x} _ _} cb
  divout-disjoint dehole dehole vraise-var
  (dcvar p≐C⟦rin⟧) (dcvar r≐C⟦ro⟧) rinsn⟶₁ro with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ (dcenv p≐C⟦rin⟧) rinsn⟶₁ro) ,′
   _ , dehole , dehole , rraise-var {_} {_} {x} _ _ , vraise-var

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = rif-false {x = x} x∈ θx≡zero dehole} cb
  divout-disjoint dehole dehole vif-false
  (dcif₁ p≐C⟦rin⟧) (dcif₁ r≐C⟦ro⟧) rinsn⟶₁ro =
  _ , inj₁ refl ,′
  _ , dehole , dehole , rif-false {x = x} x∈ θx≡zero dehole , vif-false

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = rif-false {x = x} x∈ θx≡zero dehole} cb
  divout-disjoint dehole dehole vif-false
  (dcif₂ p≐C⟦rin⟧) (dcif₂ r≐C⟦ro⟧) rinsn⟶₁ro with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ p≐C⟦rin⟧ rinsn⟶₁ro) ,′
   _ , dehole , dehole , rif-false {x = x} x∈ θx≡zero dehole , vif-false

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = rif-true {θ} {x = x} x∈ θx≡suc dehole} cb
  divout-disjoint dehole dehole vif-true
  (dcif₁ p≐C⟦rin⟧) (dcif₁ r≐C⟦ro⟧) rinsn⟶₁ro with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ p≐C⟦rin⟧ rinsn⟶₁ro) ,′
   _ , dehole , dehole , rif-true {x = x} x∈ θx≡suc dehole , vif-true

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = rif-true {x = x} x∈ θx≡suc dehole} cb
  divout-disjoint dehole dehole vif-true
  (dcif₂ p≐C⟦rin⟧) (dcif₂ r≐C⟦ro⟧) rinsn⟶₁ro =
  _ , inj₁ refl ,′
  _ , dehole , dehole , rif-true {x = x} x∈ θx≡suc dehole , vif-true

1-steplρ-E-view-ecsplit cb divpar-split₁
  (depar₁ p₁≐E⟦qin⟧) (depar₁ q≐E⟦qo⟧) e-view
  (dcpar₂ p≐C⟦rin⟧) (dcpar₂ r≐C⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho _ _ _ p₁≐E⟦qin⟧ q≐E⟦qo⟧ e-view
... | ρθ·p₁sn⟶₁ρθq·q , e-view' with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ (dcpar₂ p≐C⟦rin⟧) rinsn⟶₁ro) ,′
   _ , _ , _ , wrap-rho ρθ·p₁sn⟶₁ρθq·q _ _ e-view' _ (depar₁ p₁≐E⟦qin⟧) (depar₁ q≐E⟦qo⟧)

1-steplρ-E-view-ecsplit cb divpar-split₂
  (depar₂ p₂≐E⟦qin⟧) (depar₂ q≐E⟦qo⟧) e-view
  (dcpar₁ p≐C⟦rin⟧) (dcpar₁ r≐C⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho _ _ _ p₂≐E⟦qin⟧ q≐E⟦qo⟧ e-view
... | ρθ·p₂sn⟶₁ρθq·q , e-view' with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ (dcpar₁ p≐C⟦rin⟧) rinsn⟶₁ro) ,′
   _ , _ , _ , wrap-rho ρθ·p₂sn⟶₁ρθq·q _ _ e-view' _ (depar₂ p₂≐E⟦qin⟧) (depar₂ q≐E⟦qo⟧)

1-steplρ-E-view-ecsplit cb divseq-split
  (deseq p₁≐E⟦qin⟧) (deseq q≐E⟦qo⟧) e-view
  (dcseq₂ p≐C⟦rin⟧) (dcseq₂ r≐C⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho _ _ _ p₁≐E⟦qin⟧ q≐E⟦qo⟧ e-view
... | ρθ·p₁sn⟶₁ρθq·q , e-view' with sym (unplugc r≐C⟦ro⟧)
... | refl
  = _ , inj₂ (rcontext _ (dcseq₂ p≐C⟦rin⟧) rinsn⟶₁ro) ,′
    _ , _ , _ , wrap-rho ρθ·p₁sn⟶₁ρθq·q _ _ e-view' _ (deseq p₁≐E⟦qin⟧) (deseq q≐E⟦qo⟧)

1-steplρ-E-view-ecsplit cb divloopˢ-split
  (deloopˢ p₁≐E⟦qin⟧) (deloopˢ q≐E⟦qo⟧) e-view
  (dcloopˢ₂ p≐C⟦rin⟧) (dcloopˢ₂ r≐C⟦ro⟧) rinsn⟶₁ro
  with unwrap-rho _ _ _ p₁≐E⟦qin⟧ q≐E⟦qo⟧ e-view
... | ρθ·p₁sn⟶₁ρθq·q , e-view' with sym (unplugc r≐C⟦ro⟧)
... | refl
 = _ , inj₂ (rcontext _ (dcloopˢ₂ p≐C⟦rin⟧) rinsn⟶₁ro) ,′
   _ , _ , _ , wrap-rho ρθ·p₁sn⟶₁ρθq·q _ _ e-view' _ (deloopˢ p₁≐E⟦qin⟧) (deloopˢ q≐E⟦qo⟧)

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBpar cbp cbq _ _ _ _) (divin div)
  (depar₁ p≐E⟦qin⟧) (depar₁ q≐E⟦qo⟧) e-view-E₁
  (dcpar₁ p≐C⟦rin⟧) (dcpar₁ r≐C⟦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)
  with 1-steplρ-E-view-ecsplit cbp div p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro
... | _ , qsn⟶po? , _ , r≐E'⟦qin⟧ , po≐E'⟦qo⟧ , _ , e-view' =
  _ , map (cong _) (Context1-sn⟶ (ceval (epar₁ _))) qsn⟶po? ,′
  _ , depar₁ r≐E'⟦qin⟧ , depar₁ po≐E'⟦qo⟧ , wrap-rho _ _ _ e-view' _ _ _

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBpar cbp cbq _ _ _ _) (divin div)
  (depar₂ p≐E⟦qin⟧) (depar₂ q≐E⟦qo⟧) e-view-E₁
  (dcpar₂ p≐C⟦rin⟧) (dcpar₂ r≐C⟦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)
  with 1-steplρ-E-view-ecsplit cbq div p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro
... | _ , qsn⟶po? , _ , r≐E'⟦qin⟧ , po≐E'⟦qo⟧ , _ , e-view' =
  _ , map (cong _) (Context1-sn⟶ (ceval (epar₂ _))) qsn⟶po? ,′
  _ , depar₂ r≐E'⟦qin⟧ , depar₂ po≐E'⟦qo⟧ , wrap-rho _ _ _ e-view' _ _ _

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBseq cbp cbq _) (divin div)
  (deseq p≐E⟦qin⟧) (deseq q≐E⟦qo⟧) e-view-E₁
  (dcseq₁ p≐C⟦rin⟧) (dcseq₁ r≐C⟦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)
  with 1-steplρ-E-view-ecsplit cbp div p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro
... | _ , qsn⟶po? , _ , r≐E'⟦qin⟧ , po≐E'⟦qo⟧ , _ , e-view' =
  _ , map (cong _) (Context1-sn⟶ (ceval (eseq _))) qsn⟶po? ,′
  _ , deseq r≐E'⟦qin⟧ , deseq po≐E'⟦qo⟧ , wrap-rho _ _ _ e-view' _ _ _

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBloopˢ cbp cbq _ _) (divin div)
  (deloopˢ p≐E⟦qin⟧) (deloopˢ q≐E⟦qo⟧) e-view-E₁
  (dcloopˢ₁ p≐C⟦rin⟧) (dcloopˢ₁ r≐C⟦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)
  with 1-steplρ-E-view-ecsplit cbp div p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro
... | _ , qsn⟶po? , _ , r≐E'⟦qin⟧ , po≐E'⟦qo⟧ , _ , e-view' =
  _ , map (cong _) (Context1-sn⟶ (ceval (eloopˢ _))) qsn⟶po? ,′
  _ , deloopˢ r≐E'⟦qin⟧ , deloopˢ po≐E'⟦qo⟧ , wrap-rho _ _ _ e-view' _ _ _

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBsusp cb' _) (divin div)
  (desuspend p≐E⟦qin⟧) (desuspend q≐E⟦qo⟧) e-view-E₁
  (dcsuspend p≐C⟦rin⟧) (dcsuspend r≐C⟦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)
  with 1-steplρ-E-view-ecsplit cb' div p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro
... | _ , qsn⟶po? , _ , r≐E'⟦qin⟧ , po≐E'⟦qo⟧ , _ , e-view' =
  _ , map (cong _) (Context1-sn⟶ (ceval (esuspend _))) qsn⟶po? ,′
  _ , desuspend r≐E'⟦qin⟧ , desuspend po≐E'⟦qo⟧ , wrap-rho _ _ _ e-view' _ _ _

1-steplρ-E-view-ecsplit {ρθ·psn⟶₁ρθq·q = ρθ·E₁⟦p⟧sn⟶₁ρθq·E₁⟦q⟧}
  cb@(CBtrap cb') (divin div)
  (detrap p≐E⟦qin⟧) (detrap q≐E⟦qo⟧) e-view-E₁
  (dctrap p≐C⟦rin⟧) (dctrap r≐C⟦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)
  with 1-steplρ-E-view-ecsplit cb' div p≐E⟦qin⟧ q≐E⟦qo⟧ e-view p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro
... | _ , qsn⟶po? , _ , r≐E'⟦qin⟧ , po≐E'⟦qo⟧ , _ , e-view' =
  _ , map (cong _) (Context1-sn⟶ (ceval etrap)) qsn⟶po? ,′
  _ , detrap r≐E'⟦qin⟧ , detrap po≐E'⟦qo⟧ , wrap-rho _ _ _ e-view' _ _ _