{-# OPTIONS --show-irrelevant #-}

open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

postulate
  A : Set
  f : .(Bool → A) → Bool → A

mutual
  X : .A → Bool → A
  X = _

  test : (x : Bool → A) → X (x true) ≡ f x
  test x = refl


module CTL.Proof.AG where

open import CTL.Modalities.AG
open import FStream.Core
open import FStream.FVec
open import Library

-- TODO Maybe beautify syntax here and elsewhere
data proofAG' {ℓ₁ ℓ₂} {C : Container ℓ₁} : {n : ℕ} →
     (props : FVec' C (Set ℓ₂) n) → Set (ℓ₁ ⊔ ℓ₂) where
  []AG'  : proofAG' FNil'
  _▻AG'_ : ∀ {prop : Set ℓ₂} {n} {props : ⟦ C ⟧ (FVec' C (Set ℓ₂) n)} →
           prop → A (fmap proofAG' props) → proofAG' (FCons' prop props)

_pre⟨_▻AG' : ∀ {i ℓ₁ ℓ₂} {C : Container ℓ₁} {m n}
               {props : FVec' C (Set ℓ₂) m} {props' : FVec' C (Set ℓ₂) (suc n)}
            → proofAG' props → proofAG' props'
            → AG' {i} (props pre⟨ props' ▻⋯')
nowA ([]AG' pre⟨ (proof ▻AG' _) ▻AG') = proof
laterA ([]AG' pre⟨ (proof ▻AG' proofs) ▻AG') p =
  (proofs p) pre⟨ (proof ▻AG' proofs) ▻AG'
nowA ((proof ▻AG' _) pre⟨ _ ▻AG') = proof
laterA ((_ ▻AG' proofs) pre⟨ proofs' ▻AG') p =
  (proofs p) pre⟨ proofs' ▻AG'

⟨_▻AG' : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁} {n}
           {props : FVec' C (Set ℓ₂) (suc n)}
       → proofAG' props → AG' {i} (FNil' pre⟨ props ▻⋯')
⟨ proofs ▻AG' = []AG' pre⟨ proofs ▻AG'

data proofAG {ℓ₁ ℓ₂} {C : Container ℓ₁} : {n : ℕ} →
     (props : FVec C (Set ℓ₂) n) → Set (ℓ₁ ⊔ ℓ₂) where
  []AG : proofAG FNil
  ConsAG : ∀ {n} {props : ⟦ C ⟧ (Set ℓ₂ × FVec C (Set ℓ₂) n)} →
    A (fmap (λ x → (proj₁ x) × (proofAG (proj₂ x))) props) → proofAG (FCons props)
  -- TODO This constructor type signature is an abomination and should be somehow rewritten with proofAG, but how??
  -- TODO props should be of type FVec C (Set ℓ₂) (suc n) maybe? Or is it easier this way?

mapAGlemma : ∀ {i} {ℓ₁ ℓ₂ ℓ₃} {C : Container ℓ₁}
             {A : Set ℓ₂} {f : A → Set ℓ₃} {m n} →
             (v : FVec C A m) →
             (v' : FVec C A (suc n)) →
             AG {i} ((vmap f v pre⟨ vmap f v' ▻⋯)) →
             AG {i} (map f (v pre⟨ v' ▻⋯))
nowA (mapAGlemma FNil (FCons x) proofs p) = nowA (proofs p) -- TODO Why can't I join this with the next line?
nowA (mapAGlemma (FCons x) v proofs p) = nowA (proofs p)
laterA (mapAGlemma FNil (FCons (shape , vals)) proofs p) p₁ =
  mapAGlemma (proj₂ (vals p)) (FCons (shape , vals)) (laterA (proofs p)) p₁
laterA (mapAGlemma (FCons (shape , vals)) v' proofs p) p₁ =
  mapAGlemma (proj₂ (vals p)) v' (laterA (proofs p)) p₁

mapAG : ∀ {i} {ℓ₁ ℓ₂ ℓ₃} {C : Container ℓ₁}
          {A : Set ℓ₂} {f : A → Set ℓ₃} {m n} →
        {v : FVec C A m} →
        {v' : FVec C A (suc n)} →
        AG {i} ((vmap f v pre⟨ vmap f v' ▻⋯)) →
        AG {i} (map f (v pre⟨ v' ▻⋯))
mapAG {v = v} {v' = v'} = mapAGlemma v v'

_pre⟨_▻AG : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁} {m n}
              {props : FVec C (Set ℓ₂) m} {props' : FVec C (Set ℓ₂) (suc n)}
          → proofAG props
          → proofAG props'
          → AG {i} (props pre⟨ props' ▻⋯)
nowA ( ([]AG pre⟨ (ConsAG proofs) ▻AG) p) = proj₁ (proofs p)
laterA ( ([]AG pre⟨ (ConsAG proofs) ▻AG) p) p₁ =
  (proj₂ (proofs p) pre⟨ ConsAG proofs ▻AG) p₁
nowA ( ((ConsAG proofs) pre⟨ _ ▻AG) p) = proj₁ (proofs p)
laterA ( ((ConsAG proofs) pre⟨ proofs' ▻AG) p) p₁ =
  (proj₂ (proofs p) pre⟨ proofs' ▻AG) p₁
-- The p are the inputs (positions) from the side effects.

mapPreCycle : ∀ {i} {ℓ₁ ℓ₂ ℓ₃} {C : Container ℓ₁} {A : Set ℓ₂}
                {f : A → Set ℓ₃} {m n}
            → (v : FVec C A m) → (v' : FVec C A (suc n))
            → proofAG (vmap f v) → proofAG (vmap f v')
            → AG {i} (map f (v pre⟨ v' ▻⋯))
nowA (mapPreCycle FNil (FCons x) []AG (ConsAG proofs) p)
      with proofs p
...   | proof , proofs' = proof
laterA (mapPreCycle FNil (FCons (shape , vals)) []AG (ConsAG proofs) p) p'
      with proofs p
...   | proof , proofs'
      with vals p
...   | a , v = mapPreCycle v (FCons (shape , vals)) proofs' (ConsAG proofs) p'
nowA (mapPreCycle (FCons x) v' (ConsAG proofs) proofs' p) = proj₁ (proofs p)
laterA (mapPreCycle (FCons (shape , vals)) (FCons x) (ConsAG proofs) proofs' p) p₁
      with proofs p
...   | proof , proofs''
      with vals p
...   | a , v = mapPreCycle v (FCons x) proofs'' proofs' p₁

infixr 5 _▻AG_
infix 6 ⟨_▻AG
infix 7 _⟩AG

⟨_▻AG : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁} {n}
      → {props : FVec C (Set ℓ₂) (suc n)}
      → proofAG props
      → AG {i} (FNil pre⟨ props ▻⋯)
⟨_▻AG = []AG pre⟨_▻AG

_⟩AG : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁} {prop : ⟦ C ⟧ (Set ℓ₂)}
     → A prop
     → proofAG (FCons (fmap (_, FNil) prop))
x ⟩AG = ConsAG (λ p → x p , []AG)

_▻AG_ : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁}
          {prop : ⟦ C ⟧ (Set ℓ₂)} {n} {props : FVec C (Set ℓ₂) n}
      → A prop → proofAG props
      → proofAG (FCons (fmap (_, props) prop))
x ▻AG v = ConsAG (λ p → (x p) , v)


open import Common.Prelude
open import Common.Reflection
open import Common.Equality
open import Agda.Builtin.Sigma

magic₁ : ⊥ → Nat
magic₁ = λ ()

magic₂ : ⊥ → Nat
magic₂ = λ { () }

magic₃ : ⊥ → Nat
magic₃ ()

data Wrap (A : Set) : Set where
  wrap : A → Wrap A

magic₄ : Wrap ⊥ → Nat
magic₄ (wrap ())

data OK : Set where
  ok : OK

bad : String
bad = "not good"

macro
  checkDefinition : (Definition → Bool) → QName → Tactic
  checkDefinition isOk f hole =
    bindTC (getDefinition f) λ def →
    give (if isOk def then quoteTerm ok else quoteTerm bad) hole

pattern `Nat  = def (quote Nat) []
pattern _`→_ a b = pi (vArg a) (abs "_" b)
pattern `Wrap a = def (quote Wrap) (vArg a ∷ [])
pattern `⊥ = def (quote ⊥) []

pattern expected₄ = funDef
  (absurdClause (("()" , vArg `⊥) ∷ []) (vArg (con (quote wrap) (vArg absurd ∷ [])) ∷ [])
  ∷ [])

check₄ : OK
check₄ = checkDefinition (λ { expected₄ → true; _ → false }) magic₄

expected = extLam (absurdClause (("()" , vArg `⊥) ∷ []) (arg (argInfo visible relevant) absurd ∷ []) ∷ []) []

macro

  quoteTermNormalised : Term → Term → TC ⊤
  quoteTermNormalised t hole =
    bindTC (normalise t) λ t →
    bindTC (quoteTC t) λ t →
    unify hole t

check₁ : quoteTermNormalised magic₁ ≡ expected
check₁ = refl

check₂ : quoteTermNormalised magic₂ ≡ expected
check₂ = refl

pattern expectedDef =
  funDef (absurdClause (("()" , vArg `⊥) ∷ []) (vArg absurd ∷ []) ∷ [])

check₃ : OK
check₃ = checkDefinition (λ { expectedDef → true; _ → false }) magic₃


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

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Base.Types
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open WithAbsVote

module LibraBFT.Concrete.Obligations.VotesOnce
  (𝓔 : EpochConfig)
  (𝓥 : VoteEvidence 𝓔)
 where
 open import LibraBFT.Abstract.Abstract      UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Concrete.Intermediate                    𝓔 𝓥

 -------------------
 -- * VotesOnce * --
 -------------------

 module _ {ℓ}(𝓢 : IntermediateSystemState ℓ) where
  open IntermediateSystemState 𝓢
  Type : Set ℓ
  Type = ∀{α v v'}
       → Meta-Honest-Member α
       → vMember v  ≡ α → HasBeenSent v
       → vMember v' ≡ α → HasBeenSent v'
       → vRound v ≡ vRound v'
       → vBlockUID v ≡ vBlockUID v'
       -- NOTE: It is interesting that this does not require the timeout signature (or even
       -- presence/lack thereof) to be the same.  The abstract proof goes through without out it, so I
       -- am leaving it out for now, but I'm curious what if anything could go wrong if an honest
       -- author can send different votes for the same epoch and round that differ on timeout
       -- signature.  Maybe something for liveness?

  proof : Type → VotesOnlyOnceRule InSys
  proof glob-inv α hα {q} {q'} q∈sys q'∈sys va va' VO≡
     with ∈QC⇒HasBeenSent q∈sys  hα va
        | ∈QC⇒HasBeenSent q'∈sys hα va'
  ...| sent-cv | sent-cv'
     with glob-inv hα (sym (∈QC-Member q  va))  sent-cv
                      (sym (∈QC-Member q' va')) sent-cv'
                      VO≡
  ...| bId≡
     = Vote-η VO≡ (trans (sym (∈QC-Member q va)) (∈QC-Member q' va'))
                  bId≡


module Reduction where

import Level
open import Data.Empty
open import Data.Unit as Unit
open import Data.Nat
open import Data.List as List renaming ([] to Ø; [_] to [_]L)
open import NonEmptyList as NList
open import Data.Fin hiding (_+_)
open import Data.Vec as Vec renaming ([_] to [_]V; _++_ to _++V_)
open import Data.Product as Prod
open import Function

open import Relation.Binary.PropositionalEquality as PE hiding ([_])
open import Relation.Binary
open ≡-Reasoning

Rel₀ : Set → Set₁
Rel₀ X = Rel X Level.zero

open import Common.Context as Context

open import Algebra
open Monoid {{ ... }} hiding (refl)

open import SyntaxRaw
open import Syntax

-----------------------------------------------------
---- Action of types on terms
-----------------------------------------------------

PreArrow : RawCtx → Set
PreArrow Γ = PreType Ø Γ Ø × PreTerm (∗ ∷ Γ) Ø × PreType Ø Γ Ø

Args : TyCtx → Set
Args Ø = ⊤
Args (Γ ∷ Θ) = PreArrow Γ × (Args Θ)

getArg : ∀ {Θ Γ₁} → TyVar Θ Γ₁ → Args Θ → PreTerm (∗ ∷ Γ₁) Ø
getArg zero        ((_ , t , _) , ts) = t
getArg (succ Γ₁ X) (_           , ts) = getArg X ts

projArgDom : ∀ {Θ} → Args Θ → TyCtxMorP Ø Θ
projArgDom {Ø} a = tt
projArgDom {Γ ∷ Θ} ((A , _) , a) = (Λ A , projArgDom a)

projArgCodom : ∀ {Θ} → Args Θ → TyCtxMorP Ø Θ
projArgCodom {Ø} a = tt
projArgCodom {Γ ∷ Θ} ((_ , _ , B) , a) = (Λ B , projArgDom a)

-- | Extend arguments by the identity on a given type.
extArgs : ∀ {Θ Γ} → Args Θ → PreType Ø Γ Ø → Args (Γ ∷ Θ)
extArgs a A = ((A , varPO zero , A) , a)

-- | Domain of ⟪ A ⟫(φ) for arguments φ : Args Θ.
⟪_⟫₀ : ∀ {Θ Γ₁ Γ₂} →
       PreType Θ Γ₁ Γ₂ → Args Θ → PreType Ø (Γ₂ ++ Γ₁) Ø
⟪_⟫₀ {Γ₁ = Γ₁} {Γ₂} C φ =
  substTy (weakenPT' Γ₂ C) (projArgDom φ) §ₜ ctxProjP' Ø Γ₂ Γ₁

-- | Functorial action of a type A on terms.
-- We are given one term with its types for domain and codomain for each
-- variable in Θ. This is ensured by Args Θ. The result is then a term, which
-- can be thought of as ⟪A⟫(φ) : ⟪A⟫₀(φ) → ⟪A⟫₁(φ).
-- Otherwise, ⟪A⟫ is just defined by induction in A, as in the paper.
-- Note: For now, we have to declare this as non-terminating, as the induction
-- is not obviously terminating for Agda. This should be fixable through sized
-- types.
tyAction : ∀ {Θ Γ₁ Γ₂} →
           (A : Raw Θ Γ₁ Γ₂) → DecentType A → Args Θ → PreTerm (∗ ∷ Γ₂ ++ Γ₁) Ø
tyAction ._ (DT-⊤ Θ Γ)                    ts = varPO zero
tyAction ._ (DT-tyVar Γ₁ X)               ts = weakenPO'' Γ₁ Ø (getArg X ts)
tyAction ._ (DT-inst {Θ} {Γ₁} {Γ₂} {B} A t p q) ts
  = substP (tyAction A p ts) f
  where
    -- | Substitute t for the second variable, i.e., f = (id, t, x).
    f : CtxMorP (∗ ∷ Γ₂ ++ Γ₁) (∗ ∷ Γ₂ ↑ B ++ Γ₁)
    f = subst
        (Vec (PreTerm (∗ ∷ Γ₂ ++ Γ₁) Ø)) -- (CtxMorP (∗ ∷ Γ₂ ++ Γ₁))
        (cong suc r)
        (varPO zero
          ∷ (ctxProjP' [ ∗ ]L Γ₂ Γ₁)
          ++V [ weakenPO' (∗ ∷ Γ₂) (t , q) ]V
          ++V ctxProjP Γ₁ (∗ ∷ Γ₂)
        )
      where
        r : length' Γ₂ + suc (length' Γ₁) ≡ length' (Γ₂ ↑ B ++ Γ₁)
        r =
          begin
            length' Γ₂ + suc (length' Γ₁)
          ≡⟨ refl ⟩
            length' Γ₂ + length' (B ∷ Γ₁)
          ≡⟨ PE.sym (length'-hom Γ₂ (B ∷ Γ₁)) ⟩
            length' (Γ₂ ++ B ∷ Γ₁)
          ≡⟨ mvVar-length Γ₁ Γ₂ B ⟩
            length' (Γ₂ ↑ B ++ Γ₁)
          ∎

tyAction ._ (DT-paramAbstr {Θ} {Γ₂} {B} Γ₁ {A} p) ts =
  subst (λ u → PreTerm u Ø)
        (cong (_∷_ ∗) (mvVar Γ₁ Γ₂ B))
        (tyAction A p ts)

tyAction ._ (DT-fp {Θ} {Γ₂} Γ₁ μ D D-dec) ts
  = weakenPO'' Γ₁ Ø (rec Γ₂ (∗ ∷ Γ₂) (gs D D-dec 0) §ₘ ctxidP (∗ ∷ Γ₂))
  where
    RB : PreType Ø Γ₂ Ø
    RB = subst (λ u → PreType Ø u Ø) (proj₂ identity Γ₂)
               (⟪ fpPT {Θ} {Γ₂} Ø μ (mkFpDataP {D = D} D-dec) ⟫₀ ts)

    -- Construction of gₖ = αₖ id (⟪ Bₖ ⟫ (ts, id))
    mkBase : ∀{Γ'}
             (f : CtxMor Raw Γ' Γ₂) (A : Raw (Γ₂ ∷ Θ) Γ' Ø) →
             DecentCtxMor f →
             DecentType A →
             ℕ →
             Σ RawCtx (λ Γ' →
               PreType [ Γ₂ ]L Γ' Ø
               × CtxMorP Γ' Γ₂
               × PreTerm (∗ ∷ Γ') Ø)
    mkBase {Γ'} g M g-dec M-dec k
      = (Γ' , C , mkCtxMorP g-dec , αₖ §ₘ r)
      where
        A : PreType (Γ₂ ∷ Θ) Γ' Ø
        A = mkPreType M-dec

        αₖ : PreTerm (∗ ∷ Γ') (∗ ∷ Γ')
        αₖ = α _ Γ' ∗ k

        r : CtxMorP (∗ ∷ Γ') (∗ ∷ Γ')
        r = tyAction M M-dec (extArgs ts RB) ∷ ctxProjP Γ' [ ∗ ]L

        C : PreType [ Γ₂ ]L Γ' Ø
        C = substTy A (tyVarPT Ø zero , weakenTyCtxMor₁ Γ₂ (projArgDom ts))

    -- Construct the g₁, ..., gₙ used in the recursion
    gs : (D : FpData Raw Θ Γ₂) → DecentFpData D → ℕ → FpMapDataP Γ₂
    gs [ Γ' , f , M ] (f-dec , M-dec) k
      = [ mkBase f M f-dec M-dec k ]
    gs ((Γ' , f , M) ∷ D) ((f-dec , M-dec) , D-dec) k
      = mkBase f M f-dec M-dec k ∷ gs D D-dec (suc k)

tyAction ._ (DT-fp {Θ} {Γ₂} Γ₁ ν D D-dec) ts
  = weakenPO'' Γ₁ Ø (corec Γ₂ (∗ ∷ Γ₂) (gs D D-dec 0) §ₘ ctxidP (∗ ∷ Γ₂))
  where
    -- Construction of gₖ = αₖ id (⟪ Bₖ ⟫ (ts, id))
    mkBase : ∀{Γ'} (x : CtxMor Raw Γ' Γ₂ × Raw (Γ₂ ∷ Θ) Γ' Ø) →
             (f : DecentCtxMor (proj₁ x)) →
             (q : DecentType (proj₂ x)) →
             ℕ →
             Σ RawCtx (λ Γ' →
               PreType [ Γ₂ ]L Γ' Ø
               × CtxMorP Γ' Γ₂
               × PreTerm (∗ ∷ Γ') Ø)
    mkBase {Γ'} (g , M) g-dec M-dec k = (Γ' , C , mkCtxMorP g-dec , f)
      where
        A : PreType (Γ₂ ∷ Θ) Γ' Ø
        A = mkPreType M-dec

        ξₖ : PreTerm (∗ ∷ Γ') (∗ ∷ Γ')
        ξₖ = ξ _ Γ' ∗ k

        RA : PreType Ø Γ₂ Ø
        RA = subst (λ u → PreType Ø u Ø) (proj₂ identity Γ₂)
             (⟪ fpPT {Θ} {Γ₂} Ø μ (mkFpDataP {D = D} D-dec) ⟫₀ ts)

        f : PreTerm (∗ ∷ Γ') Ø
        f = substPO (tyAction M M-dec (extArgs ts RA))
                    ((ξₖ §ₘ ctxidP (∗ ∷ Γ')) ∷ weakenCtxMorP (ctxidP Γ'))

        C : PreType [ Γ₂ ]L Γ' Ø
        C = substTy A (tyVarPT Ø zero , weakenTyCtxMor₁ Γ₂ (projArgDom ts))

    -- Construct the g₁, ..., gₙ used in the recursion
    gs : (D : FpData Raw Θ Γ₂) → DecentFpData D → ℕ → FpMapDataP Γ₂
    gs [ Γ' , x ] (f , p) k = [ mkBase x f p k ]
    gs ((Γ' , x) ∷ D₁) ((f , q) , p₁) k = mkBase x f q k ∷ gs D₁ p₁ (suc k)

⟪_⟫ : ∀ {Θ Γ₁ Γ₂} →
      PreType Θ Γ₁ Γ₂ → Args Θ → PreTerm (∗ ∷ Γ₂ ++ Γ₁) Ø
⟪ A , A-dec ⟫ = tyAction A A-dec

-----------------------------------------------------
---- Reduction relation on pre-types and pre-terms
-----------------------------------------------------

getRecCtx : ∀{Γ} → (D : FpMapDataP Γ) → Pos D → RawCtx
getRecCtx [ x ]   _       = proj₁ x
getRecCtx (x ∷ D) zero    = proj₁ x
getRecCtx (x ∷ D) (suc p) = getRecCtx D p

getRecMor : ∀{Γ} (D : FpMapDataP Γ) (p : Pos D) →
            PreTerm (∗ ∷ getRecCtx D p) Ø
getRecMor [ Γ' , A , f , t ]      _       = t
getRecMor ((Γ' , A , f , t) ∷ D) zero    = t
getRecMor (x ∷ D)                (suc p) = getRecMor D p

getRecTy : ∀{Γ} (D : FpMapDataP Γ) (p : Pos D) →
           PreType [ Γ ]L (getRecCtx D p) Ø
getRecTy [ x ]   _       = proj₁ (proj₂ x)
getRecTy (x ∷ D) zero    = proj₁ (proj₂ x)
getRecTy (x ∷ D) (suc p) = getRecTy D p

getRecSubst : ∀{Γ} (D : FpMapDataP Γ) (p : Pos D) →
              CtxMorP (getRecCtx D p) Γ
getRecSubst [ Γ' , A , f , t ]     _       = f
getRecSubst ((Γ' , A , f , t) ∷ D) zero    = f
getRecSubst (x ∷ D)                (suc p) = getRecSubst D p

infix 0 _≻_

-- | Contraction for terms
data _≻_  : {Γ₁ Γ₂ : RawCtx} → PreTerm Γ₁ Γ₂ → PreTerm Γ₁ Γ₂ → Set where
  contract-iter : (Γ Δ : RawCtx) (D : FpMapDataP Γ) (C : PreType Ø Ø Γ)
                  (p : Pos D)
                  (τ : CtxMorP Δ (getRecCtx D p))
                  (u : PreTerm Δ Ø) →
                rec Γ Δ D §ₘ
                  (α Δ (getRecCtx D p) ∗ (toℕ p) §ₘ' τ §ₒ u)
                  ∷ getRecSubst D p • τ
                ≻ (getRecMor D p)
                  ↓[ (⟪ getRecTy D p ⟫ (
                        ( fpPT Γ μ (getFpData D) §ₜ ctxidP Γ
                        , rec Γ (∗ ∷ Γ) D §ₘ ctxidP _
                        , (weakenPT'' Γ C) §ₜ ctxidP Γ)
                        , tt))
                     ∷ ctxProjP (getRecCtx D p) [ ∗ ]L ]
                  ↓[ u ∷ τ ]
  contract-coiter : (Γ Δ : RawCtx) (D : FpMapDataP Γ) (C : PreType Ø Ø Γ)
                    (p : Pos D)
                    (τ : CtxMorP Δ (getRecCtx D p))
                    (u : PreTerm Δ Ø) →
                    ξ Δ (getRecCtx D p) ∗ (toℕ p)
                      §ₘ' τ
                      §ₒ corec Γ Δ D §ₘ u ∷ (getRecSubst D p • τ)
                    ≻ (⟪ getRecTy D p ⟫ (
                         (weakenPT'' Γ C §ₜ ctxidP Γ
                         , corec Γ (∗ ∷ Γ) D §ₘ ctxidP _
                         , fpPT Γ ν (getFpData D) §ₜ ctxidP Γ)
                      , tt)
                      ↓[ (getRecMor D p) ∷ ctxProjP (getRecCtx D p) [ ∗ ]L ])
                      ↓[ u ∷ τ ]

-- | Lift term reduction to fixed point data
data _∼>_ : {Γ : RawCtx} → Rel₀ (FpMapDataP Γ)

-- | Compatible closure of contraction
data _⟶_ : {Γ₁ Γ₂ : RawCtx} → Rel₀ (PreTerm Γ₁ Γ₂) where
  contract : {Γ₁ Γ₂ : RawCtx} (t₁ t₂ : PreTerm Γ₁ Γ₂) → t₁ ≻ t₂ → t₁ ⟶ t₂

  inst-clos₁ : ∀ {Γ₁ Γ₂ A} (s₁ s₂ : PreTerm Γ₁ (Γ₂ ↑ A)) (t : PreTerm Γ₁ Ø) →
               s₁ ⟶ s₂ → instPO {Γ₁} {Γ₂} s₁ t ⟶ instPO s₂ t

  inst-clos₂ : ∀ {Γ₁ Γ₂ A} (s : PreTerm Γ₁ (Γ₂ ↑ A)) (t₁ t₂ : PreTerm Γ₁ Ø) →
               t₁ ⟶ t₂ → instPO {Γ₁} {Γ₂} s t₂ ⟶ instPO s t₂

  grec-clos : (Γ : RawCtx) (Δ : RawCtx) (D D' : FpMapDataP Γ) (ρ : FP) →
              D ∼> D' → grec Γ Δ D ρ ⟶ grec Γ Δ D' ρ

data _∼>_ where
  single-clos : {Γ : RawCtx} (Γ' : RawCtx) (A : PreType [ Γ ]L Γ' Ø)
                (f : CtxMorP Γ' Γ) (M₁ M₂ : PreTerm (∗ ∷ Γ') Ø) →
                M₁ ⟶ M₂ → [ Γ' , A , f , M₁ ] ∼> [ Γ' , A , f , M₂ ]

  step-clos₁ : {Γ : RawCtx} (Γ' : RawCtx) (A : PreType [ Γ ]L Γ' Ø)
               (f : CtxMorP Γ' Γ) (M₁ M₂ : PreTerm (∗ ∷ Γ') Ø)
               (D : FpMapDataP Γ) →
               M₁ ⟶ M₂ → ((Γ' , A , f , M₁) ∷ D) ∼> ((Γ' , A , f , M₂) ∷ D)

  step-clos₂ : {Γ : RawCtx} (Γ' : RawCtx) (A : PreType [ Γ ]L Γ' Ø)
               (f : CtxMorP Γ' Γ) (M : PreTerm (∗ ∷ Γ') Ø)
               (D₁ D₂ : FpMapDataP Γ) →
               D₁ ∼> D₂ → ((Γ' , A , f , M) ∷ D₁) ∼> ((Γ' , A , f , M) ∷ D₂)

-- | β-reduction for parameter abstraction/instantiation
data _⟶ₚ_ : {Θ : TyCtx} {Γ₁ Γ₂ : RawCtx} → Rel₀ (PreType Θ Γ₁ Γ₂) where
     β-red : {Θ : TyCtx} {Γ₂ : RawCtx} (Γ₁ : RawCtx) {A : U}
             (B : PreType Θ (A ∷ Γ₁) Γ₂) (t : PreTerm Γ₁ Ø) →
             instPT (paramAbstrPT Γ₁ B) t ⟶ₚ substPT B (t ∷ (ctxidP Γ₁))

-- | Lift type reductions to fixed point data
data _∼>ₜ_ : {Θ : TyCtx} {Γ : RawCtx} → Rel₀ (FpDataP Θ Γ)

-- | Reduction on types. This is either a β-reduction for parameters,
-- a reduction of a term in parameter position, or it happens through
-- the compatible closure.
data _⟶ₜ_ : {Θ : TyCtx} {Γ₁ Γ₂ : RawCtx} → Rel₀ (PreType Θ Γ₁ Γ₂) where
     param-conv : ∀ {Θ Γ₁ Γ₂ A}
                  (B : PreType Θ Γ₁ (Γ₂ ↑ A)) (t₁ t₂ : PreTerm Γ₁ Ø) →
                  t₁ ⟶ t₂ → instPT {Γ₂ = Γ₂} B t₁ ⟶ₜ instPT B t₂

     inst-conv : {Θ : TyCtx} {Γ₁ Γ₂ : RawCtx} → (A₁ A₂ : PreType Θ Γ₁ Γ₂) →
                 A₁ ⟶ₚ A₂ → A₁ ⟶ₜ A₂

     instPT-clos : ∀ {Θ Γ₁ Γ₂ A}
                  (B₁ B₂ : PreType Θ Γ₁ (Γ₂ ↑ A)) (t : PreTerm Γ₁ Ø) →
                  B₁ ⟶ₜ B₂ → instPT {Γ₂ = Γ₂} B₁ t ⟶ₜ instPT B₂ t

     paramAbstr-clos : {Θ : TyCtx} {Γ₂ : RawCtx} (Γ₁ : RawCtx) {A : U} →
                       (B₁ B₂ : PreType Θ (A ∷ Γ₁) Γ₂) →
                       B₁ ⟶ₜ B₂ → paramAbstrPT Γ₁ B₁ ⟶ₜ paramAbstrPT Γ₁ B₂

     fp-clos : {Θ : TyCtx} {Γ₂ : RawCtx} (Γ₁ : RawCtx) →
               (ρ : FP) (D₁ D₂ : FpDataP Θ Γ₂) →
               D₁ ∼>ₜ D₂ → fpPT Γ₁ ρ D₁ ⟶ₜ fpPT Γ₁ ρ D₂

data _∼>ₜ_ where
  singlePT-clos : {Θ : TyCtx} {Γ : RawCtx}
    (Γ' : RawCtx) (f : CtxMorP Γ' Γ) (A₁ A₂ : PreType (Γ ∷ Θ) Γ' Ø) →
    A₁ ⟶ₜ A₂ → [ Γ' , f , A₁ ] ∼>ₜ [ Γ' , f , A₂ ]

  stepPT-clos₁ : {Θ : TyCtx} {Γ : RawCtx}
    (Γ' : RawCtx) (f : CtxMorP Γ' Γ) (A₁ A₂ : PreType (Γ ∷ Θ) Γ' Ø)
    (D : FpDataP Θ Γ) →
    A₁ ⟶ₜ A₂ -> ((Γ' , f , A₁) ∷ D) ∼>ₜ ((Γ' , f , A₂) ∷ D)

  stepPT-clos₂ : {Θ : TyCtx} {Γ : RawCtx}
    (Γ' : RawCtx) (f : CtxMorP Γ' Γ) (A : PreType (Γ ∷ Θ) Γ' Ø)
    (D₁ D₂ : FpDataP Θ Γ) →
    D₁ ∼>ₜ D₂ -> ((Γ' , f , A) ∷ D₁) ∼>ₜ ((Γ' , f , A) ∷ D₂)


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

open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; subst; cong; trans)
open import Relation.Nullary.Decidable using (toWitness; fromWitness)
open import Relation.Nullary using (yes; no)
open import Function.Reasoning
open import Function using (_∘_)

import Data.Empty as Empty
import Data.Product as Product
import Data.Product.Properties as Productₚ
import Data.Unit as Unit
import Data.Nat.Base as Nat
import Data.Vec.Base as Vec
import Data.Vec.Properties as Vecₚ
import Data.Fin.Base as Fin
import Data.Fin.Properties as Finₚ
import Data.Vec.Relation.Unary.All as All

open Empty using (⊥-elim)
open Unit using (tt)
open Nat using (ℕ; zero; suc)
open Vec using (Vec; []; _∷_)
open All using (All; []; _∷_)
open Fin using (Fin ; zero ; suc)
open Product using (Σ-syntax; ∃-syntax; _×_; _,_; proj₁; proj₂)

import PiCalculus.Syntax
open PiCalculus.Syntax.Scoped
open import PiCalculus.Semantics
open import PiCalculus.Semantics.Properties
open import PiCalculus.LinearTypeSystem.Algebras

module PiCalculus.LinearTypeSystem.Substitution (Ω : Algebras) where
open Algebras Ω
open import PiCalculus.LinearTypeSystem Ω
open import PiCalculus.LinearTypeSystem.ContextLemmas Ω
open import PiCalculus.LinearTypeSystem.Framing Ω

private
  variable
    n : ℕ
    i j : Fin n
    t t' : Type
    γ : PreCtx n
    idx idx' : Idx
    idxs : Idxs n
    x y z m m' l δ : Usage idx ²
    Γ Γₗ Γᵣ Ξₗ Ξᵣ Δ Δ' Ξ' Θ Ψ Ξ Ψ' Θ' Δₗ Δᵣ Β : Ctx idxs
    P : Scoped n

midpoint : {Γᵢ Γ Δ Ψ ΔP Ξᵢ ΔQ Ψᵢ : Ctx idxs} {m n : Usage idx ²}
         → Γᵢ ∋[ i ] m ▹ Γ
         → Γ ≔ Δ ⊗ Ψ
         → All.lookup i Δ ≡ ℓ∅
         → Γᵢ ≔ ΔP ⊗ Ξᵢ
         → Ξᵢ ≔ ΔQ ⊗ Ψᵢ
         → Ψᵢ ∋[ i ] n ▹ Ψ
         → Σ[ δ ∈ Usage idx ² ]
           Σ[ Θ ∈ Ctx idxs ]
           Σ[ Δ₁ ∈ Ctx idxs ]
           Σ[ Δ₂ ∈ Ctx idxs ] (
           Ξᵢ ∋[ i ] δ ▹ Θ
         × Γ ≔ Δ₁ ⊗ Θ
         × Θ ≔ Δ₂ ⊗ Ψ)

midpoint {i = zero} (zero γᵢ≔m∙γ) (Γ≔Δ∙Ψ , γ≔δ∙ψ) refl (Γᵢ≔ΔP∙Ξᵢ , γᵢ≔δp∙ξᵢ) (Ξᵢ≔ΔQ∙Ψᵢ , ξᵢ≔δq∙ψᵢ) (zero ψᵢ≔n∙ψ)
  rewrite ∙²-unique γ≔δ∙ψ ∙²-idˡ =
  let _ , ξᵢ≔δ∙θ , _ = ∙²-assoc⁻¹ ξᵢ≔δq∙ψᵢ ψᵢ≔n∙ψ in
  _ , _ , (_ -, _) , _ , zero ξᵢ≔δ∙θ , (Γᵢ≔ΔP∙Ξᵢ , ∙²-idˡ) , (Ξᵢ≔ΔQ∙Ψᵢ , ∙²-idˡ)
midpoint {i = suc i} (suc Γᵢ≔m∙Γ) (Γ≔Δ∙Ψ , _) Δ[i]≡ℓ∅ (Γᵢ≔ΔP∙Ξᵢ , γᵢ≔δp∙ξᵢ) (Ξᵢ≔ΔQ∙Ψᵢ , ξᵢ≔δq∙ψᵢ) (suc ψᵢ≔n∙ψ) =
  let _ , _ , _ , _ , Ξᵢ≔δ∙Θ , Γ≔Δ₁∙Θ , Θ≔Δ₂∙Ψ = midpoint Γᵢ≔m∙Γ Γ≔Δ∙Ψ Δ[i]≡ℓ∅ Γᵢ≔ΔP∙Ξᵢ Ξᵢ≔ΔQ∙Ψᵢ ψᵢ≔n∙ψ in
  _ , _ , (_ -, _) , _ , suc Ξᵢ≔δ∙Θ , (Γ≔Δ₁∙Θ , γᵢ≔δp∙ξᵢ) , (Θ≔Δ₂∙Ψ , ξᵢ≔δq∙ψᵢ)

cutpoint : {Γ Δ Θ Γⱼ : Ctx idxs} {m n l : Usage idx ²}
       → Γ ≔ Δ ⊗ Θ
       → Γⱼ ∋[ j ] m ▹ Γ
       → m ≔ n ∙² l
       → Σ[ Θⱼ ∈ Ctx idxs ] (Θⱼ ∋[ j ] l ▹ Θ)
cutpoint (_ , γ≔) (zero x) m≔ =
  let
    _ , _ , a = ∙²-assoc x m≔
    _ , _ , c = ∙²-assoc (∙²-comm a) γ≔
  in _ , zero (∙²-comm c)
cutpoint (Γ≔ , _) (suc ∋j) m≔ with cutpoint Γ≔ ∋j m≔
cutpoint (Γ≔ , _) (suc ∋j) m≔ | _ , r = _ , suc r

∋-subst : {Γ Γᵢ Γⱼ Δ Ψ Ψᵢ Ψⱼ Ξᵢ CONT : Ctx idxs} {i j x : Fin n} {mx : Usage idx' ²} {m n : Usage idx ²}
        → Vec.lookup γ i ≡ Vec.lookup γ j
        → Γᵢ ∋[ i ] m ▹ Γ
        → Γⱼ ∋[ j ] m ▹ Γ
        → Ψᵢ ∋[ i ] n ▹ Ψ
        → Ψⱼ ∋[ j ] n ▹ Ψ
        → Γ ≔ Δ ⊗ Ψ
        → All.lookup i Δ ≡ ℓ∅
        → γ ； Γᵢ ∋[ x ] t ； mx ▹ Ξᵢ
        → Ξᵢ ≔ CONT ⊗ Ψᵢ
        → Σ[ Ξⱼ ∈ Ctx idxs ]
          Σ[ Θ ∈ Ctx idxs ]
          Σ[ Δ' ∈ Ctx idxs ]
          Σ[ m' ∈ Usage idx ² ]
         (γ ； Γⱼ ∋[ x [ i ↦ j ]' ] t ； mx ▹ Ξⱼ
        × Ξᵢ ∋[ i ] m' ▹ Θ
        × Ξⱼ ∋[ j ] m' ▹ Θ
        × Θ ≔ Δ' ⊗ Ψ
        × All.lookup i Δ' ≡ ℓ∅)
∋-subst {i = i} {x = x} eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (∋t , ∋x) Ξᵢ≔CONT∙Ψᵢ with i Finₚ.≟ x
∋-subst {i = i} {x = x} eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (∋t , ∋x) Ξᵢ≔CONT∙Ψᵢ | yes refl with ∋-≡Idx ∋i | ∋-≡Idx ∋x
∋-subst {i = i} {x = x} eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (∋t , ∋x) Ξᵢ≔CONT∙Ψᵢ | yes refl | refl | refl =
  let
    _ , Ξᵢ≔CONTn∙Ψ , _ = ⊗-assoc⁻¹ Ξᵢ≔CONT∙Ψᵢ (proj₁ (proj₂ (∋-⊗ ∈i)))
    δ , m≔ℓ∙δ = boil ∋i ∋x Ξᵢ≔CONTn∙Ψ Γ≔Δ∙Ψ Δ∋iℓ∅
    _ , Γᵢ≔ℓ∙⁇ᵢ , ⁇ᵢ≔δ∙Γ = split m≔ℓ∙δ ∋i
    _ , Γⱼ≔ℓ∙⁇ⱼ , ⁇ⱼ≔δ∙Γ = split m≔ℓ∙δ ∋j
    ⁇ᵢ≡Ξᵢ = ∋-uniqueʳ Γᵢ≔ℓ∙⁇ᵢ ∋x
    Ξᵢ≔δ∙Γ = subst (λ ● → ● ∋[ _ ] δ ▹ _) ⁇ᵢ≡Ξᵢ ⁇ᵢ≔δ∙Γ
  in _ , _ , _ , _ , (≡Type-∋ (trans (sym eq) (∋-≡Type ∋t)) , Γⱼ≔ℓ∙⁇ⱼ) , Ξᵢ≔δ∙Γ , ⁇ⱼ≔δ∙Γ , Γ≔Δ∙Ψ , Δ∋iℓ∅

∋-subst {i = i} {x = x} eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (∋t , ∋x) Ξᵢ≔CONT∙Ψᵢ | no i≢x =
  let
    _ , Ξᵢ≔m∙Θ , Γ≔ℓ∙Θ = diamond i≢x ∋x ∋i
    _ , Γⱼ≔m'∙Γ , m'≔m∙ε = ∋-⊗ ∋j
    _ , Γ≔ℓ'∙Θ ,  ℓ'≔ℓ∙ε = ∋-⊗ Γ≔ℓ∙Θ
    _ , Γⱼ≔ℓ'∙Ξⱼ , Ξⱼ≔m'∙Θ = reverse Γⱼ≔m'∙Γ Γ≔ℓ'∙Θ
    _ , Γᵢ≔ℓCONT∙Ψᵢ , _ = ⊗-assoc⁻¹ (proj₁ (proj₂ (∋-⊗ ∋x))) Ξᵢ≔CONT∙Ψᵢ
    _ , Ξᵢ≔CONTn∙Ψ , _ = ⊗-assoc⁻¹ Ξᵢ≔CONT∙Ψᵢ (proj₁ (proj₂ (∋-⊗ ∈i)))
    _ , Θ≔Δ'∙Ψ = outer-diamond i≢x ∋i ∋x Γ≔ℓ∙Θ Ξᵢ≔m∙Θ Γ≔Δ∙Ψ Ξᵢ≔CONTn∙Ψ
    _ , Δ'∋iℓ∅ = split-ℓ∅ Γ≔Δ∙Ψ (proj₁ (proj₂ (∋-⊗ Γ≔ℓ∙Θ))) Θ≔Δ'∙Ψ Δ∋iℓ∅
  in _ , _ , _ , _ , (∋t , ⊗-∋ Γⱼ≔ℓ'∙Ξⱼ ℓ'≔ℓ∙ε) , Ξᵢ≔m∙Θ , ⊗-∋ Ξⱼ≔m'∙Θ m'≔m∙ε , Θ≔Δ'∙Ψ , Δ'∋iℓ∅

⊢-subst-ih : ∀ {γ : PreCtx n} {idxs : Idxs n} {Γ Γᵢ Γⱼ Δ Ψ Ψᵢ Ψⱼ : Ctx idxs} {i j : Fin n} {m n : Usage idx ²}
           → Vec.lookup γ i ≡ Vec.lookup γ j
           → Γᵢ ∋[ i ] m ▹ Γ
           → Γⱼ ∋[ j ] m ▹ Γ
           → Ψᵢ ∋[ i ] n ▹ Ψ
           → Ψⱼ ∋[ j ] n ▹ Ψ
           → Γ ≔ Δ ⊗ Ψ
           → All.lookup i Δ ≡ ℓ∅
           → γ ； Γᵢ ⊢ P ▹ Ψᵢ
           → γ ； Γⱼ ⊢ P [ i ↦ j ] ▹ Ψⱼ

⊢-subst-ih {i = i} eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ 𝟘 with ⊗-get i Γ≔Δ∙Ψ | ∋-≡Idx ∈i | ∋-≡Idx ∋i
⊢-subst-ih {i = i} eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ 𝟘 | Γi≔Δi∙Ψi | refl | refl with ∋-lookup-≡ ∈i | ∋-lookup-≡ ∋i
⊢-subst-ih {i = i} eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ 𝟘 | Γi≔Δi∙Ψi | refl | refl | qeq | qe
  rewrite Δ∋iℓ∅ | ∙²-unique Γi≔Δi∙Ψi ∙²-idˡ | ∙²-uniqueˡ qe qeq | ∋-uniqueʳ ∋i ∈i | ∋-uniqueˡ ∋j ∈j = 𝟘
⊢-subst-ih eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (ν t m μ ⊢P) =
  ν t m μ (⊢-subst-ih eq (suc ∋i) (suc ∋j) (suc ∈i) (suc ∈j) (Γ≔Δ∙Ψ , ∙²-idʳ) Δ∋iℓ∅ ⊢P)
⊢-subst-ih eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (∋x ⦅⦆ ⊢P) with ⊢-⊗ ⊢P
⊢-subst-ih eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (∋x ⦅⦆ ⊢P) | (_ -, _) , (Ξᵢ≔δ⊢P∙Ψᵢ , _) =
  let _ , _ , _ , _ , ∋x' , ∋i' , ∋j' , Θ≔Δ'∙Ψ , Δ'∋iℓ∅ = ∋-subst eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ ∋x Ξᵢ≔δ⊢P∙Ψᵢ in
  ∋x' ⦅⦆ ⊢-subst-ih eq (suc ∋i') (suc ∋j') (suc ∈i) (suc ∈j) (Θ≔Δ'∙Ψ , ∙²-idʳ) Δ'∋iℓ∅ ⊢P
⊢-subst-ih eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ ((∋tx , ∋x) ⟨ ∋ty , ∋y ⟩ ⊢P) =
  let
    _ , δ⊢P = ⊢-⊗ ⊢P
    _ , δy , _ = ∋-⊗ ∋y
    _ , δy⊢P , _ = ⊗-assoc⁻¹ δy δ⊢P
    _ , _ , _ , _ , ∋x' , ∋i' , ∋j' , Θ≔Δ'∙Ψ , Δ'∋iℓ∅ = ∋-subst eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (∋tx , ∋x) δy⊢P
    _ , _ , _ , _ , ∋y' , ∋i'' , ∋j'' , Θ≔Δ''∙Ψ , Δ''∋iℓ∅ = ∋-subst eq ∋i' ∋j' ∈i ∈j Θ≔Δ'∙Ψ Δ'∋iℓ∅ (∋ty , ∋y) δ⊢P
  in ∋x' ⟨ ∋y' ⟩ ⊢-subst-ih eq ∋i'' ∋j'' ∈i ∈j Θ≔Δ''∙Ψ Δ''∋iℓ∅ ⊢P
⊢-subst-ih eq ∋i ∋j ∈i ∈j Γ≔Δ∙Ψ Δ∋iℓ∅ (_∥_ {Δ = Ξᵢ} ⊢P ⊢Q) =
  let
    _ , Γᵢ≔δ⊢P∙Ξᵢ = ⊢-⊗ ⊢P
    _ , Ξᵢ≔δ⊢Q∙Ψᵢ = ⊢-⊗ ⊢Q
    _ , _ , _ , _ , Ξᵢ≔δ∙Θ , Γ≔Δ₁∙Θ , Θ≔Δ₂∙Ψ = midpoint ∋i Γ≔Δ∙Ψ Δ∋iℓ∅ Γᵢ≔δ⊢P∙Ξᵢ Ξᵢ≔δ⊢Q∙Ψᵢ ∈i
    _ , Ξᵢ≔δ'∙Θ , δ'≔δ∙ε = ∋-⊗ Ξᵢ≔δ∙Θ
    _ , Γᵢ≔δ'∙⁇ᵢ , ⁇ᵢ≔δ⊢P∙Θ = reverse Γᵢ≔δ⊢P∙Ξᵢ Ξᵢ≔δ'∙Θ
    Δ₁∋iℓ∅ , Δ₂∋iℓ∅ = split-ℓ∅ Γ≔Δ∙Ψ Γ≔Δ₁∙Θ Θ≔Δ₂∙Ψ Δ∋iℓ∅
    _ , m≔δ∙δ⊢P = boil ∋i (⊗-∋ Γᵢ≔δ'∙⁇ᵢ δ'≔δ∙ε) ⁇ᵢ≔δ⊢P∙Θ Γ≔Δ₁∙Θ Δ₁∋iℓ∅
    _ , Ξⱼ≔δ∙Θ = cutpoint Γ≔Δ₁∙Θ ∋j (∙²-comm m≔δ∙δ⊢P)
  in ⊢-subst-ih eq ∋i ∋j Ξᵢ≔δ∙Θ Ξⱼ≔δ∙Θ Γ≔Δ₁∙Θ Δ₁∋iℓ∅ ⊢P ∥ ⊢-subst-ih eq Ξᵢ≔δ∙Θ Ξⱼ≔δ∙Θ ∈i ∈j Θ≔Δ₂∙Ψ Δ₂∋iℓ∅ ⊢Q

switch : ∀ {γ : PreCtx n} {idxs : Idxs n} {Γ Ξ Ψ : Ctx idxs} {t  idx}  {m : Usage idx ²}
       → γ -, t ； Γ -, m ⊢ P ▹ Ψ -, ℓ∅
       → Ψ ∋[ j ] m ▹ Ξ
       → ∃[ Θ ] (Γ      ∋[ j ] m ▹ Θ
      × γ -, t ； Θ -, m ⊢ P      ▹ Ξ -, ℓ∅)
switch ⊢P ∋j with ⊢-⊗ ⊢P | ∋-⊗ ∋j
switch ⊢P ∋j | (Δ⊢P -, _) , (Γ≔ , _) | _ , Ψ≔ , _ =
  let W , Γ≔Δj∙W , W≔Δ⊢P∙Ξ = ⊗-assoc (⊗-comm Γ≔) Ψ≔ in
  _ , ∋-frame Ψ≔ Γ≔Δj∙W  ∋j , ⊢-frame (Γ≔ , ∙²-idʳ) (⊗-comm W≔Δ⊢P∙Ξ , ∙²-idʳ) ⊢P

⊢-subst : ∀ {γ : PreCtx n} {idxs : Idxs n} {Γ Ξ Ψ : Ctx idxs} {t  idx}  {m : Usage idx ²}
        → γ ； Ψ ∋[ j ] t ； m ▹ Ξ
        → γ -, t ； Γ -, m ⊢ P ▹ Ψ -, ℓ∅
        → γ -, t ； Γ -, m ⊢ P [ zero ↦ suc j ] ▹ Ξ -, m
⊢-subst {Γ = Γ} {Ξ} (t , y) ⊢P with switch ⊢P y
⊢-subst {Γ = Γ} {Ξ} (t , y) ⊢P | Θ , y' , ⊢P' with ⊢-⊗ ⊢P'
⊢-subst {Γ = Γ} {Ξ} (t , y) ⊢P | Θ , y' , ⊢P' | (_ -, _) , (⊢P'≔ , _) =
  ⊢-frame (proj₂ Γ≔ , ∙²-idˡ) (proj₂ Γ≔ , ∙²-idˡ) ⊢P''
  where
  ⊢P'' = ⊢-subst-ih (sym (∋-≡Type t)) (zero ∙²-idʳ) (suc y') (zero ∙²-idʳ) (suc (∋-ℓ∅ (∋-≡Idx y))) (⊢P'≔ , ∙²-idʳ) refl ⊢P'
  Γ≔ : ∃[ Δ ] (Γ ≔ Δ ⊗ Ξ)
  Γ≔ with ⊢-⊗ ⊢P''
  Γ≔ | (_ -, _) , (x , _) = _ , x


module nodcap.Norm where

open import Category.Monad
open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺ using (ℕ⁺; suc; _+_)
open import Data.List as L using (List; []; _∷_; _++_)
open import Data.List.Any as LA using (Any; here; there)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open import Data.Environment
open import nodcap.Base
open import nodcap.Typing as FF using (⊢_)
open import nodcap.NF.Typing as NF using (⊢ⁿᶠ_)
import nodcap.NF.Axiom as NFA
import nodcap.NF.Cut as NFD
import nodcap.NF.CutND as NFND

private
  open module LM {ℓ} = RawMonadPlus (L.monadPlus {ℓ})

nf : {Γ : Environment} → ⊢ Γ → ⊢ⁿᶠ Γ
nf  FF.ax        = NFA.ax
nf (FF.cut  x y) = NFD.cut (nf x) (nf y)
nf (FF.send x y) = NF.send (nf x) (nf y)
nf (FF.recv x)   = NF.recv (nf x)
nf (FF.sel₁ x)   = NF.sel₁ (nf x)
nf (FF.sel₂ x)   = NF.sel₂ (nf x)
nf (FF.case x y) = NF.case (nf x) (nf y)
nf  FF.halt      = NF.halt
nf (FF.wait x)   = NF.wait (nf x)
nf  FF.loop      = NF.loop
nf (FF.mk?₁ x)   = NF.mk?₁ (nf x)
nf (FF.mk!₁ x)   = NF.mk!₁ (nf x)
nf (FF.cont x)   = NF.cont (nf x)
nf (FF.pool x y) = NF.pool (nf x) (nf y)
nf (FF.exch b x) = NF.exch b (nf x)

nfND : {Γ : Environment} → ⊢ Γ → List (⊢ⁿᶠ Γ)
nfND  FF.ax        = return NFA.ax
nfND (FF.cut  x y) = nfND x >>= λ x → nfND y >>= λ y → NFND.cutND x y
nfND (FF.send x y) = nfND x >>= λ x → nfND y >>= λ y → return $ NF.send x y
nfND (FF.recv x)   = nfND x >>= λ x → return $ NF.recv x
nfND (FF.sel₁ x)   = nfND x >>= λ x → return $ NF.sel₁ x
nfND (FF.sel₂ x)   = nfND x >>= λ x → return $ NF.sel₂ x
nfND (FF.case x y) = nfND x >>= λ x → nfND y >>= λ y → return $ NF.case x y
nfND  FF.halt      = return NF.halt
nfND (FF.wait x)   = nfND x >>= λ x → return (NF.wait x)
nfND  FF.loop      = return NF.loop
nfND (FF.mk?₁ x)   = nfND x >>= λ x → return $ NF.mk?₁ x
nfND (FF.mk!₁ x)   = nfND x >>= λ x → return $ NF.mk!₁ x
nfND (FF.cont x)   = nfND x >>= λ x → return $ NF.cont x
nfND (FF.pool x y) = nfND x >>= λ x → nfND y >>= λ y → return $ NF.pool x y
nfND (FF.exch b x) = nfND x >>= λ x → return $ NF.exch b x

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


module SetClash where

postulate x : Set

y : Set1
y = x


------------------------------------------------------------------------
-- Document renderers
------------------------------------------------------------------------

{-# OPTIONS --guardedness #-}

module Renderer where

open import Algebra
open import Data.Bool
open import Data.Char using (Char)
open import Data.Empty
open import Data.Integer using (ℤ; +_; -[1+_]; _-_; _⊖_)
open import Data.List as List hiding ([_])
open import Data.List.NonEmpty using (_∷⁺_)
open import Data.List.Properties
open import Data.Nat
open import Data.Product
open import Data.String as String using (String)
open import Data.Unit
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (module Inverse)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Tactic.MonoidSolver

private
  module LM {A : Set} = Monoid (++-monoid A)

open import Grammar.Infinite as G hiding (_⊛_; _<⊛_; _⊛>_)
open import Pretty using (Doc; Docs; Pretty-printer)
open Pretty.Doc
open Pretty.Docs
open import Utilities

------------------------------------------------------------------------
-- Renderers

record Renderer : Set₁ where
  field
    -- The function that renders.

    render : ∀ {A} {g : Grammar A} {x : A} → Doc g x → List Char

    -- The rendered string must be parsable.

    parsable : ∀ {A} {g : Grammar A} {x : A}
               (d : Doc g x) → x ∈ g · render d

  ----------------------------------------------------------------------
  -- Some derived definitions and properties

  -- Pretty-printers are correct by definition, for any renderer,
  -- assuming that the underlying grammar is unambiguous.

  correct :
    ∀ {A} {g : Grammar A} (pretty : Pretty-printer g) →
    ∀ x → x ∈ g · render (pretty x)
  correct pretty x = parsable (pretty x)

  correct-if-locally-unambiguous :
    ∀ {A} {g : Grammar A} →
    (parse : Parser g) (pretty : Pretty-printer g) →
    ∀ x →
    Locally-unambiguous g (render (pretty x)) →
    ∃ λ p → parse (render (pretty x)) ≡ yes (x , p)
  correct-if-locally-unambiguous parse pretty x unambiguous = c
    where
    c : ∃ λ p → parse (render (pretty x)) ≡ yes (x , p)
    c with parse (render (pretty x))
    c | no  no-parse   = ⊥-elim (no-parse (x , correct pretty x))
    c | yes (y  , y∈g) with unambiguous y∈g (correct pretty x)
    c | yes (.x , x∈g) | P.refl = (x∈g , P.refl)

  correct-if-unambiguous :
    ∀ {A} {g : Grammar A} →
    Unambiguous g → (parse : Parser g) (pretty : Pretty-printer g) →
    ∀ x → ∃ λ p → parse (render (pretty x)) ≡ yes (x , p)
  correct-if-unambiguous unambiguous parse pretty x =
    correct-if-locally-unambiguous parse pretty x unambiguous

  -- If there is only one grammatically correct string, then the
  -- renderer returns this string.

  render-unique-string : ∀ {A} {g : Grammar A} {x s} →
                         (∀ {s′} → x ∈ g · s′ → s′ ≡ s) →
                         (d : Doc g x) → render d ≡ s
  render-unique-string unique d = unique (parsable d)

  -- Thus, in particular, documents for the grammar "string s" are
  -- always rendered in the same way.

  render-string : ∀ {s s′} (d : Doc (string s) s′) → render d ≡ s
  render-string = render-unique-string λ s′∈ →
    P.sym $ proj₂ (Inverse.to string-sem′ ⟨$⟩ s′∈)

  -- The property of ignoring (top-level) emb constructors.

  Ignores-emb : Set₁
  Ignores-emb =
    ∀ {A B x y} {g₁ : Grammar A} {g₂ : Grammar B}
      {f : ∀ {s} → x ∈ g₁ · s → y ∈ g₂ · s} {d : Doc g₁ x} →
    render (emb f d) ≡ render d

  -- If the renderer ignores emb constructors then, for every valid
  -- string, there is a document that renders as that string. (The
  -- renderers below ignore emb.)

  every-string-possible :
    Ignores-emb →
    ∀ {A} {g : Grammar A} {x s} →
    x ∈ g · s → ∃ λ (d : Doc g x) → render d ≡ s
  every-string-possible ignores-emb {g = g} {x} {s} x∈ =
    (Pretty.embed lemma₁ text , lemma₂)
    where
    open P.≡-Reasoning

    lemma₁ : ∀ {s′} → s ∈ string s · s′ → x ∈ g · s′
    lemma₁ s∈ = cast (proj₂ (Inverse.to string-sem′ ⟨$⟩ s∈)) x∈

    lemma₂ = begin
      render (Pretty.embed lemma₁ text)  ≡⟨ ignores-emb ⟩
      render text                        ≡⟨ render-string _ ⟩
      s                                  ∎

------------------------------------------------------------------------
-- An example renderer

-- This renderer renders every occurrence of "line" as a single space
-- character.

ugly-renderer : Renderer
ugly-renderer = record
  { render   = render
  ; parsable = parsable
  }
  where

  mutual

    render : ∀ {A} {g : Grammar A} {x} → Doc g x → List Char
    render (d₁ ◇ d₂)      = render d₁ ++ render d₂
    render (text {s = s}) = s
    render line           = String.toList " "
    render (group d)      = render d
    render (nest _ d)     = render d
    render (emb _ d)      = render d
    render (fill ds)      = render-fills ds

    render-fills : ∀ {A} {g : Grammar A} {x} → Docs g x → List Char
    render-fills [ d ]    = render d
    render-fills (d ∷ ds) = render d ++ ' ' ∷ render-fills ds

  mutual

    parsable : ∀ {A x} {g : Grammar A}
               (d : Doc g x) → x ∈ g · render d
    parsable (d₁ ◇ d₂)  = >>=-sem (parsable d₁) (parsable d₂)
    parsable text       = string-sem
    parsable line       = <$-sem single-space-sem
    parsable (group d)  = parsable d
    parsable (nest _ d) = parsable d
    parsable (emb f d)  = f (parsable d)
    parsable (fill ds)  = parsable-fills ds

    parsable-fills : ∀ {A xs} {g : Grammar A} (ds : Docs g xs) →
                     xs ∈ g sep-by whitespace + · render-fills ds
    parsable-fills [ d ]    = sep-by-sem-singleton (parsable d)
    parsable-fills (d ∷ ds) =
      sep-by-sem-∷ (parsable d) single-space-sem (parsable-fills ds)

-- The "ugly renderer" ignores emb constructors.

ugly-renderer-ignores-emb : Renderer.Ignores-emb ugly-renderer
ugly-renderer-ignores-emb = P.refl

------------------------------------------------------------------------
-- A general document property, proved using ugly-renderer

-- For every document of type Doc g x there is a string that witnesses
-- that the value x is generated by the grammar g.

string-exists : ∀ {A} {g : Grammar A} {x} →
                Doc g x → ∃ λ s → x ∈ g · s
string-exists d = (render d , parsable d)
  where open Renderer ugly-renderer

------------------------------------------------------------------------
-- An example renderer, based on the one in Wadler's "A prettier
-- printer"

module Wadler's-renderer where

  -- Layouts (representations of certain strings).

  data Layout-element : Set where
    text : List Char → Layout-element
    line : ℕ         → Layout-element

  Layout : Set
  Layout = List Layout-element

  -- Conversion of layouts into strings.

  show-element : Layout-element → List Char
  show-element (text s) = s
  show-element (line i) = '\n' ∷ replicate i ' '

  show : Layout → List Char
  show = concat ∘ List.map show-element

  -- Documents with unions instead of groups, and no fills. An extra
  -- index—the nesting level—is also included, and the line
  -- combinator's type is more precise (it can't be used for single
  -- spaces, only for newline-plus-indentation).

  infixr 20 _◇_

  data DocN : ∀ {A} → ℕ → Grammar A → A → Set₁ where
    _◇_   : ∀ {i c₁ c₂ A B x y}
              {g₁ : ∞Grammar c₁ A} {g₂ : A → ∞Grammar c₂ B} →
            DocN i (♭? g₁) x → DocN i (♭? (g₂ x)) y →
            DocN i (g₁ >>= g₂) y
    text  : ∀ {i} (s : List Char) → DocN i (string s) s
    line  : (i : ℕ) →
            let s = show-element (line i) in
            DocN i (string s) s
    union : ∀ {i A} {g : Grammar A} {x} →
            DocN i g x → DocN i g x → DocN i g x
    nest  : ∀ {i A} {g : Grammar A} {x}
            (j : ℕ) → DocN (j + i) g x → DocN i g x
    emb   : ∀ {i A B} {g₁ : Grammar A} {g₂ : Grammar B} {x y} →
            (∀ {s} → x ∈ g₁ · s → y ∈ g₂ · s) →
            DocN i g₁ x → DocN i g₂ y

  -- Some derived combinators.

  infix  21 <$>_
  infixl 20 _⊛_ _⊛>_

  embed : ∀ {i A B} {g₁ : Grammar A} {g₂ : Grammar B} {x y} →
          (∀ {s} → x ∈ g₁ · s → y ∈ g₂ · s) → DocN i g₁ x → DocN i g₂ y
  embed f (emb g d) = emb (f ∘ g) d
  embed f d         = emb f d

  nil : ∀ {i A} {x : A} → DocN i (return x) x
  nil = embed lemma (text [])
    where
    lemma : ∀ {x s} → [] ∈ string [] · s → x ∈ return x · s
    lemma return-sem = return-sem

  <$>_ : ∀ {i c A B} {f : A → B} {x} {g : ∞Grammar c A} →
         DocN i (♭? g) x → DocN i (f <$> g) (f x)
  <$> d = embed <$>-sem d

  _⊛_ : ∀ {i c₁ c₂ A B f x} {g₁ : ∞Grammar c₁ (A → B)}
          {g₂ : ∞Grammar c₂ A} →
        DocN i (♭? g₁) f → DocN i (♭? g₂) x → DocN i (g₁ G.⊛ g₂) (f x)
  _⊛_ {g₁ = g₁} {g₂} d₁ d₂ = embed lemma (d₁ ◇ <$> d₂)
    where
    lemma : ∀ {x s} →
            x ∈ (g₁ >>= λ f → f <$> g₂) · s → x ∈ g₁ G.⊛ g₂ · s
    lemma (>>=-sem f∈ (<$>-sem x∈)) = ⊛-sem f∈ x∈

  _⊛>_ : ∀ {i c₁ c₂ A B x y} {g₁ : ∞Grammar c₁ A}
           {g₂ : ∞Grammar c₂ B} →
         DocN i (♭? g₁) x → DocN i (♭? g₂) y → DocN i (g₁ G.⊛> g₂) y
  _⊛>_ {g₁ = g₁} {g₂} d₁ d₂ =
    embed lemma (nil ⊛ d₁ ⊛ d₂)
    where
    lemma : ∀ {y s} →
            y ∈ return (λ _ x → x) G.⊛ g₁ G.⊛ g₂ · s →
            y ∈ g₁ G.⊛> g₂ · s
    lemma (⊛-sem (⊛-sem return-sem x∈) y∈) = ⊛>-sem x∈ y∈

  cons : ∀ {i A B} {g : Grammar A} {sep : Grammar B} {x xs} →
         DocN i g x → DocN i (tt <$ sep) tt → DocN i (g sep-by sep) xs →
         DocN i (g sep-by sep) (x ∷⁺ xs)
  cons {g = g} {sep} d₁ d₂ d₃ =
    embed lemma (<$> d₁ ⊛ (d₂ ⊛> d₃))
    where
    lemma : ∀ {ys s} →
            ys ∈ _∷⁺_ <$> g G.⊛ ((tt <$ sep) G.⊛> (g sep-by sep)) · s →
            ys ∈ g sep-by sep · s
    lemma (⊛-sem (<$>-sem x∈) (⊛>-sem (<$-sem y∈) xs∈)) =
      sep-by-sem-∷ x∈ y∈ xs∈

  -- A single space character.

  imprecise-space : ∀ {i} → DocN i (tt <$ whitespace +) tt
  imprecise-space = embed lemma (text (String.toList " "))
    where
    lemma : ∀ {s} →
            String.toList " " ∈ string′ " " · s →
            tt ∈ tt <$ whitespace + · s
    lemma s∈ =
      cast (proj₂ (Inverse.to string-sem′ ⟨$⟩ s∈))
           (<$-sem single-space-sem)

  -- A variant of line that has the same type as Pretty.line (except
  -- for the indentation index).

  imprecise-line : (i : ℕ) → DocN i (tt <$ whitespace +) tt
  imprecise-line i = embed lemma (line i)
    where
    replicate-lemma :
      ∀ i → replicate i ' ' ∈ whitespace ⋆ · replicate i ' '
    replicate-lemma zero    = ⋆-[]-sem
    replicate-lemma (suc i) =
      ⋆-∷-sem (left-sem tok-sem) (replicate-lemma i)

    lemma : ∀ {i s′} →
            let s = show-element (line i) in
            s ∈ string s · s′ → tt ∈ tt <$ whitespace + · s′
    lemma s∈ =
      cast (proj₂ (Inverse.to string-sem′ ⟨$⟩ s∈))
           (<$-sem (+-sem (right-sem tok-sem) (replicate-lemma _)))

  mutual

    -- Replaces line constructors with single spaces, removes groups.

    flatten : ∀ {i A} {g : Grammar A} {x} → Doc g x → DocN i g x
    flatten (d₁ ◇ d₂)  = flatten d₁ ◇ flatten d₂
    flatten text       = text _
    flatten line       = imprecise-space
    flatten (group d)  = flatten d
    flatten (nest _ d) = flatten d
    flatten (emb f d)  = embed f (flatten d)
    flatten (fill ds)  = flatten-fills ds

    flatten-fills : ∀ {i A} {g : Grammar A} {xs} →
                    Docs g xs → DocN i (g sep-by whitespace +) xs
    flatten-fills [ d ]    = embed sep-by-sem-singleton (flatten d)
    flatten-fills (d ∷ ds) =
      cons (flatten d) imprecise-space (flatten-fills ds)

  mutual

    -- Converts ("expands") groups to unions.

    expand : ∀ {i A} {g : Grammar A} {x} → Doc g x → DocN i g x
    expand (d₁ ◇ d₂)  = expand d₁ ◇ expand d₂
    expand text       = text _
    expand line       = imprecise-line _
    expand (group d)  = union (flatten d) (expand d)
    expand (nest j d) = nest j (expand d)
    expand (emb f d)  = embed f (expand d)
    expand (fill ds)  = expand-fills false ds

    expand-fills : Bool → -- Unconditionally flatten the first document?
                   ∀ {i A} {g : Grammar A} {xs} →
                   Docs g xs → DocN i (g sep-by whitespace +) xs
    expand-fills fl [ d ] =
      embed sep-by-sem-singleton (flatten/expand fl d)
    expand-fills fl (d ∷ ds) =
      union (cons (flatten d)           imprecise-space    (expand-fills true  ds))
            (cons (flatten/expand fl d) (imprecise-line _) (expand-fills false ds))

    flatten/expand : Bool → -- Flatten?
                     ∀ {i A} {g : Grammar A} {x} → Doc g x → DocN i g x
    flatten/expand true  d = flatten d
    flatten/expand false d = expand d

  -- Does the first line of the layout fit on a line with the given
  -- number of characters?

  fits : ℤ → Layout → Bool
  fits -[1+ w ] _            = false
  fits w        []           = true
  fits w        (text s ∷ x) = fits (w - + length s) x
  fits w        (line i ∷ x) = true

  module _ (width : ℕ) where

    -- Chooses the first layout if it fits, otherwise the second. The
    -- natural number is the current column number.

    better : ℕ → Layout → Layout → Layout
    better c x y = if fits (width ⊖ c) x then x else y

    -- If, for any starting column c, κ c is the layout for some text,
    -- then best i d κ c is the layout for the document d followed by
    -- this text, given the current indentation i and the current column
    -- number c.

    best : ∀ {i A} {g : Grammar A} {x} →
           DocN i g x → (ℕ → Layout) → (ℕ → Layout)
    best (d₁ ◇ d₂)     = best d₁ ∘ best d₂
    best (text [])     = id
    best (text s)      = λ κ c → text s ∷ κ (length s + c)
    best (line i)      = λ κ _ → line i ∷ κ i
    best (union d₁ d₂) = λ κ c → better c (best d₁ κ c)
                                          (best d₂ κ c)
    best (nest _ d)    = best d
    best (emb _ d)     = best d

    -- Renders a document.

    renderN : ∀ {A i} {g : Grammar A} {x} → DocN i g x → List Char
    renderN d = show (best d (λ _ → []) 0)

    -- Renders a document.

    render : ∀ {A} {g : Grammar A} {x} → Doc g x → List Char
    render d = renderN (expand {i = 0} d)

    -- A simple lemma.

    if-lemma :
      ∀ {A} {g : Grammar A} {x l₁ l₂} s b →
      x ∈ g · s ++ show l₁ →
      x ∈ g · s ++ show l₂ →
      x ∈ g · s ++ show (if b then l₁ else l₂)
    if-lemma _ true  ∈l₁ ∈l₂ = ∈l₁
    if-lemma _ false ∈l₁ ∈l₂ = ∈l₂

    -- The main correctness property for best.

    best-lemma :
      ∀ {c A B i} {g : Grammar A} {g′ : Grammar B} {x y κ}
        s (d : DocN i g x) →
      (∀ {s′ c′} → x ∈ g · s′ → y ∈ g′ · s ++ s′ ++ show (κ c′)) →
      y ∈ g′ · s ++ show (best d κ c)
    best-lemma     s (text [])      hyp = hyp return-sem
    best-lemma     s (text (_ ∷ _)) hyp = hyp string-sem
    best-lemma     s (line i)       hyp = hyp string-sem
    best-lemma {c} s (union d₁ d₂)  hyp = if-lemma s
                                            (fits (width ⊖ c) _)
                                            (best-lemma s d₁ hyp)
                                            (best-lemma s d₂ hyp)
    best-lemma     s (nest _ d)     hyp = best-lemma s d hyp
    best-lemma     s (emb f d)      hyp = best-lemma s d (hyp ∘ f)
    best-lemma     s (d₁ ◇ d₂)      hyp =
      best-lemma s d₁ λ {s′} f∈ →
        cast (LM.assoc s _ _)
          (best-lemma (s ++ s′) d₂ λ x∈ →
             cast lemma
               (hyp (>>=-sem f∈ x∈)))
      where
      lemma :
        ∀ {s′ s″ s‴} →
        s ++ (s′ ++ s″) ++ s‴ ≡ (s ++ s′) ++ s″ ++ s‴
      lemma = solve (++-monoid Char)

    -- A corollary.

    best-lemma′ :
      ∀ {A i} {g : Grammar A} {x}
      (d : DocN i g x) → x ∈ g · renderN d
    best-lemma′ d = best-lemma [] d (cast (P.sym $ proj₂ LM.identity _))

    -- The renderer is correct.

    parsable : ∀ {A} {g : Grammar A} {x}
               (d : Doc g x) → x ∈ g · render d
    parsable d = best-lemma′ (expand d)

    -- The renderer.

    wadler's-renderer : Renderer
    wadler's-renderer = record
      { render   = render
      ; parsable = parsable
      }

  -- The renderer ignores emb constructors.

  ignores-emb :
    ∀ {w} → Renderer.Ignores-emb (wadler's-renderer w)
  ignores-emb {d = d} with expand {i = 0} d
  ... | _ ◇ _     = P.refl
  ... | text _    = P.refl
  ... | line ._   = P.refl
  ... | union _ _ = P.refl
  ... | nest _ _  = P.refl
  ... | emb _ _   = P.refl

  -- A (heterogeneous) notion of document equivalence.

  infix 4 _≈_

  _≈_ : ∀ {A₁ i₁ g₁} {x₁ : A₁}
          {A₂ i₂ g₂} {x₂ : A₂} →
        DocN i₁ g₁ x₁ → DocN i₂ g₂ x₂ → Set
  d₁ ≈ d₂ = ∀ width → renderN width d₁ ≡ renderN width d₂

  -- Some laws satisfied by the DocN combinators.

  text-++ : ∀ {i₁ i₂} s₁ s₂ →
        text {i = i₁} (s₁ ++ s₂) ≈
        _⊛>_ {c₁ = false} {c₂ = false} (text {i = i₂} s₁) (text s₂)
  text-++ []        []        _ = P.refl
  text-++ []        (t₂ ∷ s₂) _ = P.refl
  text-++ (t₁ ∷ s₁) []        _ = lemma
    where
    lemma : ∀ {s₁} → (s₁ ++ []) ++ [] ≡ s₁ ++ []
    lemma = solve (++-monoid Char)
  text-++ (t₁ ∷ s₁) (t₂ ∷ s₂) _ = lemma (_ ∷ s₁)
    where
    lemma : ∀ s₁ {s₂} → (s₁ ++ s₂) ++ [] ≡ s₁ ++ s₂ ++ []
    lemma _ = solve (++-monoid Char)

  nest-union : ∀ {A i j g} {x : A} {d₁ d₂ : DocN (j + i) g x} →
               nest j (union d₁ d₂) ≈ union (nest j d₁) (nest j d₂)
  nest-union _ = P.refl

  union-◇ : ∀ {A B i x y c₁ c₂}
              {g₁ : ∞Grammar c₁ A} {g₂ : A → ∞Grammar c₂ B}
              {d₁ d₂ : DocN i (♭? g₁) x} {d₃ : DocN i (♭? (g₂ x)) y} →
            _◇_ {g₁ = g₁} {g₂ = g₂} (union d₁ d₂) d₃ ≈
            union (d₁ ◇ d₃) (_◇_ {g₁ = g₁} {g₂ = g₂} d₂ d₃)
  union-◇ _ = P.refl

  -- A law that is /not/ satisfied by the DocN combinators.

  ¬-◇-union :
    ¬ (∀ {A B i x y} c₁ c₂
         {g₁ : ∞Grammar c₁ A} {g₂ : A → ∞Grammar c₂ B}
       (d₁ : DocN i (♭? g₁) x) (d₂ d₃ : DocN i (♭? (g₂ x)) y) →
       _◇_ {g₁ = g₁} {g₂ = g₂} d₁ (union d₂ d₃) ≈
       union (d₁ ◇ d₂) (_◇_ {g₁ = g₁} {g₂ = g₂} d₁ d₃))
  ¬-◇-union hyp with hyp false false d₁ d₂ d₁ 0
    where
    d₁ = imprecise-line 0
    d₂ = imprecise-space

    -- The following four definitions are not part of the proof.

    left : DocN 0 _ _
    left = _◇_ {c₁ = false} {c₂ = false} d₁ (union d₂ d₁)

    right : DocN 0 _ _
    right = union (d₁ ◇ d₂) (_◇_ {c₁ = false} {c₂ = false} d₁ d₁)

    -- Note that left and right are not rendered in the same way.

    left-hand-string : renderN 0 left ≡ String.toList "\n\n"
    left-hand-string = P.refl

    right-hand-string : renderN 0 right ≡ String.toList "\n "
    right-hand-string = P.refl

  ... | ()

-- Uses Wadler's-renderer.render to render a document using the
-- given line width.

render : ∀ {A} {g : Grammar A} {x} → ℕ → Doc g x → String
render w d = String.fromList (Wadler's-renderer.render w d)


module _ where

{- NOTE: To run move to adga directory or figure out how `agda -I` works -}

open import utility
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Environment as Env
open import Esterel.Context
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List
open import Relation.Nullary
import Relation.Binary.PropositionalEquality as Prop
open import Data.Empty
open import calculus
open import context-properties
open import Esterel.Lang.Binding
open import Data.Maybe using (just ; nothing)
open import Esterel.Variable.Signal as Signal using (Signal ; _ₛ)
open import Esterel.Variable.Sequential as SeqVar using (SeqVar ; _ᵥ)
open import Esterel.Variable.Shared as ShVar using (SharedVar ; _ₛₕ)
open import Data.List.Any

S : Signal
S = 0 ₛ

start : Term
start = signl S ((emit S) >> (present S ∣⇒ pause ∣⇒ nothin))
step1 = ρ (Θ [ (just Signal.unknown) ] [] []) · ((emit S) >> (present S ∣⇒ pause ∣⇒ nothin))
step2 = ρ (Θ [ (just Signal.present) ] [] []) · (nothin >> (present S ∣⇒ pause ∣⇒ nothin))
step3 = ρ (Θ [ (just Signal.present) ] [] []) · (present S ∣⇒ pause ∣⇒ nothin)
end : Term
end   = ρ (Θ [ (just Signal.present) ] [] []) · pause

red : start ⟶* end
red = rstep{start}{step1}
          (⟶-inclusion (rraise-signal{((emit S) >> (present S ∣⇒ pause ∣⇒ nothin))}{S}) )
          (rstep {step1} {step2}
                 (⟶-inclusion (remit (Data.List.Any.Any.here Prop.refl)
                                      (deseq{p = (emit S)}{q = (present S ∣⇒ pause ∣⇒ nothin)} (dehole{emit S}))))
                 (rstep {step2} {step3}
                        (rcontext (cenv (Θ (just Signal.present ∷ []) [] []) ∷ [])
                           (dcenv dchole) rseq-done)
                        (rstep {step3} {end}
                        (rcontext [] dchole
                                    (ris-present (Data.List.Any.Any.here Prop.refl) Prop.refl dehole)) rrefl)))


------------------------------------------------------------------------
-- Asymmetric choice
------------------------------------------------------------------------

{-# OPTIONS --universe-polymorphism #-}

module TotalParserCombinators.AsymmetricChoice where

open import Data.Empty
open import Data.List
open import Data.List.Any using (here)
open import Data.List.Any.Membership.Propositional
  using (_∈_) renaming (_∼[_]_ to _List-∼[_]_)
open import Data.Product
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence using (module Equivalence)
open import Function.Inverse as Inv using (_↔_)
open import Function.Related as Related
open import Function.Related.TypeIsomorphisms
import Relation.Binary.PropositionalEquality as P
import Relation.Binary.Sigma.Pointwise as Σ

open import TotalParserCombinators.Congruence using (_∼[_]P_; _≅P_)
open import TotalParserCombinators.Derivative using (D)
open import TotalParserCombinators.Parser
import TotalParserCombinators.Pointwise as Pointwise
open import TotalParserCombinators.Semantics using (_∈_·_)

------------------------------------------------------------------------
-- An initial bag operator

-- first-nonempty returns the left-most non-empty initial bag, if any.

first-nonempty : {R : Set} → List R → List R → List R
first-nonempty [] ys = ys
first-nonempty xs ys = xs

-- first-nonempty preserves equality.

first-nonempty-cong :
  ∀ {k R} {xs₁ xs₁′ xs₂ xs₂′ : List R} →
  xs₁ List-∼[ ⌊ k ⌋⇔ ] xs₁′ → xs₂ List-∼[ ⌊ k ⌋⇔ ] xs₂′ →
  first-nonempty xs₁ xs₂ List-∼[ ⌊ k ⌋⇔ ] first-nonempty xs₁′ xs₂′
first-nonempty-cong {xs₁ = []}    {[]}    eq₁ eq₂ = eq₂
first-nonempty-cong {xs₁ = _ ∷ _} {_ ∷ _} eq₁ eq₂ = eq₁
first-nonempty-cong {xs₁ = []} {_ ∷ _} eq₁ eq₂
  with Equivalence.from (⇒⇔ eq₁) ⟨$⟩ here P.refl
... | ()
first-nonempty-cong {xs₁ = _ ∷ _} {[]} eq₁ eq₂
  with Equivalence.to (⇒⇔ eq₁) ⟨$⟩ here P.refl
... | ()

-- first-nonempty is correct.

first-nonempty-left :
  ∀ {k R} {xs₁ xs₂ : List R} →
  (∃ λ y → y ∈ xs₁) → first-nonempty xs₁ xs₂ List-∼[ k ] xs₁
first-nonempty-left {xs₁ = []}    (_ , ())
first-nonempty-left {xs₁ = _ ∷ _} _        = _ ∎
  where open Related.EquationalReasoning

first-nonempty-right :
  ∀ {k R} {xs₁ xs₂ : List R} →
  (∄ λ y → y ∈ xs₁) → first-nonempty xs₁ xs₂ List-∼[ k ] xs₂
first-nonempty-right {xs₁ = x ∷ _} ∉x∷ = ⊥-elim $ ∉x∷ (x , here P.refl)
first-nonempty-right {xs₁ = []}    _   = _ ∎
  where open Related.EquationalReasoning

------------------------------------------------------------------------
-- Asymmetric choice

-- _◃_ is defined as a pointwise lifting of first-nonempty. Note that
-- _◃_ preserves parser and language equality, but not the
-- sub-/superparser and sub-/superlanguage relations.

private
  module AC {R} = Pointwise R R ⌊_⌋⇔ first-nonempty first-nonempty-cong

-- p₁ ◃ p₂ returns a result if either p₁ or p₂ does. For a given
-- string results are returned either from p₁ or from p₂, not both.

infixl 5 _◃_ _◃-cong_

_◃_ : ∀ {Tok R xs₁ xs₂} →
      Parser Tok R xs₁ → Parser Tok R xs₂ →
      Parser Tok R (first-nonempty xs₁ xs₂)
_◃_ = AC.lift

-- D distributes over _◃_.

D-◃ : ∀ {Tok R xs₁ xs₂ t}
      (p₁ : Parser Tok R xs₁) (p₂ : Parser Tok R xs₂) →
      D t (p₁ ◃ p₂) ≅P D t p₁ ◃ D t p₂
D-◃ = AC.D-lift

-- _◃_ preserves equality.

_◃-cong_ : ∀ {k Tok R xs₁ xs₁′ xs₂ xs₂′}
             {p₁  : Parser Tok R xs₁} {p₁′ : Parser Tok R xs₁′}
             {p₂  : Parser Tok R xs₂} {p₂′ : Parser Tok R xs₂′} →
           p₁ ∼[ ⌊ k ⌋⇔ ]P p₁′ → p₂ ∼[ ⌊ k ⌋⇔ ]P p₂′ →
           p₁ ◃ p₂ ∼[ ⌊ k ⌋⇔ ]P p₁′ ◃ p₂′
_◃-cong_ = AC.lift-cong

-- If p₁ accepts s, then p₁ ◃ p₂ behaves as p₁ when applied to s.

left : ∀ {Tok R xs₁ xs₂ x s}
       (p₁ : Parser Tok R xs₁) (p₂ : Parser Tok R xs₂) →
       (∃ λ y → y ∈ p₁ · s) → x ∈ p₁ ◃ p₂ · s ↔ x ∈ p₁ · s
left {x = x} =
  AC.lift-property
    (λ F _ H → ∃ F → H x ↔ F x)
    (λ F↔F′ _ H↔H′ →
       Σ.cong Inv.id (λ {x} → ↔⇒ (F↔F′ x))
         →-cong-⇔
       Related-cong (H↔H′ x) (F↔F′ x))
    (λ ∈xs₁ → first-nonempty-left ∈xs₁)

-- If p₁ does not accept s, then p₁ ◃ p₂ behaves as p₂ when applied to
-- s.

right : ∀ {Tok R xs₁ xs₂ x s}
        (p₁ : Parser Tok R xs₁) (p₂ : Parser Tok R xs₂) →
        (∄ λ y → y ∈ p₁ · s) → x ∈ p₁ ◃ p₂ · s ↔ x ∈ p₂ · s
right {x = x} =
  AC.lift-property
    (λ F G H → ∄ F → H x ↔ G x)
    (λ F↔F′ G↔G′ H↔H′ →
       ¬-cong-⇔ (Σ.cong Inv.id λ {x} → ↔⇒ (F↔F′ x))
         →-cong-⇔
       Related-cong (H↔H′ x) (G↔G′ x))
    (λ ∉xs₁ → first-nonempty-right ∉xs₁)


module Languages.ILL.Intermediate where

open import Utils.HaskellTypes
open import Utils.HaskellFunctions
open import Languages.ILL.TypeSyntax

{-# IMPORT Languages.ILL.Intermediate #-}

data IPattern : Set where
  PTriv : IPattern
  PVar : String → IPattern
  PTensor : IPattern → IPattern → IPattern
{-# COMPILED_DATA IPattern Languages.ILL.Intermediate.IPattern
                           Languages.ILL.Intermediate.PTriv
                           Languages.ILL.Intermediate.PVar
                           Languages.ILL.Intermediate.PTensor #-}

data ITerm : Set where
  Var : String → ITerm
  Triv : ITerm
  TTensor : ITerm → ITerm → ITerm
  Lam : String → Type → ITerm → ITerm
  Let : ITerm → Type → IPattern → ITerm → ITerm
  App : ITerm → ITerm → ITerm
  Promote : List (Triple ITerm String Type) → ITerm → ITerm
  Discard : ITerm → ITerm → ITerm
  Copy : ITerm → String → String → ITerm → ITerm
  Derelict : ITerm → ITerm
{-# COMPILED_DATA ITerm Languages.ILL.Intermediate.ITerm
                        Languages.ILL.Intermediate.Var
                        Languages.ILL.Intermediate.Triv
                        Languages.ILL.Intermediate.TTensor
                        Languages.ILL.Intermediate.Lam
                        Languages.ILL.Intermediate.Let
                        Languages.ILL.Intermediate.App
                        Languages.ILL.Intermediate.Promote
                        Languages.ILL.Intermediate.Discard
                        Languages.ILL.Intermediate.Copy
                        Languages.ILL.Intermediate.Derelict #-}


{- Definition of join for ◇ and associated lemmas. -}
module TemporalOps.Diamond.JoinLemmas where

open import CategoryTheory.Categories
open import CategoryTheory.Instances.Reactive
open import CategoryTheory.Functor
open import CategoryTheory.NatTrans
open import CategoryTheory.Monad
open import TemporalOps.Common
open import TemporalOps.Next
open import TemporalOps.Delay
open import TemporalOps.Diamond.Functor
open import TemporalOps.Diamond.Join

import Relation.Binary.PropositionalEquality as ≡
open import Data.Product
open import Relation.Binary.HeterogeneousEquality as ≅
            using (_≅_ ; ≅-to-≡ ; ≡-to-≅ ; cong₂)
open import Data.Nat.Properties
            using (+-identityʳ ; +-comm ; +-suc ; +-assoc)

open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

-- | Auxiliary lemmas

-- Equality of two delayed values
◇-≅ : ∀{A : τ}{n n′ k k′ : ℕ}
          -> {v : delay A by k at n} {v′ : delay A by k′ at n′}
          -> (pk : k ≡ k′) (pn : n ≡ n′)
          -> v ≅ v′
          -> _≅_ {A = ◇ A at n} (k , v)
                 {B = ◇ A at n′} (k′ , v′)
◇-≅ refl refl ≅.refl = ≅.refl

-- | Lemmas involving μ

-- Two consecutive shifts can be composed
μ-shift-comp : ∀{A} {n k l : ℕ} {a : ◇ A at n}
            -> μ-shift l (k + n) (μ-shift {A} k n a)
             ≅ μ-shift {A} (l + k) n a
μ-shift-comp {A} {n} {k} {l} {j , v} =
    begin
        μ-shift l (k + n) (μ-shift k n (j , v))
    ≡⟨⟩
        μ-shift l (k + n) (k + j , v′)
    ≡⟨⟩
        l + (k + j) , rew (sym (delay-+ l (k + j) (k + n))) v′
    ≅⟨ ◇-≅ (sym (+-assoc l k j)) ((sym (+-assoc l k n))) pr ⟩
        (l + k) + j , rew (sym (delay-+ (l + k) j n)) v
    ≡⟨⟩
        μ-shift (l + k) n (j , v)
    ∎
    where
    open ≅.≅-Reasoning
    v′ : delay A by (k + j) at (k + n)
    v′ = rew (sym (delay-+ k j n)) v
    v≅v′ : v ≅ v′
    v≅v′ = rew-to-≅ (sym (delay-+ k j n))
    pr : rew (sym (delay-+ l (k + j) (k + n))) v′
        ≅ rew (sym (delay-+ (l + k) j n)) v
    pr = delay-assoc-sym l k j n v′ v (≅.sym v≅v′)

private module μ = _⟹_ μ-◇
open ≅.≅-Reasoning

-- Shift and multiplication can be interchanged
μ-interchange : ∀{A}{n k : ℕ}{a : ◇ ◇ A at n}
             -> μ.at A (k + n) (μ-shift k n a)
              ≅ μ-shift k n (μ.at A n a)
μ-interchange {A} {n} {k} {l , y} with inspect (compareLeq l n)
μ-interchange {A} {.(l + m)} {k} {l , v} | snd==[ .l + m ] with≡ pf =
    begin
        μ.at A (k + (l + m)) (μ-shift k (l + m) (l , v))
    ≡⟨⟩
        μ.at A (k + (l + m)) (k + l , rew (sym (delay-+ k l (l + m))) v)
    ≡⟨⟩
        μ-compare A (k + (l + m)) (k + l) v′ (compareLeq (k + l) (k + (l + m)))
    ≅⟨
        ≅-cong₃ (λ x y z → μ-compare A x (k + l) y z)
            (≡-to-≅ (sym (+-assoc k l m))) v′≅v″ (compare-snd-+-assoc l m k pf)
     ⟩
        μ-compare A ((k + l) + m) (k + l) v″ (snd==[ (k + l) + m ])
    ≡⟨⟩
        μ-shift (k + l) m ⌞ rew (delay-+-left0 (k + l) m) v″ ⌟
    ≡⟨ cong! (pr k l m v″ v v″≅v) ⟩
        μ-shift (k + l) m (rew (delay-+-left0 l m) v)
    ≅⟨ ≅.sym ( μ-shift-comp {A} {m} {l} {k} {(rew (delay-+-left0 l m) v)} ) ⟩
        μ-shift k (l + m) (μ-shift l m (rew (delay-+-left0 l m) v))
    ≡⟨⟩
        μ-shift k (l + m) (μ-compare A (l + m) l v ⌞ snd==[ l + m ] ⌟)
    ≡⟨ cong! (sym pf) ⟩
        μ-shift k (l + m) (μ-compare A (l + m) l v (compareLeq l (l + m)))
    ≡⟨⟩
        μ-shift k (l + m) (μ.at A (l + m) (l , v))
    ∎
    where
    v′ : delay ◇ A by (k + l) at (k + (l + m))
    v′ = rew (sym (delay-+ k l (l + m))) v
    v≅v′ : v ≅ v′
    v≅v′ = rew-to-≅ (sym (delay-+ k l (l + m)))
    lemma-assoc : ∀{A : τ} -> (a b c : ℕ)
              -> delay ◇ A by (a + b) at (a + (b + c))
               ≡ delay ◇ A by (a + b) at ((a + b) + c)
    lemma-assoc a b c rewrite sym (+-assoc a b c) = refl
    v″ : delay ◇ A by (k + l) at ((k + l) + m)
    v″ = (rew (lemma-assoc k l m) v′)
    v′≅v″ : v′ ≅ v″
    v′≅v″ = rew-to-≅ (lemma-assoc k l m)
    v″≅v : v″ ≅ v
    v″≅v = ≅.trans (≅.sym v′≅v″) (≅.sym v≅v′)
    pr : ∀{A} (k l m : ℕ) -> Proof-≡ (delay-+-left0 {A} (k + l) m)
                                     (delay-+-left0 {A} l m)
    pr zero l m v .v ≅.refl = refl
    pr (suc k) l m = pr k l m

-- l = n + suc j
μ-interchange {A} {.n} {k} {.(n + suc l) , v} | fst==suc[ n + l ] with≡ pf =
    begin
        μ.at A (k + n) (μ-shift k n (n + suc l , v))
    ≡⟨⟩
        μ.at A (k + n) (k + (n + suc l) , rew (sym (delay-+ k (n + suc l) n)) v)
    ≡⟨⟩
        μ-compare A (k + n) (k + (n + suc l)) v′ (compareLeq (k + (n + suc l)) (k + n))
    ≅⟨ ≅-cong₃ ((λ x y z → μ-compare A (k + n) x y z))
            (≡-to-≅ (sym (+-assoc k n (suc l)))) v′≅v″ (compare-fst-+-assoc n l k pf) ⟩
        μ-compare A (k + n) ((k + n) + suc l) v″ fst==suc[ (k + n) + l ]
    ≡⟨⟩
        (k + n) + suc l , rew (delay-⊤ (k + n) l) top.tt
    ≅⟨ ◇-≅ (+-assoc k n (suc l)) refl (pr n k l) ⟩
        k + (n + suc l) , rew (sym (delay-+ k (n + suc l) n)) (rew (delay-⊤ n l) top.tt)
    ≡⟨⟩
        μ-shift k n (n + suc l , rew (delay-⊤ n l) top.tt)
    ≡⟨⟩
        μ-shift k n (μ-compare A n (n + suc l) v ⌞ fst==suc[ n + l ] ⌟)
    ≡⟨ cong! (sym pf) ⟩
        μ-shift k n (μ-compare A n (n + suc l) v (compareLeq (n + suc l) n))
    ≡⟨⟩
        μ-shift k n (μ.at A n (n + suc l , v))
    ∎
    where
    v′ : delay ◇ A by (k + (n + suc l)) at (k + n)
    v′ = (rew (sym (delay-+ k (n + suc l) n)) v)
    lemma-assoc : ∀{A : τ} -> (a b c : ℕ)
              -> delay ◇ A by (a + (b + c)) at (a + b)
               ≡ delay ◇ A by ((a + b) + c) at (a + b)
    lemma-assoc {A} a b c rewrite sym (+-assoc a b c) = refl
    v″ : delay ◇ A by ((k + n) + suc l) at (k + n)
    v″ = (rew (lemma-assoc k n (suc l)) v′)
    v′≅v″ : v′ ≅ v″
    v′≅v″ = rew-to-≅ (lemma-assoc k n (suc l))
    pr : ∀{A} (n k l : ℕ)
      -> rew (delay-⊤ {A} (k + n) l) top.tt
       ≅ rew (sym (delay-+ {A} k (n + suc l) n)) (rew (delay-⊤ n l) top.tt)
    pr n zero l = ≅.refl
    pr n (suc k) l = pr n k l


module Categories.Comonad where


module STLC.Coquand.Soundness where

open import STLC.Coquand.Completeness public

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

-- Un⟦_⟧
postulate
  ⟦_⟧Un : ∀ {Γ Ξ A} → {ρ : Γ ⊩⋆ Ξ}
                    → (M : Ξ ⊢ A) → Un⋆ ρ
                    → Un (⟦ M ⟧ ρ)

-- 𝒰⋆⟦_⟧ₛ
postulate
  ⟦_⟧Un⋆ : ∀ {Γ Ξ Φ} → {ρ : Γ ⊩⋆ Ξ}
                     → (σ : Ξ ⊢⋆ Φ) → Un⋆ ρ
                     → Un⋆ (⟦ σ ⟧⋆ ρ)

postulate
  ⟦_⟧Eq : ∀ {Γ Ξ A} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                    → (M : Ξ ⊢ A) → Eq⋆ ρ₁ ρ₂ → Un⋆ ρ₁ → Un⋆ ρ₂
                    → Eq (⟦ M ⟧ ρ₁) (⟦ M ⟧ ρ₂)

-- Eq⋆⟦_⟧ₛ
postulate
  ⟦_⟧Eq⋆ : ∀ {Γ Ξ Φ} → {ρ₁ ρ₂ : Γ ⊩⋆ Ξ}
                     → (σ : Ξ ⊢⋆ Φ) → Eq⋆ ρ₁ ρ₂ → Un⋆ ρ₁ → Un⋆ ρ₂
                     → Eq⋆ (⟦ σ ⟧⋆ ρ₁) (⟦ σ ⟧⋆ ρ₂)

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

-- ⟦_⟧⬗Eq = symEq ∘ ↑⟨_⟩Eq⟦_⟧
⟦_⟧⬗Eq : ∀ {Γ Γ′ Ξ A} → {ρ : Γ ⊩⋆ Ξ}
                      → (M : Ξ ⊢ A) (η : Γ′ ∋⋆ Γ) → Un⋆ ρ
                      → Eq (⟦ M ⟧ (η ⬗ ρ))
                            (acc η (⟦ M ⟧ ρ))

⟦_⟧⬗Eq (𝓋 i)   η υ = get⬗Eq η i υ

⟦_⟧⬗Eq (ƛ M)   η υ = eq⊃ (λ η′ u →
                           ⟦ M ⟧Eq (comp⬗◇Eq⋆ η′ η υ , reflEq u)
                                   (cong⬗Un⋆ η′ (cong⬗Un⋆ η υ) , u)
                                   (cong⬗Un⋆ (η′ ○ η) υ , u))

⟦_⟧⬗Eq (M ∙ N) η υ =
    cong⟦∙⟧Eq idᵣ (⟦ M ⟧⬗Eq η υ) (⟦ M ⟧Un (cong⬗Un⋆ η υ)) (congaccUn η (⟦ M ⟧Un υ))
                  (⟦ N ⟧⬗Eq η υ) (⟦ N ⟧Un (cong⬗Un⋆ η υ)) (congaccUn η (⟦ N ⟧Un υ))
  ⦙ acc⟦∙⟧idEq η (⟦ M ⟧Un υ) (congaccUn η (⟦ N ⟧Un υ))
  ⦙ (cong⟦∙⟧Eq η ((lidaccEq (⟦ M ⟧Un υ)) ⁻¹) (⟦ M ⟧Un υ) (congaccUn idᵣ (⟦ M ⟧Un υ))
                 (reflEq (congaccUn η (⟦ N ⟧Un υ))) (congaccUn η (⟦ N ⟧Un υ)) (congaccUn η (⟦ N ⟧Un υ))
  ⦙ acc⟦∙⟧Eq idᵣ η (⟦ M ⟧Un υ) (⟦ N ⟧Un υ))

-- ⟦_⟧⬗Eq⋆ = symEq ∘ ↑⟨_⟩Eq⋆⟦_⟧ₛ
⟦_⟧⬗Eq⋆ : ∀ {Γ Γ′ Ξ Φ} → {ρ : Γ ⊩⋆ Ξ}
                       → (σ : Ξ ⊢⋆ Φ) (η : Γ′ ∋⋆ Γ) → Un⋆ ρ
                       → Eq⋆ (⟦ σ ⟧⋆ (η ⬗ ρ))
                              (η ⬗ ⟦ σ ⟧⋆ ρ)
⟦_⟧⬗Eq⋆ ∅       η υ = ∅
⟦_⟧⬗Eq⋆ (σ , M) η υ = ⟦ σ ⟧⬗Eq⋆ η υ , ⟦ M ⟧⬗Eq η υ

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

-- TODO: Generalise to zap⬖
postulate
  aux₄₈₁ : ∀ {Γ Ξ A} → {ρ : Γ ⊩⋆ Ξ} {a : Γ ⊩ A}
                     → Un⋆ ρ
                     → Eq⋆ ((ρ , a) ⬖ wkᵣ idᵣ) ρ

-- TODO
-- Basic properties of _◇_
-- Advanced properties of _◇_
-- Basic properties of _⬗_
-- Basic properties of _◆_
-- Advanced properties of _⬗_
-- Advanced properties of _◆_

-- TODO: Fix the instance argument problem; abstract over models; rename η to ξ…

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

renlift⟦_⟧Eq : ∀ {Γ Γ′ A B w w′} → {ρ : w ⊩⋆ Γ′} {a : w′ ⊩ A}
                                 → (M : Γ , A ⊢ B) (η₁ : Γ′ ∋⋆ Γ) (η₂ : w′ ∋⋆ w) → Un⋆ ρ → Un a
                                 → Eq (⟦ ren (liftᵣ {A} η₁) M ⟧ (η₂ ⬗ ρ , a))
                                       (⟦ M ⟧ (η₂ ⬗ (ρ ⬖ η₁) , a))

renlift⟦_⟧Eq (𝓋 zero) η₁ η₂ υ u = reflEq u

renlift⟦_⟧Eq {ρ = ρ} {a} (𝓋 (suc i)) η₁ η₂ υ u =
    ≡→Eq ((getᵥ (η₂ ⬗ ρ , a)) & natgetᵣ η₁ i)
          (conggetUn (getᵣ (wkᵣ η₁) i) (cong⬗Un⋆ η₂ υ , u))
  ⦙ get⬖Eq η₁ (getᵣ η₁ i) i (cong⬗Un⋆ η₂ υ) ⁻¹
  ⦙ conggetEq i (comp⬗⬖Eq⋆ η₂ η₁ υ ⁻¹)

renlift⟦_⟧Eq (ƛ M) η₁ η₂ υ u =
      eq⊃ (λ η′ u′ → renlift⟦ M ⟧Eq (liftᵣ η₁) η′ (cong⬗Un⋆ η₂ υ , u) u′
                    ⦙ ⟦ M ⟧Eq ( ( cong⬗Eq⋆ η′ (( comp⬗⬖Eq⋆ η₂ η₁ υ
                                               ⦙ zap⬖Eq⋆ (wkᵣ η₁) η₁ (cong⬗Un⋆ η₂ υ) ⁻¹
                                               ) ⁻¹)
                                , reflEq (congaccUn η′ u)
                                )
                              , reflEq u′
                              )
                              ((cong⬗Un⋆ η′ (cong⬖Un⋆ (wkᵣ η₁) (cong⬗Un⋆ η₂ υ , u)) , congaccUn η′ u) , u′)
                              ((cong⬗Un⋆ η′ (cong⬗Un⋆ η₂ (cong⬖Un⋆ η₁ υ)) , congaccUn η′ u) , u′))

renlift⟦_⟧Eq (M ∙ N) η₁ η₂ υ u =
  cong⟦∙⟧Eq idᵣ (renlift⟦ M ⟧Eq η₁ η₂ υ u) (⟦ ren (liftᵣ η₁) M ⟧Un (cong⬗Un⋆ η₂ υ , u)) (⟦ M ⟧Un (cong⬗Un⋆ η₂ (cong⬖Un⋆ η₁ υ) , u))
                (renlift⟦ N ⟧Eq η₁ η₂ υ u) (⟦ ren (liftᵣ η₁) N ⟧Un (cong⬗Un⋆ η₂ υ , u)) (⟦ N ⟧Un (cong⬗Un⋆ η₂ (cong⬖Un⋆ η₁ υ) , u))

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

renwk⟦_⟧Eq : ∀ {Γ Γ′ A C w} → {ρ : w ⊩⋆ Γ′} {a : w ⊩ A}
                            → (M : Γ ⊢ C) (η : Γ′ ∋⋆ Γ) → Un⋆ ρ → Un a
                            → Eq (⟦ ren (wkᵣ {A} η) M ⟧ (ρ , a))
                                  (⟦ M ⟧ (ρ ⬖ η))

renwk⟦_⟧Eq (𝓋 i) η υ u =
    get⬖Eq (wkᵣ η) (getᵣ (wkᵣ η) i) i (υ , u) ⁻¹
  ⦙ conggetEq i (zap⬖Eq⋆ (wkᵣ η) η υ)

renwk⟦_⟧Eq (ƛ M) η υ u =
  eq⊃ (λ η′ u′ → renlift⟦ M ⟧Eq (wkᵣ η) η′ (υ , u) u′
                ⦙ ⟦ M ⟧Eq (cong⬗Eq⋆ η′ (zap⬖Eq⋆ (wkᵣ η) η υ) , reflEq u′)
                          (cong⬗Un⋆ η′ (cong⬖Un⋆ (wkᵣ η) (υ , u)) , u′)
                          (cong⬗Un⋆ η′ (cong⬖Un⋆ η υ) , u′))

renwk⟦_⟧Eq (M ∙ N) η υ u =
  cong⟦∙⟧Eq idᵣ (renwk⟦ M ⟧Eq η υ u) (⟦ ren (wkᵣ η) M ⟧Un (υ , u)) (⟦ M ⟧Un (cong⬖Un⋆ η υ))
                (renwk⟦ N ⟧Eq η υ u) (⟦ ren (wkᵣ η) N ⟧Un (υ , u)) (⟦ N ⟧Un (cong⬖Un⋆ η υ))

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

wk⟦_⟧Eq : ∀ {Γ A C w} → {ρ : w ⊩⋆ Γ} {a : w ⊩ A}
                      → (M : Γ ⊢ C) → Un⋆ ρ → Un a
                      → Eq (⟦ wk {A} M ⟧ (ρ , a))
                            (⟦ M ⟧ ρ)
wk⟦_⟧Eq M υ u = renwk⟦ M ⟧Eq idᵣ υ u
              ⦙ ⟦ M ⟧Eq (rid⬖Eq⋆ υ) (cong⬖Un⋆ idᵣ υ) υ

wk⟦_⟧Eq⋆ : ∀ {Γ Ξ A w} → {ρ : w ⊩⋆ Γ} {a : w ⊩ A}
                       → (σ : Γ ⊢⋆ Ξ) → Un⋆ ρ → Un a
                       → Eq⋆ (⟦ wkₛ {A} σ ⟧⋆ (ρ , a))
                              (⟦ σ ⟧⋆ ρ)
wk⟦_⟧Eq⋆ ∅       υ u = ∅
wk⟦_⟧Eq⋆ (σ , M) υ u = wk⟦ σ ⟧Eq⋆ υ u , wk⟦ M ⟧Eq υ u

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

get⟦_⟧Eq : ∀ {Γ Ξ A w} → {ρ : w ⊩⋆ Γ}
                       → (σ : Γ ⊢⋆ Ξ) (i : Ξ ∋ A) → Un⋆ ρ
                       → Eq (⟦ getₛ σ i ⟧ ρ)
                             (getᵥ (⟦ σ ⟧⋆ ρ) i)
get⟦_⟧Eq (σ , M) zero    υ = reflEq (⟦ M ⟧Un υ)
get⟦_⟧Eq (σ , M) (suc i) υ = get⟦ σ ⟧Eq i υ

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

sublift⟦_⟧Eq : ∀ {Γ Ξ A B w} → {ρ : w ⊩⋆ Γ} {a : w ⊩ A}
                             → (M : Ξ , A ⊢ B) (σ : Γ ⊢⋆ Ξ) → Un⋆ ρ → Un a
                             → Eq (⟦ sub (liftₛ {A} σ) M ⟧ (ρ , a))
                                   (⟦ M ⟧ (⟦ σ ⟧⋆ ρ , a))

sublift⟦_⟧Eq (𝓋 zero) σ υ u = reflEq u

sublift⟦_⟧Eq {ρ = ρ} {a} (𝓋 (suc i)) σ υ u =
    ≡→Eq ((λ M′ → ⟦ M′ ⟧ (ρ , a)) & natgetₛ σ i)
          (⟦ getₛ (wkₛ σ) i ⟧Un (υ , u))
  ⦙ wk⟦ getₛ σ i ⟧Eq υ u
  ⦙ get⟦ σ ⟧Eq i υ

sublift⟦_⟧Eq (ƛ M) σ υ u =
  eq⊃ (λ η′ u′ → sublift⟦ M ⟧Eq (liftₛ σ) (cong⬗Un⋆ η′ υ , congaccUn η′ u) u′
                ⦙ ⟦ M ⟧Eq ((⟦ wkₛ σ ⟧⬗Eq⋆ η′ (υ , u) , reflEq (congaccUn η′ u)) , reflEq u′)
                          ((⟦ wkₛ σ ⟧Un⋆ (cong⬗Un⋆ η′ υ , congaccUn η′ u) , congaccUn η′ u) , u′)
                          ((cong⬗Un⋆ η′ (⟦ wkₛ σ ⟧Un⋆ (υ , u)) , congaccUn η′ u) , u′)
                ⦙ ⟦ M ⟧Eq ((cong⬗Eq⋆ η′ (wk⟦ σ ⟧Eq⋆ υ u) , reflEq (congaccUn η′ u)) , reflEq u′)
                          ((cong⬗Un⋆ η′ (⟦ wkₛ σ ⟧Un⋆ (υ , u)) , congaccUn η′ u) , u′)
                          ((cong⬗Un⋆ η′ (⟦ σ ⟧Un⋆ υ) , congaccUn η′ u) , u′))

sublift⟦_⟧Eq (M ∙ N) σ υ u =
  cong⟦∙⟧Eq idᵣ (sublift⟦ M ⟧Eq σ υ u) (⟦ sub (liftₛ σ) M ⟧Un (υ , u)) (⟦ M ⟧Un (⟦ σ ⟧Un⋆ υ , u))
                (sublift⟦ N ⟧Eq σ υ u) (⟦ sub (liftₛ σ) N ⟧Un (υ , u)) (⟦ N ⟧Un (⟦ σ ⟧Un⋆ υ , u))

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

subliftwk⟦_⟧Eq : ∀ {Γ Ξ A A′ B w w′} → {ρ : w ⊩⋆ Γ} {a : w ⊩ A} {a′ : w′ ⊩ A′}
                                     → (M : Ξ , A′ ⊢ B) (σ : Γ ⊢⋆ Ξ) (η : w′ ∋⋆ w) → Un⋆ ρ → Un a → Un a′
                                     → Eq (⟦ sub (liftₛ (wkₛ σ)) M ⟧ (η ⬗ ρ , acc η a , a′))
                                           (⟦ sub (liftₛ σ) M ⟧ (η ⬗ ρ , a′))
subliftwk⟦_⟧Eq M σ η υ u u′ = sublift⟦ M ⟧Eq (wkₛ σ) (cong⬗Un⋆ η υ , congaccUn η u) u′
                            ⦙ ⟦ M ⟧Eq (wk⟦ σ ⟧Eq⋆ (cong⬗Un⋆ η υ) (congaccUn η u) , reflEq u′)
                                      (⟦ wkₛ σ ⟧Un⋆ (cong⬗Un⋆ η υ , congaccUn η u) , u′)
                                      (⟦ σ ⟧Un⋆ (cong⬗Un⋆ η υ) , u′)
                            ⦙ sublift⟦ M ⟧Eq σ (cong⬗Un⋆ η υ) u′ ⁻¹

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

subwk⟦_⟧Eq : ∀ {Γ Ξ A C w} → {ρ : w ⊩⋆ Γ} {a : w ⊩ A}
                           → (M : Ξ ⊢ C) (σ : Γ ⊢⋆ Ξ) → Un⋆ ρ → Un a
                           → Eq (⟦ sub (wkₛ {A} σ) M ⟧ (ρ , a))
                                 (⟦ sub σ M ⟧ ρ)

subwk⟦_⟧Eq {ρ = ρ} {a} (𝓋 i) σ υ u =
    ≡→Eq ((λ M′ → ⟦ M′ ⟧ (ρ , a)) & (natgetₛ σ i))
          (⟦ getₛ (wkₛ σ) i ⟧Un (υ , u))
  ⦙ wk⟦ getₛ σ i ⟧Eq υ u

subwk⟦_⟧Eq (ƛ {A = A′} M) σ υ u =
  eq⊃ (λ η u′ → subliftwk⟦ M ⟧Eq σ η υ u u′)

subwk⟦_⟧Eq (M ∙ N) σ υ u =
  cong⟦∙⟧Eq idᵣ (subwk⟦ M ⟧Eq σ υ u) (⟦ sub (wkₛ σ) M ⟧Un (υ , u)) (⟦ sub σ M ⟧Un υ)
                (subwk⟦ N ⟧Eq σ υ u) (⟦ sub (wkₛ σ) N ⟧Un (υ , u)) (⟦ sub σ N ⟧Un υ)

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

sub⟦_⟧Eq : ∀ {Γ Ξ A w} → {ρ : w ⊩⋆ Γ}
                       → (M : Ξ ⊢ A) (σ : Γ ⊢⋆ Ξ) → Un⋆ ρ
                       → Eq (⟦ sub σ M ⟧ ρ)
                             (⟦ M ⟧ (⟦ σ ⟧⋆ ρ))

sub⟦_⟧Eq (𝓋 i) σ υ = get⟦ σ ⟧Eq i υ

sub⟦_⟧Eq (ƛ M) σ υ =
  eq⊃ (λ η u → sublift⟦ M ⟧Eq σ (cong⬗Un⋆ η υ) u
              ⦙ ⟦ M ⟧Eq (⟦ σ ⟧⬗Eq⋆ η υ , reflEq u)
                        (⟦ σ ⟧Un⋆ (cong⬗Un⋆ η υ) , u)
                        (cong⬗Un⋆ η (⟦ σ ⟧Un⋆ υ) , u))

sub⟦_⟧Eq (M ∙ N) σ υ =
  cong⟦∙⟧Eq idᵣ (sub⟦ M ⟧Eq σ υ) (⟦ sub σ M ⟧Un υ) (⟦ M ⟧Un (⟦ σ ⟧Un⋆ υ))
                (sub⟦ N ⟧Eq σ υ) (⟦ sub σ N ⟧Un υ) (⟦ N ⟧Un (⟦ σ ⟧Un⋆ υ))

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

-- TODO: Rename this
sublift⟦⟧Eq⁈ : ∀ {Γ Ξ A B w} → {ρ : w ⊩⋆ Γ}
                             → (σ : Γ ⊢⋆ Ξ) (M : Ξ , A ⊢ B) (N : Γ ⊢ A) → Un⋆ ρ
                             → Eq (⟦ sub (liftₛ {A} σ) M ⟧ (ρ , ⟦ N ⟧ ρ))
                                   (⟦ sub (σ , N) M ⟧ ρ)
sublift⟦⟧Eq⁈ {ρ = ρ} σ M N υ = sublift⟦ M ⟧Eq σ υ (⟦ N ⟧Un υ)
                             ⦙ sub⟦ M ⟧Eq (σ , N) υ ⁻¹

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

-- TODO: Generalise theorem 4 over models

module _ where
  open 𝔐 canon

  mutual
    lemƛ : ∀ {Γ A B w} → {ρ : w ⊩⋆ Γ} {M M′ : Γ , A ⊢ B}
                       → M ∼ M′ → Un⋆ ρ
                       → Eq (⟦ ƛ M ⟧ ρ) (⟦ ƛ M′ ⟧ ρ)
    lemƛ p υ = eq⊃ (λ xs u → cong⟦ p ⟧Eq (cong⬗Un⋆ xs υ , u))

    lem∙ : ∀ {Γ A B w} → {ρ : w ⊩⋆ Γ} {M M′ : Γ ⊢ A ⇒ B} {N N′ : Γ ⊢ A}
                       → M ∼ M′ → N ∼ N′ → Un⋆ ρ
                       → Eq (⟦ M ∙ N ⟧ ρ) (⟦ M′ ∙ N′ ⟧ ρ)
    lem∙ {M = M} {M′} {N} {N′} p q υ = cong⟦∙⟧Eq idᵣ (cong⟦ p ⟧Eq υ) (⟦ M ⟧Un υ) (⟦ M′ ⟧Un υ)
                                                     (cong⟦ q ⟧Eq υ) (⟦ N ⟧Un υ) (⟦ N′ ⟧Un υ)

    lemred⇒ : ∀ {Γ Ξ A B w} → {ρ : w ⊩⋆ Γ}
                             → (σ : Γ ⊢⋆ Ξ) (M : Ξ , A ⊢ B) (N : Γ ⊢ A) → Un⋆ ρ
                             → Eq (⟦ sub σ (ƛ M) ∙ N ⟧ ρ) (⟦ sub (σ , N) M ⟧ ρ)
    lemred⇒ {ρ = ρ} σ M N υ =
        ⟦ sub (liftₛ σ) M ⟧Eq (lid⬗Eq⋆ υ , reflEq (⟦ N ⟧Un υ))
                              (cong⬗Un⋆ idᵣ υ , ⟦ N ⟧Un υ)
                              (υ , ⟦ N ⟧Un υ)
      ⦙ sublift⟦⟧Eq⁈ σ M N υ

    lemexp⇒ : ∀ {Γ A B w} → {ρ : w ⊩⋆ Γ}
                           → (M : Γ ⊢ A ⇒ B) → Un⋆ ρ
                           → Eq (⟦ M ⟧ ρ) (⟦ ƛ (wk M ∙ 0) ⟧ ρ)
    lemexp⇒ {ρ = ρ} M υ =
      eq⊃ (λ η {a} u → acc⟦∙⟧idEq η (⟦ M ⟧Un υ) u ⁻¹
                      ⦙ cong⟦∙⟧Eq idᵣ (⟦ M ⟧⬗Eq η υ ⁻¹) (congaccUn η (⟦ M ⟧Un υ)) (⟦ M ⟧Un (cong⬗Un⋆ η υ))
                                      (reflEq u) u u
                      ⦙ cong⟦∙⟧Eq idᵣ (wk⟦ M ⟧Eq (cong⬗Un⋆ η υ) u ⁻¹) (⟦ M ⟧Un (cong⬗Un⋆ η υ)) (⟦ wk M ⟧Un (cong⬗Un⋆ η υ , u))
                                      (reflEq u) u u)

    -- Theorem 4.
    cong⟦_⟧Eq : ∀ {Γ A w} → {M M′ : Γ ⊢ A} {ρ : w ⊩⋆ Γ}
                          → M ∼ M′ → Un⋆ ρ
                          → Eq (⟦ M ⟧ ρ) (⟦ M′ ⟧ ρ)
    cong⟦ refl∼ {M = M} ⟧Eq υ = reflEq (⟦ M ⟧Un υ)
    cong⟦ p ⁻¹∼ ⟧Eq         υ = cong⟦ p ⟧Eq υ ⁻¹
    cong⟦ p ⦙∼ q ⟧Eq        υ = cong⟦ p ⟧Eq υ ⦙ cong⟦ q ⟧Eq υ
    cong⟦ ƛ∼ p ⟧Eq          υ = lemƛ p υ
    cong⟦ p ∙∼ q ⟧Eq        υ = lem∙ p q υ
    cong⟦ red⇒ σ M N ⟧Eq   υ = lemred⇒ σ M N υ
    cong⟦ exp⇒ M ⟧Eq       υ = lemexp⇒ M υ

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

-- Theorem 5.
thm₅ : ∀ {Γ A} → (M M′ : Γ ⊢ A) → nf M ≡ nf M′
               → M ∼ M′
thm₅ M M′ p = thm₂ M
            ⦙ ≡→∼ p
            ⦙ (thm₂ M′ ⁻¹)

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

-- proj⟨_⟩𝒰⋆
⌊_⌋ᵤ : ∀ {Γ Γ′} → (η : Γ′ ∋⋆ Γ)
                → Un⋆ ⌊ η ⌋ᵥ
⌊ ∅ ⌋ᵤ     = ∅
⌊ η , i ⌋ᵤ = ⌊ η ⌋ᵤ , ⟪𝓋 i ⟫ᵤ

-- refl𝒰⋆
idᵤ : ∀ {Γ} → Un⋆ (idᵥ {Γ})
idᵤ = ⌊ idᵣ ⌋ᵤ

-- Theorem 6.
thm₆ : ∀ {Γ A} → (M M′ : Γ ⊢ A) → M ∼ M′
               → nf M ≡ nf M′
thm₆ M M′ p = cor₁ M M′ (cong⟦ p ⟧Eq idᵤ)

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


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

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

module is-lib.SInfSys {𝓁} where
  open import is-lib.InfSys.Base {𝓁} public
  open import is-lib.InfSys.Induction {𝓁} public
  open import is-lib.InfSys.SCoinduction {𝓁} public
  open import is-lib.InfSys.FlexSCoinduction {𝓁} public
  open MetaRule public
  open FinMetaRule public
  open IS public


------------------------------------------------------------------------------
-- Distributive laws on a binary operation: Task B
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module DistributiveLaws.TaskB.UnprovedATP where

open import DistributiveLaws.Base

------------------------------------------------------------------------------
-- 2018-06-28: The ATPs could not prove the theorem (300 sec).
postulate
  prop₂ : ∀ u x y z →
          (x · y · (z · u)) · ((x · y · (z · u)) · (x · z · (y · u))) ≡
            x · z · (y · u)
{-# ATP prove prop₂ #-}


-- Andreas, 2018-06-19, issue #3130

module Issue3130 where

-- A pattern variable should not shadow a postfix projection
-- in the same scope.

module Shadow where

  record R : Set₁ where
    field y : Set → Set
  open R

  -- Should succeed or maybe complain about pattern variable y,
  -- but not about the postfix projection pattern.

  test : R
  test .y y = y

-- Disambiguation

module Parens where

  record R : Set₁ where
    field p : Set
  open R

  data D : (R → Set) → Set₁ where
    c : D p

  test : (f : R → Set) (x : D f) → Set₁
  test .(p) c = Set


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

open import Prelude
open import GSeTT.Syntax
open import GSeTT.Rules
open import GSeTT.Disks
open import CaTT.Ps-contexts
open import CaTT.Uniqueness-Derivations-Ps
open import Sets ℕ eqdecℕ

module CaTT.Fullness where

  data Ty : Set₁
  data Tm : Set₁
  data Sub : Set₁

  data _is-full-in_ : Ty → ps-ctx → Set₁

  data Ty where
    ∗ : Ty
    ⇒ : Ty → Tm → Tm → Ty
  data Tm where
    v : ℕ → Tm
    coh : (Γ : ps-ctx) → (A : Ty) → A is-full-in Γ → Sub  → Tm
  data Sub where
    <> : Sub
    <_,_↦_> : Sub → ℕ → Tm → Sub

  =⇒Ty : ∀ {A A' : Ty} {t t' u u' : Tm} → _==_ {A = Ty} (⇒ A t u) (⇒ A' t' u') → ((A == A' × t == t') × u == u')
  =⇒Ty idp = (idp , idp) , idp

  coh= : ∀ {Γ Γ' A A' Afull A'full γ γ'} → coh Γ A Afull γ == coh Γ' A' A'full γ' → ((Γ == Γ' × A == A') × γ == γ')
  coh= idp = (idp , idp) , idp

  <>= : ∀ {γ γ' x x' t t'} → < γ , x ↦ t > == < γ' , x' ↦ t' > → ((γ == γ' × x == x') × t == t')
  <>= idp = (idp , idp) , idp

  {- Set of variables -}
  varC : Pre-Ctx → set
  varC nil = Ø
  varC (Γ :: (x , _)) = (varC Γ) ∪-set (singleton x)

  varT : Ty → set
  vart : Tm → set
  varS : Sub → set

  varT ∗ = Ø
  varT (⇒ A t u) = (varT A) ∪-set ((vart t) ∪-set (vart u))
  vart (v x) = singleton x
  vart (coh Γ A Afull γ) = varS γ
  varS <> = Ø
  varS < γ , x ↦ t > = (varS γ) ∪-set (vart t)

  {- fullness condition -}
  data _is-full-in_ where
    side-cond₁ : ∀ Γ A t u → (src-var Γ) ≗ ((varT A) ∪-set (vart t)) → (tgt-var Γ) ≗ ((varT A) ∪-set (vart u)) → (⇒ A t u) is-full-in Γ
    side-cond₂ : ∀ Γ A →  (varC (fst Γ)) ≗ (varT A) → A is-full-in Γ

  ∈-drop : ∀ {A : Set} {a : A} {l : list A} → a ∈-list drop l → a ∈-list l
  ∈-drop {A} {a} {l :: a₁} x = inl x

  l∉∂⁻ : ∀ {Γ i x A y} → (Γ⊢ps : Γ ⊢ps x # A) → length Γ ≤ y → ¬ (y ∈-list (srcᵢ-var i Γ⊢ps))
  l∉∂⁻ {i = i} pss lΓ≤y y∈ with eqdecℕ i O
  ... | inl _ = y∈
  l∉∂⁻ {i = i} pss lΓ≤y (inr idp) | inr _ = Sn≰n _ lΓ≤y
  l∉∂⁻ (psd Γ⊢ps) lΓ≤y y∈ = l∉∂⁻ Γ⊢ps lΓ≤y y∈
  l∉∂⁻ {i = i} (pse {A = A} Γ⊢ps idp idp idp idp idp) SSl≤y y∈ with dec-≤ i (S (dim A))
  ... | inl _ = l∉∂⁻ Γ⊢ps (Sn≤m→n≤m (Sn≤m→n≤m SSl≤y)) y∈
  l∉∂⁻ {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inl (inl y∈)) | inr _ = l∉∂⁻ Γ⊢ps (Sn≤m→n≤m (Sn≤m→n≤m SSl≤y)) y∈
  l∉∂⁻ {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inl (inr idp)) | inr _ = Sn≰n _ (n≤m→n≤Sm SSl≤y)
  l∉∂⁻ {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inr idp) | inr _ = Sn≰n _ SSl≤y

  l∉∂⁺ : ∀ {Γ i x A y} → (Γ⊢ps : Γ ⊢ps x # A) → length Γ ≤ y → ¬ (y ∈-list (tgtᵢ-var i Γ⊢ps))
  l∉∂⁺ {i = i} pss lΓ≤y y∈ with eqdecℕ i O
  ... | inl _ = y∈
  l∉∂⁺ {i = i} pss lΓ≤y (inr idp) | inr _ = Sn≰n _ lΓ≤y
  l∉∂⁺ (psd Γ⊢ps) lΓ≤y y∈ = l∉∂⁺ Γ⊢ps lΓ≤y y∈
  l∉∂⁺ {i = i} (pse {A = A} Γ⊢ps idp idp idp idp idp) SSl≤y y∈ with dec-≤ i (S (dim A))
  l∉∂⁺ {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inl (inl y∈)) | inr _ = l∉∂⁺ Γ⊢ps (Sn≤m→n≤m (Sn≤m→n≤m SSl≤y)) y∈
  l∉∂⁺ {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inl (inr idp)) | inr _ = Sn≰n _ (n≤m→n≤Sm SSl≤y)
  l∉∂⁺ {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inr idp) | inr x = Sn≰n _ SSl≤y
  ... | inl _ with eqdecℕ i (S (dim A))
  l∉∂⁺ {i = .(S (dim _))} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inl y∈drop) | inl _ | inl idp = l∉∂⁺ Γ⊢ps (Sn≤m→n≤m (Sn≤m→n≤m SSl≤y)) (∈-drop y∈drop)
  l∉∂⁺ {i = .(S (dim _))} (pse {A = _} Γ⊢ps idp idp idp idp idp) SSl≤y (inr idp) | inl _ | inl idp = Sn≰n _ (n≤m→n≤Sm SSl≤y)
  ... | inr _ = l∉∂⁺ Γ⊢ps (Sn≤m→n≤m (Sn≤m→n≤m SSl≤y)) y∈

  ∂⁻ᵢ-var : ∀ {Γ x A y B i} → (Γ⊢ps : Γ ⊢ps x # A)  → Γ ⊢t (Var y) # B → i ≤ dim B → ¬ (y ∈-list (srcᵢ-var i Γ⊢ps))
  ∂⁻ᵢ-var pss (var x (inr (idp , idp))) (0≤ .0) ()
  ∂⁻ᵢ-var (psd Γ⊢ps) Γ⊢y i≤B y∈∂⁻ = ∂⁻ᵢ-var Γ⊢ps Γ⊢y i≤B y∈∂⁻
  ∂⁻ᵢ-var {i = i} (pse {A = A} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B y∈∂⁻ with dec-≤ i (S (dim A))
  ... | inl _ = ∂⁻ᵢ-var Γ⊢ps (var (psv Γ⊢ps) y∈Γ) i≤B y∈∂⁻
  ∂⁻ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B (inl (inl y∈∂⁻)) | inr _ = ∂⁻ᵢ-var Γ⊢ps (var (psv Γ⊢ps) y∈Γ) i≤B y∈∂⁻
  ∂⁻ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B (inl (inr idp)) | inr _ = x∉ (psv Γ⊢ps) (n≤n _) (var (psv Γ⊢ps) y∈Γ)
  ∂⁻ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B (inr idp) | inr _ = x∉ (psv Γ⊢ps) (n≤Sn _) (var (psv Γ⊢ps) y∈Γ)
  ∂⁻ᵢ-var {i = i} (pse {A = B} Γ⊢ps idp idp idp idp idp) (var _ (inl (inr (idp , idp)))) i≤B y∈∂⁻ with dec-≤ i (S (dim B))
  ... | inl _ = l∉∂⁻ Γ⊢ps (n≤n _) y∈∂⁻
  ... | inr i≰SB = i≰SB (n≤m→n≤Sm i≤B)
  ∂⁻ᵢ-var {i = i} (pse {A = A} Γ⊢ps idp idp idp idp idp) (var _ (inr (idp , idp))) i≤SA y∈∂⁻ with dec-≤ i (S (dim A))
  ... | inl _ = l∉∂⁻ Γ⊢ps (n≤Sn _) y∈∂⁻
  ... | inr i≰SA = i≰SA i≤SA

  ∂⁺ᵢ-var : ∀ {Γ x A y B i} → (Γ⊢ps : Γ ⊢ps x # A)  → Γ ⊢t (Var y) # B → i ≤ dim B → ¬ (y ∈-list (tgtᵢ-var i Γ⊢ps))
  ∂⁺ᵢ-var pss (var x (inr (idp , idp))) (0≤ .0) ()
  ∂⁺ᵢ-var (psd Γ⊢ps) Γ⊢y i≤B y∈∂⁺ = ∂⁺ᵢ-var Γ⊢ps Γ⊢y i≤B y∈∂⁺
  ∂⁺ᵢ-var {i = i} (pse {A = A} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B y∈∂⁺ with dec-≤ i (S (dim A))
  ... | inl i≤SdimA with eqdecℕ i (S (dim A))
  ... | inr _ = ∂⁺ᵢ-var Γ⊢ps (var (psv Γ⊢ps) y∈Γ) i≤B y∈∂⁺
  ∂⁺ᵢ-var {i = .(S (dim _))} (pse {A = A}  Γ⊢ps idp idp idp idp idp) (var {x = y} _ (inl (inl y∈Γ))) i≤B (inl y∈drop) | inl i≤SdimA | inl idp = ∂⁺ᵢ-var Γ⊢ps (var (psv Γ⊢ps) y∈Γ) i≤B (∈-drop y∈drop)
  ∂⁺ᵢ-var {i = .(S (dim _))} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B (inr idp) | inl i≤SdimA | inl idp = lΓ∉Γ (psv Γ⊢ps) y∈Γ
  ∂⁺ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B (inl (inl y∈∂⁻)) | inr _ = ∂⁺ᵢ-var Γ⊢ps (var (psv Γ⊢ps) y∈Γ) i≤B y∈∂⁻
  ∂⁺ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B (inl (inr idp)) | inr _ = x∉ (psv Γ⊢ps) (n≤n _) (var (psv Γ⊢ps) y∈Γ)
  ∂⁺ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inl (inl y∈Γ))) i≤B (inr idp) | inr _ = x∉ (psv Γ⊢ps) (n≤Sn _) (var (psv Γ⊢ps) y∈Γ)
  ∂⁺ᵢ-var {i = i} (pse {A = B} Γ⊢ps idp idp idp idp idp) (var _ (inl (inr (idp , idp)))) i≤B y∈∂⁺ with dec-≤ i (S (dim B))
  ... | inr i≰SB = i≰SB (n≤m→n≤Sm i≤B)
  ... | inl _  with eqdecℕ i (S (dim B))
  ... | inr _ = l∉∂⁺ Γ⊢ps (n≤n _) y∈∂⁺
  ∂⁺ᵢ-var (pse Γ⊢ps idp idp idp idp idp) (var _ (inl (inr (idp , idp)))) i≤B (inl l∈drop) | inl _ | inl _ = l∉∂⁺ Γ⊢ps (n≤n _) (∈-drop l∈drop)
  ∂⁺ᵢ-var (pse Γ⊢ps idp idp idp idp idp) (var _ (inl (inr (idp , idp)))) i≤B (inr p) | inl _ | inl idp = Sn≰n _ i≤B
  ∂⁺ᵢ-var {i = i} (pse {A = A} Γ⊢ps idp idp idp idp idp) (var _ (inr (idp , idp))) i≤SA y∈∂⁺ with dec-≤ i (S (dim A))
  ... | inr i≰SA = i≰SA i≤SA
  ... | inl _ with eqdecℕ i (S (dim A))
  ... | inr _ = l∉∂⁺ Γ⊢ps (n≤Sn _) y∈∂⁺
  ∂⁺ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inr (idp , idp))) i≤SA (inl Sl∈drop) | inl _ | inl _ = l∉∂⁺ Γ⊢ps (n≤Sn _) (∈-drop Sl∈drop)
  ∂⁺ᵢ-var {i = i} (pse {A = _} Γ⊢ps idp idp idp idp idp) (var _ (inr (idp , idp))) i≤SA (inr Sl=l) | inl _ | inl _ = Sn≠n _ Sl=l

  ∈-varC : ∀ {Γ x A} →  x # A ∈ Γ → x ∈-set (varC Γ)
  ∈-varC {Γ :: (y , B)} {x} {A} (inl x∈Γ) = ∈-∪₁ {A = varC Γ} {B = singleton y} (∈-varC x∈Γ)
  ∈-varC {Γ :: (y , B)} {x} {A} (inr (idp , _)) = ∈-∪₂ {A = varC Γ} {B = singleton y} (∈-singleton y)

  max-var-def : Pre-Ctx → ℕ × Pre-Ty
  max-var-def nil = 0 , ∗
  max-var-def (Γ :: (y , B)) with dec-≤ (dimC Γ) (dim B)
  ... | inr _ = max-var-def Γ
  ... | inl _ = y , B

  max-var-is-max : ∀ {Γ} → Γ ≠ nil → Γ ⊢C → let (x , A) = max-var-def Γ in ((x # A ∈ Γ) × (dimC Γ == dim A))
  max-var-is-max {nil} Γ≠nil _ = ⊥-elim (Γ≠nil idp)
  max-var-is-max {Γ :: (y , B)} _ Γ⊢ with dec-≤ (dimC Γ) (dim B)
  ... | inl _ = inr (idp , idp) , idp
  ... | inr _ with Γ
  max-var-is-max {Γ :: (y , B)} _ (cc Γ⊢ Γ⊢B idp) | inr _ | Δ :: (x , A) = let (x∈ , dimA) = max-var-is-max (λ{()}) Γ⊢ in inl x∈ , dimA
  max-var-is-max {Γ :: (.0 , .∗)} _ (cc Γ⊢ (ob _) idp) | inr _ | nil = inr (idp , idp) , idp
  max-var-is-max {Γ :: (.0 , _)} _ (cc Γ⊢ (ar _ _) idp) | inr dΓ≤dB | nil = ⊥-elim (dΓ≤dB (0≤ _))

  psx-nonul : ∀ {Γ x A} → Γ ⊢ps x # A → Γ ≠ nil
  psx-nonul (psd x) idp = psx-nonul x idp

  ps-nonul : ∀ {Γ} → Γ ⊢ps → Γ ≠ nil
  ps-nonul (ps Γ⊢ps) = psx-nonul Γ⊢ps

  max-var : ∀ {Γ} → Γ ⊢ps → Σ (ℕ × Pre-Ty) λ {(x , A) → (x # A ∈ Γ) × (dimC Γ == dim A)}
  max-var {Γ} Γ⊢ps@(ps Γ⊢psx) = max-var-def Γ , max-var-is-max (ps-nonul Γ⊢ps) (psv Γ⊢psx)

  ∂Γ-not-full : ∀ Γ → ¬ (varC (fst Γ) ⊂ ((src-var Γ) ∪-set (tgt-var Γ)))
  ∂Γ-not-full (Γ , Γ⊢ps@(ps Γ⊢psx)) vΓ⊂∂ = let ((x , A) , (x∈Γ , dimA)) = max-var Γ⊢ps in
    ∉-∪ {set-of-list (srcᵢ-var (dimC Γ) Γ⊢psx)} {set-of-list (tgtᵢ-var (dimC Γ) Γ⊢psx)} {x}
    (λ x∈∂⁻ → ∂⁻ᵢ-var Γ⊢psx (var (psv Γ⊢psx) x∈Γ) (≤-= (n≤n _) dimA) (∈-set-∈-list _ _ x∈∂⁻))
    (λ x∈∂⁺ → ∂⁺ᵢ-var Γ⊢psx (var (psv Γ⊢psx) x∈Γ) (≤-= (n≤n _) dimA) (∈-set-∈-list _ _ x∈∂⁺))
    (vΓ⊂∂ x (∈-varC x∈Γ))

  disjoint-cond : ∀ Γ A t u → (src-var Γ) ≗ ((varT A) ∪-set (vart t)) → (tgt-var Γ) ≗ ((varT A) ∪-set (vart u)) → ¬ (varC (fst Γ) ≗ varT (⇒ A t u))
  disjoint-cond Γ A t u (_ , A⊂∂⁻) (_ , A⊂∂⁺) (Γ⊂A , _) =
    let vA = varT A in let vt = vart t in let vu = vart u in
    let sr = src-var Γ in let tg = tgt-var Γ in
    ∂Γ-not-full Γ
      (⊂-trans {varC (fst Γ)} {vA ∪-set (vt ∪-set vu)} {sr ∪-set tg} Γ⊂A
      (≗-⊂ {vA ∪-set (vt ∪-set vu)} {(vA ∪-set vt) ∪-set (vA ∪-set vu)} {sr ∪-set tg} (∪-factor (varT A) (vart t) (vart u))
      (⊂-∪ {vA ∪-set vt} {sr} {vA ∪-set vu} {tg} A⊂∂⁻ A⊂∂⁺)))

  side-cond₁= : ∀ Γ A t u ∂⁻-full₁ ∂⁻-full₂ ∂⁺-full₁ ∂⁺-full₂ → ∂⁻-full₁ == ∂⁻-full₂ → ∂⁺-full₁ == ∂⁺-full₂ → side-cond₁ Γ A t u ∂⁻-full₁ ∂⁺-full₁ == side-cond₁ Γ A t u ∂⁻-full₂ ∂⁺-full₂
  side-cond₁= Γ A t u ∂⁻-full₁ .∂⁻-full₁ ∂⁺-full₁ .∂⁺-full₁ idp idp = idp

  has-all-paths-is-full : ∀ Γ A → has-all-paths (A is-full-in Γ)
  has-all-paths-is-full Γ .(⇒ A t u) (side-cond₁ .Γ A t u x x₁) (side-cond₁ .Γ .A .t .u x₂ x₃) = ap² (λ ∂⁻ → λ ∂⁺ → side-cond₁ Γ A t u ∂⁻ ∂⁺) (is-prop-has-all-paths (is-prop-≗ (src-var Γ) (varT A ∪-set vart t)) x x₂) (is-prop-has-all-paths (is-prop-≗ (tgt-var Γ) (varT A ∪-set vart u)) x₁ x₃)
  has-all-paths-is-full Γ .(⇒ A t u) (side-cond₁ .Γ A t u ∂⁻ ∂⁺) (side-cond₂ .Γ .(⇒ A t u) full) = ⊥-elim (disjoint-cond Γ A t u ∂⁻ ∂⁺ full)
  has-all-paths-is-full Γ .(⇒ A t u) (side-cond₂ .Γ .(⇒ A t u) full) (side-cond₁ .Γ A t u ∂⁻ ∂⁺) = ⊥-elim (disjoint-cond Γ A t u ∂⁻ ∂⁺ full)
  has-all-paths-is-full Γ A (side-cond₂ .Γ .A x) (side-cond₂ .Γ .A x₁) = ap (side-cond₂ Γ A) (is-prop-has-all-paths (is-prop-≗ (varC (fst Γ)) (varT A)) x x₁)

  is-prop-full : ∀ Γ A → is-prop (A is-full-in Γ)
  is-prop-full Γ A = has-all-paths-is-prop (has-all-paths-is-full Γ A)

  eqdec-Ty : eqdec Ty
  eqdec-Tm : eqdec Tm
  eqdec-Sub : eqdec Sub

  eqdec-Ty ∗ ∗ = inl idp
  eqdec-Ty ∗ (⇒ _ _ _) = inr λ{()}
  eqdec-Ty (⇒ _ _ _) ∗ = inr λ{()}
  eqdec-Ty (⇒ A t u) (⇒ A' t' u') with eqdec-Ty A A' | eqdec-Tm t t' | eqdec-Tm u u'
  ...                                        | inl idp | inl idp | inl idp = inl idp
  ...                                        | inr A≠A' | _ | _ = inr λ {idp → A≠A' idp}
  ...                                        | inl idp | inr t≠t' | _ = inr λ p → t≠t' (snd (fst (=⇒Ty p)))
  ...                                        | inl idp | inl idp | inr u≠u' = inr λ p → u≠u' (snd (=⇒Ty p))
  eqdec-Tm (v x) (v y) with eqdecℕ x y
  ...                   | inl idp = inl idp
  ...                   | inr x≠y = inr λ{idp → x≠y idp}
  eqdec-Tm (v _) (coh _ _ _ _) = inr λ{()}
  eqdec-Tm (coh _ _ _ _) (v _) = inr λ{()}
  eqdec-Tm (coh Γ A Afull γ) (coh Γ' A' A'full γ') with eqdec-ps Γ Γ' | eqdec-Ty A A' | eqdec-Sub γ γ'
  ...                                               | inl idp | inl idp | inl idp = inl (ap (λ X → coh Γ A X γ) (is-prop-has-all-paths (is-prop-full Γ A) Afull A'full))
  ...                                               | inr Γ≠Γ' | _ | _ = inr λ {idp → Γ≠Γ' idp}
  ...                                               | inl idp | inr A≠A' | _ = inr λ p → A≠A' (snd (fst (coh= p)))
  ...                                               | inl idp | inl idp | inr γ≠γ' = inr λ p → γ≠γ' (snd (coh= p))
  eqdec-Sub <> <> = inl idp
  eqdec-Sub <> < _ , _ ↦ _ > = inr λ{()}
  eqdec-Sub < _ , _ ↦ _ > <> = inr λ{()}
  eqdec-Sub < γ , x ↦ t > < γ' , x' ↦ t' > with eqdec-Sub γ γ' | eqdecℕ x x' | eqdec-Tm t t'
  ...                                        | inl idp | inl idp | inl idp = inl idp
  ...                                        | inr γ≠γ' | _ | _ = inr λ {idp → γ≠γ' idp}
  ...                                        | inl idp | inr x≠x' | _ = inr λ p → x≠x' (snd (fst (<>= p)))
  ...                                        | inl idp | inl idp | inr t≠t' = inr λ p → t≠t' (snd (<>= p))


module CoinductiveConstructorsAndLet where

open import Common.Coinduction

data D : Set where

foo : D → ∞ D
foo x = let y = x in ♯ y

-- CoinductiveConstructorsAndLet.agda:9,24-25
-- Panic: thing out of context ([CtxId 1] is not a sub context of
-- [CtxId 3])
-- when checking that the expression y has type D


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use the Data.(Nat/Fin).Induction
-- modules directly.
------------------------------------------------------------------------

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

module Induction.Nat where

open import Data.Nat.Induction public
open import Data.Fin.Induction public

{-# WARNING_ON_IMPORT
"Induction.Nat was deprecated in v1.1.
Use Data.Nat.Induction and Data.Fin.Induction instead."
#-}


------------------------------------------------------------------------
-- The parser type
------------------------------------------------------------------------

module TotalParserCombinators.Parser where

open import Algebra
open import Category.Monad
open import Codata.Musical.Notation
open import Data.List
open import Data.Maybe using (Maybe; nothing; just)
open import Data.List.Categorical as ListMonad
  using () renaming (module MonadProperties to ListMonadProp)
open import Data.List.Relation.Binary.BagAndSetEquality
open import Data.Product using (proj₂)
open import Function
open import Level
open import Relation.Binary.PropositionalEquality

open RawMonadPlus {f = zero} ListMonad.monadPlus
  using ()
  renaming ( return to return′
           ; ∅      to fail′
           ; _∣_    to _∣′_
           ; _⊛_    to _⊛′_
           ; _>>=_  to _>>=′_
           )

------------------------------------------------------------------------
-- Helper functions

-- Flattening for potential lists.

flatten : {A : Set} → Maybe (List A) → List A
flatten nothing   = []
flatten (just xs) = xs

-- fs ⊛flatten mxs is a variant of fs ⊛′ flatten mxs, with the
-- property that fs ⊛flatten nothing evaluates to [].

_⊛flatten_ : {A B : Set} → List (A → B) → Maybe (List A) → List B
fs ⊛flatten nothing = []
fs ⊛flatten just xs = fs ⊛′ xs

-- Applies the function to the value, returning the empty list if
-- there is no function.

apply : {A B : Set} → Maybe (A → List B) → A → List B
apply nothing  x = []
apply (just f) x = f x

-- bind mxs mf is a variant of flatten mxs >>=′ apply mf, with the
-- property that bind mxs nothing evaluates to [].

bind :  {A B : Set} → Maybe (List A) → Maybe (A → List B) → List B
bind mxs nothing  = []
bind mxs (just f) = flatten mxs >>=′ f

-- Verification of some claims made above.

module Claims where

  ⊛flatten-⊛-flatten : ∀ {A B : Set} (fs : List (A → B)) mxs →
                       fs ⊛flatten mxs ≡ (fs ⊛′ flatten mxs)
  ⊛flatten-⊛-flatten fs nothing   = sym $ ListMonadProp.right-zero fs
  ⊛flatten-⊛-flatten fs (just xs) = refl

  ⊛flatten-nothing : {A B : Set} (fs : List (A → B)) →
                     fs ⊛flatten nothing ≡ []
  ⊛flatten-nothing fs = refl

  bind-flatten->>=-apply : ∀ {A B : Set} mxs (mf : Maybe (A → List B)) →
                           bind mxs mf ≡ (flatten mxs >>=′ apply mf)
  bind-flatten->>=-apply mxs (just f) = refl
  bind-flatten->>=-apply mxs nothing  =
    sym $ ListMonadProp.right-zero (flatten mxs)

  bind-nothing : {A B : Set} (mxs : Maybe (List A)) →
                 bind mxs nothing ≡ [] {A = B}
  bind-nothing mxs = refl

------------------------------------------------------------------------
-- Parsers

infixl 50 _⊛_ _<$>_ _⊛flatten_
infixl 10 _>>=_
infixl  5 _∣_

-- The list index is the "initial bag"; it contains the results which
-- can be emitted without consuming any input. For
--   p : Parser Tok R xs
-- we have
--   x ∈ xs  iff  x ∈ p · []
-- (see TotalParserCombinators.InitialBag).

mutual

  data Parser (Tok : Set) : (R : Set) → List R → Set₁ where
    return   : ∀ {R} (x : R) → Parser Tok R (return′ x)
    fail     : ∀ {R} → Parser Tok R fail′
    token    : Parser Tok Tok fail′
    _∣_      : ∀ {R xs₁ xs₂}
               (p₁ : Parser Tok R  xs₁       )
               (p₂ : Parser Tok R         xs₂) →
                     Parser Tok R (xs₁ ∣′ xs₂)
    _<$>_    : ∀ {R₁ R₂ xs}
               (f : R₁ → R₂)
               (p : Parser Tok R₁        xs) →
                    Parser Tok R₂ (map f xs)
    _⊛_      : ∀ {R₁ R₂ fs xs}
               (p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs)            )
               (p₂ : ∞⟨ fs ⟩Parser Tok  R₁                   (flatten xs)) →
                            Parser Tok       R₂  (flatten fs ⊛flatten xs)
    _>>=_    : ∀ {R₁ R₂ xs} {f : Maybe (R₁ → List R₂)}
               (p₁ :            ∞⟨ f  ⟩Parser Tok R₁ (flatten xs))
               (p₂ : (x : R₁) → ∞⟨ xs ⟩Parser Tok R₂ (apply f x)) →
                                       Parser Tok R₂ (bind xs f)
    nonempty : ∀ {R xs} (p : Parser Tok R xs) → Parser Tok R []
    cast     : ∀ {R xs₁ xs₂} (xs₁≈xs₂ : xs₁ ∼[ bag ] xs₂)
               (p : Parser Tok R xs₁) → Parser Tok R xs₂

  ∞⟨_⟩Parser : {A : Set} → Maybe A → Set → (R : Set) → List R → Set₁
  ∞⟨ nothing ⟩Parser Tok R₁ xs = ∞ (Parser Tok R₁ xs)
  ∞⟨ just _  ⟩Parser Tok R₁ xs =    Parser Tok R₁ xs

-- Note that, with the definition above, a sequenced parser is
-- /allowed/ to be delayed if the "other" parser is not nullable, but
-- it does not have to be.

-- Note also that it would be safe to make the first argument of _>>=_
-- coinductive if apply f x ≡_[] for all x in xs. I suspect that this
-- criterion would be awkward to work with, though. Instead I only
-- allow the argument to be coinductive if f ≡ nothing.

-- Finally note that some of the combinators above are not included in
-- the paper "Total Parser Combinators".

------------------------------------------------------------------------
-- Examples

private

  -- Note that these parsers can be both left and right recursive:

  leftRight : ∀ {R Tok} → Parser Tok R _
  leftRight {R} = ♯ (const <$> leftRight) ⊛ ♯ leftRight {R}

  leftRight′ : ∀ {R Tok} → Parser Tok R _
  leftRight′ {R} = ♯ leftRight′ {R} >>= λ _ → ♯ leftRight′

  -- More examples, included to ensure that all implicit arguments are
  -- inferred automatically.

  p : {Tok R : Set} → Parser Tok R _
  p = token >>= λ _ → ♯ p

  p′ : {Tok : Set} → Parser Tok Tok _
  p′ = ♯ p′ >>= λ _ → token

------------------------------------------------------------------------
-- Helper functions

-- Returns the initial bag.

initial-bag : ∀ {Tok R xs} → Parser Tok R xs → List R
initial-bag {xs = xs} _ = xs

-- Forces if necessary.

♭? : ∀ {Tok R₁ R₂} {m : Maybe R₂} {xs} →
     ∞⟨ m ⟩Parser Tok R₁ xs → Parser Tok R₁ xs
♭? {m = nothing} = ♭
♭? {m = just _}  = id

-- Is the argument parser forced? If the result is just something,
-- then it is.

forced? : ∀ {Tok A R xs} {m : Maybe A} →
          ∞⟨ m ⟩Parser Tok R xs → Maybe A
forced? {m = m} _ = m

forced?′ : {Tok R₁ R₂ A : Set} {m : Maybe A} {f : R₁ → List R₂} →
           ((x : R₁) → ∞⟨ m ⟩Parser Tok R₂ (f x)) → Maybe A
forced?′ {m = m} _ = m

-- Short synonyms for just and nothing. ◌ stands for "delayed" (think
-- "not here") and ○ for "not delayed".

◌ : {R : Set} → Maybe R
◌ = nothing

○ : {R : Set} {x : R} → Maybe R
○ {x = x} = just x