-- Andreas, 2019-11-12, issue #4168b
--
-- Meta variable solver should not use uncurrying
-- if the record type contains erased fields.

open import Agda.Builtin.Equality
open import Agda.Builtin.Sigma
open import Common.IO

P : (A B : Set) → (A → B) → Set
P A B f = (y : B) → Σ A (λ x → f x ≡ y)

record R (A B : Set) : Set where
  field
    to      : A → B
    from    : B → A
    from-to : (x : A) → from (to x) ≡ x

p : (A B : Set) (r : R A B) → P A B (R.to r)
p _ _ r y = R.from r y , to-from y
  where
  postulate
    to-from : ∀ x → R.to r (R.from r x) ≡ x

record Box (A : Set) : Set where
  constructor box
  field
    @0 unbox : A

test : (A : Set) → P (Box A) (Box (Box A)) (box {A = Box A})
test A = p _ _ (record
  { to      = box {A = _}
  ; from    = λ { (box (box x)) → box {A = A} x }
      -- at first, a postponed type checking problem ?from
  ; from-to = λ x → refl {A = Box A} {x = _}
  })
-- from-to creates constraint
--
--   x : Box A |- ?from (box x) = x : Box A
--
-- This was changed to
--
--   y : Box (Box A) |- ?from y = unbox y : Box A
--
-- which is an invalid transformation since x is not
-- guaranteed to be in erased context.

-- As a consequence, compilation (GHC backend) failed.

-- A variant with a non-erased field.

record ⊤ : Set where

record Box' (A : Set) : Set where
  constructor box'
  field
    unit : ⊤
    @0 unbox' : A

test' : (A : Set) → P (Box' A) (Box' (Box' A)) (box' {A = Box' A} _)
test' A = p _ _ (record
  { to      = box' {A = _} _
  ; from    = λ { (box' _ (box' _ x)) → box' {A = A} _ x }
  ; from-to = λ x → refl {A = Box' A} {x = _}
  })

main : IO ⊤
main = return _


module Tactic.Reflection where

open import Prelude hiding (abs; _>>=_) renaming (_>>=′_ to _>>=_)
open import Builtin.Reflection           public
open import Tactic.Reflection.DeBruijn   public
open import Tactic.Reflection.Telescope  public
open import Tactic.Reflection.Substitute public
open import Tactic.Reflection.Free       public
open import Tactic.Reflection.Equality   public
open import Tactic.Reflection.Meta       public

set₀ : Type
set₀ = agda-sort (lit 0)

set! : Type
set! = agda-sort unknown

pattern var₀ x         = var x []
pattern var₁ x a       = var x (vArg a ∷ [])
pattern var₂ x a b     = var x (vArg a ∷ vArg b ∷ [])
pattern var₃ x a b c   = var x (vArg a ∷ vArg b ∷ vArg c ∷ [])
pattern var₄ x a b c d = var x (vArg a ∷ vArg b ∷ vArg c ∷ vArg d ∷ [])

pattern con₀ c         = con c []
pattern con₁ c x       = con c (vArg x ∷ [])
pattern con₂ c x y     = con c (vArg x ∷ vArg y ∷ [])
pattern con₃ c x y z   = con c (vArg x ∷ vArg y ∷ vArg z ∷ [])
pattern con₄ c x y z u = con c (vArg x ∷ vArg y ∷ vArg z ∷ vArg u ∷ [])

pattern def₀ f         = def f []
pattern def₁ f x       = def f (vArg x ∷ [])
pattern def₂ f x y     = def f (vArg x ∷ vArg y ∷ [])
pattern def₃ f x y z   = def f (vArg x ∷ vArg y ∷ vArg z ∷ [])
pattern def₄ f x y z u = def f (vArg x ∷ vArg y ∷ vArg z ∷ vArg u ∷ [])

infixr 4 _`→_ _`→ʰ_ _`→ⁱ_
_`→_ _`→ʰ_ _`→ⁱ_ : Type → Type → Type
_`→_  a b = pi (vArg a) (abs "_" b)
_`→ʰ_ a b = pi (hArg a) (abs "_" b)
_`→ⁱ_ a b = pi (iArg a) (abs "_" b)

`λ : Term → Term
`λ b = lam visible (abs "_" b)

infixl 9 _`∘_
_`∘_ : Term → Term → Term
_`∘_ = def₂ (quote _∘_)

infixr -20 _`$_
_`$_ : Term → Term → Term
_`$_ = def₂ (quote _$_)

_:′_ : Term → Type → TC Term
_:′_ = checkType

λ′ : ∀ {a} {A : Set a} → Arg Type → TC A → TC A
λ′ = extendContext

infix 2 _=′_
_=′_ : Term → Term → TC ⊤
_=′_ = unify

on-goal : (Type → Tactic) → Tactic
on-goal tac hole = inferNormalisedType hole >>= λ goal → tac goal hole

forceFun : Type → TC Type
forceFun a = do
  dom ← newMeta set!
  rng ← newMeta set!
  unify a (dom `→ weaken 1 rng)
  normalise a

inferFunRange : Term → TC Type
inferFunRange hole = unPi =<< forceFun =<< inferType hole where
  unPi : Type → TC Type
  unPi (pi _ (abs _ (meta x _))) = blockOnMeta! x
  unPi (pi _ (abs _ b)) = maybe (typeError ( strErr "Must be applied in a non-dependent function position"
                                           ∷ termErr b ∷ [])) pure $ strengthen 1 b
  unPi x = typeError (strErr "Invalid goal" ∷ termErr x ∷ [])

macro
  runT : Tactic → Tactic
  runT t = t

evalTC : ∀ {a} {A : Set a} → TC A → Tactic
evalTC {A = A} c hole = do
  v  ← c
  `v ← quoteTC v
  `A ← quoteTC A
  checkedHole ← checkType hole `A
  unify checkedHole `v

macro
  evalT : ∀ {a} {A : Set a} → TC A → Tactic
  evalT = evalTC


module Luau.Value where

open import Luau.Addr using (Addr)
open import Luau.Syntax using (Block; Expr; nil; addr; function⟨_⟩_end)
open import Luau.Var using (Var)

data Value : Set where
  nil : Value
  addr : Addr → Value

val : Value → Expr
val nil = nil
val (addr a) = addr a


------------------------------------------------------------------------
-- "Equational" reasoning combinator setup
------------------------------------------------------------------------

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

open import Labelled-transition-system

module Bisimilarity.Weak.Equational-reasoning-instances
         {ℓ} {lts : LTS ℓ} where

open import Prelude

open import Bisimilarity lts
import Bisimilarity.Equational-reasoning-instances
open import Bisimilarity.Weak lts
open import Equational-reasoning
open import Expansion lts
import Expansion.Equational-reasoning-instances

instance

  reflexive≈ : ∀ {i} → Reflexive [ i ]_≈_
  reflexive≈ = is-reflexive reflexive-≈

  reflexive≈′ : ∀ {i} → Reflexive [ i ]_≈′_
  reflexive≈′ = is-reflexive reflexive-≈′

  symmetric≈ : ∀ {i} → Symmetric [ i ]_≈_
  symmetric≈ = is-symmetric symmetric-≈

  symmetric≈′ : ∀ {i} → Symmetric [ i ]_≈′_
  symmetric≈′ = is-symmetric symmetric-≈′

  convert≈≈ : ∀ {i} → Convertible [ i ]_≈_ [ i ]_≈_
  convert≈≈ = is-convertible id

  convert≈′≈ : ∀ {i} → Convertible _≈′_ [ i ]_≈_
  convert≈′≈ = is-convertible (λ p≈′q → force p≈′q)

  convert≈≈′ : ∀ {i} → Convertible [ i ]_≈_ [ i ]_≈′_
  convert≈≈′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ≈ q → [ i ] p ≈′ q
    force (lemma p≈q) = p≈q

  convert≈′≈′ : ∀ {i} → Convertible [ i ]_≈′_ [ i ]_≈′_
  convert≈′≈′ = is-convertible id

  convert∼≈ : ∀ {i} → Convertible [ i ]_∼_ [ i ]_≈_
  convert∼≈ = is-convertible ∼⇒≈

  convert∼′≈ : ∀ {i} → Convertible _∼′_ [ i ]_≈_
  convert∼′≈ = is-convertible (convert ∘ ∼⇒≈′)

  convert∼≈′ : ∀ {i} → Convertible [ i ]_∼_ [ i ]_≈′_
  convert∼≈′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ∼ q → [ i ] p ≈′ q
    force (lemma p∼q) = ∼⇒≈ p∼q

  convert∼′≈′ : ∀ {i} → Convertible [ i ]_∼′_ [ i ]_≈′_
  convert∼′≈′ = is-convertible ∼⇒≈′

  convert≳≈ : ∀ {i} → Convertible [ i ]_≳_ [ i ]_≈_
  convert≳≈ = is-convertible ≳⇒≈

  convert≳′≈ : ∀ {i} → Convertible _≳′_ [ i ]_≈_
  convert≳′≈ = is-convertible (convert ∘ ≳⇒≈′)

  convert≳≈′ : ∀ {i} → Convertible [ i ]_≳_ [ i ]_≈′_
  convert≳≈′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ≳ q → [ i ] p ≈′ q
    force (lemma p≳q) = ≳⇒≈ p≳q

  convert≳′≈′ : ∀ {i} → Convertible [ i ]_≳′_ [ i ]_≈′_
  convert≳′≈′ = is-convertible ≳⇒≈′

  trans≈≈ : Transitive _≈_ _≈_
  trans≈≈ = is-transitive transitive-≈

  trans≈′≈ : Transitive _≈′_ _≈_
  trans≈′≈ = is-transitive λ p≈′q → transitive (force p≈′q)

  trans≈′≈′ : Transitive _≈′_ _≈′_
  trans≈′≈′ = is-transitive λ p≈′q q≈′r →
    transitive-≈′ p≈′q (convert q≈′r)

  trans≈≈′ : Transitive _≈_ _≈′_
  trans≈≈′ = is-transitive λ p≈q q≈′r →
    transitive-≈′ (convert p≈q) (convert q≈′r)

  trans∼≈ : ∀ {i} → Transitive _∼_ [ i ]_≈_
  trans∼≈ = is-transitive (transitive-≳≈ ∘ convert {a = ℓ})

  trans∼′≈ : ∀ {i} → Transitive _∼′_ [ i ]_≈_
  trans∼′≈ = is-transitive (transitive-≳≈ ∘ convert {a = ℓ})

  trans∼′≈′ : ∀ {i} → Transitive _∼′_ [ i ]_≈′_
  trans∼′≈′ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → p ∼′ q → [ i ] q ≈′ r → [ i ] p ≈′ r
    force (lemma p∼′q q≈′r) =
      transitive-≳≈ (convert {a = ℓ} p∼′q) (force q≈′r)

  trans∼≈′ : ∀ {i} → Transitive _∼_ [ i ]_≈′_
  trans∼≈′ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → p ∼ q → [ i ] q ≈′ r → [ i ] p ≈′ r
    force (lemma p∼q q≈′r) =
      transitive-≳≈ (convert {a = ℓ} p∼q) (force q≈′r)

  trans≈∼ : ∀ {i} → Transitive′ [ i ]_≈_ _∼_
  trans≈∼ = is-transitive transitive-≈∼

  trans≈∼′ : ∀ {i} → Transitive′ [ i ]_≈_ _∼′_
  trans≈∼′ = is-transitive (λ p≈q q∼′r →
    transitive-≈∼ p≈q (convert {a = ℓ} q∼′r))

  trans≈′∼ : ∀ {i} → Transitive′ [ i ]_≈′_ _∼_
  trans≈′∼ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → [ i ] p ≈′ q → q ∼ r → [ i ] p ≈′ r
    force (lemma p≈′q q∼r) = transitive-≈∼ (force p≈′q) q∼r

  trans≈′∼′ : ∀ {i} → Transitive′ [ i ]_≈′_ _∼′_
  trans≈′∼′ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → [ i ] p ≈′ q → q ∼′ r → [ i ] p ≈′ r
    force (lemma p≈′q q∼r) =
      transitive-≈∼ (force p≈′q) (convert {a = ℓ} q∼r)

  trans≳≈ : ∀ {i} → Transitive _≳_ [ i ]_≈_
  trans≳≈ = is-transitive transitive-≳≈

  trans≳′≈ : ∀ {i} → Transitive _≳′_ [ i ]_≈_
  trans≳′≈ = is-transitive (transitive-≳≈ ∘ convert {a = ℓ})

  trans≳′≈′ : ∀ {i} → Transitive _≳′_ [ i ]_≈′_
  trans≳′≈′ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → p ≳′ q → [ i ] q ≈′ r → [ i ] p ≈′ r
    force (lemma p≳′q q≈′r) =
      transitive-≳≈ (convert {a = ℓ} p≳′q) (force q≈′r)

  trans≳≈′ : ∀ {i} → Transitive _≳_ [ i ]_≈′_
  trans≳≈′ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → p ≳ q → [ i ] q ≈′ r → [ i ] p ≈′ r
    force (lemma p≳q q≈′r) = transitive-≳≈ p≳q (force q≈′r)

  -- For a proof showing that the following lemma cannot, in general,
  -- be made size-preserving in its first argument, see
  -- Bisimilarity.Weak.Delay-monad.size-preserving-transitivity-≈≳ˡ⇔uninhabited.

  trans≈≳ : Transitive′ _≈_ _≳_
  trans≈≳ = is-transitive (λ p≈q → transitive p≈q ∘ ≳⇒≈)

  trans≈≳′ : Transitive′ _≈_ _≳′_
  trans≈≳′ = is-transitive (λ p≈q → transitive p≈q ∘ ≳⇒≈ ∘ convert)

  trans≈′≳′ : Transitive′ _≈′_ _≳′_
  trans≈′≳′ = is-transitive (λ p≈′q → transitive p≈′q ∘ ≳⇒≈′)

  trans≈′≳ : Transitive′ _≈′_ _≳_
  trans≈′≳ = is-transitive (λ p≈′q → transitive p≈′q ∘ ≳⇒≈′ ∘ convert)

  trans≈≲ : ∀ {i} → Transitive′ [ i ]_≈_ _≲_
  trans≈≲ = is-transitive transitive-≈≲

  trans≈≲′ : ∀ {i} → Transitive′ [ i ]_≈_ _≲′_
  trans≈≲′ = is-transitive (λ p≈q q≲r → transitive-≈≲ p≈q (force q≲r))

  trans≈′≲ : ∀ {i} → Transitive′ [ i ]_≈′_ _≲_
  trans≈′≲ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → [ i ] p ≈′ q → q ≲ r → [ i ] p ≈′ r
    force (lemma p≈′q q≳′r) =
      transitive-≈≲ (force p≈′q) q≳′r

  trans≈′≲′ : ∀ {i} → Transitive′ [ i ]_≈′_ _≲′_
  trans≈′≲′ = is-transitive (λ p≈′q q≲′r →
                transitive′ p≈′q (force q≲′r))


module Impure.LFRef.Properties.Soundness where

open import Data.Nat
open import Data.Sum
open import Data.Product as Pr
open import Data.List as List hiding (monad)
open import Data.Fin using (fromℕ≤; Fin)
open import Data.Vec hiding (_∷ʳ_; _>>=_)
open import Data.Star hiding (_>>=_)
open import Function
open import Extensions.List as L

open import Relation.Binary.PropositionalEquality as P
open import Relation.Binary.Core using (REL; Reflexive)
open import Relation.Binary.List.Pointwise as PRel hiding (refl)

open import Impure.LFRef.Syntax
open import Impure.LFRef.Welltyped
open import Impure.LFRef.Eval
open import Impure.LFRef.Properties.Decidable

progress : ∀ {𝕊 Σ A} {e : Exp 0} {μ} →
           𝕊 , Σ ⊢ μ →
           𝕊 , Σ , [] ⊢ₑ e ∶ A →
           --------------------------------------
           (ExpVal e) ⊎ (∃₂ λ e' μ' → (𝕊 ⊢ e , μ ≻ e' , μ'))

progress p (tm (con k ts _)) = inj₁ (tm con)
progress p (tm unit) = inj₁ (tm unit)
progress p (tm (var ()))
progress p (tm (loc x)) = inj₁ (tm loc)

progress p (fn ·★[ q ] ts) = inj₂ (, (, funapp-β fn (tele-fit-length ts)))

progress p (ref e) with progress p e
progress p (ref {_} {tm _} (tm _)) | inj₁ (tm v) = inj₂ (, (, ref-val v))
progress p (ref {_} {_ ·★ _} e) | inj₁ ()
progress p (ref {_} {ref x} e) | inj₁ ()
progress p (ref {_} { ! x } e) | inj₁ ()
progress p (ref {_} {x ≔ x₁} e) | inj₁ ()
progress p (ref e) | inj₂ (e' , μ' , step) = inj₂ (, (, ref-clos step))

progress p (!_ {x = x} e) with progress p e
progress p (!_ {_} {tm .(loc _)} (tm (loc x))) | inj₁ (tm _) =
  inj₂ (, (, !-val (P.subst (_<_ _) (pointwise-length p) ([]=-length x))))
progress p (!_ {_} {tm (var ())} e) | _
progress p (!_ {_} {_ ·★ _} e) | inj₁ ()
progress p (!_ {_} {ref x} e) | inj₁ ()
progress p (!_ {_} { ! x } e) | inj₁ ()
progress p (!_ {_} {x ≔ x₁} e) | inj₁ ()
progress p (! e) | inj₂ (e' , μ' , step) = inj₂ (, (, !-clos step))

progress p (l ≔ e) with progress p l | progress p e
progress p (tm () ≔ e) | inj₁ (tm unit) | (inj₁ (tm x₁))
progress p (tm () ≔ e) | inj₁ (tm con) | (inj₁ (tm x₁))
progress p (tm (loc x) ≔ e) | inj₁ (tm loc) | (inj₁ (tm v)) =
  inj₂ (, (, ≔-val (P.subst (_<_ _) (pointwise-length p) ([]=-length x)) v))
progress p (l ≔ e) | inj₂ (_ , _ , step) | _ = inj₂ (, (, ≔-clos₁ step))
progress p (l ≔ e) | inj₁ v | (inj₂ (_ , _ , step)) = inj₂ (, (, ≔-clos₂ v step))

progress-seq : ∀ {𝕊 Σ A} {e : SeqExp 0} {μ} →
                𝕊 , Σ ⊢ μ →
                𝕊 , Σ , [] ⊢ₛ e ∶ A →
                --------------------------------------
                SeqExpVal e ⊎ ∃₂ λ e' μ' → (𝕊 ⊢ e , μ ≻ₛ e' , μ')

progress-seq p (ret e) with progress p e
... | inj₁ (tm v) = inj₁ (ret-tm v)
... | inj₂ (e' , μ' , step) = inj₂ (, , ret-clos step)
progress-seq p (lett x e) with progress p x
progress-seq p (lett x e) | inj₁ (tm v) = inj₂ (, (, lett-β))
progress-seq p (lett x e) | inj₂ (x' , μ' , step) = inj₂ (, (, lett-clos step))

postulate

  lem₂ : ∀ {n 𝕊 Σ e a b t} {Γ : Ctx n} →
           𝕊 , Σ , (a :+: Γ) ⊢ₑ e ∶ weaken₁-tp b →
           𝕊 , Σ , Γ ⊢ t ∶ a →
           𝕊 , Σ , Γ ⊢ₑ (e exp/ (sub t)) ∶ b

  lem₃ : ∀ {n 𝕊 Σ e a b t} {Γ : Ctx n} →
           𝕊 , Σ , (a :+: Γ) ⊢ₛ e ∶ weaken₁-tp b →
           𝕊 , Σ , Γ ⊢ t ∶ a →
           𝕊 , Σ , Γ ⊢ₛ (e seq/ (sub t)) ∶ b

  lem₁ : ∀ {n 𝕊 Σ φ ts} {Γ : Ctx n} →
          𝕊 ⊢ φ fnOk →
          (p : 𝕊 , Σ , Γ ⊢ ts ∶ⁿ weaken+-tele n (Fun.args φ)) →
          (q : length ts ≡ (Fun.m φ)) →
          𝕊 , Σ , Γ ⊢ₑ (!call (Fun.body φ) ts q) ∶ ((Fun.returntype φ) fun[ ts / q ])

-- loading from a welltyped store results in a welltyped term
!load-ok : ∀ {Σ Σ' A μ i 𝕊} →
            -- store-welltypedness type (strengthened for induction)
            Rel (λ A x → 𝕊 , Σ , [] ⊢ (proj₁ x) ∶ A) Σ' μ →
            Σ' L.[ i ]= A → (l : i < length μ) →
            𝕊 , Σ , [] ⊢ (!load μ l) ∶ A
!load-ok [] ()
!load-ok (x∼y ∷ p) here (s≤s z≤n) = x∼y
!load-ok (x∼y ∷ p) (there q) (s≤s l) = !load-ok p q l

mutual
  ⊒-preserves-tm : ∀ {n Γ Σ Σ' A 𝕊} {t : Term n} → Σ' ⊒ Σ → 𝕊 , Σ , Γ ⊢ t ∶ A → 𝕊 , Σ' , Γ ⊢ t ∶ A
  ⊒-preserves-tm ext unit = unit
  ⊒-preserves-tm ext (var x) = var x
  ⊒-preserves-tm ext (con x p q) = con x (⊒-preserves-tele ext p) q
  ⊒-preserves-tm ext (loc x) = loc (xs⊒ys[i] x ext)

  ⊒-preserves-tele : ∀ {n m Γ Σ Σ' 𝕊} {ts : List (Term n)} {T : Tele n m} → Σ' ⊒ Σ →
                    𝕊 , Σ , Γ ⊢ ts ∶ⁿ T →
                    𝕊 , Σ' , Γ ⊢ ts ∶ⁿ T
  ⊒-preserves-tele ext ε = ε
  ⊒-preserves-tele ext (x ⟶ p) = ⊒-preserves-tm ext x ⟶ (⊒-preserves-tele ext p)

-- welltypedness is preseved under store extensions
⊒-preserves : ∀ {n Γ Σ Σ' A 𝕊} {e : Exp n} → Σ' ⊒ Σ → 𝕊 , Σ , Γ ⊢ₑ e ∶ A → 𝕊 , Σ' , Γ ⊢ₑ e ∶ A
⊒-preserves ext (tm x) = tm (⊒-preserves-tm ext x)
⊒-preserves ext (x ·★[ refl ] p) with ⊒-preserves-tele ext p
... | p' = x ·★[ refl ] p'

⊒-preserves ext (ref p) = ref (⊒-preserves ext p)
⊒-preserves ext (! p) = ! (⊒-preserves ext p)
⊒-preserves ext (p ≔ q) = ⊒-preserves ext p ≔ ⊒-preserves ext q

⊒-preserves-seq : ∀ {n Γ Σ Σ' A 𝕊} {e : SeqExp n} → Σ' ⊒ Σ → 𝕊 , Σ , Γ ⊢ₛ e ∶ A → 𝕊 , Σ' , Γ ⊢ₛ e ∶ A
⊒-preserves-seq ext (ret e) = ret (⊒-preserves ext e)
⊒-preserves-seq ext (lett e c) = lett (⊒-preserves ext e) (⊒-preserves-seq ext c)

-- helper for lifting preserving reductions into their closure
clos-cong : ∀ {Σ μ 𝕊 A B} {e : Exp 0} (c : Exp 0 → Exp 0) →
                (f : ∀ {Σ'} (ext : Σ' ⊒ Σ) → 𝕊 , Σ' , [] ⊢ₑ e ∶ A → 𝕊 , Σ' , [] ⊢ₑ c e ∶ B) →
                (∃ λ Σ' → 𝕊 , Σ' , [] ⊢ₑ e ∶ A × Σ' ⊒ Σ × 𝕊 , Σ' ⊢ μ) →
                ∃ λ Σ' → 𝕊 , Σ' , [] ⊢ₑ c e ∶ B × Σ' ⊒ Σ × 𝕊 , Σ' ⊢ μ
clos-cong _ f (Σ , wte , ext , μ-wt) = Σ , f ext wte , ext , μ-wt

≻-preserves : ∀ {𝕊 Σ A} {e : Exp 0} {e' μ' μ} →
              𝕊 , [] ⊢ok →
              𝕊 , Σ , [] ⊢ₑ e ∶ A →
              𝕊 , Σ ⊢ μ →
              𝕊 ⊢ e , μ ≻ e' , μ' →
              ----------------------------------------------------
              ∃ λ Σ' → 𝕊 , Σ' , [] ⊢ₑ e' ∶ A × Σ' ⊒ Σ × 𝕊 , Σ' ⊢ μ'

-- variables
≻-preserves ok (tm x) q ()

-- function application
≻-preserves {Σ = Σ} ok (fn ·★[ refl ] ts) q (funapp-β x refl) with
  []=-functional _ _  fn x | all-lookup fn (_,_⊢ok.funs-ok ok)
... | refl | fn-ok = Σ , (lem₁ fn-ok ts refl) , ⊑-refl , q

-- new references
≻-preserves {Σ = Σ} ok (ref {A = A} (tm x)) q (ref-val v) = let ext = (∷ʳ-⊒ A Σ) in
  Σ ∷ʳ A ,
  (tm (loc (P.subst (λ i → _ L.[ i ]= _) (pointwise-length q) (∷ʳ[length] Σ A)))) ,
  ext ,
  pointwise-∷ʳ (PRel.map (⊒-preserves-tm ext) q) (⊒-preserves-tm ext x)
≻-preserves ok (ref p) q (ref-clos step) =
  clos-cong
    ref (const ref)
    (≻-preserves ok p q step)

-- dereferencing
≻-preserves {Σ = Σ₁} ok (! tm (loc x)) q (!-val p)
  = Σ₁ , tm (!load-ok q x p) , ⊑-refl , q
≻-preserves ok (! p) q (!-clos step) =
  clos-cong
    !_ (const !_)
    (≻-preserves ok p q step)

-- assignment
≻-preserves {Σ = Σ₁} ok (_≔_ (tm (loc x)) (tm y)) q (≔-val p v) =
  Σ₁ , tm unit , ⊑-refl , pointwise-[]≔ q x p y
≻-preserves ok (p ≔ p₁) q (≔-clos₁ step) =
  clos-cong
    (λ p' → p' ≔ _) (λ ext p' → p' ≔ ⊒-preserves ext p₁)
    (≻-preserves ok p q step)
≻-preserves ok (p ≔ p₁) q (≔-clos₂ v step) =
  clos-cong
    (λ p' → _ ≔ p') (λ ext p' → ⊒-preserves ext p ≔ p')
    (≻-preserves ok p₁ q step)

-- let binding
≻ₛ-preserves : ∀ {𝕊 Σ A} {e : SeqExp 0} {e' μ' μ} →
              𝕊 , [] ⊢ok →
              𝕊 , Σ , [] ⊢ₛ e ∶ A →
              𝕊 , Σ ⊢ μ →
              𝕊 ⊢ e , μ ≻ₛ e' , μ' →
              -------------------------------------------------------
              ∃ λ Σ' → 𝕊 , Σ' , [] ⊢ₛ e' ∶ A × Σ' ⊒ Σ × 𝕊 , Σ' ⊢ μ'
≻ₛ-preserves {Σ = Σ} ok (lett (tm x) p) q lett-β = Σ , lem₃ p x , ⊑-refl , q
≻ₛ-preserves ok (lett p p₁) q (lett-clos step) with ≻-preserves ok p q step
... | Σ₂ , wte' , Σ₂⊒Σ₁ , q' = Σ₂ , lett wte' ((⊒-preserves-seq Σ₂⊒Σ₁ p₁)) , Σ₂⊒Σ₁ , q'
≻ₛ-preserves ok (ret e) q (ret-clos step) with ≻-preserves ok e q step
... | Σ₂ , wte' , Σ₂⊒Σ₁ , q' = Σ₂ , ret wte' , Σ₂⊒Σ₁ , q'

module SafeEval where

  open import Category.Monad.Partiality
  open import Category.Monad
  open import Coinduction
  open import Level as Lev

  open RawMonad {f = Lev.zero} monad

  -- typesafe evaluation in the partiality/delay-monad;
  -- or "soundness" modulo non-trivial divergence
  eval : ∀ {𝕊 Σ a μ} {e : SeqExp 0} →
        𝕊 , [] ⊢ok → -- given an ok signature context,
        𝕊 , Σ , [] ⊢ₛ e ∶ a → -- a welltyped closed expression,
        𝕊 , Σ ⊢ μ → -- and a welltyped store
       ---------------------------------------------------------------------------------------
        -- eval will either diverge or provide evidence of a term v, store μ' and storetype Σ'
        (∃ λ v → ∃ λ μ' → ∃ λ Σ' →
          -- such that v is a value,
          (SeqExpVal v) ×
          -- ...there is a sequence of small steps from e to v
          (𝕊 ⊢ e , μ ≻⋆ v , μ') ×
          -- ...v has the same type as e
          (𝕊 , Σ' , [] ⊢ₛ v ∶ a) ×
          -- ...μ' is typed by Σ'
          (𝕊 , Σ' ⊢ μ') ×
          -- ...and finally, Σ' is an extension of Σ
          (Σ' ⊒ Σ)) ⊥

  eval 𝕊-ok wte μ-ok with progress-seq μ-ok wte
  eval 𝕊-ok wte μ-ok | inj₁ v = now (_ , _ , _ , v , ε , wte , μ-ok , ⊑-refl)
  eval 𝕊-ok wte μ-ok | inj₂ (e' , μ' , step) with ≻ₛ-preserves 𝕊-ok wte μ-ok step
  ... | (Σ' , wte' , ext₁ , μ'-ok) with later (♯ (eval 𝕊-ok wte' μ'-ok))
  ... | (now (v' , μ'' , Σ'' , val , steps , wte'' , μ''-ok , ext₂)) =
    now (v' , (μ'' , (Σ'' , val , ((steps ▻ step) , (wte'' , μ''-ok , ⊑-trans ext₁ ext₂)))))
  ... | (later x) = later (♯ (♭ x >>=
    λ{ (v' , μ'' , Σ'' , val , steps , wte'' , μ''-ok , ext₂) →
      now (v' , μ'' , Σ'' , val , steps ▻ step , wte'' , μ''-ok , ⊑-trans ext₁ ext₂)
    }))


-- P: <E[fork e]> --> <E[()]> | <e>
module Properties.StepFork where

open import Data.List
open import Data.List.All
open import Data.Product

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Typing
open import Syntax
open import Global
open import Channel
open import Values
open import Session
open import Schedule

open import ProcessSyntax
open import ProcessRun

open import Properties.Base

mkfork : ∀ {Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ → Expr Φ₁ TUnit → Expr (TUnit ∷ Φ₂) TUnit → Expr Φ TUnit
mkfork sp e E = letbind sp (fork e) E

mklhs : ∀ {Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂
  → Expr Φ₁ TUnit → Expr (TUnit ∷ Φ₂) TUnit → Proc Φ
mklhs sp e E =
  exp (mkfork sp e E)

mkrhs : ∀ {Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂
  → Expr Φ₁ TUnit → Expr (TUnit ∷ Φ₂) TUnit → Proc Φ
mkrhs sp e E =
  par sp (exp e) (exp (letbind (split-all-right _) (unit []) E))

-- weaken2-command : ∀ {G} G' G'' → Command (G' ++ G) → Command (G' ++ inactive-clone G'' ++ G)

-- obviously true, but requires a nasty inductive proof
postulate
  weaken2-ident : ∀ {G} → (cmd : Command G) → weaken2-command [] [] cmd ≡ cmd

reduction : (e : Expr [] TUnit) → (E : Expr (TUnit ∷ []) TUnit)
  →
    let lhs = (runProc [] (mklhs [] e E) (vnil []-inactive)) in
    let rhs = (runProc [] (mkrhs [] e E) (vnil []-inactive)) in
    let rhs' = one-step rhs in
    one-step lhs ≡
    (Forked , proj₁ rhs , proj₂ rhs)
reduction e E
  with ssplit-refl-left-inactive []
... | G' , ina-G' , ss-GG'
  rewrite weaken2-ident (run [] ss-[] e (vnil []-inactive) (halt []-inactive UUnit))
  = refl


module ANF where

open import Data.List
open import Data.List.All

open import Typing
open import DSyntax
open import Syntax

-- transform a direct style expression into and anf expression

anf : ∀ {φ t} → DExpr φ t → Expr φ t
anf (var x) = var x
anf (nat unr-φ i) = nat unr-φ i
anf (unit unr-φ) = unit unr-φ
anf (pair sp de de₁) = letbind sp (anf de) (letbind (rght (split-all-left _)) (anf de₁) (pair (rght (left [])) (here []) (here [])))
anf (letpair sp de de₁) = letbind sp (anf de) (letpair (left (split-all-right _)) (here []) (anf de₁))
anf (fork de) = fork (anf de)
anf (new unr-φ s) = new unr-φ s
anf (send sp de de₁) = letbind sp (anf de) (letbind (rght (split-all-left _)) (anf de₁) (send (rght (left [])) (here []) (here [])))
anf (recv de) = letbind (split-all-left _) (anf de) (recv (here []))
anf (close de) = letbind (split-all-left _) (anf de) (close (here []))
anf (wait de) = letbind (split-all-left _) (anf de) (wait (here []))
anf (select lab de) = letbind (split-all-left _) (anf de) (select lab (here []))
anf (branch sp de de₁ de₂) = letbind sp (anf de) (branch (left (split-all-right _)) (here []) (anf de₁) (anf de₂))
anf (ulambda unr-φ de) = ulambda (split-all-left _) unr-φ [] (anf de)
anf (llambda de) = llambda (split-all-left _) [] (anf de)
anf (app sp de de₁) = letbind sp (anf de) (letbind (rght (split-all-left _)) (anf de₁) (app (rght (left [])) (here []) (here [])))
anf (subsume de t≤t') = subsume (anf de) t≤t'


{-

  - Automatically generate UARel and DUARel instances

-}
{-# OPTIONS --no-exact-split --safe #-}
module Cubical.Displayed.Auto where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Displayed.Base
open import Cubical.Displayed.Subst
open import Cubical.Displayed.Morphism

open import Cubical.Displayed.Constant
open import Cubical.Displayed.Function
open import Cubical.Displayed.Generic
open import Cubical.Displayed.Sigma
open import Cubical.Displayed.Unit
open import Cubical.Displayed.Universe

open import Cubical.Data.List.Base
open import Cubical.Data.Nat.Base
open import Cubical.Data.Sigma.Base
open import Cubical.Data.Unit.Base

import Agda.Builtin.Reflection as R
open import Cubical.Reflection.Base

-- Descriptor language

mutual
  data UARelDesc : ∀ {ℓA ℓ≅A} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → Typeω where

    generic : ∀ {ℓA} {A : Type ℓA} → UARelDesc (𝒮-generic A)

    univ : ∀ ℓU → UARelDesc (𝒮-Univ ℓU)

    -- Having a special descriptor for non-dependent × helps to avoid
    -- combinatorial explosion. Automation will try to apply this first.
    prod : ∀ {ℓA ℓ≅A ℓB ℓ≅B}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A)
      {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} (dB : UARelDesc 𝒮-B)
      → UARelDesc (𝒮-A ×𝒮 𝒮-B)

    sigma : ∀ {ℓA ℓ≅A ℓB ℓ≅B}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A)
      {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B)
      → UARelDesc (∫ 𝒮ᴰ-B)

    param : ∀ {ℓA ℓB ℓ≅B} (A : Type ℓA)
      {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} (dB : UARelDesc 𝒮-B)
      → UARelDesc (A →𝒮 𝒮-B)

    pi : ∀ {ℓA ℓ≅A ℓB ℓ≅B}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} (dA : UARelDesc 𝒮-A)
      {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B)
      → UARelDesc (𝒮-Π 𝒮-A 𝒮ᴰ-B)

    unit : UARelDesc 𝒮-Unit

  -- Projections from one UARel to another
  data UARelReindex : ∀ {ℓA ℓ≅A ℓC ℓ≅C}
    {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
    {C : Type ℓC} {𝒮-C : UARel C ℓ≅C}
    (f : UARelHom 𝒮-A 𝒮-C)
    → Typeω
    where

    id : ∀ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      → UARelReindex (𝒮-id 𝒮-A)

    ∘fst : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B}
      {C : Type ℓC} {𝒮-C : UARel C ℓ≅C}
      {f : UARelHom 𝒮-A 𝒮-C}
      → UARelReindex f
      → UARelReindex (𝒮-∘ f (𝒮-fst {𝒮ᴰ-B = 𝒮ᴰ-B}))

    ∘snd : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : Type ℓB} {𝒮-B : UARel B ℓ≅B}
      {C : Type ℓC} {𝒮-C : UARel C ℓ≅C}
      {f : UARelHom 𝒮-B 𝒮-C}
      → UARelReindex f
      → UARelReindex (𝒮-∘ f (𝒮-snd {𝒮-A = 𝒮-A}))

    ∘app : ∀ {ℓA ℓB ℓ≅B ℓC ℓ≅C}
      {A : Type ℓA}
      {B : Type ℓB} {𝒮-B : UARel B ℓ≅B}
      {C : Type ℓC} {𝒮-C : UARel C ℓ≅C}
      {f : UARelHom 𝒮-B 𝒮-C}
      → UARelReindex f
      → (a : A) → UARelReindex (𝒮-∘ f (𝒮-app a))

  data SubstRelDesc : ∀ {ℓA ℓ≅A ℓB}
    {A : Type ℓA} (𝒮-A : UARel A ℓ≅A)
    {B : A → Type ℓB} (𝒮ˢ-B : SubstRel 𝒮-A B) → Typeω
    where

    generic : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB}
      → SubstRelDesc 𝒮-A (𝒮ˢ-generic 𝒮-A B)

    constant : ∀ {ℓA ℓ≅A ℓB}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB}
      → SubstRelDesc 𝒮-A (𝒮ˢ-const 𝒮-A B)

    -- We have an element DUARel over any 𝒮-A with a proejction to a universe
    -- that can be described with UARelReindex
    el : ∀ {ℓA ℓ≅A ℓU} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {f : UARelHom 𝒮-A (𝒮-Univ ℓU)}
      → UARelReindex f
      → SubstRelDesc 𝒮-A (𝒮ˢ-reindex f (𝒮ˢ-El ℓU))

    prod : ∀ {ℓA ℓ≅A ℓB ℓC}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B)
      {C : A → Type ℓC} {𝒮ˢ-C : SubstRel 𝒮-A C} (dC : SubstRelDesc 𝒮-A 𝒮ˢ-C)
      → SubstRelDesc 𝒮-A (𝒮ˢ-B ×𝒮ˢ 𝒮ˢ-C)

    sigma : ∀ {ℓA ℓ≅A ℓB ℓC}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B)
      {C : Σ A B → Type ℓC} {𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C} (dC : SubstRelDesc (∫ˢ 𝒮ˢ-B) 𝒮ˢ-C)
      → SubstRelDesc 𝒮-A (𝒮ˢ-Σ 𝒮ˢ-B 𝒮ˢ-C)

    pi : ∀ {ℓA ℓ≅A ℓB ℓC}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B)
      {C : Σ A B → Type ℓC} {𝒮ˢ-C : SubstRel (∫ˢ 𝒮ˢ-B) C} (dC : SubstRelDesc (∫ˢ 𝒮ˢ-B) 𝒮ˢ-C)
      → SubstRelDesc 𝒮-A (𝒮ˢ-Π 𝒮ˢ-B 𝒮ˢ-C)

  data DUARelDesc : ∀ {ℓA ℓ≅A ℓB ℓ≅B}
    {A : Type ℓA} (𝒮-A : UARel A ℓ≅A)
    {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B) → Typeω
    where

    generic : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : A → Type ℓB}
      → DUARelDesc 𝒮-A (𝒮ᴰ-generic 𝒮-A B)

    constant : ∀ {ℓA ℓ≅A ℓB ℓ≅B}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : Type ℓB} {𝒮-B : UARel B ℓ≅B}
      → UARelDesc 𝒮-B
      → DUARelDesc 𝒮-A (𝒮ᴰ-const 𝒮-A 𝒮-B)

    el : ∀ {ℓA ℓ≅A ℓU} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {f : UARelHom 𝒮-A (𝒮-Univ ℓU)}
      → UARelReindex f
      → DUARelDesc 𝒮-A (𝒮ᴰ-reindex f (𝒮ᴰ-El ℓU))

    prod : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B)
      {C : A → Type ℓC} {𝒮ᴰ-C : DUARel 𝒮-A C ℓ≅C} (dC : DUARelDesc 𝒮-A 𝒮ᴰ-C)
      → DUARelDesc 𝒮-A (𝒮ᴰ-B ×𝒮ᴰ 𝒮ᴰ-C)

    sigma : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B)
      {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C} (dC : DUARelDesc (∫ 𝒮ᴰ-B) 𝒮ᴰ-C)
      → DUARelDesc 𝒮-A (𝒮ᴰ-Σ 𝒮ᴰ-B 𝒮ᴰ-C)

    pi : ∀ {ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B} (dB : DUARelDesc 𝒮-A 𝒮ᴰ-B)
      {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ 𝒮ᴰ-B) C ℓ≅C} (dC : DUARelDesc (∫ 𝒮ᴰ-B) 𝒮ᴰ-C)
      → DUARelDesc 𝒮-A (𝒮ᴰ-Π 𝒮ᴰ-B 𝒮ᴰ-C)

    piˢ : ∀ {ℓA ℓ≅A ℓB ℓC ℓ≅C}
      {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
      {B : A → Type ℓB} {𝒮ˢ-B : SubstRel 𝒮-A B} (dB : SubstRelDesc 𝒮-A 𝒮ˢ-B)
      {C : Σ A B → Type ℓC} {𝒮ᴰ-C : DUARel (∫ˢ 𝒮ˢ-B) C ℓ≅C} (dC : DUARelDesc (∫ˢ 𝒮ˢ-B) 𝒮ᴰ-C)
      → DUARelDesc 𝒮-A (𝒮ᴰ-Πˢ 𝒮ˢ-B 𝒮ᴰ-C)

private
  getUARel : ∀ {ℓA ℓ≅A} {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
    → UARelDesc 𝒮-A → UARel A ℓ≅A
  getUARel {𝒮-A = 𝒮-A} _ = 𝒮-A

  getDUARel : ∀ {ℓA ℓ≅A ℓB ℓ≅B}
    {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
    {B : A → Type ℓB} {𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B}
    → DUARelDesc 𝒮-A 𝒮ᴰ-B → DUARel 𝒮-A B ℓ≅B
  getDUARel {𝒮ᴰ-B = 𝒮ᴰ-B} _ = 𝒮ᴰ-B

-- Magic number
private
  FUEL = 10000

mutual
  autoUARelDesc : ℕ → R.Term → R.TC Unit
  autoUARelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ]
  autoUARelDesc (suc n) hole =
    tryUniv <|> tryProd <|> trySigma <|> tryParam <|> tryPi <|> tryUnit <|> useGeneric
    where
    tryUniv : R.TC Unit
    tryUniv = R.unify (R.con (quote UARelDesc.univ) [ varg R.unknown ]) hole

    tryBinary : R.Name → R.TC Unit
    tryBinary name =
      newMeta R.unknown >>= λ hole₁ →
      newMeta R.unknown >>= λ hole₂ →
      R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >>
      autoUARelDesc n hole₁ >>
      autoDUARelDesc n hole₂

    tryParam : R.TC Unit
    tryParam =
      newMeta R.unknown >>= λ paramTy →
      newMeta R.unknown >>= λ hole₁ →
      R.unify (R.con (quote UARelDesc.param) (paramTy v∷ hole₁ v∷ [])) hole >>
      autoUARelDesc n hole₁

    tryProd = tryBinary (quote UARelDesc.prod)
    trySigma = tryBinary (quote UARelDesc.sigma)
    tryPi = tryBinary (quote UARelDesc.pi)

    tryUnit : R.TC Unit
    tryUnit = R.unify (R.con (quote UARelDesc.unit) []) hole

    useGeneric : R.TC Unit
    useGeneric = R.unify (R.con (quote UARelDesc.generic) []) hole

  autoUARelReindex : ℕ → R.Term → R.TC Unit
  autoUARelReindex zero hole = R.typeError [ R.strErr "Out of fuel" ]
  autoUARelReindex (suc n) hole =
    tryId <|> tryFst <|> trySnd <|> tryApp
    where
    tryId : R.TC Unit
    tryId = R.unify (R.con (quote UARelReindex.id) []) hole

    tryUnary : R.Name → R.TC Unit
    tryUnary name =
      newMeta R.unknown >>= λ hole₁ →
      R.unify (R.con name [ varg hole₁ ]) hole >>
      autoUARelReindex n hole₁

    tryFst = tryUnary (quote UARelReindex.∘fst)
    trySnd = tryUnary (quote UARelReindex.∘snd)

    tryApp : R.TC Unit
    tryApp =
      newMeta R.unknown >>= λ hole₁ →
      newMeta R.unknown >>= λ param →
      R.unify (R.con (quote UARelReindex.∘app) (hole₁ v∷ param v∷ [])) hole >>
      autoUARelReindex n hole₁

  autoSubstRelDesc : ℕ → R.Term → R.TC Unit
  autoSubstRelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ]
  autoSubstRelDesc (suc n) hole =
    tryConstant <|> tryEl <|> tryProd <|> trySigma <|> tryPi <|> useGeneric
    where
    tryConstant : R.TC Unit
    tryConstant =
      R.unify (R.con (quote SubstRelDesc.constant) []) hole

    tryEl : R.TC Unit
    tryEl =
      newMeta R.unknown >>= λ hole₁ →
      R.unify (R.con (quote SubstRelDesc.el) [ varg hole₁ ]) hole >>
      autoUARelReindex n hole₁

    tryBinary : R.Name → R.TC Unit
    tryBinary name =
      newMeta R.unknown >>= λ hole₁ →
      newMeta R.unknown >>= λ hole₂ →
      R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >>
      autoSubstRelDesc n hole₁ >>
      autoSubstRelDesc n hole₂

    tryProd = tryBinary (quote SubstRelDesc.prod)
    trySigma = tryBinary (quote SubstRelDesc.sigma)
    tryPi = tryBinary (quote SubstRelDesc.pi)

    useGeneric : R.TC Unit
    useGeneric = R.unify (R.con (quote SubstRelDesc.generic) []) hole

  autoDUARelDesc : ℕ → R.Term → R.TC Unit
  autoDUARelDesc zero hole = R.typeError [ R.strErr "Out of fuel" ]
  autoDUARelDesc (suc n) hole =
    tryConstant <|> tryEl <|> tryProd <|> trySigma <|> tryPiˢ <|> tryPi <|> useGeneric
    where
    tryConstant : R.TC Unit
    tryConstant =
      newMeta R.unknown >>= λ hole₁ →
      R.unify (R.con (quote DUARelDesc.constant) [ varg hole₁ ]) hole >>
      autoUARelDesc n hole₁

    tryEl : R.TC Unit
    tryEl =
      newMeta R.unknown >>= λ hole₁ →
      R.unify (R.con (quote DUARelDesc.el) [ varg hole₁ ]) hole >>
      autoUARelReindex n hole₁

    tryBinary : R.Name → R.TC Unit
    tryBinary name =
      newMeta R.unknown >>= λ hole₁ →
      newMeta R.unknown >>= λ hole₂ →
      R.unify (R.con name (hole₁ v∷ hole₂ v∷ [])) hole >>
      autoDUARelDesc n hole₁ >>
      autoDUARelDesc n hole₂

    tryProd = tryBinary (quote DUARelDesc.prod)
    trySigma = tryBinary (quote DUARelDesc.sigma)
    tryPi = tryBinary (quote DUARelDesc.pi)

    tryPiˢ : R.TC Unit
    tryPiˢ =
      newMeta R.unknown >>= λ hole₁ →
      newMeta R.unknown >>= λ hole₂ →
      R.unify (R.con (quote DUARelDesc.piˢ) (hole₁ v∷ hole₂ v∷ [])) hole >>
      autoSubstRelDesc n hole₁ >>
      autoDUARelDesc n hole₂

    useGeneric : R.TC Unit
    useGeneric = R.unify (R.con (quote DUARelDesc.generic) []) hole

module DisplayedAutoMacro where
  autoUARel : ∀ {ℓA} (A : Type ℓA) → ℕ → R.Term → R.TC Unit
  autoUARel A n hole =
    R.quoteTC A >>= λ `A` →
    newMeta R.unknown >>= λ desc →
    makeAuxiliaryDef "autoUA"
      (R.def (quote UARel) (`A` v∷ R.unknown v∷ []))
      (R.def (quote getUARel) [ varg desc ])
      >>= λ uaTerm →
    R.unify hole uaTerm >>
    autoUARelDesc n desc

  autoDUARel : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB)
    → ℕ → R.Term → R.TC Unit
  autoDUARel 𝒮-A B n hole =
    R.quoteTC 𝒮-A >>= λ `𝒮-A` →
    R.quoteTC B >>= λ `B` →
    newMeta R.unknown >>= λ desc →
    makeAuxiliaryDef "autoDUA"
      (R.def (quote DUARel) (`𝒮-A` v∷ `B` v∷ R.unknown v∷ []))
      (R.def (quote getDUARel) [ varg desc ])
      >>= λ duaTerm →
    R.unify hole duaTerm >>
    autoDUARelDesc n desc

macro
  autoUARel : ∀ {ℓA} (A : Type ℓA) → R.Term → R.TC Unit
  autoUARel A = DisplayedAutoMacro.autoUARel A FUEL

  autoDUARel : ∀ {ℓA ℓ≅A ℓB} {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB)
    → R.Term → R.TC Unit
  autoDUARel 𝒮-A B = DisplayedAutoMacro.autoDUARel 𝒮-A B FUEL

private
  module Example (A : Type) (a₀ : A) where

    example0 : DUARel (autoUARel Type) (λ X → X → A × X) ℓ-zero
    example0 = autoDUARel _ _

    example0' : {X Y : Type} (e : X ≃ Y)
      (f : X → A × X) (g : Y → A × Y)
      → (∀ x → (f x .fst ≡ g (e .fst x) .fst) × (e .fst (f x .snd) ≡ g (e .fst x) .snd))
      → PathP (λ i → ua e i → A × ua e i) f g
    example0' e f g = example0 .DUARel.uaᴰ f e g .fst

    -- An example where a DUARel is parameterized over a pair of types

    example1 : DUARel (autoUARel (Type × Type)) (λ (X , Z) → X → Z) ℓ-zero
    example1 = autoDUARel _ _

    example1' : {X Y : Type} (e : X ≃ Y) {Z W : Type} (h : Z ≃ W)
      (f : X → Z) (g : Y → W)
      → (∀ x → h .fst (f x) ≡ g (e .fst x))
      → PathP (λ i → ua e i → ua h i) f g
    example1' e h f g = example1 .DUARel.uaᴰ f (e , h) g .fst

    -- An example where a DUARel is parameterized over a family of types

    example2 : DUARel (autoUARel (A → Type)) (λ B → B a₀) ℓ-zero
    example2 = autoDUARel _ _

    example2' : {B C : A → Type} (e : (a : A) → B a ≃ C a)
      (b : B a₀) (c : C a₀)
      → e a₀ .fst b ≡ c
      → PathP (λ i → ua (e a₀) i) b c
    example2' e b c = example2 .DUARel.uaᴰ b e c .fst


open import Prelude
open import RW.Language.RTerm
open import RW.Language.RTermUtils
open import RW.Language.RTermIdx
open import RW.Data.RTrie

open import RW.Strategy using (Trs; Symmetry; UData; u-data)

module RW.Language.RTermTrie where

  open import RW.Utils.Monads
  open Monad {{...}}

  add-action : Name → ℕ × RTrie → ℕ × RTrie
  add-action act bt
    = let
      ty = lift-ivar $ typeResult $ Ag2RType $ type act
    in insertTerm act ty bt

  replicateM : {A : Set} → List (Maybe A) → Maybe (List A)
  replicateM [] = just []
  replicateM (nothing ∷ _)  = nothing
  replicateM (just x  ∷ xs) with replicateM xs
  ...| just xs' = just (x ∷ xs')
  ...| nothing  = nothing

  postulate
    not-found       : Name × UData
    ul-is-nothing   : Name × UData

  search-action : RTermName → RBinApp ⊥ → RTrie → List (Name × UData)
  search-action hd (_ , g₁ , g₂) trie
    = let g□ = g₁ ∩↑ g₂
          u₁ = g□ -↓ g₁
          u₂ = g□ -↓ g₂
          ul = replicateM (u₁ ∷ u₂ ∷ [])
    in maybe (mkSearch g□) (ul-is-nothing ∷ []) ul
    where
      convert : RTerm (Maybe ⊥) → List (ℕ × RTerm ⊥) × Name → Name × UData
      convert g□ (ns , act) = act , u-data (⊥2UnitCast g□) ns []

      convert-sym : RTerm (Maybe ⊥) → List (ℕ × RTerm ⊥) × Name → Name × UData
      convert-sym g□ (ns , act) = act , u-data (⊥2UnitCast g□) ns (Symmetry ∷ [])

      mkLkup : List (RTerm ⊥) → Maybe (List (List (ℕ × RTerm ⊥) × Name))
      mkLkup ul with lookupTerm (rapp hd ul) trie
      ...| [] = nothing
      ...| l  = just l

      mkSearch : RTerm (Maybe ⊥) → List (RTerm ⊥) → List (Name × UData)
      mkSearch g□ ul with mkLkup ul
      ...| just l = map (convert g□) l
      ...| nothing with mkLkup (reverse ul)
      ...| nothing = not-found ∷ []
      ...| just l  = map (convert-sym g□) l


-- Andreas, 2011-09-11
module Issue392 where
import Common.Irrelevance

-- Create an non-irrelevant record R1 (at least one field relevant).
record R1 : Set1 where
  field
    .f1 : Set
    f1' : Set

{- This creates a module with an relevant record parameter

   module R1 (r : R1) where
     .f1 : Set -- = R1.f1 r
     f1' : Set
-}

-- Create an irrelevant instance f2 of R1.
record R2 : Set2 where
  field
    .f2 : R1
    f3  : Set

-- This should not succeed.
  open R1 f2 public

{-
identifier f2 is declared irrelevant, so it cannot be used here
when checking that the expression f2 has type R1
-}


module MatchUpNames where
open import ParseTree
open import ScopeState
open import Data.Sum

open import Data.List hiding (lookup)
open import AgdaHelperFunctions

matchUpSignature : TypeSignature -> ScopeState TypeSignature

matchUpExpr : Expr -> ScopeState Expr
matchUpExpr (ident identifier₁) = do
  x <- access identifier₁
  return $ ident x
matchUpExpr (functionApp x x₁ {b} ) = do
  r1 <- matchUpExpr x
  r2 <- matchUpExpr x₁
  return $ functionApp r1 r2 {b}
matchUpExpr (namedArgument arg {b} {bef} {aft}) = do
  x <- matchUpSignature arg
  return $ namedArgument x {b} {bef} {aft}
matchUpExpr x =  return x

matchUpSignature (typeSignature funcName funcType) = do
  newName <- access funcName
  newType <- matchUpExpr funcType
  return $ typeSignature newName newType

matchUpPragma : Pragma -> ScopeState Pragma
matchUpPragma (builtin concept definition) = do
  x <- access definition
  return $ builtin concept x
matchUpPragma x = return x

matchUpTree : ParseTree -> ScopeState ParseTree
matchUpTree (signature signature₁ range₁) = do
  x <- matchUpSignature signature₁
  return $ signature x range₁
matchUpTree (functionDefinition definitionOf params body range₁) = do
  newDef <- access definitionOf
  newParams <- mapState matchUpExpr params
  newBody <- matchUpExpr body
  return $ functionDefinition newDef newParams newBody range₁
matchUpTree (dataStructure dataName parameters indexInfo constructors range₁ {comments}) = do
  newName <- access dataName
  newParams <- mapState matchUpSignature parameters
  newIndex <- matchUpExpr indexInfo
  newCons <- mapState matchUpSignature constructors
  return $ dataStructure newName newParams newIndex newCons range₁ {comments}
matchUpTree (pragma pragma₁ range₁) = do
  x <- matchUpPragma pragma₁
  return $ pragma x range₁
matchUpTree (moduleName id r) = do
  x <- access id
  return $ moduleName x r
matchUpTree x = return x

matchUpNames : List ParseTree -> ScopeState (List ParseTree)
matchUpNames list = mapState matchUpTree list


{-# OPTIONS --safe #-}

module Definition.Conversion.HelperDecidable where

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Conversion
open import Definition.Conversion.Whnf
open import Definition.Conversion.Soundness
open import Definition.Conversion.Symmetry
open import Definition.Conversion.Stability
open import Definition.Conversion.Conversion
open import Definition.Conversion.Lift
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Reduction
open import Definition.Typed.Consequences.Equality
open import Definition.Typed.Consequences.Inequality as IE
open import Definition.Typed.Consequences.NeTypeEq
open import Definition.Typed.Consequences.SucCong

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

dec-relevance : ∀ (r r′ : Relevance) → Dec (r PE.≡ r′)
dec-relevance ! ! = yes PE.refl
dec-relevance ! % = no (λ ())
dec-relevance % ! = no (λ ())
dec-relevance % % = yes PE.refl

dec-level : ∀ (l l′ : Level) → Dec (l PE.≡ l′)
dec-level ⁰ ⁰ = yes PE.refl
dec-level ⁰ ¹ = no (λ ())
dec-level ¹ ⁰ = no (λ ())
dec-level ¹ ¹ = yes PE.refl

-- Algorithmic equality of variables infers propositional equality.
strongVarEq : ∀ {m n A Γ l} → Γ ⊢ var n ~ var m ↑! A ^ l → n PE.≡ m
strongVarEq (var-refl x x≡y) = x≡y

-- Helper function for decidability of applications.
dec~↑!-app : ∀ {k k₁ l l₁ F F₁ G G₁ rF B Γ Δ lF lG lΠ lK}
          → ⊢ Γ ≡ Δ
          → Γ ⊢ k ∷ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ ! , ι lΠ ]
          → Δ ⊢ k₁ ∷ Π F₁ ^ rF ° lF ▹ G₁ ° lG ° lΠ ^ [ ! , ι lΠ ]
          → Γ ⊢ k ~ k₁ ↓! B ^ lK
          → Dec (Γ ⊢ l [genconv↑] l₁ ∷ F ^ [ rF , ι lF ])
          → Dec (∃ λ A → ∃ λ lA → Γ ⊢ k ∘ l ^ lΠ ~ k₁ ∘ l₁ ^ lΠ ↑! A ^ lA)
dec~↑!-app Γ≡Δ k k₁ k~k₁ (yes p) =
  let
    whnfA , neK , neL = ne~↓! k~k₁
    ⊢A , ⊢k , ⊢l = syntacticEqTerm (soundness~↓! k~k₁)
    l≡l , ΠFG₁≡A = neTypeEq neK k ⊢k
    H , E , A≡ΠHE = Π≡A ΠFG₁≡A whnfA
    F≡H , rF≡rH , lF≡lH , lG≡lE , G₁≡E = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x ^ _) A≡ΠHE ΠFG₁≡A)
  in yes (E [ _ ] , _ , app-cong (PE.subst₂ (λ x y → _ ⊢ _ ~ _ ↓! x ^ y) A≡ΠHE (PE.sym l≡l) k~k₁) (convConvTerm%! p F≡H))
dec~↑!-app Γ≡Δ k k₁ k~k₁ (no ¬p) = no (λ { (_ , _ ,  app-cong k~k₁′ p) →
  let
    whnfA , neK , neL = ne~↓! k~k₁′
    ⊢A , ⊢k , ⊢l = syntacticEqTerm (soundness~↓! k~k₁′)
    l≡l , Π≡Π = neTypeEq neK k ⊢k
    F≡F , rF≡rF , lF≡lF , lG≡lG , G≡G = injectivity Π≡Π
  in ¬p (convConvTerm%! (PE.subst₂ (λ x y → _ ⊢ _ [genconv↑] _ ∷ _ ^ [ x , ι y ]) (PE.sym rF≡rF) (PE.sym lF≡lF) p) (sym F≡F)) })

nonNeutralℕ : Neutral ℕ → ⊥
nonNeutralℕ ()

nonNeutralU : ∀ {r l} → Neutral (Univ r l) → ⊥
nonNeutralU ()

Idℕ-elim : ∀ {Γ l A B t u t' u'} → Neutral A → Γ ⊢ Id A t u ~ Id ℕ t' u' ↑! B ^ l → ⊥
Idℕ-elim neA (Id-cong x x₁ x₂) = let _ , _ , neℕ = ne~↓! x in ⊥-elim (nonNeutralℕ neℕ)
Idℕ-elim neA (Id-ℕ x x₁) = ⊥-elim (nonNeutralℕ neA)
Idℕ-elim neA (Id-ℕ0 x) = ⊥-elim (nonNeutralℕ neA)
Idℕ-elim neA (Id-ℕS x x₁) = ⊥-elim (nonNeutralℕ neA)

Idℕ-elim' : ∀ {Γ l A B t u t' u'} → Neutral A → Γ ⊢ Id ℕ t u ~ Id A t' u' ↑! B ^ l → ⊥
Idℕ-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in Idℕ-elim neA e'

conv↑-inversion : ∀ {Γ l A t u} → Whnf A → Whnf t → Whnf u → Γ ⊢ t [conv↑] u ∷ A ^ l → Γ ⊢ t [conv↓] u ∷ A ^ l
conv↑-inversion whnfA whnft whnfu ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
  let et = whnfRed*Term d whnft
      eu = whnfRed*Term d′ whnfu
      eA = whnfRed* D whnfA
  in PE.subst₃ (λ A X Y → _ ⊢ X [conv↓] Y ∷ A ^ _) (PE.sym eA) (PE.sym et) (PE.sym eu) t<>u

Idℕ0-elim- : ∀ {Γ l t} → Neutral t → Γ ⊢ t [conv↓] zero ∷ ℕ ^ l → ⊥
Idℕ0-elim- net (ℕ-ins ())
Idℕ0-elim- net (ne-ins x x₁ x₂ ())
Idℕ0-elim- () (zero-refl x)

Idℕ0-elim : ∀ {Γ l A t u u'} → Neutral t → Γ ⊢ Id ℕ t u ~ Id ℕ zero u' ↑! A ^ l → ⊥
Idℕ0-elim net (Id-cong x y x₂) =
  let e = conv↑-inversion ℕₙ (ne net) zeroₙ y in Idℕ0-elim- net e
Idℕ0-elim net (Id-ℕ () x₁)
Idℕ0-elim () (Id-ℕ0 x)

Idℕ0-elim' : ∀ {Γ l A t u u'} → Neutral t → Γ ⊢ Id ℕ zero u ~ Id ℕ t u' ↑! A ^ l → ⊥
Idℕ0-elim' net e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in Idℕ0-elim net e'

IdℕS-elim- : ∀ {Γ l t n} → Neutral t → Γ ⊢ t [conv↓] suc n ∷ ℕ ^ l → ⊥
IdℕS-elim- net (ℕ-ins ())
IdℕS-elim- net (ne-ins x x₁ x₂ ())
IdℕS-elim- () (suc-cong x)

IdℕS-elim : ∀ {Γ l A t u n u'} → Neutral t → Γ ⊢ Id ℕ t u ~ Id ℕ (suc n) u' ↑! A ^ l → ⊥
IdℕS-elim net (Id-cong x y x₂) =
  let e = conv↑-inversion ℕₙ (ne net) sucₙ y in IdℕS-elim- net e
IdℕS-elim net (Id-ℕ () x₁)
IdℕS-elim () (Id-ℕS x _)

IdℕS-elim' : ∀ {Γ l A t u n u'} → Neutral t → Γ ⊢ Id ℕ (suc n) u ~ Id ℕ t u' ↑! A ^ l → ⊥
IdℕS-elim' net e =  let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in IdℕS-elim net e'

Idℕ0S-elim- : ∀ {Γ l n} → Γ ⊢ zero [conv↓] suc n ∷ ℕ ^ l → ⊥
Idℕ0S-elim- (ℕ-ins ())
Idℕ0S-elim- (ne-ins x x₁ x₂ ())

Idℕ0S-elim : ∀ {Γ l A u u' n} → Γ ⊢ Id ℕ zero u ~ Id ℕ (suc n) u' ↑! A ^ l → ⊥
Idℕ0S-elim (Id-cong x y x₂) =
  let e = conv↑-inversion ℕₙ zeroₙ sucₙ y in Idℕ0S-elim- e
Idℕ0S-elim (Id-ℕ () _)

Idℕ0S-elim' : ∀ {Γ l A u u' n} → Γ ⊢ Id ℕ (suc n) u ~ Id ℕ zero u' ↑! A ^ l → ⊥
Idℕ0S-elim' e =  let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in Idℕ0S-elim e'

IdU-elim : ∀ {Γ l A B t u t' u' rU lU} → Neutral A → Γ ⊢ Id A t u ~ Id (Univ rU lU) t' u' ↑! B ^ l → ⊥
IdU-elim neA (Id-cong x x₁ x₂) = let _ , _ , neU = ne~↓! x in ⊥-elim (nonNeutralU neU)
IdU-elim neA (Id-U x x₁) = ⊥-elim (nonNeutralU neA)
IdU-elim neA (Id-Uℕ x) = ⊥-elim (nonNeutralU neA)
IdU-elim neA (Id-UΠ x x₁) = ⊥-elim (nonNeutralU neA)

IdU-elim' : ∀ {Γ l A B t u t' u' rU lU} → Neutral A → Γ ⊢ Id (Univ rU lU) t u ~ Id A t' u' ↑! B ^ l → ⊥
IdU-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in IdU-elim neA e'

IdUℕ-elim : ∀ {Γ l A t u t' u' rU lU} → Γ ⊢ Id (Univ rU lU) t u ~ Id ℕ t' u' ↑! A ^ l → ⊥
IdUℕ-elim (Id-cong () x₁ x₂)

IdℕU-elim : ∀ {Γ l A t u t' u' rU lU} → Γ ⊢ Id ℕ t u ~ Id (Univ rU lU) t' u' ↑! A ^ l → ⊥
IdℕU-elim (Id-cong () x₁ x₂)

IdUUℕ-elim : ∀ {Γ l A t u u'} → Neutral t → Γ ⊢ Id (U ⁰) t u ~ Id (U ⁰) ℕ u' ↑! A ^ l → ⊥
IdUUℕ-elim () (Id-Uℕ x)

IdUUℕ-elim' : ∀ {Γ l A t u u'} → Neutral t → Γ ⊢ Id (U ⁰) ℕ u ~ Id (U ⁰) t u' ↑! A ^ l → ⊥
IdUUℕ-elim' () (Id-Uℕ x)

IdUUΠ-elim- : ∀ {Γ l A rA B X t} → Neutral t → Γ ⊢ t [conv↓] Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰ ∷ X ^ l → ⊥
IdUUΠ-elim- net (η-eq x x₁ x₂ x₃ x₄ x₅ (ne ()) x₇)

IdUUΠ-elim : ∀ {Γ l A rA B X t u u'} → Neutral t → Γ ⊢ Id (U ⁰) t u ~ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) u' ↑! X ^ l → ⊥
IdUUΠ-elim net (Id-cong x y x₂) = let e = conv↑-inversion Uₙ (ne net) Πₙ y in IdUUΠ-elim- net e
IdUUΠ-elim net (Id-U () x₁)
IdUUΠ-elim () (Id-UΠ x x₁)

IdUUΠ-elim' : ∀ {Γ l A rA B X t u u'} → Neutral t → Γ ⊢ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) u ~ Id (U ⁰) t u' ↑! X ^ l → ⊥
IdUUΠ-elim' net e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in IdUUΠ-elim net e'

IdUUΠℕ-elim- : ∀ {Γ l A rA B X} → Γ ⊢ Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰ [conv↓] ℕ ∷ X ^ l → ⊥
IdUUΠℕ-elim- (η-eq x x₁ x₂ x₃ x₄ x₅ (ne ()) x₇)

IdUUΠℕ-elim : ∀ {Γ l A rA B X u u'} → Γ ⊢ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) u ~ Id (U ⁰) ℕ u' ↑! X ^ l → ⊥
IdUUΠℕ-elim (Id-cong x y x₂) = let e = conv↑-inversion Uₙ Πₙ ℕₙ y in IdUUΠℕ-elim- e
IdUUΠℕ-elim (Id-U () x₁)

IdUUΠℕ-elim' : ∀ {Γ l A rA B X u u'} → Γ ⊢ Id (U ⁰) ℕ u ~ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) u' ↑! X ^ l → ⊥
IdUUΠℕ-elim' e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in IdUUΠℕ-elim e'

castℕ-elim : ∀ {Γ l A B B' X t e t' e'} → Neutral A → Γ ⊢ cast ⁰ A B e t ~ cast ⁰ ℕ B' e' t' ↑! X ^ l → ⊥
castℕ-elim neA (cast-cong () x₁ x₂ x₃ x₄)
castℕ-elim () (cast-ℕ x x₁ x₂ x₃)
castℕ-elim () (cast-ℕℕ x x₁ x₂)
castℕ-elim () (cast-ℕΠ x x₁ x₂ x₃)

castℕ-elim' : ∀ {Γ l A B B' X t e t' e'} → Neutral A → Γ ⊢ cast ⁰ ℕ B e t ~ cast ⁰ A B' e' t' ↑! X ^ l → ⊥
castℕ-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castℕ-elim neA e'

castΠ-elim : ∀ {Γ l A B B' X t e t' e' r P Q} → Neutral A → Γ ⊢ cast ⁰ A B e t ~ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) B' e' t' ↑! X ^ l → ⊥
castΠ-elim neA (cast-cong () x₁ x₂ x₃ x₄)
castΠ-elim () (cast-Π x x₁ x₂ x₃ x₄)
castΠ-elim () (cast-Πℕ x x₁ x₂ x₃)
castΠ-elim () (cast-ΠΠ%! x x₁ x₂ x₃ x₄)
castΠ-elim () (cast-ΠΠ!% x x₁ x₂ x₃ x₄)

castΠ-elim' : ∀ {Γ l A B B' X t e t' e' r P Q} → Neutral A → Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) B e t ~ cast ⁰ A B' e' t' ↑! X ^ l → ⊥
castΠ-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castΠ-elim neA e'

castℕℕ-elim : ∀ {Γ l A X t e t' e'} → Neutral A → Γ ⊢ cast ⁰ ℕ A e t ~ cast ⁰ ℕ ℕ e' t' ↑! X ^ l → ⊥
castℕℕ-elim neA (cast-cong () x₁ x₂ x₃ x₄)
castℕℕ-elim (var n) (cast-ℕ () x₁ x₂ x₃)
castℕℕ-elim () (cast-ℕℕ x x₁ x₂)

castℕℕ-elim' : ∀ {Γ l A X t e t' e'} → Neutral A → Γ ⊢ cast ⁰ ℕ ℕ e t ~ cast ⁰ ℕ A e' t' ↑! X ^ l → ⊥
castℕℕ-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castℕℕ-elim neA e'

castℕΠ-elim : ∀ {Γ l A A' X t e t' e' r P Q} → Γ ⊢ cast ⁰ ℕ A e t ~ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) A' e' t' ↑! X ^ l → ⊥
castℕΠ-elim (cast-cong () x₁ x₂ x₃ x₄)

castℕΠ-elim' : ∀ {Γ l A A' X t e t' e' r P Q} → Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) A e t ~ cast ⁰ ℕ A' e' t' ↑! X ^ l → ⊥
castℕΠ-elim' (cast-cong () x₁ x₂ x₃ x₄)

castℕneΠ-elim : ∀ {Γ l A X t e t' e' r P Q} → Neutral A → Γ ⊢ cast ⁰ ℕ A e t ~ cast ⁰ ℕ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) e' t' ↑! X ^ l → ⊥
castℕneΠ-elim neA (cast-cong () x₁ x₂ x₃ x₄)
castℕneΠ-elim neA (cast-ℕ () x₁ x₂ x₃)
castℕneΠ-elim () (cast-ℕΠ x x₁ x₂ x₃)

castℕneΠ-elim' : ∀ {Γ l A X t e t' e' r P Q} → Neutral A → Γ ⊢ cast ⁰ ℕ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) e t ~ cast ⁰ ℕ A e' t' ↑! X ^ l → ⊥
castℕneΠ-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castℕneΠ-elim neA e'

castℕℕΠ-elim : ∀ {Γ l X t e t' e' r P Q} → Γ ⊢ cast ⁰ ℕ ℕ e t ~ cast ⁰ ℕ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) e' t' ↑! X ^ l → ⊥
castℕℕΠ-elim (cast-cong () x₁ x₂ x₃ x₄)
castℕℕΠ-elim (cast-ℕ () x₁ x₂ x₃)

castℕℕΠ-elim' : ∀ {Γ l X t e t' e' r P Q} → Γ ⊢ cast ⁰ ℕ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) e t ~ cast ⁰ ℕ ℕ e' t' ↑! X ^ l → ⊥
castℕℕΠ-elim' e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castℕℕΠ-elim e'

castΠneℕ-elim : ∀ {Γ l A X t e t' e' r P Q r' P' Q'} → Neutral A → Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) A e t ~
                                                                       cast ⁰ (Π P' ^ r' ° ⁰ ▹ Q' ° ⁰ ° ⁰) ℕ e' t' ↑! X ^ l → ⊥
castΠneℕ-elim neA (cast-cong () x₁ x₂ x₃ x₄)
castΠneℕ-elim neA (cast-Π x () x₂ x₃ x₄)
castΠneℕ-elim () (cast-Πℕ x x₁ x₂ x₃)

castΠneℕ-elim' : ∀ {Γ l A X t e t' e' r P Q r' P' Q'} → Neutral A → Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) ℕ e t ~
                                                                       cast ⁰ (Π P' ^ r' ° ⁰ ▹ Q' ° ⁰ ° ⁰) A e' t' ↑! X ^ l → ⊥
castΠneℕ-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castΠneℕ-elim neA e'

castΠneΠ-elim : ∀ {Γ l A X t e t' e' r P Q r' P' Q' r'' P'' Q''} → Neutral A →
                  Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) A e t ~ cast ⁰ (Π P' ^ r' ° ⁰ ▹ Q' ° ⁰ ° ⁰) (Π P'' ^ r'' ° ⁰ ▹ Q'' ° ⁰ ° ⁰) e' t' ↑! X ^ l → ⊥
castΠneΠ-elim neA (cast-cong () x₁ x₂ x₃ x₄)
castΠneΠ-elim neA (cast-Π x () x₂ x₃ x₄)
castΠneΠ-elim () (cast-ΠΠ%! x x₁ x₂ x₃ x₄)
castΠneΠ-elim () (cast-ΠΠ!% x x₁ x₂ x₃ x₄)

castΠneΠ-elim' : ∀ {Γ l A X t e t' e' r P Q r' P' Q' r'' P'' Q''} → Neutral A →
                  Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) (Π P'' ^ r'' ° ⁰ ▹ Q'' ° ⁰ ° ⁰) e t ~ cast ⁰ (Π P' ^ r' ° ⁰ ▹ Q' ° ⁰ ° ⁰) A e' t' ↑! X ^ l → ⊥
castΠneΠ-elim' neA e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castΠneΠ-elim neA e'

castΠΠℕ-elim : ∀ {Γ l X t e t' e' r P Q r' P' Q' r'' P'' Q''} →
                  Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) ℕ e t ~ cast ⁰ (Π P' ^ r' ° ⁰ ▹ Q' ° ⁰ ° ⁰) (Π P'' ^ r'' ° ⁰ ▹ Q'' ° ⁰ ° ⁰) e' t' ↑! X ^ l → ⊥
castΠΠℕ-elim (cast-cong () x₁ x₂ x₃ x₄)
castΠΠℕ-elim (cast-Π x () x₂ x₃ x₄)

castΠΠℕ-elim' : ∀ {Γ l X t e t' e' r P Q r' P' Q' r'' P'' Q''} →
                  Γ ⊢ cast ⁰ (Π P ^ r ° ⁰ ▹ Q ° ⁰ ° ⁰) (Π P'' ^ r'' ° ⁰ ▹ Q'' ° ⁰ ° ⁰) e t ~ cast ⁰ (Π P' ^ r' ° ⁰ ▹ Q' ° ⁰ ° ⁰) ℕ e' t' ↑! X ^ l → ⊥
castΠΠℕ-elim' e = let _ , _ , e' = sym~↑! (reflConEq (wfEqTerm (soundness~↑! e))) e in castΠΠℕ-elim e'

castΠΠ!%-elim : ∀ {Γ l A A' X t e t' e' P Q P' Q'} → Γ ⊢ cast ⁰ (Π P ^ ! ° ⁰ ▹ Q ° ⁰ ° ⁰) A e t ~
                                                         cast ⁰ (Π P' ^ % ° ⁰ ▹ Q' ° ⁰ ° ⁰) A' e' t' ↑! X ^ l → ⊥
castΠΠ!%-elim (cast-cong () x₁ x₂ x₃ x₄)

castΠΠ%!-elim : ∀ {Γ l A A' X t e t' e' P Q P' Q'} → Γ ⊢ cast ⁰ (Π P ^ % ° ⁰ ▹ Q ° ⁰ ° ⁰) A e t ~
                                                         cast ⁰ (Π P' ^ ! ° ⁰ ▹ Q' ° ⁰ ° ⁰) A' e' t' ↑! X ^ l → ⊥
castΠΠ%!-elim (cast-cong () x₁ x₂ x₃ x₄)

  -- Helper functions for decidability for neutrals
decConv↓Term-ℕ-ins : ∀ {t u Γ l}
 → Γ ⊢ t [conv↓] u ∷ ℕ ^ l
 → Γ ⊢ t ~ t ↓! ℕ ^ l
 → Γ ⊢ t ~ u ↓! ℕ ^ l
decConv↓Term-ℕ-ins (ℕ-ins x) t~t = x
decConv↓Term-ℕ-ins (ne-ins x x₁ () x₃) t~t
decConv↓Term-ℕ-ins (zero-refl x) ([~] A D whnfB ())
decConv↓Term-ℕ-ins (suc-cong x) ([~] A D whnfB ())

decConv↓Term-U-ins : ∀ {t u Γ r lU l}
  → Γ ⊢ t [conv↓] u ∷ Univ r lU ^ l
  → Γ ⊢ t ~ t ↓! Univ r lU ^ l
  → Γ ⊢ t ~ u ↓! Univ r lU ^ l
decConv↓Term-U-ins (ne x) t~r = x

decConv↓Term-ne-ins : ∀ {t u A Γ l}
  → Neutral A
  → Γ ⊢ t [conv↓] u ∷ A ^ l
  → ∃ λ B → ∃ λ lB → Γ ⊢ t ~ u ↓! B ^ lB
decConv↓Term-ne-ins neA (ne-ins x x₁ x₂ x₃) = _ , _ , x₃

-- Helper function for decidability for impossibility of terms not being equal
-- as neutrals when they are equal as terms and the first is a neutral.
decConv↓Term-ℕ : ∀ {t u Γ l}
  → Γ ⊢ t [conv↓] u ∷ ℕ ^ l
  → Γ ⊢ t ~ t ↓! ℕ ^ l
  → ¬ (Γ ⊢ t ~ u ↓! ℕ ^ l)
  → ⊥
decConv↓Term-ℕ (ℕ-ins x) t~t ¬u~u = ¬u~u x
decConv↓Term-ℕ (ne-ins x x₁ () x₃) t~t ¬u~u
decConv↓Term-ℕ (zero-refl x) ([~] A D whnfB ()) ¬u~u
decConv↓Term-ℕ (suc-cong x) ([~] A D whnfB ()) ¬u~u

decConv↓Term-U : ∀ {t u Γ r lU l}
  → Γ ⊢ t [conv↓] u ∷ Univ r lU ^ l
  → Γ ⊢ t ~ t ↓! Univ r lU ^ l
  → ¬ (Γ ⊢ t ~ u ↓! Univ r lU ^ l)
  → ⊥
decConv↓Term-U (ne x) t~t ¬u~u = ¬u~u x


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

module Definition.Typed.Properties where

open import Definition.Untyped
open import Definition.Typed

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

-- Escape context extraction

wfTerm : ∀ {Γ A t} → Γ ⊢ t ∷ A → ⊢ Γ
wfTerm (ℕⱼ ⊢Γ) = ⊢Γ
wfTerm (Emptyⱼ ⊢Γ) = ⊢Γ
wfTerm (Unitⱼ ⊢Γ) = ⊢Γ
wfTerm (Πⱼ F ▹ G) = wfTerm F
wfTerm (var ⊢Γ x₁) = ⊢Γ
wfTerm (lamⱼ F t) with wfTerm t
wfTerm (lamⱼ F t) | ⊢Γ ∙ F′ = ⊢Γ
wfTerm (g ∘ⱼ a) = wfTerm a
wfTerm (zeroⱼ ⊢Γ) = ⊢Γ
wfTerm (sucⱼ n) = wfTerm n
wfTerm (natrecⱼ F z s n) = wfTerm z
wfTerm (Emptyrecⱼ A e) = wfTerm e
wfTerm (starⱼ ⊢Γ) = ⊢Γ
wfTerm (conv t A≡B) = wfTerm t
wfTerm (Σⱼ a ▹ a₁) = wfTerm a
wfTerm (prodⱼ F G a a₁) = wfTerm a
wfTerm (fstⱼ _ _ a) = wfTerm a
wfTerm (sndⱼ _ _ a) = wfTerm a

wf : ∀ {Γ A} → Γ ⊢ A → ⊢ Γ
wf (ℕⱼ ⊢Γ) = ⊢Γ
wf (Emptyⱼ ⊢Γ) = ⊢Γ
wf (Unitⱼ ⊢Γ) = ⊢Γ
wf (Uⱼ ⊢Γ) = ⊢Γ
wf (Πⱼ F ▹ G) = wf F
wf (Σⱼ F ▹ G) = wf F
wf (univ A) = wfTerm A

wfEqTerm : ∀ {Γ A t u} → Γ ⊢ t ≡ u ∷ A → ⊢ Γ
wfEqTerm (refl t) = wfTerm t
wfEqTerm (sym t≡u) = wfEqTerm t≡u
wfEqTerm (trans t≡u u≡r) = wfEqTerm t≡u
wfEqTerm (conv t≡u A≡B) = wfEqTerm t≡u
wfEqTerm (Π-cong F F≡H G≡E) = wfEqTerm F≡H
wfEqTerm (app-cong f≡g a≡b) = wfEqTerm f≡g
wfEqTerm (β-red F t a) = wfTerm a
wfEqTerm (η-eq F f g f0≡g0) = wfTerm f
wfEqTerm (suc-cong n) = wfEqTerm n
wfEqTerm (natrec-cong F≡F′ z≡z′ s≡s′ n≡n′) = wfEqTerm z≡z′
wfEqTerm (natrec-zero F z s) = wfTerm z
wfEqTerm (natrec-suc n F z s) = wfTerm n
wfEqTerm (Emptyrec-cong A≡A' e≡e') = wfEqTerm e≡e'
wfEqTerm (η-unit e e') = wfTerm e
wfEqTerm (Σ-cong F _ _) = wf F
wfEqTerm (fst-cong _ _ a) = wfEqTerm a
wfEqTerm (snd-cong _ _ a) = wfEqTerm a
wfEqTerm (Σ-η _ _ x _ _ _) = wfTerm x
wfEqTerm (Σ-β₁ F G x x₁) = wfTerm x
wfEqTerm (Σ-β₂ F G x x₁) = wfTerm x

wfEq : ∀ {Γ A B} → Γ ⊢ A ≡ B → ⊢ Γ
wfEq (univ A≡B) = wfEqTerm A≡B
wfEq (refl A) = wf A
wfEq (sym A≡B) = wfEq A≡B
wfEq (trans A≡B B≡C) = wfEq A≡B
wfEq (Π-cong F F≡H G≡E) = wf F
wfEq (Σ-cong F x₁ x₂) = wf F

-- Reduction is a subset of conversion

subsetTerm : ∀ {Γ A t u} → Γ ⊢ t ⇒ u ∷ A → Γ ⊢ t ≡ u ∷ A
subsetTerm (natrec-subst F z s n⇒n′) =
  natrec-cong (refl F) (refl z) (refl s) (subsetTerm n⇒n′)
subsetTerm (natrec-zero F z s) = natrec-zero F z s
subsetTerm (natrec-suc n F z s) = natrec-suc n F z s
subsetTerm (Emptyrec-subst A n⇒n′) =
  Emptyrec-cong (refl A) (subsetTerm n⇒n′)
subsetTerm (app-subst t⇒u a) = app-cong (subsetTerm t⇒u) (refl a)
subsetTerm (β-red A t a) = β-red A t a
subsetTerm (conv t⇒u A≡B) = conv (subsetTerm t⇒u) A≡B
subsetTerm (fst-subst F G x) = fst-cong F G (subsetTerm x)
subsetTerm (snd-subst F G x) = snd-cong F G (subsetTerm x)
subsetTerm (Σ-β₁ F G x x₁) = Σ-β₁ F G x x₁
subsetTerm (Σ-β₂ F G x x₁) = Σ-β₂ F G x x₁

subset : ∀ {Γ A B} → Γ ⊢ A ⇒ B → Γ ⊢ A ≡ B
subset (univ A⇒B) = univ (subsetTerm A⇒B)

subset*Term : ∀ {Γ A t u} → Γ ⊢ t ⇒* u ∷ A → Γ ⊢ t ≡ u ∷ A
subset*Term (id t) = refl t
subset*Term (t⇒t′ ⇨ t⇒*u) = trans (subsetTerm t⇒t′) (subset*Term t⇒*u)

subset* : ∀ {Γ A B} → Γ ⊢ A ⇒* B → Γ ⊢ A ≡ B
subset* (id A) = refl A
subset* (A⇒A′ ⇨ A′⇒*B) = trans (subset A⇒A′) (subset* A′⇒*B)

-- Can extract left-part of a reduction

redFirstTerm : ∀ {Γ t u A} → Γ ⊢ t ⇒ u ∷ A → Γ ⊢ t ∷ A
redFirstTerm (conv t⇒u A≡B) = conv (redFirstTerm t⇒u) A≡B
redFirstTerm (app-subst t⇒u a) = (redFirstTerm t⇒u) ∘ⱼ a
redFirstTerm (β-red A t a) = (lamⱼ A t) ∘ⱼ a
redFirstTerm (natrec-subst F z s n⇒n′) = natrecⱼ F z s (redFirstTerm n⇒n′)
redFirstTerm (natrec-zero F z s) = natrecⱼ F z s (zeroⱼ (wfTerm z))
redFirstTerm (natrec-suc n F z s) = natrecⱼ F z s (sucⱼ n)
redFirstTerm (Emptyrec-subst A n⇒n′) = Emptyrecⱼ A (redFirstTerm n⇒n′)
redFirstTerm (fst-subst F G x) = fstⱼ F G (redFirstTerm x)
redFirstTerm (snd-subst F G x) = sndⱼ F G (redFirstTerm x)
redFirstTerm (Σ-β₁ F G x x₁) = fstⱼ F G (prodⱼ F G x x₁)
redFirstTerm (Σ-β₂ F G x x₁) = sndⱼ F G (prodⱼ F G x x₁)

redFirst : ∀ {Γ A B} → Γ ⊢ A ⇒ B → Γ ⊢ A
redFirst (univ A⇒B) = univ (redFirstTerm A⇒B)

redFirst*Term : ∀ {Γ t u A} → Γ ⊢ t ⇒* u ∷ A → Γ ⊢ t ∷ A
redFirst*Term (id t) = t
redFirst*Term (t⇒t′ ⇨ t′⇒*u) = redFirstTerm t⇒t′

redFirst* : ∀ {Γ A B} → Γ ⊢ A ⇒* B → Γ ⊢ A
redFirst* (id A) = A
redFirst* (A⇒A′ ⇨ A′⇒*B) = redFirst A⇒A′

-- No neutral terms are well-formed in an empty context

noNe : ∀ {t A} → ε ⊢ t ∷ A → Neutral t → ⊥
noNe (conv ⊢t x) n = noNe ⊢t n
noNe (var x₁ ()) (var x)
noNe (⊢t ∘ⱼ ⊢t₁) (∘ₙ neT) = noNe ⊢t neT
noNe (fstⱼ _ _ ⊢t) (fstₙ neT) = noNe ⊢t neT
noNe (sndⱼ _ _ ⊢t) (sndₙ neT) = noNe ⊢t neT
noNe (natrecⱼ x ⊢t ⊢t₁ ⊢t₂) (natrecₙ neT) = noNe ⊢t₂ neT
noNe (Emptyrecⱼ A ⊢e) (Emptyrecₙ neT) = noNe ⊢e neT

-- Neutrals do not weak head reduce

neRedTerm : ∀ {Γ t u A} (d : Γ ⊢ t ⇒ u ∷ A) (n : Neutral t) → ⊥
neRedTerm (conv d x) n = neRedTerm d n
neRedTerm (app-subst d x) (∘ₙ n) = neRedTerm d n
neRedTerm (β-red x x₁ x₂) (∘ₙ ())
neRedTerm (natrec-subst x x₁ x₂ d) (natrecₙ n₁) = neRedTerm d n₁
neRedTerm (natrec-zero x x₁ x₂) (natrecₙ ())
neRedTerm (natrec-suc x x₁ x₂ x₃) (natrecₙ ())
neRedTerm (Emptyrec-subst x d) (Emptyrecₙ n₁) = neRedTerm d n₁
neRedTerm (fst-subst _ _ d) (fstₙ n) = neRedTerm d n
neRedTerm (snd-subst _ _ d) (sndₙ n) = neRedTerm d n
neRedTerm (Σ-β₁ F G x x₁) (fstₙ ())
neRedTerm (Σ-β₂ F G x x₁) (sndₙ ())

neRed : ∀ {Γ A B} (d : Γ ⊢ A ⇒ B) (N : Neutral A) → ⊥
neRed (univ x) N = neRedTerm x N

-- Whnfs do not weak head reduce

whnfRedTerm : ∀ {Γ t u A} (d : Γ ⊢ t ⇒ u ∷ A) (w : Whnf t) → ⊥
whnfRedTerm (conv d x) w = whnfRedTerm d w
whnfRedTerm (app-subst d x) (ne (∘ₙ x₁)) = neRedTerm d x₁
whnfRedTerm (β-red x x₁ x₂) (ne (∘ₙ ()))
whnfRedTerm (natrec-subst x x₁ x₂ d) (ne (natrecₙ x₃)) = neRedTerm d x₃
whnfRedTerm (natrec-zero x x₁ x₂) (ne (natrecₙ ()))
whnfRedTerm (natrec-suc x x₁ x₂ x₃) (ne (natrecₙ ()))
whnfRedTerm (Emptyrec-subst x d) (ne (Emptyrecₙ x₂)) = neRedTerm d x₂
whnfRedTerm (fst-subst _ _ d) (ne (fstₙ n)) = neRedTerm d n
whnfRedTerm (snd-subst _ _ d) (ne (sndₙ n)) = neRedTerm d n
whnfRedTerm (Σ-β₁ F G x x₁) (ne (fstₙ ()))
whnfRedTerm (Σ-β₂ F G x x₁) (ne (sndₙ ()))

whnfRed : ∀ {Γ A B} (d : Γ ⊢ A ⇒ B) (w : Whnf A) → ⊥
whnfRed (univ x) w = whnfRedTerm x w

whnfRed*Term : ∀ {Γ t u A} (d : Γ ⊢ t ⇒* u ∷ A) (w : Whnf t) → t PE.≡ u
whnfRed*Term (id x) Uₙ = PE.refl
whnfRed*Term (id x) Πₙ = PE.refl
whnfRed*Term (id x) Σₙ = PE.refl
whnfRed*Term (id x) ℕₙ = PE.refl
whnfRed*Term (id x) Emptyₙ = PE.refl
whnfRed*Term (id x) Unitₙ = PE.refl
whnfRed*Term (id x) lamₙ = PE.refl
whnfRed*Term (id x) prodₙ = PE.refl
whnfRed*Term (id x) zeroₙ = PE.refl
whnfRed*Term (id x) sucₙ = PE.refl
whnfRed*Term (id x) starₙ = PE.refl
whnfRed*Term (id x) (ne x₁) = PE.refl
whnfRed*Term (conv x x₁ ⇨ d) w = ⊥-elim (whnfRedTerm x w)
whnfRed*Term (x ⇨ d) (ne x₁) = ⊥-elim (neRedTerm x x₁)

whnfRed* : ∀ {Γ A B} (d : Γ ⊢ A ⇒* B) (w : Whnf A) → A PE.≡ B
whnfRed* (id x) w = PE.refl
whnfRed* (x ⇨ d) w = ⊥-elim (whnfRed x w)

-- Whr is deterministic

whrDetTerm : ∀{Γ t u A u′ A′} (d : Γ ⊢ t ⇒ u ∷ A) (d′ : Γ ⊢ t ⇒ u′ ∷ A′) → u PE.≡ u′
whrDetTerm (conv d x) d′ = whrDetTerm d d′
whrDetTerm d (conv d′ x₁) = whrDetTerm d d′
whrDetTerm (app-subst d x) (app-subst d′ x₁) rewrite whrDetTerm d d′ = PE.refl
whrDetTerm (β-red x x₁ x₂) (β-red x₃ x₄ x₅) = PE.refl
whrDetTerm (fst-subst _ _ x) (fst-subst _ _ y) rewrite whrDetTerm x y = PE.refl
whrDetTerm (snd-subst _ _ x) (snd-subst _ _ y) rewrite whrDetTerm x y = PE.refl
whrDetTerm (Σ-β₁ F G x x₁) (Σ-β₁ F₁ G₁ x₂ x₃) = PE.refl
whrDetTerm (Σ-β₂ F G x x₁) (Σ-β₂ F₁ G₁ x₂ x₃) = PE.refl
whrDetTerm (natrec-subst x x₁ x₂ d) (natrec-subst x₃ x₄ x₅ d′) rewrite whrDetTerm d d′ = PE.refl
whrDetTerm (natrec-zero x x₁ x₂) (natrec-zero x₃ x₄ x₅) = PE.refl
whrDetTerm (natrec-suc x x₁ x₂ x₃) (natrec-suc x₄ x₅ x₆ x₇) = PE.refl
whrDetTerm (Emptyrec-subst x d) (Emptyrec-subst x₂ d′) rewrite whrDetTerm d d′ = PE.refl

whrDetTerm (app-subst d x) (β-red x₁ x₂ x₃) = ⊥-elim (whnfRedTerm d lamₙ)
whrDetTerm (β-red x x₁ x₂) (app-subst d x₃) = ⊥-elim (whnfRedTerm d lamₙ)
whrDetTerm (natrec-subst x x₁ x₂ d) (natrec-zero x₃ x₄ x₅) = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (natrec-subst x x₁ x₂ d) (natrec-suc x₃ x₄ x₅ x₆) = ⊥-elim (whnfRedTerm d sucₙ)
whrDetTerm (natrec-zero x x₁ x₂) (natrec-subst x₃ x₄ x₅ d′) = ⊥-elim (whnfRedTerm d′ zeroₙ)
whrDetTerm (natrec-suc x x₁ x₂ x₃) (natrec-subst x₄ x₅ x₆ d′) = ⊥-elim (whnfRedTerm d′ sucₙ)
whrDetTerm (fst-subst _ _ x) (Σ-β₁ F G x₁ x₂) = ⊥-elim (whnfRedTerm x prodₙ)
whrDetTerm (snd-subst _ _ x) (Σ-β₂ F G x₁ x₂) = ⊥-elim (whnfRedTerm x prodₙ)
whrDetTerm (Σ-β₁ F G x x₁) (fst-subst _ _ y) = ⊥-elim (whnfRedTerm y prodₙ)
whrDetTerm (Σ-β₂ F G x x₁) (snd-subst _ _ y) = ⊥-elim (whnfRedTerm y prodₙ)

whrDet : ∀{Γ A B B′} (d : Γ ⊢ A ⇒ B) (d′ : Γ ⊢ A ⇒ B′) → B PE.≡ B′
whrDet (univ x) (univ x₁) = whrDetTerm x x₁

whrDet↘Term : ∀{Γ t u A u′} (d : Γ ⊢ t ↘ u ∷ A) (d′ : Γ ⊢ t ⇒* u′ ∷ A) → Γ ⊢ u′ ⇒* u ∷ A
whrDet↘Term (proj₁ , proj₂) (id x) = proj₁
whrDet↘Term (id x , proj₂) (x₁ ⇨ d′) = ⊥-elim (whnfRedTerm x₁ proj₂)
whrDet↘Term (x ⇨ proj₁ , proj₂) (x₁ ⇨ d′) =
  whrDet↘Term (PE.subst (λ x₂ → _ ⊢ x₂ ↘ _ ∷ _) (whrDetTerm x x₁) (proj₁ , proj₂)) d′

whrDet*Term : ∀{Γ t u A u′} (d : Γ ⊢ t ↘ u ∷ A) (d′ : Γ ⊢ t ↘ u′ ∷ A) → u PE.≡ u′
whrDet*Term (id x , proj₂) (id x₁ , proj₄) = PE.refl
whrDet*Term (id x , proj₂) (x₁ ⇨ proj₃ , proj₄) = ⊥-elim (whnfRedTerm x₁ proj₂)
whrDet*Term (x ⇨ proj₁ , proj₂) (id x₁ , proj₄) = ⊥-elim (whnfRedTerm x proj₄)
whrDet*Term (x ⇨ proj₁ , proj₂) (x₁ ⇨ proj₃ , proj₄) =
  whrDet*Term (proj₁ , proj₂) (PE.subst (λ x₂ → _ ⊢ x₂ ↘ _ ∷ _)
                                    (whrDetTerm x₁ x) (proj₃ , proj₄))

whrDet* : ∀{Γ A B B′} (d : Γ ⊢ A ↘ B) (d′ : Γ ⊢ A ↘ B′) → B PE.≡ B′
whrDet* (id x , proj₂) (id x₁ , proj₄) = PE.refl
whrDet* (id x , proj₂) (x₁ ⇨ proj₃ , proj₄) = ⊥-elim (whnfRed x₁ proj₂)
whrDet* (x ⇨ proj₁ , proj₂) (id x₁ , proj₄) = ⊥-elim (whnfRed x proj₄)
whrDet* (A⇒A′ ⇨ A′⇒*B , whnfB) (A⇒A″ ⇨ A″⇒*B′ , whnfB′) =
  whrDet* (A′⇒*B , whnfB) (PE.subst (λ x → _ ⊢ x ↘ _)
                                     (whrDet A⇒A″ A⇒A′)
                                     (A″⇒*B′ , whnfB′))

-- Identity of syntactic reduction

idRed:*: : ∀ {Γ A} → Γ ⊢ A → Γ ⊢ A :⇒*: A
idRed:*: A = [ A , A , id A ]

idRedTerm:*: : ∀ {Γ A t} → Γ ⊢ t ∷ A → Γ ⊢ t :⇒*: t ∷ A
idRedTerm:*: t = [ t , t , id t ]

-- U cannot be a term

UnotInA : ∀ {A Γ} → Γ ⊢ U ∷ A → ⊥
UnotInA (conv U∷U x) = UnotInA U∷U

UnotInA[t] : ∀ {A B t a Γ}
         → t [ a ] PE.≡ U
         → Γ ⊢ a ∷ A
         → Γ ∙ A ⊢ t ∷ B
         → ⊥
UnotInA[t] () x₁ (ℕⱼ x₂)
UnotInA[t] () x₁ (Emptyⱼ x₂)
UnotInA[t] () x₁ (Πⱼ x₂ ▹ x₃)
UnotInA[t] x₁ x₂ (var x₃ here) rewrite x₁ = UnotInA x₂
UnotInA[t] () x₂ (var x₃ (there x₄))
UnotInA[t] () x₁ (lamⱼ x₂ x₃)
UnotInA[t] () x₁ (x₂ ∘ⱼ x₃)
UnotInA[t] () x₁ (zeroⱼ x₂)
UnotInA[t] () x₁ (sucⱼ x₂)
UnotInA[t] () x₁ (natrecⱼ x₂ x₃ x₄ x₅)
UnotInA[t] () x₁ (Emptyrecⱼ x₂ x₃)
UnotInA[t] x x₁ (conv x₂ x₃) = UnotInA[t] x x₁ x₂

redU*Term′ : ∀ {A B U′ Γ} → U′ PE.≡ U → Γ ⊢ A ⇒ U′ ∷ B → ⊥
redU*Term′ U′≡U (conv A⇒U x) = redU*Term′ U′≡U A⇒U
redU*Term′ () (app-subst A⇒U x)
redU*Term′ U′≡U (β-red x x₁ x₂) = UnotInA[t] U′≡U x₂ x₁
redU*Term′ () (natrec-subst x x₁ x₂ A⇒U)
redU*Term′ PE.refl (natrec-zero x x₁ x₂) = UnotInA x₁
redU*Term′ () (natrec-suc x x₁ x₂ x₃)
redU*Term′ () (Emptyrec-subst x A⇒U)
redU*Term′ PE.refl (Σ-β₁ F G x x₁) = UnotInA x
redU*Term′ PE.refl (Σ-β₂ F G x x₁) = UnotInA x₁

redU*Term : ∀ {A B Γ} → Γ ⊢ A ⇒* U ∷ B → ⊥
redU*Term (id x) = UnotInA x
redU*Term (x ⇨ A⇒*U) = redU*Term A⇒*U

-- Nothing reduces to U

redU : ∀ {A Γ} → Γ ⊢ A ⇒ U → ⊥
redU (univ x) = redU*Term′ PE.refl x

redU* : ∀ {A Γ} → Γ ⊢ A ⇒* U → A PE.≡ U
redU* (id x) = PE.refl
redU* (x ⇨ A⇒*U) rewrite redU* A⇒*U = ⊥-elim (redU x)


------------------------------------------------------------------------
-- A partial order
------------------------------------------------------------------------

{-# OPTIONS --cubical --sized-types #-}

open import Prelude hiding (⊥; module W)

module Partiality-monad.Coinductive.Partial-order {a} {A : Type a} where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms.Univalence equality-with-paths
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
  as Trunc
open import Quotient equality-with-paths as Quotient
open import Univalence-axiom equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity as B using (_≈_)
import Delay-monad.Partial-order as PO

open import Partiality-monad.Coinductive

-- An ordering relation.

LE : A ⊥ → A ⊥ → Proposition a
LE x y = Quotient.rec
  (λ where
     .[]ʳ x                 → LE″ x y
     .[]-respects-relationʳ → left-lemma″-∥∥ y
     .is-setʳ               → is-set)
  x
  where
  LE′ : Delay A ∞ → Delay A ∞ → Proposition a
  LE′ x y = ∥ x PO.⊑ y ∥ , truncation-is-proposition

  abstract

    is-set : Is-set (∃ λ (A : Type a) → Is-proposition A)
    is-set = Is-set-∃-Is-proposition ext prop-ext

    right-lemma : ∀ {x y z} → x ≈ y → LE′ z x ≡ LE′ z y
    right-lemma x≈y =
      _↔_.to (⇔↔≡″ ext prop-ext)
             (record { to   = ∥∥-map (flip PO.transitive-⊑≈ x≈y)
                     ; from = ∥∥-map (flip PO.transitive-⊑≈
                                        (B.symmetric x≈y))
                     })

    right-lemma-∥∥ : ∀ {x y z} → ∥ x ≈ y ∥ → LE′ z x ≡ LE′ z y
    right-lemma-∥∥ = Trunc.rec is-set right-lemma

  LE″ : Delay A ∞ → A ⊥ → Proposition a
  LE″ x y = Quotient.rec
    (λ where
       .[]ʳ                   → LE′ x
       .[]-respects-relationʳ → right-lemma-∥∥
       .is-setʳ               → is-set)
    y

  abstract

    left-lemma : ∀ {x y z} → x ≈ y → LE′ x z ≡ LE′ y z
    left-lemma x≈y =
      _↔_.to (⇔↔≡″ ext prop-ext)
             (record { to   = ∥∥-map (PO.transitive-≈⊑
                                        (B.symmetric x≈y))
                     ; from = ∥∥-map (PO.transitive-≈⊑ x≈y)
                     })

    left-lemma″ : ∀ {x y} z → x ≈ y → LE″ x z ≡ LE″ y z
    left-lemma″ {x} {y} z x≈y = Quotient.elim-prop
      {P = λ z → LE″ x z ≡ LE″ y z}
      (λ where
         .[]ʳ _             → left-lemma x≈y
         .is-propositionʳ _ →
           Is-set-∃-Is-proposition ext prop-ext)
      z

    left-lemma″-∥∥ : ∀ {x y} z → ∥ x ≈ y ∥ → LE″ x z ≡ LE″ y z
    left-lemma″-∥∥ z = Trunc.rec
     is-set
     (left-lemma″ z)

infix 4 _⊑_

_⊑_ : A ⊥ → A ⊥ → Type a
x ⊑ y = proj₁ (LE x y)

-- _⊑_ is propositional.

⊑-propositional : ∀ x y → Is-proposition (x ⊑ y)
⊑-propositional x y = proj₂ (LE x y)

-- _⊑_ is reflexive.

reflexive : ∀ x → x ⊑ x
reflexive = Quotient.elim-prop λ where
  .[]ʳ x             → ∣ PO.reflexive x ∣
  .is-propositionʳ x → ⊑-propositional [ x ] [ x ]

-- _⊑_ is antisymmetric.

antisymmetric : ∀ x y → x ⊑ y → y ⊑ x → x ≡ y
antisymmetric = Quotient.elim-prop λ where
  .[]ʳ x → Quotient.elim-prop (λ where
    .[]ʳ y ∥x⊑y∥ ∥y⊑x∥ →
      []-respects-relation $
      Trunc.rec truncation-is-proposition
        (λ x⊑y → ∥∥-map (PO.antisymmetric x⊑y) ∥y⊑x∥)
        ∥x⊑y∥
    .is-propositionʳ _ →
      Π-closure ext 1 λ _ →
      Π-closure ext 1 λ _ →
      ⊥-is-set)
  .is-propositionʳ _ →
    Π-closure ext 1 λ _ →
    Π-closure ext 1 λ _ →
    Π-closure ext 1 λ _ →
    ⊥-is-set

-- _⊑_ is transitive.

transitive : ∀ x y z → x ⊑ y → y ⊑ z → x ⊑ z
transitive = Quotient.elim-prop λ where
  .[]ʳ x → Quotient.elim-prop λ where
    .[]ʳ y → Quotient.elim-prop λ where
      .[]ʳ z ∥x⊑y∥ →
        Trunc.rec truncation-is-proposition
          (λ y⊑z → ∥∥-map (λ x⊑y → PO.transitive x⊑y y⊑z) ∥x⊑y∥)
      .is-propositionʳ _ →
        Π-closure ext 1 λ _ →
        Π-closure ext 1 λ _ →
        ⊑-propositional [ _ ] [ _ ]
    .is-propositionʳ _ →
      Π-closure ext 1 λ z →
      Π-closure ext 1 λ _ →
      Π-closure ext 1 λ _ →
      ⊑-propositional [ _ ] z
  .is-propositionʳ _ →
    Π-closure ext 1 λ _ →
    Π-closure ext 1 λ z →
    Π-closure ext 1 λ _ →
    Π-closure ext 1 λ _ →
    ⊑-propositional [ _ ] z


------------------------------------------------------------------------
-- "Equational" reasoning combinator setup
------------------------------------------------------------------------

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

open import Labelled-transition-system

module Expansion.Equational-reasoning-instances {ℓ} {lts : LTS ℓ} where

open import Prelude

open import Bisimilarity lts
import Bisimilarity.Equational-reasoning-instances
open import Equational-reasoning
open import Expansion lts

instance

  reflexive≳ : ∀ {i} → Reflexive [ i ]_≳_
  reflexive≳ = is-reflexive reflexive-≳

  reflexive≳′ : ∀ {i} → Reflexive [ i ]_≳′_
  reflexive≳′ = is-reflexive reflexive-≳′

  convert≳≳ : ∀ {i} → Convertible [ i ]_≳_ [ i ]_≳_
  convert≳≳ = is-convertible id

  convert≳′≳ : ∀ {i} → Convertible _≳′_ [ i ]_≳_
  convert≳′≳ = is-convertible λ p≳′q → force p≳′q

  convert≳≳′ : ∀ {i} → Convertible [ i ]_≳_ [ i ]_≳′_
  convert≳≳′ = is-convertible lemma
    where
    lemma : ∀ {i p q} → [ i ] p ≳ q → [ i ] p ≳′ q
    force (lemma p≳q) = p≳q

  convert≳′≳′ : ∀ {i} → Convertible [ i ]_≳′_ [ i ]_≳′_
  convert≳′≳′ = is-convertible id

  convert∼≳ : ∀ {i} → Convertible [ i ]_∼_ [ i ]_≳_
  convert∼≳ = is-convertible ∼⇒≳

  convert∼′≳ : ∀ {i} → Convertible _∼′_ [ i ]_≳_
  convert∼′≳ = is-convertible (convert ∘ ∼⇒≳′)

  convert∼≳′ : ∀ {i} → Convertible [ i ]_∼_ [ i ]_≳′_
  convert∼≳′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ∼ q → [ i ] p ≳′ q
    force (lemma p∼q) = ∼⇒≳ p∼q

  convert∼′≳′ : ∀ {i} → Convertible [ i ]_∼′_ [ i ]_≳′_
  convert∼′≳′ = is-convertible ∼⇒≳′

  trans≳≳ : ∀ {i} → Transitive _≳_ [ i ]_≳_
  trans≳≳ = is-transitive transitive-≳

  trans≳′≳ : ∀ {i} → Transitive _≳′_ [ i ]_≳_
  trans≳′≳ = is-transitive λ p≳′q → transitive (force p≳′q)

  trans≳′≳′ : ∀ {i} → Transitive _≳′_ [ i ]_≳′_
  trans≳′≳′ = is-transitive transitive-≳′

  trans≳≳′ : ∀ {i} → Transitive _≳_ [ i ]_≳′_
  trans≳≳′ = is-transitive lemma
    where
    lemma : ∀ {i p q r} → p ≳ q → [ i ] q ≳′ r → [ i ] p ≳′ r
    force (lemma p≳q q≳′r) = transitive-≳ p≳q (force q≳′r)

  trans∼≳ : ∀ {i} → Transitive _∼_ [ i ]_≳_
  trans∼≳ = is-transitive transitive-∼≳

  -- The occurrences of {a = ℓ} below can perhaps be removed if
  -- Issue #2780 on the Agda bug tracker is fixed.

  trans∼′≳ : ∀ {i} → Transitive _∼′_ [ i ]_≳_
  trans∼′≳ = is-transitive (transitive-∼≳ ∘ convert {a = ℓ})

  trans∼′≳′ : ∀ {i} → Transitive _∼′_ [ i ]_≳′_
  trans∼′≳′ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → p ∼′ q → [ i ] q ≳′ r → [ i ] p ≳′ r
    force (lemma p∼′q q≳′r) =
      transitive-∼≳ (convert {a = ℓ} p∼′q) (force q≳′r)

  trans∼≳′ : ∀ {i} → Transitive _∼_ [ i ]_≳′_
  trans∼≳′ {i} = is-transitive lemma
    where
    lemma : ∀ {p q r} → p ∼ q → [ i ] q ≳′ r → [ i ] p ≳′ r
    force (lemma p∼q q≳′r) = transitive-∼≳ p∼q (force q≳′r)

  trans≳∼ : ∀ {i} → Transitive′ [ i ]_≳_ _∼_
  trans≳∼ = is-transitive transitive-≳∼

  trans≳∼′ : ∀ {i} → Transitive′ [ i ]_≳_ _∼′_
  trans≳∼′ = is-transitive (λ p≳q q∼′r →
    transitive-≳∼ p≳q (convert {a = ℓ} q∼′r))

  trans≳′∼′ : ∀ {i} → Transitive′ [ i ]_≳′_ _∼′_
  trans≳′∼′ = is-transitive transitive-≳∼′

  trans≳′∼ : ∀ {i} → Transitive′ [ i ]_≳′_ _∼_
  trans≳′∼ = is-transitive λ p≳′q q∼r →
    transitive-≳∼′ p≳′q (convert {a = ℓ} q∼r)


{- 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
-}

-- This module provides some scaffolding to define the handlers for our
-- implementation and connect them to the interface of the SystemModel.

open import LibraBFT.ImplShared.Base.Types

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open import LibraBFT.Concrete.Records
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Impl.IO.OBM.InputOutputHandlers
open import LibraBFT.Impl.IO.OBM.Properties.InputOutputHandlers
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Crypto
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.ByteString
open import Util.Encode
open import Util.KVMap
open import Util.Hash
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

module LibraBFT.Impl.Handle.Properties where

open        EpochConfig
import      LibraBFT.Impl.Handle                as Handle
open import LibraBFT.Impl.Handle.InitProperties
open        initHandlerSpec
open        ParamsWithInitAndHandlers Handle.InitHandler.initAndHandlers
open        PeerCanSignForPK
open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms
                      Handle.InitHandler.initAndHandlers
                      PeerCanSignForPK PeerCanSignForPK-stable
open        Invariants
open        RoundManagerTransProps

-- TODO-1: Should 'invariantsCorrect' and direct corollaries be in a `Properties.Invariants` module?
------------------------------------------------------------------------------

-- For any peer in a reachable state, show that it respects RoundManager invariants.
invariantsCorrect
  : ∀ pid (pre : SystemState)
  → initialised pre pid ≡ initd
  → ReachableSystemState pre
  → RoundManagerInv (peerStates pre pid)

--------------------------------------------------
-- AN UNINITIALIZED PEER.
-- A peer has NOT been initialized at 'step-0', therefore it cannot be initialized (i.e., absurd).
invariantsCorrect _ _ () step-0

--------------------------------------------------
-- A CHEATER DOES NOT MODIFY STATE NOR INITIALIZED.
-- pid    : the peer we are reasoning about
-- pid'   : the peer taking the step
--          in the cheat step case, if does not matter if pid == pid'
-- pre    : the prestate of pid
-- pre'   : pre state for this reachable state (before the step, i.e., cheat here)
-- preach : evidence that pre' is reachable
-- cheatStepDNMPeerStates₁  : Does Not Modify state
-- cheatStepDNMInitialised₁ : Does Not Modify initialized
invariantsCorrect pid pre ini (step-s {pre = pre'} preach (step-peer step@(step-cheat  {pid'} _)))
  -- Goal: RoundManagerInv (override (peerStates pre') pid' (peerStates pre' pid') pid)
  rewrite cheatStepDNMPeerStates₁ {pid'} {pid} {pre = pre'} step unit
  -- Goal: RoundManagerInv (peerStates pre' pid)
  with trans (sym $ cheatStepDNMInitialised₁ step unit) ini
...| initialised-pre'-pid≡-initd                        -- preach : ReachableSystemState pre'
  = invariantsCorrect pid pre' initialised-pre'-pid≡-initd preach

--------------------------------------------------
-- Honest steps for the rest of the proof.
-- Note: all these top-level 'invariantsCorrect' are the SAME clause,
-- each with different pattern matching.

--------------------------------------------------
-- PEERS CANNOT MODIFY EACH OTHER'S STATE NOR INITIALIZED STATUS.
-- Reasoning about pid.
-- Peer taking step is different (pid').
invariantsCorrect pid pre ini (step-s {pre = pre'} preach (step-peer step@(step-honest {pid'} sps)))
  with pid ≟ pid'
...| no pid≢pid' -- NO case : step is for a different peer (pid') not this peer (pid).
  -- In that case pid' cannot modify pid's state,
  rewrite sym (pids≢StepDNMPeerStates {pre = pre'} sps pid≢pid')
  -- nor pid's initialized status.
  = invariantsCorrect pid pre' (trans (pids≢StepDNMInitialised {pre = pre'} sps pid≢pid') ini) preach

--------------------------------------------------
-- INITIALIZATION STEP
-- pre' is pre state of this init step
invariantsCorrect pid _   _   (step-s {pre = pre'} preach (step-peer (step-honest {outs = outs} (step-init {rm} rm×acts _))))
   | yes refl -- YES is from the 'with' above
              -- because this is the SAME clause except pattern matching deeper to get 'step-init'.
  -- Goal: RoundManagerInv ... where peerStates pre' pid "contains" the 'rm' from init
  rewrite override-target-≡ {a = pid} {b = rm} {f = peerStates pre'}
  -- Goal: RoundManagerInv rm
  with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
  = initHandlerSpec.ContractOk.rmInv init-contract

--------------------------------------------------
-- PROPOSAL MSG
invariantsCorrect pid _   _   (step-s {pre = pre'} preach (step-peer (step-honest (step-msg {sndr , P pm} m∈pool ini))))
   | yes refl -- pid≡pid'
   -- Goal: RoundManagerInv ... where peerStates pre' pid "contains" the proposal msg
  with handleProposalSpec.contract! 0 pm (msgPool pre') (peerStates pre' pid)
...| c -- contract that says proposal has been handled
  with handleProposalSpec.Contract.rmInv c
...| invPres --   RoundManagerInv (peerStates pre' pid)
             -- → RoundManagerInv where state is updated from proposal message
  with invariantsCorrect pid pre' ini preach
...| ic      --   RoundManagerInv (peerStates pre' pid)
  -- Modify state to contain "results" of handling the proposal.
  rewrite override-target-≡ {a = pid} {b = LBFT-post (handleProposal 0 pm) (peerStates pre' pid)} {f = peerStates pre'}
  = invPres ic

--------------------------------------------------
-- VOTE MSG
invariantsCorrect pid _   _   (step-s {pre = pre'} preach (step-peer (step-honest (step-msg {sndr , V vm} m∈pool ini))))
   | yes refl -- pid≡pid'
  with handleVoteSpec.Contract.rmInv $ handleVoteSpec.contract! 0 vm (msgPool pre') (peerStates pre' pid)
...| invPres
  rewrite override-target-≡ {a = pid} {b = LBFT-post (handleVote 0 vm) (peerStates pre' pid)} {f = peerStates pre'}
  = invPres (invariantsCorrect pid pre' ini preach)

--------------------------------------------------
-- COMMIT MSG
invariantsCorrect pid _   _   (step-s {pre = pre'} preach (step-peer (step-honest (step-msg {sndr , C cm} m∈pool ini))))
   | yes refl -- pid≡pid'
  rewrite override-target-≡ {a = pid} {b = LBFT-post (handle pid (C cm) 0) (peerStates pre' pid)} {f = peerStates pre'}
  = invariantsCorrect pid pre' ini preach

------------------------------------------------------------------------------

-- All signatures represented in QCs that are in the RoundManager for each peer
-- have been sent before (i.e., no peer conjures a signature and makes a QC out of it
-- and stores it).
qcVoteSigsSentB4 :
    ∀ pid (st : SystemState)
    → initialised st pid ≡ initd
    → ReachableSystemState st
    → QCProps.SigsForVotes∈Rm-SentB4 (msgPool st) (peerStates st pid)

------------------------------------------------------------------------------

-- Handling any messages preserves the above 'qcVoteSigsSentB4' property.
-- Says this indirectly, via ReachableSystemState
-- then says the property holds after executing a handler from that ReachableSystemState.
-- "preserves"
-- - know it is true in the prestate (from qcVoteSigsSendB4)
-- - proving it's true in the poststate.
handlePreservesSigsB4 :
    ∀ {nm pid pre sndr}
    → initialised pre pid ≡ initd
    → ReachableSystemState pre
    → (sndr , nm) ∈ msgPool pre
    → QCProps.SigsForVotes∈Rm-SentB4 (msgPool pre) (LBFT-post (handle pid nm 0) (peerStates pre pid))
handlePreservesSigsB4 {nm} {pid} {pre} {sndr} ini preach m∈pool {qc} {v} {pk} = hyp
   where
   hPool = msgPool pre
   hPre  = peerStates pre pid

   hPost = LBFT-post (handle pid nm 0) hPre

   qcPost' : (nm' : NetworkMsg) → nm' ≡ nm → QCProps.∈Post⇒∈PreOr (_QC∈NM nm) hPre hPost
   qcPost' (P pm) refl = qcPost
      where open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm hPool hPre)
   qcPost' (V vm) refl = qcPost
      where open handleVoteSpec.Contract     (handleVoteSpec.contract!     0 vm hPool hPre)
   qcPost' (C cm) refl qc qc∈pre = Left qc∈pre

   hyp : QCProps.SigForVote∈Rm-SentB4 v pk qc hPost hPool
   hyp qc∈hpPst sig {vs} vs∈qcvs ≈v ¬bootstrap
      with qcPost' nm refl qc qc∈hpPst
   ...| Left qc∈hpPre =
     qcVoteSigsSentB4 pid pre ini preach qc∈hpPre sig vs∈qcvs ≈v ¬bootstrap
   ...| Right qc∈m =
      mkMsgWithSig∈ nm v (vote∈qc vs∈qcvs ≈v qc∈m) sndr m∈pool sig (cong (_^∙ vSignature) ≈v)

------------------------------------------------------------------------------

qcVoteSigsSentB4 pid st ()   step-0

qcVoteSigsSentB4 pid st ini (step-s rss (step-peer {pid'} {pre = pre} step@(step-cheat cmc)))
  rewrite cheatStepDNMPeerStates₁ {pid'} {pid} {pre = pre} step unit
  with trans (sym $ cheatStepDNMInitialised₁ step unit) ini
...| initialised-pre-pid≡-initd
  = QCProps.++-SigsForVote∈Rm-SentB4
      {rm = peerStates pre pid} _ (qcVoteSigsSentB4 pid pre initialised-pre-pid≡-initd rss)

qcVoteSigsSentB4 pid st ini (step-s rss (step-peer {pid'} {pre = pre} (step-honest sps)))
  with pid ≟ pid'

-- DIFFERENT PEER CASE
...| no  pid≢pid'
  rewrite sym (pids≢StepDNMPeerStates {pre = pre} sps pid≢pid')
  = QCProps.++-SigsForVote∈Rm-SentB4
      {rm = peerStates pre pid} _
      (qcVoteSigsSentB4 pid pre (trans (pids≢StepDNMInitialised {pre = pre} sps pid≢pid') ini) rss)
...| yes refl
  with sps

-- INIT CASE
...| step-init {rm} rm×acts _
  = ret
   where
    ret : QCProps.SigsForVotes∈Rm-SentB4 (msgPool st) (peerStates st pid)
    ret
      with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
    ...| init-contract
      rewrite override-target-≡ {a = pid} {b = rm} {f = peerStates pre}
      = λ qc∈rm sig vs∈qc rbld≈ ¬bootstrap
        → ⊥-elim $
          ¬bootstrap
          (initHandlerSpec.ContractOk.sigs∈bs
            init-contract vs∈qc qc∈rm)

-- MSG CASE
...| step-msg {sndr , nm} m∈pool init
  rewrite override-target-≡ {a = pid} {b = LBFT-post (handle pid nm 0) (peerStates pre pid)} {f = peerStates pre}
  = QCProps.++-SigsForVote∈Rm-SentB4
      {rm = LBFT-post (handle pid nm 0) (peerStates pre pid)} _
      (handlePreservesSigsB4 init rss m∈pool)

------------------------------------------------------------------------------

qcVoteSigsSentB4-sps
  : ∀ pid (pre : SystemState) {s acts}
  → ReachableSystemState pre
  → (StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s , acts))
  → ∀ {qc v pk}
  → qc QCProps.∈RoundManager s
  → WithVerSig pk v
  → ∀ {vs : Author × Signature} → let (pid , sig) = vs in
    vs ∈ qcVotes qc → rebuildVote qc vs ≈Vote v
  → ¬ ∈BootstrapInfo-impl fakeBootstrapInfo sig
  → MsgWithSig∈ pk sig (msgPool pre)

qcVoteSigsSentB4-sps pid pre rss (step-init {rm} rm×acts _) qc∈s sig vs∈qcvs ≈v ¬bootstrap
  with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
  rewrite sym $ ++-identityʳ (msgPool pre)
  = QCProps.++-SigsForVote∈Rm-SentB4 {rm = rm} (msgPool pre)
      (λ qc∈rm sig vs∈qc rbld≈ ¬bootstrap
       → ⊥-elim $
           ¬bootstrap
           (initHandlerSpec.ContractOk.sigs∈bs
             init-contract vs∈qc qc∈rm))
      qc∈s sig vs∈qcvs ≈v ¬bootstrap

qcVoteSigsSentB4-sps pid pre rss (step-msg {sndr , m} m∈pool ini) {qc} {v} {pk} qc∈s sig {vs} vs∈qcvs ≈v ¬bootstrap
  with m
  -- TODO-2: refactor for DRY
...| P pm = help
  where
    hpPre = peerStates pre pid
    open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm (msgPool pre) hpPre)

    help : MsgWithSig∈ pk (proj₂ vs) (msgPool pre)
    help
      with qcPost qc qc∈s
    ...| Left qc∈pre = qcVoteSigsSentB4 pid pre ini rss qc∈pre sig vs∈qcvs ≈v ¬bootstrap
    ...| Right qc∈pm =
      mkMsgWithSig∈ (P pm) v (vote∈qc vs∈qcvs ≈v qc∈pm) sndr m∈pool sig (cong (_^∙ vSignature) ≈v)

   -- TODO-2: refactor for DRY
...| V vm = help
  where
    hvPre = peerStates pre pid
    open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)

    help : MsgWithSig∈ pk (proj₂ vs) (msgPool pre)
    help
      with qcPost qc qc∈s
    ...| Left qc∈pre = qcVoteSigsSentB4 pid pre ini rss qc∈pre sig vs∈qcvs ≈v ¬bootstrap
    ...| Right qc∈vm =
      mkMsgWithSig∈ (V vm) v (vote∈qc vs∈qcvs ≈v qc∈vm) sndr m∈pool sig (cong (_^∙ vSignature) ≈v)

...| C cm = qcVoteSigsSentB4 pid pre ini rss qc∈s sig vs∈qcvs ≈v ¬bootstrap

------------------------------------------------------------------------------

lastVotedRound-mono
  : ∀ pid (pre : SystemState) {ppost} {msgs}
  → ReachableSystemState pre
  → initialised pre pid ≡ initd
  → StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (ppost , msgs)
  → peerStates pre pid ≡L ppost at rmEpoch
  → Meta.getLastVoteRound ((peerStates pre pid) ^∙ pssSafetyData-rm)
    ≤
    Meta.getLastVoteRound (ppost                ^∙ pssSafetyData-rm)

lastVotedRound-mono pid pre preach ini (step-init _ uni) epoch≡ =
  case (trans (sym ini) uni) of λ ()

lastVotedRound-mono pid pre {ppost} preach ini₀ (step-msg {_ , m} m∈pool ini₁) epoch≡
  with m
...| P pm rewrite sym $ StepPeer-post-lemma {pre = pre} (step-honest (step-msg m∈pool ini₁)) = help
  where
  hpPool = msgPool pre
  hpPre  = peerStates pre pid
  hpPst  = LBFT-post (handleProposal 0 pm) hpPre
  hpOut  = LBFT-outs (handleProposal 0 pm) hpPre

  open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm hpPool hpPre {- hpReq -} )
  open RoundManagerInv (invariantsCorrect pid pre ini₁ preach)

  module VoteOld (lv≡ : hpPre ≡L hpPst at pssSafetyData-rm ∙ sdLastVote) where
    help : Meta.getLastVoteRound (hpPre ^∙ pssSafetyData-rm) ≤ Meta.getLastVoteRound (hpPst ^∙ pssSafetyData-rm)
    help = ≡⇒≤ (cong (Maybe-maybe {B = const ℕ} (_^∙ vRound) 0) lv≡)

  module VoteNew {vote : Vote}
    (lv≡v : just vote ≡ hpPst ^∙ pssSafetyData-rm ∙ sdLastVote)
    (lvr< : hpPre [ _<_ ]L hpPst at pssSafetyData-rm ∙ sdLastVotedRound)
    (lvr≡ : vote ^∙ vRound ≡ hpPst ^∙ pssSafetyData-rm ∙ sdLastVotedRound )
   where
    help : Meta.getLastVoteRound (hpPre ^∙ pssSafetyData-rm) ≤ Meta.getLastVoteRound (hpPst ^∙ pssSafetyData-rm)
    help = ≤-trans (SafetyDataInv.lvRound≤ ∘ SafetyRulesInv.sdInv $ rmSafetyRulesInv ) (≤-trans (<⇒≤ lvr<) (≡⇒≤ (trans (sym lvr≡) $ cong (Maybe-maybe {B = const ℕ} (_^∙ vRound) 0) lv≡v)))

  open Invariants
  open Reqs (pm ^∙ pmProposal) (hpPre ^∙ lBlockTree)
  open BlockTreeInv
  open BlockStoreInv
  open RoundManagerInv

  rmi : _
  rmi = invariantsCorrect pid pre ini₁ preach

  help : Meta.getLastVoteRound (hpPre ^∙ pssSafetyData-rm) ≤ Meta.getLastVoteRound (hpPst ^∙ pssSafetyData-rm)
  help
    with BlockId-correct? (pm ^∙ pmProposal)
  ...| no ¬validProposal
    = VoteOld.help (cong (_^∙ pssSafetyData-rm ∙ sdLastVote) (proj₁ $ invalidProposal ¬validProposal))
  ...| yes pmIdCorr
    with voteAttemptCorrect pmIdCorr (nohc preach m∈pool pid ini₀ rmi refl pmIdCorr)
  ...| Voting.mkVoteAttemptCorrectWithEpochReq (inj₁ (_ , Voting.mkVoteUnsentCorrect noVoteMsgOuts nvg⊎vgusc)) sdEpoch≡?
    with nvg⊎vgusc
  ...| inj₁  (mkVoteNotGenerated lv≡  lvr≤) = VoteOld.help lv≡
  ...| inj₂  (Voting.mkVoteGeneratedUnsavedCorrect vote (Voting.mkVoteGeneratedCorrect (mkVoteGenerated lv≡v voteSrc) blockTriggered))
    with voteSrc
  ...| inj₁  (mkVoteOldGenerated lvr≡ lv≡)  = VoteOld.help lv≡
  ...| inj₂  (mkVoteNewGenerated lvr< lvr≡) = VoteNew.help lv≡v lvr< lvr≡
  help
     | yes refl
     | Voting.mkVoteAttemptCorrectWithEpochReq (Right (Voting.mkVoteSentCorrect vm _ _ (Voting.mkVoteGeneratedCorrect (mkVoteGenerated lv≡v voteSrc) _))) sdEpoch≡?
    with voteSrc
  ...| Left  (mkVoteOldGenerated lvr≡ lv≡)  = VoteOld.help lv≡
  ...| Right (mkVoteNewGenerated lvr< lvr≡) = VoteNew.help lv≡v lvr< lvr≡

-- Receiving a vote or commit message does not update the last vote
...| V vm = ≡⇒≤ $ cong (Maybe-maybe (_^∙ vRound) 0 ∘ (_^∙ sdLastVote)) noSDChange
   where
   hvPre = peerStates pre pid
   hvPst = LBFT-post (handle pid (V vm) 0) hvPre

   open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)

...| C cm = ≤-refl

------------------------------------------------------------------------------

qcVoteSigsSentB4-handle
  : ∀ pid {pre m s acts}
  → ReachableSystemState pre
  → (StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s , acts))
  → send m ∈ acts
  → ∀ {qc v pk}
  → qc QC∈NM m
  → WithVerSig pk v
  → ∀ {vs : Author × Signature} → let (pid , sig) = vs in vs ∈ qcVotes qc
  → rebuildVote qc vs ≈Vote v
  → ¬ ∈BootstrapInfo-impl fakeBootstrapInfo sig
  → MsgWithSig∈ pk sig (msgPool pre)

qcVoteSigsSentB4-handle pid {pre} {m} {s} {acts} preach
                        (step-init {rm} rm×acts _)
                        send∈acts
                        {qc}
                        qc∈m sig vs∈qc v≈rbld ¬bootstrap
  with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
  with initHandlerSpec.ContractOk.isInitPM init-contract send∈acts
...| _ , refl , noSigs = ⊥-elim (noSigs vs∈qc qc∈m)

qcVoteSigsSentB4-handle pid {pre} {m} {s} {acts} preach
                        sps@(step-msg {_ , nm} m∈pool ini)
                        m∈acts
                        {qc} qc∈m sig vs∈qc v≈rbld ¬bootstrap =
  qcVoteSigsSentB4-sps pid pre preach sps qc∈rm sig vs∈qc v≈rbld ¬bootstrap
 where
  hdPool = msgPool pre
  hdPre  = peerStates pre pid
  hdPst  = LBFT-post (handle pid nm 0) hdPre
  hdOut  = LBFT-outs (handle pid nm 0) hdPre

  qc∈rm : qc QCProps.∈RoundManager hdPst
  qc∈rm
    with sendMsg∈actions {hdOut} {st = hdPre} m∈acts
  ...| out , out∈hdOut , m∈out = All-lookup (outQcs∈RM1 nm refl) out∈hdOut qc m qc∈m m∈out
   where
    outQcs∈RM1 : (nm' : NetworkMsg) → nm ≡ nm' → QCProps.OutputQc∈RoundManager hdOut hdPst
    outQcs∈RM1 (P pm) refl = outQcs∈RM
     where open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm hdPool hdPre)
    outQcs∈RM1 (V vm) refl = outQcs∈RM
     where open handleVoteSpec.Contract     (handleVoteSpec.contract!     0 vm hdPool hdPre)


------------------------------------------------------------------------
-- "Equational" reasoning combinator setup
------------------------------------------------------------------------

{-# OPTIONS --safe #-}

open import Labelled-transition-system

-- Note that the module parameter is explicit. If the LTS is not given
-- explicitly, then the use of _[ μ ]⟶_ in the instances below can
-- make it hard for Agda to infer what instance to use.

module Labelled-transition-system.Equational-reasoning-instances
         {ℓ} (lts : LTS ℓ) where

open import Prelude

open import Equational-reasoning

open LTS lts

private

  -- Converts one kind of proof of silence to another kind.

  get : ∀ {μ} → T (silent? μ) → Silent μ
  get {μ} _  with silent? μ
  get {μ} () | no _
  get {μ} _  | yes s = s

instance

  convert⟶ : ∀ {μ} → Convertible _[ μ ]⟶_ _[ μ ]⟶_
  convert⟶ = is-convertible id

  convert⟶⇒ : ∀ {μ} {s : T (silent? μ)} → Convertible _[ μ ]⟶_ _⇒_
  convert⟶⇒ {s = s} = is-convertible (⟶→⇒ (get s))

  convert⟶[]⇒ : ∀ {μ} → Convertible _[ μ ]⟶_ _[ μ ]⇒_
  convert⟶[]⇒ = is-convertible ⟶→[]⇒

  convert⟶⇒̂ : ∀ {μ} → Convertible _[ μ ]⟶_ _[ μ ]⇒̂_
  convert⟶⇒̂ = is-convertible ⟶→⇒̂

  convert⟶⟶̂ : ∀ {μ} → Convertible _[ μ ]⟶_ _[ μ ]⟶̂_
  convert⟶⟶̂ = is-convertible ⟶→⟶̂

  convert⇒ : Convertible _⇒_ _⇒_
  convert⇒ = is-convertible id

  convert⇒⇒̂ : ∀ {μ} {s : T (silent? μ)} → Convertible _⇒_ _[ μ ]⇒̂_
  convert⇒⇒̂ {s = s} = is-convertible (silent (get s))

  convert[]⇒ : ∀ {μ} → Convertible _[ μ ]⇒_ _[ μ ]⇒_
  convert[]⇒ = is-convertible id

  convert[]⇒⇒ : ∀ {μ} {s : T (silent? μ)} → Convertible _[ μ ]⇒_ _⇒_
  convert[]⇒⇒ {s = s} = is-convertible ([]⇒→⇒ (get s))

  convert[]⇒⇒̂ : ∀ {μ} → Convertible _[ μ ]⇒_ _[ μ ]⇒̂_
  convert[]⇒⇒̂ = is-convertible ⇒→⇒̂

  convert⇒̂ : ∀ {μ} → Convertible _[ μ ]⇒̂_ _[ μ ]⇒̂_
  convert⇒̂ = is-convertible id

  convert⇒̂⇒ : ∀ {μ} {s : T (silent? μ)} → Convertible _[ μ ]⇒̂_ _⇒_
  convert⇒̂⇒ {s = s} = is-convertible (⇒̂→⇒ (get s))

  convert⇒̂[]⇒ : ∀ {μ} {¬s : if (silent? μ) then ⊥ else ⊤} →
                Convertible _[ μ ]⇒̂_ _[ μ ]⇒_
  convert⇒̂[]⇒ {μ}       with silent? μ
  convert⇒̂[]⇒ {¬s = ()} | yes _
  convert⇒̂[]⇒           | no ¬s = is-convertible (⇒̂→[]⇒ ¬s)

  convert⟶̂ : ∀ {μ} → Convertible _[ μ ]⟶̂_ _[ μ ]⟶̂_
  convert⟶̂ = is-convertible id

  convert⟶̂⇒ : ∀ {μ} {s : T (silent? μ)} → Convertible _[ μ ]⟶̂_ _⇒_
  convert⟶̂⇒ {s = s} = is-convertible (⟶̂→⇒ (get s))

  convert⟶̂⇒̂ : ∀ {μ} → Convertible _[ μ ]⟶̂_ _[ μ ]⇒̂_
  convert⟶̂⇒̂ = is-convertible ⟶̂→⇒̂

  reflexive⇒ : Reflexive _⇒_
  reflexive⇒ = is-reflexive done

  reflexive⟶̂ : ∀ {μ} {s : T (silent? μ)} → Reflexive _[ μ ]⟶̂_
  reflexive⟶̂ {s = s} = is-reflexive (done (get s))

  reflexive⇒̂ : ∀ {μ} {s : T (silent? μ)} → Reflexive _[ μ ]⇒̂_
  reflexive⇒̂ {s = s} = is-reflexive (silent (get s) done)

  trans⇒ : Transitive _⇒_ _⇒_
  trans⇒ = is-transitive ⇒-transitive

  trans⟶⇒ : ∀ {μ} {s : T (silent? μ)} → Transitive _[ μ ]⟶_ _⇒_
  trans⟶⇒ {s = s} = is-transitive (⇒-transitive ∘ ⟶→⇒ (get s))

  trans⇒̂⇒ : ∀ {μ} {s : T (silent? μ)} → Transitive _[ μ ]⇒̂_ _⇒_
  trans⇒̂⇒ {s = s} = is-transitive (⇒-transitive ∘ ⇒̂→⇒ (get s))

  trans⟶̂⇒ : ∀ {μ} {s : T (silent? μ)} → Transitive _[ μ ]⟶̂_ _⇒_
  trans⟶̂⇒ {s = s} = is-transitive (⇒-transitive ∘ ⟶̂→⇒ (get s))

  trans⇒[]⇒ : ∀ {μ} → Transitive _⇒_ _[ μ ]⇒_
  trans⇒[]⇒ = is-transitive ⇒[]⇒-transitive

  trans⟶[]⇒ : ∀ {μ μ′} {s : T (silent? μ′)} →
              Transitive _[ μ′ ]⟶_ _[ μ ]⇒_
  trans⟶[]⇒ {s = s} = is-transitive (⇒[]⇒-transitive ∘ ⟶→⇒ (get s))

  trans[]⇒[]⇒ : ∀ {μ μ′} {s : T (silent? μ′)} →
                Transitive _[ μ′ ]⇒_ _[ μ ]⇒_
  trans[]⇒[]⇒ {s = s} = is-transitive (⇒[]⇒-transitive ∘ []⇒→⇒ (get s))

  trans⟶̂[]⇒ : ∀ {μ μ′} {s : T (silent? μ′)} →
              Transitive _[ μ′ ]⟶̂_ _[ μ ]⇒_
  trans⟶̂[]⇒ {s = s} = is-transitive (⇒[]⇒-transitive ∘ ⟶̂→⇒ (get s))

  trans⇒⇒̂ : ∀ {μ} → Transitive _⇒_ _[ μ ]⇒̂_
  trans⇒⇒̂ = is-transitive ⇒⇒̂-transitive

  trans⟶⇒̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
              Transitive _[ μ′ ]⟶_ _[ μ ]⇒̂_
  trans⟶⇒̂ {s = s} = is-transitive (⇒⇒̂-transitive ∘ ⟶→⇒ (get s))

  trans[]⇒⇒̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
                Transitive _[ μ′ ]⇒_ _[ μ ]⇒̂_
  trans[]⇒⇒̂ {s = s} = is-transitive (⇒⇒̂-transitive ∘ []⇒→⇒ (get s))

  trans[]⇒̂⇒̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
              Transitive _[ μ′ ]⇒̂_ _[ μ ]⇒̂_
  trans[]⇒̂⇒̂ {s = s} = is-transitive (⇒⇒̂-transitive ∘ ⇒̂→⇒ (get s))

  trans⟶̂⇒̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
              Transitive _[ μ′ ]⟶̂_ _[ μ ]⇒̂_
  trans⟶̂⇒̂ {s = s} = is-transitive (⇒⇒̂-transitive ∘ ⟶̂→⇒ (get s))

  trans′⇒⟶ : ∀ {μ} {s : T (silent? μ)} → Transitive′ _⇒_ _[ μ ]⟶_
  trans′⇒⟶ {s = s} =
    is-transitive (flip (flip ⇒-transitive ∘ ⟶→⇒ (get s)))

  trans′⇒[]⇒ : ∀ {μ} {s : T (silent? μ)} → Transitive′ _⇒_ _[ μ ]⇒_
  trans′⇒[]⇒ {s = s} =
    is-transitive (flip (flip ⇒-transitive ∘ []⇒→⇒ (get s)))

  trans′⇒⇒̂ : ∀ {μ} {s : T (silent? μ)} → Transitive′ _⇒_ _[ μ ]⇒̂_
  trans′⇒⇒̂ {s = s} =
    is-transitive (flip (flip ⇒-transitive ∘ ⇒̂→⇒ (get s)))

  trans′⇒⟶̂ : ∀ {μ} {s : T (silent? μ)} → Transitive′ _⇒_ _[ μ ]⟶̂_
  trans′⇒⟶̂ {s = s} =
    is-transitive (flip (flip ⇒-transitive ∘ ⟶̂→⇒ (get s)))

  trans′[]⇒⟶ : ∀ {μ μ′} {s : T (silent? μ′)} →
               Transitive′ _[ μ ]⇒_ _[ μ′ ]⟶_
  trans′[]⇒⟶ {s = s} =
    is-transitive (flip (flip []⇒⇒-transitive ∘ ⟶→⇒ (get s)))

  trans′[]⇒⇒ : ∀ {μ} → Transitive′ _[ μ ]⇒_ _⇒_
  trans′[]⇒⇒ = is-transitive []⇒⇒-transitive

  trans′[]⇒[]⇒ : ∀ {μ μ′} {s : T (silent? μ′)} →
                 Transitive′ _[ μ ]⇒_ _[ μ′ ]⇒_
  trans′[]⇒[]⇒ {s = s} =
    is-transitive (flip (flip []⇒⇒-transitive ∘ []⇒→⇒ (get s)))

  trans′[]⇒[]⇒̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
                 Transitive′ _[ μ ]⇒_ _[ μ′ ]⇒̂_
  trans′[]⇒[]⇒̂ {s = s} =
    is-transitive (flip (flip []⇒⇒-transitive ∘ ⇒̂→⇒ (get s)))

  trans′[]⇒⟶̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
               Transitive′ _[ μ ]⇒_ _[ μ′ ]⟶̂_
  trans′[]⇒⟶̂ {s = s} =
    is-transitive (flip (flip []⇒⇒-transitive ∘ ⟶̂→⇒ (get s)))

  trans′⇒̂⟶ : ∀ {μ μ′} {s : T (silent? μ′)} →
             Transitive′ _[ μ ]⇒̂_ _[ μ′ ]⟶_
  trans′⇒̂⟶ {s = s} =
    is-transitive (flip (flip ⇒̂⇒-transitive ∘ ⟶→⇒ (get s)))

  trans′⇒̂⇒ : ∀ {μ} → Transitive′ _[ μ ]⇒̂_ _⇒_
  trans′⇒̂⇒ = is-transitive ⇒̂⇒-transitive

  trans′⇒̂[]⇒ : ∀ {μ μ′} {s : T (silent? μ′)} →
               Transitive′ _[ μ ]⇒̂_ _[ μ′ ]⇒_
  trans′⇒̂[]⇒ {s = s} =
    is-transitive (flip (flip ⇒̂⇒-transitive ∘ []⇒→⇒ (get s)))

  trans′⇒̂⇒̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
             Transitive′ _[ μ ]⇒̂_ _[ μ′ ]⇒̂_
  trans′⇒̂⇒̂ {s = s} =
    is-transitive (flip (flip ⇒̂⇒-transitive ∘ ⇒̂→⇒ (get s)))

  trans′⇒̂⟶̂ : ∀ {μ μ′} {s : T (silent? μ′)} →
             Transitive′ _[ μ ]⇒̂_ _[ μ′ ]⟶̂_
  trans′⇒̂⟶̂ {s = s} =
    is-transitive (flip (flip ⇒̂⇒-transitive ∘ ⟶̂→⇒ (get s)))