module Tactic.Nat.Reflect where

open import Prelude hiding (abs)
open import Control.Monad.State
open import Control.Monad.Transformer

import Agda.Builtin.Nat as Builtin

open import Builtin.Reflection
open import Tactic.Reflection
open import Tactic.Reflection.Quote
open import Tactic.Reflection.Meta
open import Tactic.Deriving.Quotable
open import Tactic.Reflection.Equality

open import Tactic.Nat.Exp

R = StateT (Nat × List (Term × Nat)) TC

fail : ∀ {A} → R A
fail = lift (typeErrorS "reflection error")

liftMaybe : ∀ {A} → Maybe A → R A
liftMaybe = maybe fail pure

runR : ∀ {A} → R A → TC (Maybe (A × List Term))
runR r =
  maybeA (second (reverse ∘ map fst ∘ snd) <$> runStateT r (0 , []))

pattern `Nat = def (quote Nat) []

infixr 1 _`->_
infix  4 _`≡_

pattern _`≡_ x y = def (quote _≡_) (_ ∷ hArg `Nat ∷ vArg x ∷ vArg y ∷ [])
pattern _`->_ a b = pi (vArg a) (abs _ b)

pattern _`+_ x y = def₂ (quote Builtin._+_) x y
pattern _`*_ x y = def₂ (quote Builtin._*_) x y
pattern `0       = con₀ (quote Nat.zero)
pattern `suc n   = con₁ (quote Nat.suc) n

fresh : Term → R (Exp Var)
fresh t =
  get >>= uncurry′ λ i Γ →
   var i <$ put (suc i , (t , i) ∷ Γ)

⟨suc⟩ : ∀ {X} → Exp X → Exp X
⟨suc⟩ (lit n) = lit (suc n)
⟨suc⟩ (lit n ⟨+⟩ e) = lit (suc n) ⟨+⟩ e
⟨suc⟩ e = lit 1 ⟨+⟩ e

private
  forceInstance : Name → Term → R ⊤
  forceInstance i v = lift $ unify v (def₀ i)
  forceSemiring = forceInstance (quote SemiringNat)
  forceNumber   = forceInstance (quote NumberNat)

termToExpR : Term → R (Exp Var)
termToExpR (a `+ b) = ⦇ termToExpR a ⟨+⟩ termToExpR b ⦈
termToExpR (a `* b) = ⦇ termToExpR a ⟨*⟩ termToExpR b ⦈
termToExpR (def (quote Semiring._+_) (_ ∷ _ ∷ vArg i@(meta x _) ∷ vArg a ∷ vArg b ∷ [])) = do
  forceSemiring i
  ⦇ termToExpR a ⟨+⟩ termToExpR b ⦈
termToExpR (def (quote Semiring._*_) (_ ∷ _ ∷ vArg i@(meta x _) ∷ vArg a ∷ vArg b ∷ [])) = do
  lift $ unify i (def₀ (quote SemiringNat))
  ⦇ termToExpR a ⟨*⟩ termToExpR b ⦈
termToExpR (def (quote Semiring.zro) (_ ∷ _ ∷ vArg i@(meta x _) ∷ [])) = do
  forceSemiring i
  pure (lit 0)
termToExpR (def (quote Semiring.one) (_ ∷ _ ∷ vArg i@(meta x _) ∷ [])) = do
  forceSemiring i
  pure (lit 1)
termToExpR (def (quote Number.fromNat) (_ ∷ _ ∷ vArg i@(meta x _) ∷ vArg a ∷ _ ∷ [])) = do
  forceNumber i
  termToExpR a
termToExpR `0       = pure (lit 0)
termToExpR (`suc a) = ⟨suc⟩ <$> termToExpR a
termToExpR (lit (nat n)) = pure (lit n)
termToExpR (meta x _) = lift (blockOnMeta x)
termToExpR unknown  = fail
termToExpR t = do
  lift (ensureNoMetas t)
  just i ← gets (flip lookup t ∘ snd) where nothing → fresh t
  pure (var i)

private
  lower : Nat → Term → R Term
  lower 0 = pure
  lower i = liftMaybe ∘ strengthen i

termToEqR : Term → R (Exp Var × Exp Var)
termToEqR (lhs `≡ rhs) = ⦇ termToExpR lhs , termToExpR rhs ⦈
termToEqR (def (quote _≡_) (_ ∷ hArg (meta x _) ∷ _)) = lift (blockOnMeta x)
termToEqR (meta x _) = lift (blockOnMeta x)
termToEqR _ = fail

termToHypsR′ : Nat → Term → R (List (Exp Var × Exp Var))
termToHypsR′ i (hyp `-> a) = _∷_ <$> (termToEqR =<< lower i hyp) <*> termToHypsR′ (suc i) a
termToHypsR′ _ (meta x _) = lift (blockOnMeta x)
termToHypsR′ i a = [_] <$> (termToEqR =<< lower i a)

termToHypsR : Term → R (List (Exp Var × Exp Var))
termToHypsR = termToHypsR′ 0

termToHyps : Term → TC (Maybe (List (Exp Var × Exp Var) × List Term))
termToHyps t = runR (termToHypsR t)

termToEq : Term → TC (Maybe ((Exp Var × Exp Var) × List Term))
termToEq t = runR (termToEqR t)

buildEnv : List Nat → Env Var
buildEnv []        i      = 0
buildEnv (x ∷ xs)  zero   = x
buildEnv (x ∷ xs) (suc i) = buildEnv xs i

defaultArg : Term → Arg Term
defaultArg = arg (arg-info visible relevant)

data ProofError {a} : Set a → Set (lsuc a) where
  bad-goal : ∀ g → ProofError g

qProofError : Term → Term
qProofError v = con (quote bad-goal) (defaultArg v ∷ [])

implicitArg instanceArg : ∀ {A} → A → Arg A
implicitArg = arg (arg-info hidden relevant)
instanceArg = arg (arg-info instance′ relevant)

unquoteDecl QuotableExp = deriveQuotable QuotableExp (quote Exp)

stripImplicitArg : Arg Term → List (Arg Term)
stripImplicitArgs : List (Arg Term) → List (Arg Term)
stripImplicitAbsTerm : Abs Term → Abs Term
stripImplicitArgTerm : Arg Term → Arg Term

stripImplicit : Term → Term
stripImplicit (var x args) = var x (stripImplicitArgs args)
stripImplicit (con c args) = con c (stripImplicitArgs args)
stripImplicit (def f args) = def f (stripImplicitArgs args)
stripImplicit (meta x args) = meta x (stripImplicitArgs args)
stripImplicit (lam v t) = lam v (stripImplicitAbsTerm t)
stripImplicit (pi t₁ t₂) = pi (stripImplicitArgTerm t₁) (stripImplicitAbsTerm t₂)
stripImplicit (agda-sort x) = agda-sort x
stripImplicit (lit l) = lit l
stripImplicit (pat-lam cs args) = pat-lam cs (stripImplicitArgs args)
stripImplicit unknown = unknown

stripImplicitAbsTerm (abs x v) = abs x (stripImplicit v)

stripImplicitArgs [] = []
stripImplicitArgs (a ∷ as) = stripImplicitArg a ++ stripImplicitArgs as

stripImplicitArgTerm (arg i x) = arg i (stripImplicit x)

stripImplicitArg (arg (arg-info visible r) x) = arg (arg-info visible r) (stripImplicit x) ∷ []
stripImplicitArg (arg (arg-info hidden r) x) = []
stripImplicitArg (arg (arg-info instance′ r) x) = []

quotedEnv : List Term → Term
quotedEnv ts = def (quote buildEnv) $ defaultArg (quoteList $ map stripImplicit ts) ∷ []

QED : ∀ {a} {A : Set a} {x : Maybe A} → Set
QED {x = x} = IsJust x

get-proof : ∀ {a} {A : Set a} (prf : Maybe A) → QED {x = prf} → A
get-proof (just eq) _ = eq
get-proof nothing ()
{-# STATIC get-proof #-}

getProof : Name → Term → Term → Term
getProof err t proof =
  def (quote get-proof)
  $ vArg proof
  ∷ vArg (def err $ vArg (stripImplicit t) ∷ [])
  ∷ []

failedProof : Name → Term → Term
failedProof err t =
  def (quote get-proof)
  $ vArg (con (quote nothing) [])
  ∷ vArg (def err $ vArg (stripImplicit t) ∷ [])
  ∷ []

cantProve : Set → ⊤
cantProve _ = _

invalidGoal : Set → ⊤
invalidGoal _ = _


module monad-instances where
open import lib
open import general-util

instance
  IO-monad : monad IO
  IO-monad = record {returnM = return; bindM = _>>=_}

instance
  id-monad : monad id
  id-monad = record {returnM = id; bindM = λ a f → f a}


module CF.Examples.Ex1 where

open import Function
open import Data.Bool
open import Data.Product
open import Data.List
open import Data.List.Relation.Unary.All
open import Data.Nat
open import Data.String

open import Relation.Binary.PropositionalEquality using (refl)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax
open import Relation.Ternary.Monad.Possibly
open import Relation.Ternary.Data.Allstar
open import Relation.Ternary.Data.Bigstar hiding ([_])

open import CF.Types
open import CF.Syntax as Src
open import CF.Contexts.Lexical

open import JVM.Transform.Assemble
open import JVM.Printer
import JVM.Printer.Jasmin as J

ex₁ : Closed (Src.Block void)
ex₁ = (
  Src.while (
    Src.bool true ∙⟨ ∙-idˡ ⟩ Src.block
    -- int j = true
    (Src.bool true ≔⟨ ∙-idˡ ⟩ Possibly.possibly ∼-all (
      Src.ifthenelse
        -- if j
        (var
          ∙⟨ overlaps ∙-idˡ ⟩
          -- then
          Src.block (
            -- int i = j
            var ≔⟨ consˡ ∙-idˡ ⟩
            Possibly.possibly ∼-all (
              -- j := j
              Src.asgn (vars ∙⟨ overlaps ∙-idˡ ⟩ var) ⍮⟨ ∙-idʳ ⟩
              Src.run unit ⍮⟨ ∙-idʳ ⟩
              emp))
          -- else
          ∙⟨ overlaps ∙-idˡ ⟩
          Src.block (
            -- int i = j
            var ≔⟨ consˡ ∙-idˡ ⟩
            Possibly.possibly ∼-none (
              Src.run unit ⍮⟨ ∙-idʳ ⟩
              emp))
          )
        Src.⍮⟨ ∙-idʳ ⟩ emp
    ))) Src.⍮⟨ ∙-idʳ ⟩ emp)

open import IO as IO
open import Codata.Musical.Notation

open import CF.Compile

main = IO.run (putStrLn test)
  where
    test = Show.showBytecode $ proj₂ $ exec-extractor $ extract (proj₂ $ compile ex₁)

-- Uncomment this instead of the above main to output Jasmin code.
-- You can assemble this using Jasmin so that you can run the output with java.
-- Disclaimer: the jasmin compiler pass is not verified.
-- main = IO.run (putStrLn (J.unlines $ J.Jasmin.out proc))
--   where
--   proc = procedure "ex1" (proj₂ $ compile ex₁)


module Issue296 where

postulate
  Unit : Set
  IO   : Set → Set
  foo  : ((A B : Set) → Unit) → IO Unit
  bar  : (A B : Set) → Unit

{-# BUILTIN IO IO #-}
{-# COMPILED_TYPE IO IO #-}
{-# COMPILED_TYPE Unit () #-}
{-# COMPILED bar undefined #-}

main : IO Unit
main = foo bar


------------------------------------------------------------------------
-- An expression can be derived from at most one string
------------------------------------------------------------------------

open import Mixfix.Expr

module Mixfix.Cyclic.Uniqueness
         (i : PrecedenceGraphInterface)
         (g : PrecedenceGraphInterface.PrecedenceGraph i)
         where

open import Codata.Musical.Notation using (♭)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.List using (List; []; _∷_)
open import Data.List.Relation.Unary.Any using (here)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Product using (_,_; -,_; proj₂)
open import Relation.Binary.HeterogeneousEquality using (_≅_; refl)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open PrecedenceCorrect i g
open import TotalParserCombinators.Semantics hiding (_≅_)
open import Mixfix.Fixity
open import Mixfix.Operator
open import Mixfix.Cyclic.Lib as Lib
open Lib.Semantics
import Mixfix.Cyclic.Grammar
private module Grammar = Mixfix.Cyclic.Grammar i g

module Unique where

 data _≋_ {A : Set} {x₁ : A} {s₁ p₁} (∈ : x₁ ∈⟦ p₁ ⟧· s₁) :
          ∀ {x₂ : A} {s₂ p₂} → x₂ ∈⟦ p₂ ⟧· s₂ → Set where
   refl : ∈ ≋ ∈

 mutual

  precs : ∀ ps {s₁ s₂} {e₁ e₂ : Expr ps}
          (∈₁ : e₁ ∈⟦ Grammar.precs ps ⟧· s₁)
          (∈₂ : e₂ ∈⟦ Grammar.precs ps ⟧· s₂) →
          e₁ ≡ e₂ → ∈₁ ≋ ∈₂
  precs [] () () _
  precs (p ∷ ps) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                 (∣ʳ (<$>_ {x = (._ ∙ ._)}  ∈₂)) refl with precs ps ∈₁ ∈₂ refl
  precs (p ∷ ps) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                 (∣ʳ (<$>_ {x = (._ ∙ ._)} .∈₁)) refl | refl = refl
  precs (p ∷ ps) (∣ˡ (<$> ∈₁)) (∣ʳ (<$>_ {x = _ ∙ _} ∈₂)) ()
  precs (p ∷ ps) (∣ʳ (<$>_ {x = _ ∙ _} ∈₁)) (∣ˡ (<$> ∈₂)) ()
  precs (p ∷ ps) (∣ˡ (<$>_ {x = e₁} ∈₁)) (∣ˡ (<$>_ {x = e₂} ∈₂)) eq =
    helper (lemma₁ eq) (lemma₂ eq) ∈₁ ∈₂
    where
    lemma₁ : ∀ {assoc₁ assoc₂}
               {e₁ : ExprIn p assoc₁} {e₂ : ExprIn p assoc₂} →
             (Expr._∙_ (here {xs = ps} refl) e₁) ≡ (here refl ∙ e₂) →
             assoc₁ ≡ assoc₂
    lemma₁ refl = refl

    lemma₂ : ∀ {assoc₁ assoc₂}
               {e₁ : ExprIn p assoc₁} {e₂ : ExprIn p assoc₂} →
             (Expr._∙_ (here {xs = ps} refl) e₁) ≡ (here refl ∙ e₂) →
             e₁ ≅ e₂
    lemma₂ refl = refl

    helper : ∀ {assoc₁ assoc₂ s₁ s₂}
             {e₁ : ExprIn p assoc₁} {e₂ : ExprIn p assoc₂} →
             assoc₁ ≡ assoc₂ → e₁ ≅ e₂ →
             (∈₁ : (-, e₁) ∈⟦ Grammar.prec p ⟧· s₁) →
             (∈₂ : (-, e₂) ∈⟦ Grammar.prec p ⟧· s₂) →
             ∣ˡ {p₁ = (λ e → here refl ∙ proj₂ e) <$> Grammar.prec p}
                {p₂ = weakenE <$> Grammar.precs ps} (<$> ∈₁) ≋
             ∣ˡ {p₁ = (λ e → here refl ∙ proj₂ e) <$> Grammar.prec p}
                {p₂ = weakenE <$> Grammar.precs ps} (<$> ∈₂)
    helper refl refl ∈₁ ∈₂ with prec ∈₁ ∈₂
    helper refl refl ∈ .∈  | refl = refl

  prec : ∀ {p assoc s₁ s₂} {e : ExprIn p assoc}
         (∈₁ : (-, e) ∈⟦ Grammar.prec p ⟧· s₁)
         (∈₂ : (-, e) ∈⟦ Grammar.prec p ⟧· s₂) →
         ∈₁ ≋ ∈₂
  prec {p} ∈₁′ ∈₂′ = prec′ ∈₁′ ∈₂′ refl
    where
    module P = Grammar.Prec p

    preRight⁺ : ∀ {s₁ s₂} {e₁ e₂ : ExprIn p right}
                (∈₁ : e₁ ∈⟦ P.preRight⁺ ⟧· s₁)
                (∈₂ : e₂ ∈⟦ P.preRight⁺ ⟧· s₂) →
                e₁ ≡ e₂ → ∈₁ ≋ ∈₂
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ˡ (<$> ∈₁′)       ⊛∞ ∣ˡ (<$> ∈₂′)) refl with inner _   ∈₁ ∈₁′ refl | preRight⁺ ∈₂ ∈₂′ refl
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ˡ (<$> .∈₁)       ⊛∞ ∣ˡ (<$> .∈₂)) refl | refl | refl = refl
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ˡ (<$> ∈₁′)       ⊛∞ ∣ʳ (<$> ∈₂′)) refl with inner _ ∈₁ ∈₁′ refl | precs _ ∈₂ ∈₂′ refl
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ˡ (<$> .∈₁)       ⊛∞ ∣ʳ (<$> .∈₂)) refl | refl | refl = refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ʳ (<$> ∈₁′ ⊛ ∈₃′) ⊛∞ ∣ˡ (<$> ∈₂′)) refl with precs _   ∈₁ ∈₁′ refl | preRight⁺ ∈₂ ∈₂′ refl | inner _   ∈₃ ∈₃′ refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ʳ (<$> .∈₁ ⊛ .∈₃) ⊛∞ ∣ˡ (<$> .∈₂)) refl | refl | refl | refl = refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ʳ (<$> ∈₁′ ⊛ ∈₃′) ⊛∞ ∣ʳ (<$> ∈₂′)) refl with precs _ ∈₁ ∈₁′ refl | precs _ ∈₂ ∈₂′ refl | inner _ ∈₃ ∈₃′ refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ʳ (<$> .∈₁ ⊛ .∈₃) ⊛∞ ∣ʳ (<$> .∈₂)) refl | refl | refl | refl = refl

    preRight⁺ (∣ˡ (<$> _)     ⊛∞ _)
              (∣ʳ (<$> _ ⊛ _) ⊛∞ _)          ()
    preRight⁺ (∣ʳ (<$> _ ⊛ _) ⊛∞ _)
              (∣ˡ (<$> _)     ⊛∞ _)          ()
    preRight⁺ (∣ˡ (<$> _)     ⊛∞ ∣ˡ (<$> _))
              (∣ˡ (<$> _)     ⊛∞ ∣ʳ (<$> _)) ()
    preRight⁺ (∣ˡ (<$> _)     ⊛∞ ∣ʳ (<$> _))
              (∣ˡ (<$> _)     ⊛∞ ∣ˡ (<$> _)) ()
    preRight⁺ (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ˡ (<$> _))
              (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ʳ (<$> _)) ()
    preRight⁺ (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ʳ (<$> _))
              (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ˡ (<$> _)) ()

    postLeft⁺ : ∀ {s₁ s₂} {e₁ e₂ : ExprIn p left}
                (∈₁ : e₁ ∈⟦ P.postLeft⁺ ⟧· s₁)
                (∈₂ : e₂ ∈⟦ P.postLeft⁺ ⟧· s₂) →
                e₁ ≡ e₂ → ∈₁ ≋ ∈₂
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ˡ (<$> ∈₁′)) ⊛∞ ∣ˡ (<$> ∈₂′))       refl with postLeft⁺ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ˡ (<$> .∈₁)) ⊛∞ ∣ˡ (<$> .∈₂))       refl | refl | refl = refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ʳ (<$> ∈₁′)) ⊛∞ ∣ˡ (<$> ∈₂′))       refl with precs _ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ʳ (<$> .∈₁)) ⊛∞ ∣ˡ (<$> .∈₂))       refl | refl | refl = refl
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ˡ (<$> ∈₁′)) ⊛∞ ∣ʳ (<$> ∈₂′ ⊛ ∈₃′)) refl with postLeft⁺ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl | precs _ ∈₃ ∈₃′ refl
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ˡ (<$> .∈₁)) ⊛∞ ∣ʳ (<$> .∈₂ ⊛ .∈₃)) refl | refl | refl | refl = refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ʳ (<$> ∈₁′)) ⊛∞ ∣ʳ (<$> ∈₂′ ⊛ ∈₃′)) refl with precs _ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl | precs _ ∈₃ ∈₃′ refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ʳ (<$> .∈₁)) ⊛∞ ∣ʳ (<$> .∈₂ ⊛ .∈₃)) refl | refl | refl | refl = refl

    postLeft⁺ (<$> _            ⊛∞ ∣ˡ (<$> _))
              (<$> _            ⊛∞ ∣ʳ (<$> _ ⊛ _)) ()
    postLeft⁺ (<$> _            ⊛∞ ∣ʳ (<$> _ ⊛ _))
              (<$> _            ⊛∞ ∣ˡ (<$> _))     ()
    postLeft⁺ (<$> (∣ˡ (<$> _)) ⊛∞ ∣ˡ (<$> _))
              (<$> (∣ʳ (<$> _)) ⊛∞ ∣ˡ (<$> _))     ()
    postLeft⁺ (<$> (∣ʳ (<$> _)) ⊛∞ ∣ˡ (<$> _))
              (<$> (∣ˡ (<$> _)) ⊛∞ ∣ˡ (<$> _))     ()
    postLeft⁺ (<$> (∣ˡ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _))
              (<$> (∣ʳ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _)) ()
    postLeft⁺ (<$> (∣ʳ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _))
              (<$> (∣ˡ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _)) ()

    prec′ : ∀ {assoc s₁ s₂} {e₁ e₂ : ExprIn p assoc} →
            (∈₁ : (-, e₁) ∈⟦ Grammar.prec p ⟧· s₁)
            (∈₂ : (-, e₂) ∈⟦ Grammar.prec p ⟧· s₂) →
            e₁ ≡ e₂ → ∈₁ ≋ ∈₂
    prec′ (∥ˡ (<$> ∈₁)) (∥ˡ (<$>  ∈₂)) refl with inner _ ∈₁ ∈₂ refl
    prec′ (∥ˡ (<$> ∈₁)) (∥ˡ (<$> .∈₁)) refl | refl = refl

    prec′ (∥ʳ (∥ˡ (<$> ∈₁  ⊛ ∈₂  ⊛∞ ∈₃ )))
          (∥ʳ (∥ˡ (<$> ∈₁′ ⊛ ∈₂′ ⊛∞ ∈₃′))) refl
      with precs _ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl | precs _ ∈₃ ∈₃′ refl
    prec′ (∥ʳ (∥ˡ (<$>  ∈₁ ⊛  ∈₂ ⊛∞  ∈₃)))
          (∥ʳ (∥ˡ (<$> .∈₁ ⊛ .∈₂ ⊛∞ .∈₃))) refl | refl | refl | refl = refl

    prec′ (∥ʳ (∥ʳ (∥ˡ ∈₁))) (∥ʳ (∥ʳ (∥ˡ  ∈₂))) refl with preRight⁺ ∈₁ ∈₂ refl
    prec′ (∥ʳ (∥ʳ (∥ˡ ∈₁))) (∥ʳ (∥ʳ (∥ˡ .∈₁))) refl | refl = refl

    prec′ (∥ʳ (∥ʳ (∥ʳ (∥ˡ ∈₁)))) (∥ʳ (∥ʳ (∥ʳ (∥ˡ  ∈₂)))) refl with postLeft⁺ ∈₁ ∈₂ refl
    prec′ (∥ʳ (∥ʳ (∥ʳ (∥ˡ ∈₁)))) (∥ʳ (∥ʳ (∥ʳ (∥ˡ .∈₁)))) refl | refl = refl

    prec′ (∥ˡ (<$> _)) (∥ʳ (∥ˡ (<$> _ ⊛ _ ⊛∞ _))) ()
    prec′ (∥ʳ (∥ˡ (<$> _ ⊛ _ ⊛∞ _))) (∥ˡ (<$> _)) ()
    prec′ (∥ʳ (∥ʳ (∥ʳ (∥ʳ ())))) _ _
    prec′ _ (∥ʳ (∥ʳ (∥ʳ (∥ʳ ())))) _

  inner : ∀ {fix s₁ s₂} ops {e₁ e₂ : Inner {fix} ops}
          (∈₁ : e₁ ∈⟦ Grammar.inner ops ⟧· s₁)
          (∈₂ : e₂ ∈⟦ Grammar.inner ops ⟧· s₂) →
          e₁ ≡ e₂ → ∈₁ ≋ ∈₂
  inner [] () () _
  inner ((_ , op) ∷ ops) (∣ˡ (<$>  ∈₁))
                         (∣ˡ (<$>  ∈₂)) refl with inner′ _ _ ∈₁ ∈₂
  inner ((_ , op) ∷ ops) (∣ˡ (<$>  ∈₁))
                         (∣ˡ (<$> .∈₁)) refl | refl = refl
  inner ((_ , op) ∷ ops) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                         (∣ʳ (<$>_ {x = (._ ∙ ._)}  ∈₂)) refl with inner ops ∈₁ ∈₂ refl
  inner ((_ , op) ∷ ops) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                         (∣ʳ (<$>_ {x = (._ ∙ ._)} .∈₁)) refl | refl = refl
  inner ((_ , op) ∷ ops) (∣ˡ (<$> ∈₁)) (∣ʳ (<$>_ {x = (_ ∙ _)} ∈₂)) ()
  inner ((_ , op) ∷ ops) (∣ʳ (<$>_ {x = (_ ∙ _)} ∈₁)) (∣ˡ (<$> ∈₂)) ()

  inner′ : ∀ {arity s₁ s₂}
           (ns : Vec NamePart (1 + arity))
           (args : Vec (Expr anyPrecedence) arity)
           (∈₁ : args ∈⟦ Grammar.expr between ns ⟧· s₁)
           (∈₂ : args ∈⟦ Grammar.expr between ns ⟧· s₂) →
           ∈₁ ≋ ∈₂
  inner′ (n ∷ [])      []           between-[] between-[] = refl
  inner′ (n ∷ n′ ∷ ns) (arg ∷ args)
         (between-∷ ∈₁ ∈⋯₁) (between-∷ ∈₂ ∈⋯₂)
    with precs _ ∈₁ ∈₂ refl | inner′ (n′ ∷ ns) args ∈⋯₁ ∈⋯₂
  inner′ (n ∷ n′ ∷ ns) (arg ∷ args)
         (between-∷ ∈₁ ∈⋯₁) (between-∷ .∈₁ .∈⋯₁) | refl | refl = refl

-- There is at most one string representing a given expression.

unique : ∀ {e s₁ s₂} →
         e ∈ Grammar.expression · s₁ →
         e ∈ Grammar.expression · s₂ →
         s₁ ≡ s₂
unique ∈₁ ∈₂ with ∈₁′ | ∈₂′ | Unique.precs _ ∈₁′ ∈₂′ refl
  where
  ∈₁′ = Lib.Semantics.complete (♭ Grammar.expr) ∈₁
  ∈₂′ = Lib.Semantics.complete (♭ Grammar.expr) ∈₂
... | ∈ | .∈ | Unique.refl = refl


module Issue249 where

postulate
  A B : Set

module A where
  X = A
  Y = B

open A renaming (X to C; Y to C)

-- open A using (X) renaming (Y to X)


------------------------------------------------------------------------
-- Inversion of canonical subtyping in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Canonical.Inversion where

open import Data.Product using (_,_; _×_; proj₁; proj₂)
open import Data.Vec using ([]; _∷_; foldl)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂)
open import Relation.Nullary using (¬_)

open import FOmegaInt.Syntax
open import FOmegaInt.Kinding.Canonical
open import FOmegaInt.Kinding.Canonical.Validity

open Syntax
open ElimCtx
open Kinding
open ContextNarrowing

------------------------------------------------------------------------
-- Inversion of canonical subtyping (in the empty context).

-- NOTE.  The lemmas in this module only hold in the empty context
-- because we can not invert instances of the interval projection
-- rules (<:-⟨| and (<:-|⟩) in arbitrary contexts.  This is because
-- instances of these rules can reflect arbitrary subtyping
-- assumptions into the subtyping relation.  Consider, e.g.
--
--     Γ, X :: ⊤..⊥ ctx    Γ(X) = ⊥..⊤
--     ------------------------------- (∈-var)
--     Γ, X :: ⊤..⊥ ⊢ X :: ⊤..⊥
--     -------------------------- (<:-⟨|, <:-|⟩)
--     Γ, X :: ⊤..⊥ ⊢ ⊤ <: X <: ⊥
--
-- Which allows us to prove that ⊤ <: ⊥ using (<:-trans) under the
-- assumption (X : ⊤..⊥).  On the other hand, it is impossible to give
-- a transitivity-free proof of ⊤ <: ⊥.  In general, it is therefore
-- impossible to invert subtyping statements in non-empty contexts,
-- i.e. one cannot prove lemmas like (<:-→-inv) or (<:-∀-inv) below
-- for arbitrary contexts.

infix 4 ⊢_<!_

-- Top-level transitivity-free canonical subtyping in the empty
-- context.
data ⊢_<!_ : Elim 0 → Elim 0 → Set where
  <!-⊥ : ∀ {a} → [] ⊢Nf a ⇉ a ⋯ a → ⊢ ⊥∙ <! a
  <!-⊤ : ∀ {a} → [] ⊢Nf a ⇉ a ⋯ a → ⊢ a  <! ⊤∙
  <!-∀ : ∀ {k₁ k₂ a₁ a₂} → [] ⊢ k₂ <∷ k₁ → kd k₂ ∷ [] ⊢ a₁ <: a₂ →
         [] ⊢Nf ∀∙ k₁ a₁ ⇉ ∀∙ k₁ a₁ ⋯ ∀∙ k₁ a₁ → ⊢ ∀∙ k₁ a₁ <! ∀∙ k₂ a₂
  <!-→ : ∀ {a₁ a₂ b₁ b₂} → [] ⊢ a₂ <: a₁ → [] ⊢ b₁ <: b₂ →
         ⊢ a₁ ⇒∙ b₁ <! a₂ ⇒∙ b₂

-- Soundness of <! with respect to <: in the empty context.
sound-<! : ∀ {a b : Elim 0} → ⊢ a <! b → [] ⊢ a <: b
sound-<! (<!-⊥ a⇉a⋯a)         = <:-⊥ a⇉a⋯a
sound-<! (<!-⊤ a⇉a⋯a)         = <:-⊤ a⇉a⋯a
sound-<! (<!-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) =
  <:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁
sound-<! (<!-→ a₂<:a₁ b₁<:b₂) = <:-→ a₂<:a₁ b₁<:b₂

-- The only proper (top-level) subtype of ⊥ is ⊥ itself.
⊥-<!-min : ∀ {a : Elim 0} → ⊢ a <! ⊥∙ → a ≡ ⊥∙
⊥-<!-min (<!-⊥ _) = refl

-- The only proper (top-level) supertype of ⊤ is ⊤ itself.
⊤-<!-max : ∀ {a : Elim 0} → ⊢ ⊤∙ <! a → a ≡ ⊤∙
⊤-<!-max (<!-⊤ _) = refl

-- Arrows are not (top-level) subtypes of universals and vice-versa.

⇒-≮!-Π : ∀ {a : Elim 0} {k b₁ b₂} → ¬ ⊢ a ⇒∙ b₁ <! ∀∙ k b₂
⇒-≮!-Π ()

Π-≮!-⇒ : ∀ {a : Elim 0} {k b₁ b₂} → ¬ ⊢ ∀∙ k b₁ <! a ⇒∙ b₂
Π-≮!-⇒ ()

-- Validity of <!
<!-valid : ∀ {a b} → ⊢ a <! b → [] ⊢Nf a ⇉ a ⋯ a × [] ⊢Nf b ⇉ b ⋯ b
<!-valid a<!b = <:-valid (sound-<! a<!b)

-- Top-level transitivity of canonical subtyping is admissible.
<!-trans : ∀ {a b c} → [] ⊢ a <: b → ⊢ b <! c → ⊢ a <! c
<!-trans (<:-trans a<:b b<:c) c<!d = <!-trans a<:b (<!-trans b<:c c<!d)
<!-trans (<:-⊥ a⇉a⋯a) a<!d     = <!-⊥ (proj₂ (<!-valid a<!d))
<!-trans (<:-⊤ a⇉a⋯a) (<!-⊤ _) = <!-⊤ a⇉a⋯a
<!-trans (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) (<!-⊤ _) =
  <!-⊤ (proj₁ (<:-valid (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁)))
<!-trans (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) (<!-∀ k₃<∷k₂ a₂<:a₃ _) =
  <!-∀ (<∷-trans k₃<∷k₂ k₂<∷k₁)
       (<:-trans (⇓-<: k₃-kd k₃<∷k₂ a₁<:a₂) a₂<:a₃) Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁
  where k₃-kd = wf-kd-inv (wf-∷₁ (<:-ctx a₂<:a₃))
<!-trans (<:-→ a₂<:a₁ b₁<:b₂) (<!-⊤ a₂⇒b₂⇉a₂⇒b₂⋯a₂⇒b₂) =
  <!-⊤ (proj₁ (<:-valid (<:-→ a₂<:a₁ b₁<:b₂)))
<!-trans (<:-→ a₂<:a₁ b₁<:b₂) (<!-→ a₃<:a₂ b₂<:b₃) =
  <!-→ (<:-trans a₃<:a₂ a₂<:a₁) (<:-trans b₁<:b₂ b₂<:b₃)
<!-trans (<:-∙ {()} _ _)        b<!c
<!-trans (<:-⟨| (∈-∙ {()} _ _)) b<!c
<!-trans (<:-|⟩ (∈-∙ {()} _ _)) b<!c

-- Completeness of <! with respect to <: in the empty context.
complete-<! : ∀ {a b : Elim 0} → [] ⊢ a <: b → ⊢ a <! b
complete-<! (<:-trans a<:b b<:c) = <!-trans a<:b (complete-<! b<:c)
complete-<! (<:-⊥ a⇉a⋯a)         = <!-⊥ a⇉a⋯a
complete-<! (<:-⊤ a⇉a⋯a)         = <!-⊤ a⇉a⋯a
complete-<! (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) =
  <!-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁
complete-<! (<:-→ a₂<:a₁ b₁<:b₂) = <!-→ a₂<:a₁ b₁<:b₂
complete-<! (<:-∙ {()} _ _)
complete-<! (<:-⟨| (∈-∙ {()} _ _))
complete-<! (<:-|⟩ (∈-∙ {()} _ _))

-- The only proper (top-level) subtype of ⊥ is ⊥ itself.
⊥-<:-min : ∀ {a : Elim 0} → [] ⊢ a <: ⊥∙ → a ≡ ⊥∙
⊥-<:-min a<:⊥ = ⊥-<!-min (complete-<! a<:⊥)

-- The only proper (top-level) supertype of ⊤ is ⊤ itself.
⊤-<:-max : ∀ {a : Elim 0} → [] ⊢ ⊤∙ <: a → a ≡ ⊤∙
⊤-<:-max ⊤<:a = ⊤-<!-max (complete-<! ⊤<:a)

-- Inversion of canonical subtyping for universals and arrow types.

<:-∀-inv : ∀ {k₁ k₂ : Kind Elim 0} {a₁ a₂} → [] ⊢ ∀∙ k₁ a₁ <: ∀∙ k₂ a₂ →
           [] ⊢ k₂ <∷ k₁ × kd k₂ ∷ [] ⊢ a₁ <: a₂
<:-∀-inv Πk₁a₁<:Πk₂a₂ with complete-<! Πk₁a₁<:Πk₂a₂
<:-∀-inv Πk₁a₁<:Πk₂a₂ | <!-∀ k₂<∷k₁ a₁<:a₂ _ = k₂<∷k₁ , a₁<:a₂

<:-→-inv : ∀ {a₁ a₂ : Elim 0} {b₁ b₂} → [] ⊢ a₁ ⇒∙ b₁ <: a₂ ⇒∙ b₂ →
           [] ⊢ a₂ <: a₁ × [] ⊢ b₁ <: b₂
<:-→-inv a₁⇒b₁<:a₂⇒b₂ with complete-<! a₁⇒b₁<:a₂⇒b₂
<:-→-inv a₁⇒b₁<:a₂⇒b₂ | <!-→ a₂<∷a₁ b₁<:b₂ = a₂<∷a₁ , b₁<:b₂

-- Arrows are not canonical subtypes of universals and vice-versa.

⇒-≮:-Π : ∀ {a : Elim 0} {k b₁ b₂} → ¬ [] ⊢ a ⇒∙ b₁ <: ∀∙ k b₂
⇒-≮:-Π = ⇒-≮!-Π ∘ complete-<!

Π-≮:-⇒ : ∀ {a : Elim 0} {k b₁ b₂} → ¬ [] ⊢ ∀∙ k b₁ <: a ⇒∙ b₂
Π-≮:-⇒ = Π-≮!-⇒ ∘ complete-<!


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

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.Types
import      LibraBFT.Impl.Types.EpochState      as EpochState
import      LibraBFT.Impl.Types.Waypoint        as Waypoint
open import LibraBFT.ImplShared.Consensus.Types
open import Util.Encode
open import Util.PKCS                           hiding (verify)
open import Util.Prelude

module LibraBFT.Impl.Types.Verifier where

record Verifier (A : Set) : Set where
  field
    verify                          : A → LedgerInfoWithSignatures → Either ErrLog Unit
    epochChangeVerificationRequired : A → Epoch                    → Bool
    isLedgerInfoStale               : A → LedgerInfo               → Bool
    ⦃ encodeA ⦄                     : Encoder A

open Verifier ⦃ ... ⦄ public

instance
  VerifierEpochState : Verifier EpochState
  VerifierEpochState = record
    { verify                          = EpochState.verify
    ; epochChangeVerificationRequired = EpochState.epochChangeVerificationRequired
    ; isLedgerInfoStale               = EpochState.isLedgerInfoStale
    }

instance
  VerifierWaypoint   : Verifier Waypoint
  VerifierWaypoint   = record
    { verify                          = Waypoint.verifierVerify
    ; epochChangeVerificationRequired = Waypoint.epochChangeVerificationRequired
    ; isLedgerInfoStale               = Waypoint.isLedgerInfoStale
    }


-- Lifting of substitutions, and instance of strength for δ
module SOAS.Coalgebraic.Lift {T : Set} where

open import SOAS.Common
open import SOAS.Context {T}
open import SOAS.Variable
open import SOAS.Families.Core {T}
import SOAS.Families.Delta {T} as δ; open δ.Sorted
open import SOAS.Abstract.Hom {T}
import SOAS.Abstract.Box {T} as □ ; open □.Sorted
import SOAS.Abstract.Coalgebra {T} as →□ ; open →□.Sorted

open import SOAS.Coalgebraic.Map
open import SOAS.Coalgebraic.Strength

private
  variable
    Γ Δ Θ : Ctx
    α : T

module _ {𝒫 : Familyₛ} (𝒫ᴮ : Coalgₚ 𝒫) where
  open Coalgₚ 𝒫ᴮ

  -- General lifting over an arbitrary context
  lift : (Ξ : Ctx) → Γ ~[ 𝒫 ]↝ Δ → (Ξ ∔ Γ) ~[ 𝒫 ]↝ (Ξ ∔ Δ)
  lift ∅ σ v             = σ v
  lift (τ ∙ Ξ) σ new     = η new
  lift (τ ∙ Ξ) σ (old v) = r (lift Ξ σ v) old

  -- Single-variable lifting
  lift₁ : {τ : T} → Γ ~[ 𝒫 ]↝ Δ → (τ ∙ Γ) ~[ 𝒫 ]↝ (τ ∙ Δ)
  lift₁ {τ = τ} = lift ⌈ τ ⌋

-- General lifting of renaming
rlift : (Ξ : Ctx) → Γ ↝ Δ → (Ξ ∔ Γ) ↝ (Ξ ∔ Δ)
rlift Ξ = lift ℐᴮ Ξ

-- Strength for context extension
δ:Strength : (Ξ : Ctx) → Strength (δF Ξ)
δ:Strength Ξ = record
  { str = λ 𝒫ᴮ 𝒳 h σ → h (lift 𝒫ᴮ Ξ σ)
  ; str-nat₁ = λ fᴮ⇒ h σ → cong h (dext (str-nat₁ Ξ fᴮ⇒ σ))
  ; str-nat₂ = λ f h σ → refl
  ; str-unit = λ 𝒳 h → cong h (dext (str-unit Ξ 𝒳))
  ; str-assoc = λ 𝒳 fᶜ h σ ς → cong h (dext (str-assoc Ξ 𝒳 fᶜ σ ς))
  }
  where
  open ≡-Reasoning
  open Coalgₚ
  open Coalgₚ⇒

  str-nat₁ : (Ξ : Ctx){𝒫 𝒬 : Familyₛ} {𝒫ᴮ : Coalgₚ 𝒫}
             {𝒬ᴮ : Coalgₚ 𝒬} {f : 𝒬 ⇾̣ 𝒫}
           → Coalgₚ⇒ 𝒬ᴮ 𝒫ᴮ f
           → (σ : Γ ~[ 𝒬 ]↝ Δ)(v : ℐ α (Ξ ∔ Γ))
    → lift 𝒫ᴮ Ξ (f ∘ σ) v
    ≡ f (lift 𝒬ᴮ Ξ σ v)
  str-nat₁ ∅ fᴮ⇒ σ v = refl
  str-nat₁ (α ∙ Ξ) {𝒫ᴮ = 𝒫ᴮ} fᴮ⇒ σ new = sym (Coalgₚ⇒.⟨η⟩ fᴮ⇒)
  str-nat₁ (α ∙ Ξ) {𝒫ᴮ = 𝒫ᴮ} {𝒬ᴮ}{f}fᴮ⇒ σ (old v) = begin
       lift 𝒫ᴮ (α ∙ Ξ) (f ∘ σ) (old v)
     ≡⟨ congr (str-nat₁ Ξ fᴮ⇒ σ v) (λ - → r 𝒫ᴮ - old) ⟩
       r 𝒫ᴮ (f (lift 𝒬ᴮ Ξ σ v)) old
     ≡˘⟨ ⟨r⟩ fᴮ⇒ ⟩
       f (lift 𝒬ᴮ (α ∙ Ξ) σ (old v))
     ∎

  str-unit : (Ξ : Ctx) (𝒳 : Familyₛ) (v : ℐ α (Ξ ∔ Γ))
    → lift ℐᴮ Ξ id v ≡ v
  str-unit ∅ 𝒳 v = refl
  str-unit (α ∙ Ξ) 𝒳 new = refl
  str-unit (α ∙ Ξ) 𝒳 (old v) = cong old (str-unit Ξ 𝒳 v)

  str-assoc : (Ξ : Ctx) (𝒳 : Familyₛ) {𝒫 𝒬 ℛ : Familyₛ}
              {𝒫ᴮ : Coalgₚ 𝒫} {𝒬ᴮ : Coalgₚ 𝒬} {ℛᴮ : Coalgₚ ℛ}
              {f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
              (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f) (open Coalgebraic fᶜ)
              (σ : Γ ~[ 𝒫 ]↝ Δ) (ς : Δ ~[ 𝒬 ]↝ Θ)(v : ℐ α (Ξ ∔ Γ))
    → lift ℛᴮ Ξ (λ u → f (σ u) ς) v
    ≡ lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v (lift 𝒬ᴮ Ξ ς)
  str-assoc ∅ 𝒳 fᶜ σ ς v = refl
  str-assoc (β ∙ Ξ) 𝒳 {𝒫ᴮ = 𝒫ᴮ}{𝒬ᴮ}{ℛᴮ} {f} fᶜ σ ς new = begin
       η ℛᴮ new                          ≡˘⟨ f∘η ⟩
       f (η 𝒫ᴮ new) (η 𝒬ᴮ)               ≡⟨ eq-at-new refl ⟩
       f (η 𝒫ᴮ new) (lift 𝒬ᴮ (β ∙ Ξ) ς)  ∎
     where open Coalgebraic fᶜ

  str-assoc {Γ = Γ} (β ∙ Ξ)  𝒳 {𝒫 = 𝒫}{𝒬}{𝒫ᴮ = 𝒫ᴮ}{𝒬ᴮ}{ℛᴮ}{f} fᶜ σ ς (old v) =
     begin
         r ℛᴮ   (lift ℛᴮ Ξ (λ u → f (σ u) ς) v)   old
     ≡⟨ congr (str-assoc Ξ 𝒳 fᶜ σ ς v) (λ - → r ℛᴮ - old) ⟩
         r ℛᴮ (  lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v   (lift 𝒬ᴮ Ξ ς)) old
     ≡⟨ congr (str-nat₁ Ξ fᴮ⇒ (σ) v) (λ - → r ℛᴮ (- (lift 𝒬ᴮ Ξ ς)) old) ⟩
         r ℛᴮ (f (lift 𝒫ᴮ Ξ σ v) (lift 𝒬ᴮ Ξ ς)) old
     ≡⟨ r∘f ⟩
         f (lift 𝒫ᴮ Ξ σ v)   (λ u → r 𝒬ᴮ (lift 𝒬ᴮ Ξ ς u) old)
     ≡˘⟨ congr (str-nat₁ Ξ fᴮ⇒ σ v) (λ - → - (λ u → r 𝒬ᴮ (lift 𝒬ᴮ Ξ ς u) old)) ⟩
         lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v (λ u → r 𝒬ᴮ (lift 𝒬ᴮ Ξ ς u) old)
     ∎
     where open Coalgebraic fᶜ renaming (ᴮ⇒ to fᴮ⇒)

module δ:Str Θ = Strength (δ:Strength Θ)

-- Derived lifting properties
rlift-id : (𝒳 : Familyₛ)(Ξ : Ctx)(b : δ Ξ (□ 𝒳) α Γ)
         → b (rlift Ξ id) ≡ b id
rlift-id 𝒳 Ξ = Strength.str-unit (δ:Strength Ξ) 𝒳

lift-comp : {𝒫 𝒬 : Familyₛ}{𝒫ᴮ : Coalgₚ 𝒫}{𝒬ᴮ : Coalgₚ 𝒬}
            (𝒳 : Familyₛ)(Ξ : Ctx){f : 𝒬 ⇾̣ 𝒫}
            (fᴮ⇒ : Coalgₚ⇒ 𝒬ᴮ 𝒫ᴮ f)
            (h : δ Ξ 〖 𝒫 , 𝒳 〗 α Γ) (σ : Γ ~[ 𝒬 ]↝ Δ)
  → h (lift 𝒫ᴮ Ξ (f ∘ σ))
  ≡ h (f ∘ lift 𝒬ᴮ Ξ σ)
lift-comp 𝒳 Ξ fᴮ⇒ h σ = Strength.str-nat₁ (δ:Strength Ξ) {𝒳 = 𝒳} fᴮ⇒ h σ

lift-assoc : {𝒫 𝒬 ℛ : Familyₛ}
            {𝒫ᴮ : Coalgₚ 𝒫} {𝒬ᴮ : Coalgₚ 𝒬} {ℛᴮ : Coalgₚ ℛ}
            (𝒳 : Familyₛ)(Ξ : Ctx) {f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
            (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f)
            (open Coalgebraic fᶜ)
            (h : δ Ξ 〖 ℛ , 𝒳 〗 α Γ)
            (σ : Γ ~[ 𝒫 ]↝ Δ) (ς : Δ ~[ 𝒬 ]↝ Θ)
  → h (lift ℛᴮ Ξ (λ v → f (σ v) ς))
  ≡ h (λ v → lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v (lift 𝒬ᴮ Ξ ς))
lift-assoc 𝒳 Ξ fᶜ h σ ς = Strength.str-assoc (δ:Strength Ξ) 𝒳 fᶜ h σ ς

lift-dist : {𝒫 𝒬 ℛ : Familyₛ}{𝒫ᴮ : Coalgₚ 𝒫}{𝒬ᴮ : Coalgₚ 𝒬}{ℛᴮ : Coalgₚ ℛ}
            (𝒳 : Familyₛ){Ξ : Ctx}{f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
            (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f)
            (h : δ Ξ 〖 ℛ , 𝒳 〗 α Γ)
            (σ : Γ ~[ 𝒫 ]↝ Δ) (ς : Δ ~[ 𝒬 ]↝ Θ)
  → h (lift ℛᴮ Ξ (λ v → f (σ v) ς))
  ≡ h (λ v → f (lift 𝒫ᴮ Ξ σ v) (lift 𝒬ᴮ Ξ ς))
lift-dist 𝒳 {Ξ} = Strength.str-dist (δ:Strength Ξ) 𝒳


module par-swap.union-properties where

open import par-swap
open import par-swap.union-confluent
open import par-swap.confluent
open import sn-calculus
open import sn-calculus-props
open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Context
open import Esterel.Context.Properties
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; sig ; []env ; VarList ;
         module SigMap ; module ShrMap ; module VarMap)
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Data.Product
open import Data.Empty
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; cong ; sym)

open import binding-preserve

∥R∪sn≡ₑ-preserve-cb : ∀ {p BVp FVp q} ->
  CorrectBinding p BVp FVp ->
  p ∥R∪sn≡ₑ q ->
  Σ (VarList × VarList) λ { (BVq , FVq) -> CorrectBinding q BVq FVq }
∥R∪sn≡ₑ-preserve-cb CBp (∪stpsn psn⟶q)
  with sn⟶-maintains-binding CBp psn⟶q
... | _ , CBq , _ = _ , CBq
∥R∪sn≡ₑ-preserve-cb CBp (∪stp∥ p∥Rq)
  with ∥R-maintains-binding CBp p∥Rq
... | CBq = _ , CBq
∥R∪sn≡ₑ-preserve-cb CBp (∪sym p∪≡ₑq CBq) = _ , CBq
∥R∪sn≡ₑ-preserve-cb CBp ∪ref = _ , CBp
∥R∪sn≡ₑ-preserve-cb CBp (∪trn p∪≡ₑr r∪≡ₑq)
  with ∥R∪sn≡ₑ-preserve-cb CBp p∪≡ₑr
... | _ , CBr = ∥R∪sn≡ₑ-preserve-cb CBr r∪≡ₑq

∥R∪sn≡ₑ-consistent : ∀{p q BV FV} →
  CorrectBinding p BV FV →
  p ∥R∪sn≡ₑ q →
  Σ[ r ∈ Term ] (p ∥R*∪sn⟶* r) × (q ∥R*∪sn⟶* r)
∥R∪sn≡ₑ-consistent CBp (∪stpsn psn⟶q)
  = _ ,  ∪sn⟶* (rstep psn⟶q rrefl) ∪refl  , ∪refl
∥R∪sn≡ₑ-consistent CBp (∪stp∥ ps∥Rq)
  = _ , ∪∥R* (∥Rn ps∥Rq ∥R0) ∪refl , ∪refl
∥R∪sn≡ₑ-consistent CBp (∪sym psn∪∥R≡ₑq CBq)
  with ∥R∪sn≡ₑ-consistent CBq psn∪∥R≡ₑq
... | _ , a , b
  = _ , b , a
∥R∪sn≡ₑ-consistent CBp ∪ref = _ , ∪refl , ∪refl
∥R∪sn≡ₑ-consistent{p}{q} CBp (∪trn{.p}{r}{.q} p≡r r≡q)
  with ∥R∪sn≡ₑ-preserve-cb CBp p≡r
... | ((BVr , FVr) , CBr)
  with ∥R∪sn≡ₑ-preserve-cb CBr r≡q
... | ((BVq , FVq) , CBq)
  with ∥R∪sn≡ₑ-consistent CBp p≡r
... | (y , p⟶y , r⟶y)
  with ∥R∪sn≡ₑ-consistent CBr r≡q
... | (z , r⟶z , q⟶z)
  with ∥R*∪sn⟶*-confluent CBr r⟶y r⟶z
... | (x , y⟶x , z⟶x)
  = x , ∥R*∪sn⟶*-concat p⟶y y⟶x , ∥R*∪sn⟶*-concat q⟶z z⟶x

inescapability-of-complete-∥R : ∀ {p q} ->
  complete p ->
  p ∥R q ->
  complete q
inescapability-of-complete-∥R
 = \ { completep (∥Rstep dc) -> thm completep dc } where

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

  thm-d : ∀ {p C p₁ p₂} ->
    done p ->
    p ≐ C ⟦ p₁ ∥ p₂ ⟧c ->
    done (C ⟦ p₂ ∥ p₁ ⟧c)
  thm-d (dhalted hnothin) ()
  thm-d (dhalted (hexit n)) ()
  thm-d (dpaused p/paused) pC
    = dpaused (thm-p p/paused pC)

  thm : ∀ {p C p₁ p₂} ->
    complete p ->
    p ≐ C ⟦ p₁ ∥ p₂ ⟧c ->
    complete (C ⟦ p₂ ∥ p₁ ⟧c)
  thm (codone x) pC = codone (thm-d x pC)
  thm (coenv x x₁) (dcenv pC) = coenv x (thm-d x₁ pC)

inescapability-of-complete-∥R* : ∀ {p q} ->
  complete p ->
  p ∥R* q ->
  complete q
inescapability-of-complete-∥R* = thm where
  thm : ∀ {p q} ->
    complete p ->
    p ∥R* q ->
    complete q
  thm completep ∥R0 = completep
  thm completep (∥Rn p∥Rr r⟶q)
    = thm (inescapability-of-complete-∥R completep p∥Rr) r⟶q

inescapability-of-complete-∪ : ∀ {p q} ->
  complete p ->
  p ∥R*∪sn⟶* q ->
  complete q
inescapability-of-complete-∪ = thm where
  thm : ∀ {p q} ->
   complete p ->
   p ∥R*∪sn⟶* q ->
   complete q
  thm completep (∪∥R* p∥R*r r⟶q)
   = thm (inescapability-of-complete-∥R* completep p∥R*r) r⟶q
  thm completep (∪sn⟶* psn⟶*r r⟶q)
   = thm (inescapability-of-complete-sn completep psn⟶*r) r⟶q
  thm completep ∪refl = completep

ρ-stays-ρ-∪ : ∀{θ p q A} →
  (ρ⟨ θ , A ⟩· p) ∥R*∪sn⟶* q →
  Σ[ θ' ∈ Env.Env ] Σ[ A' ∈ Ctrl ] Σ[ qin ∈ Term ] q ≡ (ρ⟨ θ' , A' ⟩· qin)
ρ-stays-ρ-∪ = thm where

  thm∥R : ∀{θ p q A} →
   (ρ⟨ θ , A ⟩· p) ∥R q →
   Σ[ θ' ∈ Env.Env ] Σ[ A ∈ Ctrl ] Σ[ qin ∈ Term ] q ≡ (ρ⟨ θ' , A ⟩· qin)
  thm∥R (∥Rstep (dcenv d≐C⟦p∥q⟧c))
   rewrite sym (unplugc d≐C⟦p∥q⟧c)
   = _ , _ , _ , refl

  thm∥R* : ∀{θ p q A} →
   (ρ⟨ θ , A ⟩· p) ∥R* q →
   Σ[ θ' ∈ Env.Env ] Σ[ A' ∈ Ctrl ] Σ[ qin ∈ Term ] q ≡ (ρ⟨ θ' , A' ⟩· qin)
  thm∥R* ∥R0 = _ , _ , _ , refl
  thm∥R* (∥Rn p∥Rq p⟶q)
    with thm∥R p∥Rq
  ... | (θ' , qin , A' , refl) = thm∥R* p⟶q

  thm : ∀{θ p q A} →
   (ρ⟨ θ , A ⟩· p) ∥R*∪sn⟶* q →
   Σ[ θ' ∈ Env.Env ] Σ[ A' ∈ Ctrl ] Σ[ qin ∈ Term ] q ≡ (ρ⟨ θ' , A' ⟩· qin)
  thm (∪∥R* p∥R*q p⟶q)
    with thm∥R* p∥R*q
  ... | (θ' , qin , A' , refl) = thm p⟶q
  thm (∪sn⟶* psn⟶*q p⟶q)
    with ρ-stays-ρ-sn⟶* psn⟶*q
  ... | (θ' , qin , A' , refl) = thm p⟶q
  thm ∪refl = _ , _ , _ , refl

irreducibility-of-halted-∥R : ∀ {p q} ->
  halted p ->
  p ∥R q ->
  ⊥
irreducibility-of-halted-∥R hnothin (∥Rstep ())
irreducibility-of-halted-∥R (hexit n) (∥Rstep ())

inescapability-of-paused-∥R : ∀ {p q} ->
  paused p ->
  p ∥R q ->
  paused q
inescapability-of-paused-∥R ppause (∥Rstep ())
inescapability-of-paused-∥R (pseq pausedp) (∥Rstep (dcseq₁ dc))
 = pseq (inescapability-of-paused-∥R pausedp (∥Rstep dc))
inescapability-of-paused-∥R (pseq pausedp) (∥Rstep (dcseq₂ dc))
 = pseq pausedp
inescapability-of-paused-∥R (ploopˢ pausedp) (∥Rstep (dcloopˢ₁ dc))
  = ploopˢ (inescapability-of-paused-∥R pausedp (∥Rstep dc))
inescapability-of-paused-∥R (ploopˢ pausedp) (∥Rstep (dcloopˢ₂ dc))
  = ploopˢ pausedp
inescapability-of-paused-∥R (ppar pausedp pausedq) (∥Rstep dchole)
  = ppar pausedq pausedp
inescapability-of-paused-∥R (ppar pausedp pausedq) (∥Rstep (dcpar₁ dc))
  = ppar (inescapability-of-paused-∥R pausedp (∥Rstep dc)) pausedq
inescapability-of-paused-∥R (ppar pausedp pausedq) (∥Rstep (dcpar₂ dc))
  = ppar pausedp (inescapability-of-paused-∥R pausedq (∥Rstep dc))
inescapability-of-paused-∥R (psuspend pausedp) (∥Rstep (dcsuspend dc))
  = psuspend (inescapability-of-paused-∥R pausedp (∥Rstep dc))
inescapability-of-paused-∥R (ptrap pausedp) (∥Rstep (dctrap dc))
  = ptrap (inescapability-of-paused-∥R pausedp (∥Rstep dc))

inescapability-of-paused-∥R* : ∀ {p q} ->
  paused p ->
  p ∥R* q ->
  paused q
inescapability-of-paused-∥R* pausedp ∥R0 = pausedp
inescapability-of-paused-∥R* pausedp (∥Rn p∥Rq p⟶q)
 = inescapability-of-paused-∥R* (inescapability-of-paused-∥R pausedp p∥Rq) p⟶q

equality-of-complete-∪ : ∀{θ θ' p q A A'} →
  complete (ρ⟨ θ , A ⟩·  p) →
  (ρ⟨ θ , A ⟩· p) ∥R*∪sn⟶* (ρ⟨ θ' , A' ⟩· q) →
  θ ≡ θ' × A ≡ A'
equality-of-complete-∪ = thm where

 done-not-to-ρ-∪ : ∀ {p θ q A} ->
    done p ->
    p ∥R*∪sn⟶* (ρ⟨ θ , A ⟩· q) ->
    ⊥
 done-not-to-ρ-∪ (dhalted p/halted) (∪∥R* ∥R0 p⟶q)
   = done-not-to-ρ-∪ (dhalted p/halted) p⟶q
 done-not-to-ρ-∪ (dhalted p/halted) (∪∥R* (∥Rn p∥Rq p∥R*q) p⟶q)
   = irreducibility-of-halted-∥R p/halted p∥Rq
 done-not-to-ρ-∪ (dpaused p/paused) (∪∥R* p∥R*q p⟶q)
   = done-not-to-ρ-∪ (dpaused (inescapability-of-paused-∥R* p/paused p∥R*q)) p⟶q
 done-not-to-ρ-∪ (dhalted p/halted) (∪sn⟶* rrefl r⟶q)
  = done-not-to-ρ-∪ (dhalted p/halted) r⟶q
 done-not-to-ρ-∪ (dhalted p/halted) (∪sn⟶* (rstep psn⟶q p⟶r) r⟶q)
  = irreducibility-of-halted-sn⟶ p/halted psn⟶q
 done-not-to-ρ-∪ (dpaused p/paused) (∪sn⟶* p⟶r r⟶q)
  = done-not-to-ρ-∪ (dpaused (inescapability-of-paused-sn⟶* p/paused p⟶r)) r⟶q
 done-not-to-ρ-∪ (dhalted ()) ∪refl
 done-not-to-ρ-∪ (dpaused ()) ∪refl

 ∥R*-lemma : ∀ {θ p q A} ->
   done p ->
   (ρ⟨ θ , A ⟩·  p) ∥R* q ->
   Σ[ q' ∈ Term ] q ≡ (ρ⟨ θ , A ⟩·  q') × done q'
 ∥R*-lemma done₁ ∥R0 = _ , refl , done₁
 ∥R*-lemma (dhalted hnothin) (∥Rn (∥Rstep (dcenv ())) p⟶q)
 ∥R*-lemma (dhalted (hexit n)) (∥Rn (∥Rstep (dcenv ())) p⟶q)
 ∥R*-lemma (dpaused p/paused) (∥Rn (∥Rstep (dcenv d≐C⟦p∥q⟧c)) p⟶q)
   with inescapability-of-paused-∥R p/paused (∥Rstep d≐C⟦p∥q⟧c)
 ... | q/paused = ∥R*-lemma (dpaused q/paused) p⟶q

 thm : ∀{θ θ' p q A A'} →
  complete (ρ⟨ θ , A ⟩·  p) →
  (ρ⟨ θ , A ⟩· p) ∥R*∪sn⟶* (ρ⟨ θ' , A' ⟩· q) →
  θ ≡ θ' × A ≡ A'
 thm (codone x) p⟶q =  ⊥-elim (done-not-to-ρ-∪ x p⟶q)
 thm (coenv complete-θθ donep) (∪∥R* p∥R*q p⟶q)
   with ∥R*-lemma donep p∥R*q
 ... | _ , refl , doneq' = thm (coenv complete-θθ doneq') p⟶q
 thm (coenv complete-θθ donep) (∪sn⟶* psn⟶*r r⟶q)
   with inescapability-of-complete-sn (coenv complete-θθ donep) psn⟶*r
 thm (coenv complete-θθ donep) (∪sn⟶* psn⟶*r r⟶q) | codone x
   = ⊥-elim (done-not-to-ρ-∪ x r⟶q)
 thm (coenv complete-θθ donep) (∪sn⟶* psn⟶*r r⟶q) | coenv x x₁
   with equality-of-complete-sn⟶* (coenv complete-θθ donep) psn⟶*r
 ... | refl , refl = thm (coenv x x₁) r⟶q
 thm (coenv complete-θθ donep) ∪refl = refl , refl


{-# OPTIONS --safe #-}

module Definition.Typed.Consequences.Injectivity where

open import Definition.Untyped hiding (wk)
import Definition.Untyped as U
open import Definition.Untyped.Properties

open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Fundamental.Reducibility

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Helper function of injectivity for specific reducible Π-types
injectivity′ : ∀ {F G H E rF lF rH lH  rΠ lG lE Γ lΠ l}
               ([ΠFG] : Γ ⊩⟨ l ⟩Π Π F ^ rF ° lF  ▹ G ° lG ° lΠ ^[ rΠ , lΠ ] )
             → Γ ⊩⟨ l ⟩ Π F ^ rF ° lF ▹ G ° lG  ° lΠ ≡ Π H ^ rH ° lH  ▹ E ° lE  ° lΠ ^ [ rΠ , ι lΠ ] / Π-intr [ΠFG]
             → Γ ⊢ F ≡ H ^ [ rF , ι lF ]
             × rF PE.≡ rH
             × lF PE.≡ lH
             × lG PE.≡ lE
             × Γ ∙ F ^ [ rF , ι lF ] ⊢ G ≡ E ^ [ rΠ , ι  lG ]
injectivity′ {F₁} {G₁} {H} {E} {lF = lF₁} {rΠ = rΠ} {Γ = Γ}
         (noemb (Πᵣ ! lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext))
         (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  let F≡F₁ , rF≡rF₁ , lF≡lF₁ , G≡G₁ , lG≡lG₁ , _ = Π-PE-injectivity (whnfRed* (red D) Πₙ)
      H≡F′ , rH≡rF′ , lH≡lF′ , E≡G′ , lE≡lG′ , _ = Π-PE-injectivity (whnfRed* D′ Πₙ)
      ⊢Γ = wf ⊢F
      [F]₁ = [F] id ⊢Γ
      [F]′ = irrelevance′ (PE.trans (wk-id _) (PE.sym F≡F₁)) [F]₁
      [x∷F] = neuTerm ([F] (step id) (⊢Γ ∙ ⊢F)) (var 0) (var (⊢Γ ∙ ⊢F) here)
                      (refl (var (⊢Γ ∙ ⊢F) here))
      [G]₁ = [G] (step id) (⊢Γ ∙ ⊢F) [x∷F]
      [G]′ = PE.subst₂ (λ x y → _ ∙ y ^ _ ⊩⟨ _ ⟩ x ^ _)
                       (PE.trans (wkSingleSubstId _) (PE.sym G≡G₁))
                       (PE.sym F≡F₁) [G]₁
      [F≡H]₁ = [F≡F′] id ⊢Γ
      [F≡H]′ = irrelevanceEq″ (PE.trans (wk-id _) (PE.sym F≡F₁))
                              (PE.trans (wk-id _) (PE.sym H≡F′))
                              PE.refl PE.refl
                              [F]₁ [F]′ [F≡H]₁
      [G≡E]₁ = [G≡G′] (step id) (⊢Γ ∙ ⊢F) [x∷F]
      [G≡E]′ = irrelevanceEqLift″ (PE.trans (wkSingleSubstId _) (PE.sym G≡G₁))
                                   (PE.trans (wkSingleSubstId _) (PE.sym E≡G′))
                                   (PE.sym F≡F₁) [G]₁ [G]′ [G≡E]₁
  in  PE.subst (λ r → Γ ⊢ _ ≡ _ ^ [ r , ι lF₁ ] ) (PE.sym rF≡rF₁)
        (PE.subst (λ l → Γ ⊢ F₁ ≡ H ^ [ ! , l ] ) (PE.cong ι (PE.sym lF≡lF₁))
          (escapeEq [F]′ [F≡H]′)) ,
     ( PE.trans rF≡rF₁ (PE.sym rH≡rF′) ,
     ( PE.trans lF≡lF₁ (PE.sym lH≡lF′) ,
     ( PE.trans lG≡lG₁ (PE.sym lE≡lG′) ,
        PE.subst (λ r → (_ ∙ _ ^ [ r , _ ] ) ⊢ _ ≡ _ ^ _) (PE.sym rF≡rF₁)
         (PE.subst (λ l → (Γ ∙ F₁  ^ [ ! , ι lF₁ ] ) ⊢ G₁ ≡ E ^ [ rΠ , l ]) (PE.cong ι  (PE.sym lG≡lG₁))
          (PE.subst (λ l → (Γ ∙ F₁ ^ [ ! , l ] ) ⊢ G₁ ≡ E ^  [ rΠ , ι lG ]) (PE.cong ι (PE.sym lF≡lF₁))
           (escapeEq [G]′ [G≡E]′))))))

injectivity′ {F₁} {G₁} {H} {E} {lF = lF₁} {rΠ = rΠ} {Γ = Γ}
         (noemb (Πᵣ % lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext))
         (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  let F≡F₁ , rF≡rF₁ , lF≡lF₁ , G≡G₁ , lG≡lG₁ , _ = Π-PE-injectivity (whnfRed* (red D) Πₙ)
      H≡F′ , rH≡rF′ , lH≡lF′ , E≡G′ , lE≡lG′ , _ = Π-PE-injectivity (whnfRed* D′ Πₙ)
      ⊢Γ = wf ⊢F
      [F]₁ = [F] id ⊢Γ
      [F]′ = irrelevance′ (PE.trans (wk-id _) (PE.sym F≡F₁)) [F]₁
      [x∷F] = neuTerm ([F] (step id) (⊢Γ ∙ ⊢F)) (var 0) (var (⊢Γ ∙ ⊢F) here)
                      (proof-irrelevance (var (⊢Γ ∙ ⊢F) here) (var (⊢Γ ∙ ⊢F) here))
      [G]₁ = [G] (step id) (⊢Γ ∙ ⊢F) [x∷F]
      [G]′ = PE.subst₂ (λ x y → _ ∙ y ^ _ ⊩⟨ _ ⟩ x ^ _)
                       (PE.trans (wkSingleSubstId _) (PE.sym G≡G₁))
                       (PE.sym F≡F₁) [G]₁
      [F≡H]₁ = [F≡F′] id ⊢Γ
      [F≡H]₁ = [F≡F′] id ⊢Γ
      [F≡H]′ = irrelevanceEq″ (PE.trans (wk-id _) (PE.sym F≡F₁))
                              (PE.trans (wk-id _) (PE.sym H≡F′))
                              PE.refl PE.refl
                              [F]₁ [F]′ [F≡H]₁
      [G≡E]₁ = [G≡G′] (step id) (⊢Γ ∙ ⊢F) [x∷F]
      [G≡E]′ = irrelevanceEqLift″ (PE.trans (wkSingleSubstId _) (PE.sym G≡G₁))
                                   (PE.trans (wkSingleSubstId _) (PE.sym E≡G′))
                                   (PE.sym F≡F₁) [G]₁ [G]′ [G≡E]₁
  in  PE.subst (λ r → Γ ⊢ _ ≡ _ ^ [ r , ι lF₁ ] ) (PE.sym rF≡rF₁)
        (PE.subst (λ l → Γ ⊢ F₁ ≡ H ^ [ % , l ] ) (PE.cong ι (PE.sym lF≡lF₁))
          (escapeEq [F]′ [F≡H]′)) ,
     ( PE.trans rF≡rF₁ (PE.sym rH≡rF′) ,
     ( PE.trans lF≡lF₁ (PE.sym lH≡lF′) ,
     ( PE.trans lG≡lG₁ (PE.sym lE≡lG′) ,
        PE.subst (λ r → (_ ∙ _ ^ [ r , _ ] ) ⊢ _ ≡ _ ^ _) (PE.sym rF≡rF₁)
         (PE.subst (λ l → (Γ ∙ F₁  ^ [ % , ι lF₁ ] ) ⊢ G₁ ≡ E ^ [ rΠ , l ]) (PE.cong ι  (PE.sym lG≡lG₁))
          (PE.subst (λ l → (Γ ∙ F₁ ^ [ % , l ] ) ⊢ G₁ ≡ E ^  [ rΠ , ι lG ]) (PE.cong ι (PE.sym lF≡lF₁))
           (escapeEq [G]′ [G≡E]′))))))

injectivity′ (emb emb< x) [ΠFG≡ΠHE] = injectivity′ x [ΠFG≡ΠHE]
injectivity′ (emb ∞< x) [ΠFG≡ΠHE] = injectivity′ x [ΠFG≡ΠHE]

-- Injectivity of Π
injectivity : ∀ {Γ F G H E rF lF lH lG lE rH rΠ lΠ} →
              Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ ≡ Π H ^ rH ° lH ▹ E ° lE ° lΠ ^ [ rΠ , ι lΠ ]
            → Γ ⊢ F ≡ H ^ [ rF , ι lF ]
            × rF PE.≡ rH
            × lF PE.≡ lH
            × lG PE.≡ lE
            × Γ ∙ F ^ [ rF , ι lF ] ⊢ G ≡ E ^ [ rΠ , ι lG ]
injectivity ⊢ΠFG≡ΠHE =
  let [ΠFG] , _ , [ΠFG≡ΠHE] = reducibleEq ⊢ΠFG≡ΠHE
  in  injectivity′ (Π-elim [ΠFG])
                   (irrelevanceEq [ΠFG] (Π-intr (Π-elim [ΠFG])) [ΠFG≡ΠHE])

Uinjectivity′ : ∀ {Γ r₁ r₂ l₁ l₂ lU l}
               ([U] : Γ ⊩⟨ l ⟩U Univ r₁ l₁ ^ lU)
             → Γ ⊩⟨ l ⟩ Univ r₁ l₁ ≡ Univ r₂ l₂ ^ [ ! , lU ] / U-intr [U]
             → r₁ PE.≡ r₂ × l₁ PE.≡ l₂
Uinjectivity′ (noemb (Uᵣ r l′ l< eq d)) D =
  let A , B = Univ-PE-injectivity (whnfRed* D Uₙ)
      A' , B' = Univ-PE-injectivity (whnfRed* (red d) Uₙ)
  in (PE.trans A' (PE.sym A)) , (PE.trans B' (PE.sym B))
Uinjectivity′ (emb emb< a) b = Uinjectivity′ a b
Uinjectivity′ (emb ∞< a) b = Uinjectivity′ a b

Uinjectivity : ∀ {Γ r₁ r₂ l₁ l₂ lU} →
                 Γ ⊢ Univ r₁ l₁ ≡ Univ r₂ l₂  ^ [ ! , lU ] →
                 r₁ PE.≡ r₂ × l₁ PE.≡ l₂
Uinjectivity ⊢U≡U =
  let [U] , _ , [U≡U] = reducibleEq ⊢U≡U
  in Uinjectivity′ (U-elim [U]) (irrelevanceEq [U] (U-intr (U-elim [U])) [U≡U])

-- injectivity of ∃

∃injectivity′ : ∀ {F G H E Γ l∃ l}
               ([∃FG] : Γ ⊩⟨ l ⟩∃ ∃ F ▹ G ^ l∃ )
             → Γ ⊩⟨ l ⟩ ∃ F ▹ G ≡ ∃ H ▹ E ^ [ % , ι l∃ ] / ∃-intr [∃FG]
             → Γ ⊢ F ≡ H ^ [ % , ι l∃ ]
             × Γ ∙ F ^ [ % , ι l∃ ] ⊢ G ≡ E ^ [ % , ι l∃ ]
∃injectivity′ {F₁} {G₁} {H} {E} {Γ = Γ}
         (noemb (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext))
         (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  let F≡F₁ , G≡G₁ = ∃-PE-injectivity (whnfRed* (red D) ∃ₙ)
      H≡F′ , E≡G′ = ∃-PE-injectivity (whnfRed* D′ ∃ₙ)
      ⊢Γ = wf ⊢F
      [F]₁ = [F] id ⊢Γ
      [F]′ = irrelevance′ (PE.trans (wk-id _) (PE.sym F≡F₁)) [F]₁
      [x∷F] = neuTerm ([F] (step id) (⊢Γ ∙ ⊢F)) (var 0) (var (⊢Γ ∙ ⊢F) here) (proof-irrelevance (var (⊢Γ ∙ ⊢F) here) (var (⊢Γ ∙ ⊢F) here))
      [G]₁ = [G] (step id) (⊢Γ ∙ ⊢F) [x∷F]
      [G]′ = PE.subst₂ (λ x y → _ ∙ y ^ _ ⊩⟨ _ ⟩ x ^ _)
                       (PE.trans (wkSingleSubstId _) (PE.sym G≡G₁))
                       (PE.sym F≡F₁) [G]₁
      [F≡H]₁ = [F≡F′] id ⊢Γ
      [F≡H]′ = irrelevanceEq″ (PE.trans (wk-id _) (PE.sym F≡F₁))
                              (PE.trans (wk-id _) (PE.sym H≡F′))
                              PE.refl PE.refl
                              [F]₁ [F]′ [F≡H]₁
      [G≡E]₁ = [G≡G′] (step id) (⊢Γ ∙ ⊢F) [x∷F]
      [G≡E]′ = irrelevanceEqLift″ (PE.trans (wkSingleSubstId _) (PE.sym G≡G₁))
                                   (PE.trans (wkSingleSubstId _) (PE.sym E≡G′))
                                   (PE.sym F≡F₁) [G]₁ [G]′ [G≡E]₁
  in escapeEq [F]′ [F≡H]′ , escapeEq [G]′ [G≡E]′
∃injectivity′ (emb emb< x) [∃FG≡∃HE] = ∃injectivity′ x [∃FG≡∃HE]
∃injectivity′ (emb ∞< x) [∃FG≡∃HE] = ∃injectivity′ x [∃FG≡∃HE]

-- Injectivity of ∃
∃injectivity : ∀ {Γ F G H E l∃} →
              Γ ⊢ ∃ F ▹ G ≡ ∃ H ▹ E ^ [ % , ι l∃ ]
            → Γ ⊢ F ≡ H ^ [ % , ι l∃ ]
            × Γ ∙ F ^ [ % , ι l∃ ] ⊢ G ≡ E ^ [ % , ι l∃ ]
∃injectivity ⊢∃FG≡∃HE =
  let [∃FG] , _ , [∃FG≡∃HE] = reducibleEq ⊢∃FG≡∃HE
  in ∃injectivity′ (∃-elim [∃FG])
                   (irrelevanceEq [∃FG] (∃-intr (∃-elim [∃FG])) [∃FG≡∃HE])


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.ShapeView {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Reflexivity

open import Tools.Product
open import Tools.Empty using (⊥; ⊥-elim)
import Tools.PropositionalEquality as PE

-- Type for maybe embeddings of reducible types
data MaybeEmb (l : TypeLevel) (⊩⟨_⟩ : TypeLevel → Set) : Set where
  noemb : ⊩⟨ l ⟩ → MaybeEmb l ⊩⟨_⟩
  emb   : ∀ {l′} → l′ < l → MaybeEmb l′ ⊩⟨_⟩ → MaybeEmb l ⊩⟨_⟩

-- Specific reducible types with possible embedding

_⊩⟨_⟩U : (Γ : Con Term) (l : TypeLevel) → Set
Γ ⊩⟨ l ⟩U = MaybeEmb l (λ l′ → Γ ⊩′⟨ l′ ⟩U)

_⊩⟨_⟩ℕ_ : (Γ : Con Term) (l : TypeLevel) (A : Term) → Set
Γ ⊩⟨ l ⟩ℕ A = MaybeEmb l (λ l′ → Γ ⊩ℕ A)

_⊩⟨_⟩Empty_ : (Γ : Con Term) (l : TypeLevel) (A : Term) → Set
Γ ⊩⟨ l ⟩Empty A = MaybeEmb l (λ l′ → Γ ⊩Empty A)

_⊩⟨_⟩Unit_ : (Γ : Con Term) (l : TypeLevel) (A : Term) → Set
Γ ⊩⟨ l ⟩Unit A = MaybeEmb l (λ l′ → Γ ⊩Unit A)

_⊩⟨_⟩ne_ : (Γ : Con Term) (l : TypeLevel) (A : Term) → Set
Γ ⊩⟨ l ⟩ne A = MaybeEmb l (λ l′ → Γ ⊩ne A)

_⊩⟨_⟩B⟨_⟩_ : (Γ : Con Term) (l : TypeLevel) (W : BindingType) (A : Term) → Set
Γ ⊩⟨ l ⟩B⟨ W ⟩ A = MaybeEmb l (λ l′ → Γ ⊩′⟨ l′ ⟩B⟨ W ⟩ A)

-- Construct a general reducible type from a specific

U-intr : ∀ {Γ l} → Γ ⊩⟨ l ⟩U → Γ ⊩⟨ l ⟩ U
U-intr (noemb x) = Uᵣ x
U-intr (emb 0<1 x) = emb 0<1 (U-intr x)

ℕ-intr : ∀ {A Γ l} → Γ ⊩⟨ l ⟩ℕ A → Γ ⊩⟨ l ⟩ A
ℕ-intr (noemb x) = ℕᵣ x
ℕ-intr (emb 0<1 x) = emb 0<1 (ℕ-intr x)

Empty-intr : ∀ {A Γ l} → Γ ⊩⟨ l ⟩Empty A → Γ ⊩⟨ l ⟩ A
Empty-intr (noemb x) = Emptyᵣ x
Empty-intr (emb 0<1 x) = emb 0<1 (Empty-intr x)

Unit-intr : ∀ {A Γ l} → Γ ⊩⟨ l ⟩Unit A → Γ ⊩⟨ l ⟩ A
Unit-intr (noemb x) = Unitᵣ x
Unit-intr (emb 0<1 x) = emb 0<1 (Unit-intr x)

ne-intr : ∀ {A Γ l} → Γ ⊩⟨ l ⟩ne A → Γ ⊩⟨ l ⟩ A
ne-intr (noemb x) = ne x
ne-intr (emb 0<1 x) = emb 0<1 (ne-intr x)

B-intr : ∀ {A Γ l} W → Γ ⊩⟨ l ⟩B⟨ W ⟩ A → Γ ⊩⟨ l ⟩ A
B-intr W (noemb x) = Bᵣ W x
B-intr W (emb 0<1 x) = emb 0<1 (B-intr W x)

-- Construct a specific reducible type from a general with some criterion

U-elim : ∀ {Γ l} → Γ ⊩⟨ l ⟩ U → Γ ⊩⟨ l ⟩U
U-elim (Uᵣ′ l′ l< ⊢Γ) = noemb (Uᵣ l′ l< ⊢Γ)
U-elim (ℕᵣ D) with whnfRed* (red D) Uₙ
... | ()
U-elim (Emptyᵣ D) with whnfRed* (red D) Uₙ
... | ()
U-elim (Unitᵣ D) with whnfRed* (red D) Uₙ
... | ()
U-elim (ne′ K D neK K≡K) =
  ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
U-elim (Bᵣ′ W F G D ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (U≢B W (whnfRed* (red D) Uₙ))
U-elim (emb 0<1 x) with U-elim x
U-elim (emb 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
U-elim (emb 0<1 x) | emb () x₁

ℕ-elim′ : ∀ {A Γ l} → Γ ⊢ A ⇒* ℕ → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩ℕ A
ℕ-elim′ D (Uᵣ′ l′ l< ⊢Γ) with whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , ℕₙ)
... | ()
ℕ-elim′ D (ℕᵣ D′) = noemb D′
ℕ-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (ℕ≢ne neK (whrDet* (D , ℕₙ) (red D′ , ne neK)))
ℕ-elim′ D (Bᵣ′ W F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (ℕ≢B W (whrDet* (D , ℕₙ) (red D′ , ⟦ W ⟧ₙ)))
ℕ-elim′ D (Emptyᵣ D′) with whrDet* (D , ℕₙ) (red D′ , Emptyₙ)
... | ()
ℕ-elim′ D (Unitᵣ D′) with whrDet* (D , ℕₙ) (red D′ , Unitₙ)
... | ()
ℕ-elim′ D (emb 0<1 x) with ℕ-elim′ D x
ℕ-elim′ D (emb 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
ℕ-elim′ D (emb 0<1 x) | emb () x₂

ℕ-elim : ∀ {Γ l} → Γ ⊩⟨ l ⟩ ℕ → Γ ⊩⟨ l ⟩ℕ ℕ
ℕ-elim [ℕ] = ℕ-elim′ (id (escape [ℕ])) [ℕ]

Empty-elim′ : ∀ {A Γ l} → Γ ⊢ A ⇒* Empty → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩Empty A
Empty-elim′ D (Uᵣ′ l′ l< ⊢Γ) with whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , Emptyₙ)
... | ()
Empty-elim′ D (Emptyᵣ D′) = noemb D′
Empty-elim′ D (Unitᵣ D′) with whrDet* (D , Emptyₙ) (red D′ , Unitₙ)
... | ()
Empty-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (Empty≢ne neK (whrDet* (D , Emptyₙ) (red D′ , ne neK)))
Empty-elim′ D (Bᵣ′ W F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (Empty≢B W (whrDet* (D , Emptyₙ) (red D′ , ⟦ W ⟧ₙ)))
Empty-elim′ D (ℕᵣ D′) with whrDet* (D , Emptyₙ) (red D′ , ℕₙ)
... | ()
Empty-elim′ D (emb 0<1 x) with Empty-elim′ D x
Empty-elim′ D (emb 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
Empty-elim′ D (emb 0<1 x) | emb () x₂

Empty-elim : ∀ {Γ l} → Γ ⊩⟨ l ⟩ Empty → Γ ⊩⟨ l ⟩Empty Empty
Empty-elim [Empty] = Empty-elim′ (id (escape [Empty])) [Empty]

Unit-elim′ : ∀ {A Γ l} → Γ ⊢ A ⇒* Unit → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩Unit A
Unit-elim′ D (Uᵣ′ l′ l< ⊢Γ) with whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , Unitₙ)
... | ()
Unit-elim′ D (Unitᵣ D′) = noemb D′
Unit-elim′ D (Emptyᵣ D′) with whrDet* (D , Unitₙ) (red D′ , Emptyₙ)
... | ()
Unit-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (Unit≢ne neK (whrDet* (D , Unitₙ) (red D′ , ne neK)))
Unit-elim′ D (Bᵣ′ W F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (Unit≢B W (whrDet* (D , Unitₙ) (red D′ , ⟦ W ⟧ₙ)))
Unit-elim′ D (ℕᵣ D′) with whrDet* (D , Unitₙ) (red D′ , ℕₙ)
... | ()
Unit-elim′ D (emb 0<1 x) with Unit-elim′ D x
Unit-elim′ D (emb 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
Unit-elim′ D (emb 0<1 x) | emb () x₂

Unit-elim : ∀ {Γ l} → Γ ⊩⟨ l ⟩ Unit → Γ ⊩⟨ l ⟩Unit Unit
Unit-elim [Unit] = Unit-elim′ (id (escape [Unit])) [Unit]

ne-elim′ : ∀ {A Γ l K} → Γ ⊢ A ⇒* K → Neutral K → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩ne A
ne-elim′ D neK (Uᵣ′ l′ l< ⊢Γ) =
  ⊥-elim (U≢ne neK (whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , ne neK)))
ne-elim′ D neK (ℕᵣ D′) = ⊥-elim (ℕ≢ne neK (whrDet* (red D′ , ℕₙ) (D , ne neK)))
ne-elim′ D neK (Emptyᵣ D′) = ⊥-elim (Empty≢ne neK (whrDet* (red D′ , Emptyₙ) (D , ne neK)))
ne-elim′ D neK (Unitᵣ D′) = ⊥-elim (Unit≢ne neK (whrDet* (red D′ , Unitₙ) (D , ne neK)))
ne-elim′ D neK (ne′ K D′ neK′ K≡K) = noemb (ne K D′ neK′ K≡K)
ne-elim′ D neK (Bᵣ′ W F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (B≢ne W neK (whrDet* (red D′ , ⟦ W ⟧ₙ) (D , ne neK)))
ne-elim′ D neK (emb 0<1 x) with ne-elim′ D neK x
ne-elim′ D neK (emb 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
ne-elim′ D neK (emb 0<1 x) | emb () x₂

ne-elim : ∀ {Γ l K} → Neutral K  → Γ ⊩⟨ l ⟩ K → Γ ⊩⟨ l ⟩ne K
ne-elim neK [K] = ne-elim′ (id (escape [K])) neK [K]

B-elim′ : ∀ {A Γ F G l} W → Γ ⊢ A ⇒* ⟦ W ⟧ F ▹ G → Γ ⊩⟨ l ⟩ A → Γ ⊩⟨ l ⟩B⟨ W ⟩ A
B-elim′ W D (Uᵣ′ l′ l< ⊢Γ) =
  ⊥-elim (U≢B W (whrDet* (id (Uⱼ ⊢Γ) , Uₙ) (D , ⟦ W ⟧ₙ)))
B-elim′ W D (ℕᵣ D′) =
  ⊥-elim (ℕ≢B W (whrDet* (red D′ , ℕₙ) (D , ⟦ W ⟧ₙ)))
B-elim′ W D (Emptyᵣ D′) =
  ⊥-elim (Empty≢B W (whrDet* (red D′ , Emptyₙ) (D , ⟦ W ⟧ₙ)))
B-elim′ W D (Unitᵣ D′) =
  ⊥-elim (Unit≢B W (whrDet* (red D′ , Unitₙ) (D , ⟦ W ⟧ₙ)))
B-elim′ W D (ne′ K D′ neK K≡K) =
  ⊥-elim (B≢ne W neK (whrDet* (D , ⟦ W ⟧ₙ) (red D′ , ne neK)))
B-elim′ BΠ D (Bᵣ′ BΣ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) with whrDet* (D , Πₙ) (red D′ , Σₙ)
... | ()
B-elim′ BΣ D (Bᵣ′ BΠ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) with whrDet* (D , Σₙ) (red D′ , Πₙ)
... | ()
B-elim′ BΠ D (Bᵣ′ BΠ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  noemb (Bᵣ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext)
B-elim′ BΣ D (Bᵣ′ BΣ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  noemb (Bᵣ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext)
B-elim′ W D (emb 0<1 x) with B-elim′ W D x
B-elim′ W D (emb 0<1 x) | noemb x₁ = emb 0<1 (noemb x₁)
B-elim′ W D (emb 0<1 x) | emb () x₂

B-elim : ∀ {Γ F G l} W → Γ ⊩⟨ l ⟩ ⟦ W ⟧ F ▹ G → Γ ⊩⟨ l ⟩B⟨ W ⟩ ⟦ W ⟧ F ▹ G
B-elim W [Π] = B-elim′ W (id (escape [Π])) [Π]

Π-elim : ∀ {Γ F G l} → Γ ⊩⟨ l ⟩ Π F ▹ G → Γ ⊩⟨ l ⟩B⟨ BΠ ⟩ Π F ▹ G
Π-elim [Π] = B-elim′ BΠ (id (escape [Π])) [Π]

Σ-elim : ∀ {Γ F G l} → Γ ⊩⟨ l ⟩ Σ F ▹ G → Γ ⊩⟨ l ⟩B⟨ BΣ ⟩ Σ F ▹ G
Σ-elim [Σ] = B-elim′ BΣ (id (escape [Σ])) [Σ]

-- Extract a type and a level from a maybe embedding
extractMaybeEmb : ∀ {l ⊩⟨_⟩} → MaybeEmb l ⊩⟨_⟩ → ∃ λ l′ → ⊩⟨ l′ ⟩
extractMaybeEmb (noemb x) = _ , x
extractMaybeEmb (emb 0<1 x) = extractMaybeEmb x

-- A view for constructor equality of types where embeddings are ignored
data ShapeView Γ : ∀ l l′ A B (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ B) → Set where
  Uᵥ : ∀ {l l′} UA UB → ShapeView Γ l l′ U U (Uᵣ UA) (Uᵣ UB)
  ℕᵥ : ∀ {A B l l′} ℕA ℕB → ShapeView Γ l l′ A B (ℕᵣ ℕA) (ℕᵣ ℕB)
  Emptyᵥ : ∀ {A B l l′} EmptyA EmptyB → ShapeView Γ l l′ A B (Emptyᵣ EmptyA) (Emptyᵣ EmptyB)
  Unitᵥ : ∀ {A B l l′} UnitA UnitB → ShapeView Γ l l′ A B (Unitᵣ UnitA) (Unitᵣ UnitB)
  ne  : ∀ {A B l l′} neA neB
      → ShapeView Γ l l′ A B (ne neA) (ne neB)
  Bᵥ : ∀ {A B l l′} W BA BB
    → ShapeView Γ l l′ A B (Bᵣ W BA) (Bᵣ W BB)
  emb⁰¹ : ∀ {A B l p q}
        → ShapeView Γ ⁰ l A B p q
        → ShapeView Γ ¹ l A B (emb 0<1 p) q
  emb¹⁰ : ∀ {A B l p q}
        → ShapeView Γ l ⁰ A B p q
        → ShapeView Γ l ¹ A B p (emb 0<1 q)

-- Construct an shape view from an equality (aptly named)
goodCases : ∀ {l l′ Γ A B} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
          → Γ ⊩⟨ l ⟩ A ≡ B / [A] → ShapeView Γ l l′ A B [A] [B]
-- Diagonal cases
goodCases (Uᵣ UA) (Uᵣ UB) A≡B = Uᵥ UA UB
goodCases (ℕᵣ ℕA) (ℕᵣ ℕB) A≡B = ℕᵥ ℕA ℕB
goodCases (Emptyᵣ EmptyA) (Emptyᵣ EmptyB) A≡B = Emptyᵥ EmptyA EmptyB
goodCases (Unitᵣ UnitA) (Unitᵣ UnitB) A≡B = Unitᵥ UnitA UnitB
goodCases (ne neA) (ne neB) A≡B = ne neA neB
goodCases (Bᵣ BΠ ΠA) (Bᵣ BΠ ΠB) A≡B = Bᵥ BΠ ΠA ΠB
goodCases (Bᵣ BΣ ΣA) (Bᵣ BΣ ΣB) A≡B = Bᵥ BΣ ΣA ΣB
--goodCases (Σᵣ ΣA) (Σᵣ ΣB) A≡B = Σᵥ ΣA ΣB

goodCases {l} [A] (emb 0<1 x) A≡B =
  emb¹⁰ (goodCases {l} {⁰} [A] x A≡B)
goodCases {l′ = l} (emb 0<1 x) [B] A≡B =
  emb⁰¹ (goodCases {⁰} {l} x [B] A≡B)

-- Refutable cases
-- U ≡ _
goodCases (Uᵣ′ _ _ ⊢Γ) (ℕᵣ D) PE.refl with whnfRed* (red D) Uₙ
... | ()
goodCases (Uᵣ′ _ _ ⊢Γ) (Emptyᵣ D) PE.refl with whnfRed* (red D) Uₙ
... | ()
goodCases (Uᵣ′ _ _ ⊢Γ) (Unitᵣ D) PE.refl with whnfRed* (red D) Uₙ
... | ()
goodCases (Uᵣ′ _ _ ⊢Γ) (ne′ K D neK K≡K) PE.refl =
  ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
goodCases (Uᵣ′ _ _ ⊢Γ) (Bᵣ′ W F G D ⊢F ⊢G A≡A [F] [G] G-ext) PE.refl =
  ⊥-elim (U≢B W (whnfRed* (red D) Uₙ))

-- ℕ ≡ _
goodCases (ℕᵣ D) (Uᵣ ⊢Γ) A≡B with whnfRed* A≡B Uₙ
... | ()
goodCases (ℕᵣ _) (Emptyᵣ D') D with whrDet* (D , ℕₙ) (red D' , Emptyₙ)
... | ()
goodCases (ℕᵣ x) (Unitᵣ D') D with whrDet* (D , ℕₙ) (red D' , Unitₙ)
... | ()
goodCases (ℕᵣ D) (ne′ K D₁ neK K≡K) A≡B =
  ⊥-elim (ℕ≢ne neK (whrDet* (A≡B , ℕₙ) (red D₁ , ne neK)))
goodCases (ℕᵣ D) (Bᵣ′ W F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) A≡B =
  ⊥-elim (ℕ≢B W (whrDet* (A≡B , ℕₙ) (red D₁ , ⟦ W ⟧ₙ)))

-- Empty ≢ _
goodCases (Emptyᵣ D) (Uᵣ ⊢Γ) A≡B with whnfRed* A≡B Uₙ
... | ()
goodCases (Emptyᵣ _) (Unitᵣ D') D with whrDet* (red D' , Unitₙ) (D , Emptyₙ)
... | ()
goodCases (Emptyᵣ _) (ℕᵣ D') D with whrDet* (red D' , ℕₙ) (D , Emptyₙ)
... | ()
goodCases (Emptyᵣ D) (ne′ K D₁ neK K≡K) A≡B =
  ⊥-elim (Empty≢ne neK (whrDet* (A≡B , Emptyₙ) (red D₁ , ne neK)))
goodCases (Emptyᵣ D) (Bᵣ′ W F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) A≡B =
  ⊥-elim (Empty≢B W (whrDet* (A≡B , Emptyₙ) (red D₁ , ⟦ W ⟧ₙ)))

-- Unit ≡ _
goodCases (Unitᵣ _) (Uᵣ x₁) A≡B with whnfRed* A≡B Uₙ
... | ()
goodCases (Unitᵣ _) (Emptyᵣ D') D with whrDet* (red D' , Emptyₙ) (D , Unitₙ)
... | ()
goodCases (Unitᵣ _) (ℕᵣ D') D with whrDet* (red D' , ℕₙ) (D , Unitₙ)
... | ()
goodCases (Unitᵣ D) (ne′ K D₁ neK K≡K) A≡B =
  ⊥-elim (Unit≢ne neK (whrDet* (A≡B , Unitₙ) (red D₁ , ne neK)))
goodCases (Unitᵣ D) (Bᵣ′ W F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) A≡B =
  ⊥-elim (Unit≢B W (whrDet* (A≡B , Unitₙ) (red D₁ , ⟦ W ⟧ₙ)))

-- ne ≡ _
goodCases (ne′ K D neK K≡K) (Uᵣ ⊢Γ) (ne₌ M D′ neM K≡M) =
  ⊥-elim (U≢ne neM (whnfRed* (red D′) Uₙ))
goodCases (ne′ K D neK K≡K) (ℕᵣ D₁) (ne₌ M D′ neM K≡M) =
  ⊥-elim (ℕ≢ne neM (whrDet* (red D₁ , ℕₙ) (red D′ , ne neM)))
goodCases (ne′ K D neK K≡K) (Emptyᵣ D₁) (ne₌ M D′ neM K≡M) =
  ⊥-elim (Empty≢ne neM (whrDet* (red D₁ , Emptyₙ) (red D′ , ne neM)))
goodCases (ne′ K D neK K≡K) (Unitᵣ D₁) (ne₌ M D′ neM K≡M) =
  ⊥-elim (Unit≢ne neM (whrDet* (red D₁ , Unitₙ) (red D′ , ne neM)))
goodCases (ne′ K D neK K≡K) (Bᵣ′ W F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) (ne₌ M D′ neM K≡M) =
  ⊥-elim (B≢ne W neM (whrDet* (red D₁ , ⟦ W ⟧ₙ) (red D′ , ne neM)))

-- Π ≡ _
goodCases (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Uᵣ ⊢Γ)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whnfRed* D′ Uₙ
... | ()
goodCases (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ℕᵣ D₁)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whrDet* (red D₁ , ℕₙ) (D′ , Πₙ)
... | ()
goodCases (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Emptyᵣ D₁)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whrDet* (red D₁ , Emptyₙ) (D′ , Πₙ)
... | ()
goodCases (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Unitᵣ D₁)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whrDet* (red D₁ , Unitₙ) (D′ , Πₙ)
... | ()
goodCases (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Bᵣ′ BΣ F′ G′ D′ ⊢F′ ⊢G′ A≡A′ [F]′ [G]′ G-ext′)
  (B₌ F′₁ G′₁ D′₁ A≡B [F≡F′] [G≡G′]) with whrDet* (red D′ , Σₙ) (D′₁ , Πₙ)
... | ()
goodCases (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ne′ K D₁ neK K≡K)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (B≢ne BΠ neK (whrDet* (D′ , Πₙ) (red D₁ , ne neK)))

-- Σ ≡ _
goodCases (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Uᵣ ⊢Γ)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whnfRed* D′ Uₙ
... | ()
goodCases (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ℕᵣ D₁)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whrDet* (red D₁ , ℕₙ) (D′ , Σₙ)
... | ()
goodCases (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Emptyᵣ D₁)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whrDet* (red D₁ , Emptyₙ) (D′ , Σₙ)
... | ()
goodCases (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Unitᵣ D₁)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) with whrDet* (red D₁ , Unitₙ) (D′ , Σₙ)
... | ()
goodCases (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Bᵣ′ BΠ F′ G′ D′ ⊢F′ ⊢G′ A≡A′ [F]′ [G]′ G-ext′)
  (B₌ F′₁ G′₁ D′₁ A≡B [F≡F′] [G≡G′]) with whrDet* (red D′ , Πₙ) (D′₁ , Σₙ)
... | ()
goodCases (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ne′ K D₁ neK K≡K)
          (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (B≢ne BΣ neK (whrDet* (D′ , Σₙ) (red D₁ , ne neK)))

-- Construct an shape view between two derivations of the same type
goodCasesRefl : ∀ {l l′ Γ A} ([A] : Γ ⊩⟨ l ⟩ A) ([A′] : Γ ⊩⟨ l′ ⟩ A)
              → ShapeView Γ l l′ A A [A] [A′]
goodCasesRefl [A] [A′] = goodCases [A] [A′] (reflEq [A])

-- A view for constructor equality between three types
data ShapeView₃ Γ : ∀ l l′ l″ A B C
                 (p : Γ ⊩⟨ l   ⟩ A)
                 (q : Γ ⊩⟨ l′  ⟩ B)
                 (r : Γ ⊩⟨ l″ ⟩ C) → Set where
  Uᵥ : ∀ {l l′ l″} UA UB UC → ShapeView₃ Γ l l′ l″ U U U (Uᵣ UA) (Uᵣ UB) (Uᵣ UC)
  ℕᵥ : ∀ {A B C l l′ l″} ℕA ℕB ℕC
    → ShapeView₃ Γ l l′ l″ A B C (ℕᵣ ℕA) (ℕᵣ ℕB) (ℕᵣ ℕC)
  Emptyᵥ : ∀ {A B C l l′ l″} EmptyA EmptyB EmptyC
    → ShapeView₃ Γ l l′ l″ A B C (Emptyᵣ EmptyA) (Emptyᵣ EmptyB) (Emptyᵣ EmptyC)
  Unitᵥ : ∀ {A B C l l′ l″} UnitA UnitB UnitC
    → ShapeView₃ Γ l l′ l″ A B C (Unitᵣ UnitA) (Unitᵣ UnitB) (Unitᵣ UnitC)
  ne  : ∀ {A B C l l′ l″} neA neB neC
      → ShapeView₃ Γ l l′ l″ A B C (ne neA) (ne neB) (ne neC)
  Bᵥ : ∀ {A B C l l′ l″} W BA BB BC
    → ShapeView₃ Γ l l′ l″ A B C (Bᵣ W BA) (Bᵣ W BB) (Bᵣ W BC)
  emb⁰¹¹ : ∀ {A B C l l′ p q r}
         → ShapeView₃ Γ ⁰ l l′ A B C p q r
         → ShapeView₃ Γ ¹ l l′ A B C (emb 0<1 p) q r
  emb¹⁰¹ : ∀ {A B C l l′ p q r}
         → ShapeView₃ Γ l ⁰ l′ A B C p q r
         → ShapeView₃ Γ l ¹ l′ A B C p (emb 0<1 q) r
  emb¹¹⁰ : ∀ {A B C l l′ p q r}
         → ShapeView₃ Γ l l′ ⁰ A B C p q r
         → ShapeView₃ Γ l l′ ¹ A B C p q (emb 0<1 r)

-- Combines two two-way views into a three-way view
combine : ∀ {Γ l l′ l″ l‴ A B C [A] [B] [B]′ [C]}
        → ShapeView Γ l l′ A B [A] [B]
        → ShapeView Γ l″ l‴ B C [B]′ [C]
        → ShapeView₃ Γ l l′ l‴ A B C [A] [B] [C]
-- Diagonal cases
combine (Uᵥ UA₁ UB₁) (Uᵥ UA UB) = Uᵥ UA₁ UB₁ UB
combine (ℕᵥ ℕA₁ ℕB₁) (ℕᵥ ℕA ℕB) = ℕᵥ ℕA₁ ℕB₁ ℕB
combine (Emptyᵥ EmptyA₁ EmptyB₁) (Emptyᵥ EmptyA EmptyB) = Emptyᵥ EmptyA₁ EmptyB₁ EmptyB
combine (Unitᵥ UnitA₁ UnitB₁) (Unitᵥ UnitA UnitB) = Unitᵥ UnitA₁ UnitB₁ UnitB
combine (ne neA₁ neB₁) (ne neA neB) = ne neA₁ neB₁ neB
combine (Bᵥ BΠ ΠA₁ ΠB₁) (Bᵥ BΠ ΠA ΠB) = Bᵥ BΠ ΠA₁ ΠB₁ ΠB
combine (Bᵥ BΣ ΣA₁ ΣB₁) (Bᵥ BΣ ΣA ΣB) = Bᵥ BΣ ΣA₁ ΣB₁ ΣB
combine (emb⁰¹ [AB]) [BC] = emb⁰¹¹ (combine [AB] [BC])
combine (emb¹⁰ [AB]) [BC] = emb¹⁰¹ (combine [AB] [BC])
combine [AB] (emb⁰¹ [BC]) = combine [AB] [BC]
combine [AB] (emb¹⁰ [BC]) = emb¹¹⁰ (combine [AB] [BC])

-- Refutable cases
-- U ≡ _
combine (Uᵥ UA UB) (ℕᵥ ℕA ℕB) with whnfRed* (red ℕA) Uₙ
... | ()
combine (Uᵥ UA UB) (Emptyᵥ EmptyA EmptyB) with whnfRed* (red EmptyA) Uₙ
... | ()
combine (Uᵥ UA UB) (Unitᵥ UnA UnB) with whnfRed* (red UnA) Uₙ
... | ()
combine (Uᵥ UA UB) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
combine (Uᵥ UA UB) (Bᵥ W (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) BB) =
  ⊥-elim (U≢B W (whnfRed* (red D) Uₙ))

-- ℕ ≡ _
combine (ℕᵥ ℕA ℕB) (Uᵥ UA UB) with whnfRed* (red ℕB) Uₙ
... | ()
combine (ℕᵥ ℕA ℕB) (Emptyᵥ EmptyA EmptyB) with whrDet* (red ℕB , ℕₙ) (red EmptyA , Emptyₙ)
... | ()
combine (ℕᵥ ℕA ℕB) (Unitᵥ UnA UnB) with whrDet* (red ℕB , ℕₙ) (red UnA , Unitₙ)
... | ()
combine (ℕᵥ ℕA ℕB) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (ℕ≢ne neK (whrDet* (red ℕB , ℕₙ) (red D , ne neK)))
combine (ℕᵥ ℕA ℕB) (Bᵥ W (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) BB) =
  ⊥-elim (ℕ≢B W (whrDet* (red ℕB , ℕₙ) (red D , ⟦ W ⟧ₙ)))

-- Empty ≡ _
combine (Emptyᵥ EmptyA EmptyB) (Uᵥ UA UB) with whnfRed* (red EmptyB) Uₙ
... | ()
combine (Emptyᵥ EmptyA EmptyB) (ℕᵥ ℕA ℕB) with whrDet* (red EmptyB , Emptyₙ) (red ℕA , ℕₙ)
... | ()
combine (Emptyᵥ EmptyA EmptyB) (Unitᵥ UnA UnB) with whrDet* (red EmptyB , Emptyₙ) (red UnA , Unitₙ)
... | ()
combine (Emptyᵥ EmptyA EmptyB) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (Empty≢ne neK (whrDet* (red EmptyB , Emptyₙ) (red D , ne neK)))
combine (Emptyᵥ EmptyA EmptyB) (Bᵥ W (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) BB) =
  ⊥-elim (Empty≢B W (whrDet* (red EmptyB , Emptyₙ) (red D , ⟦ W ⟧ₙ)))

-- Unit ≡ _
combine (Unitᵥ UnitA UnitB) (Uᵥ UA UB) with whnfRed* (red UnitB) Uₙ
... | ()
combine (Unitᵥ UnitA UnitB) (ℕᵥ ℕA ℕB) with whrDet* (red UnitB , Unitₙ) (red ℕA , ℕₙ)
... | ()
combine (Unitᵥ UnitA UnitB) (Emptyᵥ EmptyA EmptyB) with whrDet* (red UnitB , Unitₙ) (red EmptyA , Emptyₙ)
... | ()
combine (Unitᵥ UnitA UnitB) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (Unit≢ne neK (whrDet* (red UnitB , Unitₙ) (red D , ne neK)))
combine (Unitᵥ UnitA UnitB) (Bᵥ W (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) BB) =
  ⊥-elim (Unit≢B W (whrDet* (red UnitB , Unitₙ) (red D , ⟦ W ⟧ₙ)))

-- ne ≡ _
combine (ne neA (ne K D neK K≡K)) (Uᵥ UA UB) =
  ⊥-elim (U≢ne neK (whnfRed* (red D) Uₙ))
combine (ne neA (ne K D neK K≡K)) (ℕᵥ ℕA ℕB) =
  ⊥-elim (ℕ≢ne neK (whrDet* (red ℕA , ℕₙ) (red D , ne neK)))
combine (ne neA (ne K D neK K≡K)) (Emptyᵥ EmptyA EmptyB) =
  ⊥-elim (Empty≢ne neK (whrDet* (red EmptyA , Emptyₙ) (red D , ne neK)))
combine (ne neA (ne K D neK K≡K)) (Unitᵥ UnA UnB) =
  ⊥-elim (Unit≢ne neK (whrDet* (red UnA , Unitₙ) (red D , ne neK)))
combine (ne neA (ne K D neK K≡K)) (Bᵥ W (Bᵣ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) BB) =
  ⊥-elim (B≢ne W neK (whrDet* (red D₁ , ⟦ W ⟧ₙ) (red D , ne neK)))

-- Π/Σ ≡ _
combine (Bᵥ W BA (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Uᵥ UA UB) =
  ⊥-elim (U≢B W (whnfRed* (red D) Uₙ))
combine (Bᵥ W BA (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (ℕᵥ ℕA ℕB) =
  ⊥-elim (ℕ≢B W (whrDet* (red ℕA , ℕₙ) (red D , ⟦ W ⟧ₙ)))
combine (Bᵥ W BA (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Emptyᵥ EmptyA EmptyB) =
  ⊥-elim (Empty≢B W (whrDet* (red EmptyA , Emptyₙ) (red D , ⟦ W ⟧ₙ)))
combine (Bᵥ W BA (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Unitᵥ UnitA UnitB) =
  ⊥-elim (Unit≢B W (whrDet* (red UnitA , Unitₙ) (red D , ⟦ W ⟧ₙ)))
combine (Bᵥ W BA (Bᵣ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext)) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (B≢ne W neK (whrDet* (red D₁ , ⟦ W ⟧ₙ) (red D , ne neK)))
combine (Bᵥ BΠ ΠA (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Bᵥ BΣ (Bᵣ F′ G′ D′ ⊢F′ ⊢G′ A≡A′ [F]′ [G]′ G-ext′) ΣA)
  with whrDet* (red D , Πₙ) (red D′ , Σₙ)
... | ()
combine (Bᵥ BΣ ΣA (Bᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Bᵥ BΠ (Bᵣ F′ G′ D′ ⊢F′ ⊢G′ A≡A′ [F]′ [G]′ G-ext′) ΠA)
  with whrDet* (red D , Σₙ) (red D′ , Πₙ)
... | ()


module Issue580 where

record Bad : Set₁ where
  private field A : Set


{-# OPTIONS --no-termination-check #-}
-- TODO: switch the termination checker back on.

open import Coinduction using ( ∞ ; ♭ ; ♯_ )
open import Data.Bool using ( Bool ; true ; false )
open import Data.Maybe using ( Maybe ; just ; nothing )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Data.Product using ( ∃ ; _,_ )
open import Data.ByteString using ( ByteString ; strict ; null )
open import System.IO using ( IO ; Command ; return ; _>>_ ; _>>=_ ; skip ; getBytes ; putBytes ; commit )
open import System.IO.Transducers.Lazy using ( _⇒_ ; _⤇_ ; inp ; out ; done ; ι⁻¹ )
open import System.IO.Transducers.Session using ( I ; Σ ; Bytes )
open import System.IO.Transducers.Strict using ( _⇛_ )

module System.IO.Transducers.IO where

infixl 5 _$_

postulate
  IOError : Set
  _catch_ : ∀ {A} → (IO A) → (IOError → (IO A)) → (IO A)
{-# COMPILED_TYPE IOError IOError #-}
{-# COMPILED _catch_ (\ _ -> catch) #-}

_$_ : ∀ {A V F T} → (Σ {A} V F ⤇ T) → (a : A) → (♭ F a ⤇ T)
inp P   $ a = ♭ P a
out b P $ a = out b (P $ a)

getBytes? : IO (Maybe (ByteString strict))
getBytes? = (getBytes >>= λ x → return (just x)) catch (λ e → return nothing)

runI : (I ⤇ Bytes) → Command
runI (out true (out x P)) = putBytes x >> commit >> runI P
runI (out false P)        = skip

mutual

  run? : (Bytes ⤇ Bytes) → (Maybe (ByteString strict)) → Command
  run? P (just b) = run' (P $ true $ b)
  run? P nothing = runI (P $ false)

  run' : (Bytes ⤇ Bytes) → Command
  run' (out true (out b P)) = putBytes b >> commit >> run' P
  run' (out false P)        = skip
  run' P                    = getBytes? >>= run? P

run : (Bytes ⇒ Bytes) → Command
run P = run' (ι⁻¹ P)