module hcio where

-- https://github.com/alhassy/AgdaCheatSheet#interacting-with-the-real-world-compilation-haskell-and-io

open import Agda.Builtin.Coinduction using (♯_)
open import Agda.Builtin.Unit        using (⊤)
open import Codata.Musical.Colist    as CL using (take)
open import Codata.Musical.Costring  using (Costring)
open import Data.String              as S using (String; fromList)
open import Data.Vec.Bounded         as B using (toList)
open import Function                 using (const; _∘_)
open import IO                       as IO using ()
import      IO.Primitive             as Primitive

infixr 1 _>>=_ _>>_

_>>=_ : ∀ {ℓ} {α β : Set ℓ} → IO.IO α → (α → IO.IO β) → IO.IO β
this >>= f = ♯ this IO.>>= λ x → ♯ f x

_>>_ : ∀{ℓ} {α β : Set ℓ} → IO.IO α → IO.IO β → IO.IO β
x >> y = x >>= const y

postulate
  getLine∞ : Primitive.IO Costring

{-# FOREIGN GHC
  toColist :: [a] -> MAlonzo.Code.Codata.Musical.Colist.AgdaColist a
  toColist []       = MAlonzo.Code.Codata.Musical.Colist.Nil
  toColist (x : xs) = MAlonzo.Code.Codata.Musical.Colist.Cons x (MAlonzo.RTE.Sharp (toColist xs))
#-}

{-# FOREIGN GHC import Prelude as Haskell #-} -- rename for clarity
{-# COMPILE GHC getLine∞ = fmap toColist Haskell.getLine #-}

getLine : IO.IO String
getLine =
  IO.lift (getLine∞ Primitive.>>= (Primitive.return ∘ S.fromList ∘ B.toList ∘ CL.take 100))


primitive
  primSetOmega : _


-- Abstract definitions can't be projection-like
module Issue447 where

postulate
  I : Set
  R : I → Set

module M (i : I) (r : R i) where

  abstract

    P : Set₂
    P = Set₁

    p : P
    p = Set


-- There was a bug with the new constraint machinery
-- where a type error could be ignored and checking
-- continued.
module LostTypeError where

postulate
  Wrap : (A : Set) (P : A → Set) → A → Set
  wrap : ∀ A (P : A → Set) (x : A) → P x → Wrap A P x
  A    : Set

data Box : Set where
  box : A → Box

data Dummy : Set where
  box : Dummy

postulate
  x y : A
  P   : Box → Set
  px  : P (box x)

bad : Wrap Box P (box y)
bad = wrap _ (λ a → P _) (box x) px


{-# OPTIONS --without-K #-}
module mini-quine where
open import common

infixl 2 _▻_
infixl 3 _‘’_
infixr 1 _‘→’_
infixl 3 _‘’ₐ_
infixl 3 _w‘‘’’ₐ_
infixr 2 _‘∘’_

mutual
  data Context : Set where
    ε : Context
    _▻_ : (Γ : Context) → Type Γ → Context

  data Type : Context → Set where
    W : ∀ {Γ A} → Type Γ → Type (Γ ▻ A)
    W1 : ∀ {Γ A B} → Type (Γ ▻ B) → Type (Γ ▻ A ▻ (W {Γ = Γ} {A = A} B))
    _‘’_ : ∀ {Γ A} → Type (Γ ▻ A) → Term {Γ} A → Type Γ
    ‘Typeε’ : ∀ {Γ} → Type Γ
    ‘□’ : ∀ {Γ} → Type (Γ ▻ ‘Typeε’)
    _‘→’_ : ∀ {Γ} → Type Γ → Type Γ → Type Γ
    Quine : Type (ε ▻ ‘Typeε’) → Type ε
    ‘⊤’ : ∀ {Γ} → Type Γ
    ‘⊥’ : ∀ {Γ} → Type Γ

  data Term : {Γ : Context} → Type Γ → Set where
    ⌜_⌝ : ∀ {Γ} → Type ε → Term {Γ} ‘Typeε’
    ⌜_⌝t : ∀ {Γ T} → Term {ε} T → Term {Γ} (‘□’ ‘’ ⌜ T ⌝)
    ‘⌜‘VAR₀’⌝t’ : ∀ {T} → Term {ε ▻ ‘□’ ‘’ ⌜ T ⌝} (W (‘□’ ‘’ ⌜ ‘□’ ‘’ ⌜ T ⌝ ⌝))
    ‘λ∙’ : ∀ {Γ A B} → Term {Γ ▻ A} (W B) → Term {Γ} (A ‘→’ B)
    ‘VAR₀’ : ∀ {Γ T} → Term {Γ ▻ T} (W T)
    _‘’ₐ_ : ∀ {Γ A B} → Term {Γ} (A ‘→’ B) → Term {Γ} A → Term {Γ} B
    quine→ : ∀ {φ} → Term {ε} (Quine φ        ‘→’ φ ‘’ ⌜ Quine φ ⌝)
    quine← : ∀ {φ} → Term {ε} (φ ‘’ ⌜ Quine φ ⌝ ‘→’ Quine φ)
    ‘tt’ : ∀ {Γ} → Term {Γ} ‘⊤’
    →SW1SV→W : ∀ {Γ T X A B} {x : Term X}
      → Term {Γ} (T ‘→’ (W1 A ‘’ ‘VAR₀’ ‘→’ W B) ‘’ x)
      → Term {Γ} (T ‘→’ A ‘’ x ‘→’ B)
    ←SW1SV→W : ∀ {Γ T X A B} {x : Term X}
      → Term {Γ} ((W1 A ‘’ ‘VAR₀’ ‘→’ W B) ‘’ x ‘→’ T)
      → Term {Γ} ((A ‘’ x ‘→’ B) ‘→’ T)
    w : ∀ {Γ A T} → Term {Γ} A → Term {Γ ▻ T} (W A)
    w→ : ∀ {Γ A B X} → Term {Γ} (A ‘→’ B) → Term {Γ ▻ X} (W A ‘→’ W B)
    _‘∘’_ : ∀ {Γ A B C} → Term {Γ} (B ‘→’ C) → Term {Γ} (A ‘→’ B) → Term {Γ} (A ‘→’ C)
    _w‘‘’’ₐ_ : ∀ {A B T} → Term {ε ▻ T} (W (‘□’ ‘’ ⌜ A ‘→’ B ⌝)) → Term {ε ▻ T} (W (‘□’ ‘’ ⌜ A ⌝)) → Term {ε ▻ T} (W (‘□’ ‘’ ⌜ B ⌝))

□ : Type ε → Set _
□ = Term {ε}

max-level : Level
max-level = lzero

mutual
  Context⇓ : (Γ : Context) → Set (lsuc max-level)
  Context⇓ ε = ⊤
  Context⇓ (Γ ▻ T) = Σ (Context⇓ Γ) (Type⇓ {Γ} T)

  Type⇓ : {Γ : Context} → Type Γ → Context⇓ Γ → Set max-level
  Type⇓ (W T) Γ⇓ = Type⇓ T (Σ.proj₁ Γ⇓)
  Type⇓ (W1 T) Γ⇓ = Type⇓ T ((Σ.proj₁ (Σ.proj₁ Γ⇓)) , (Σ.proj₂ Γ⇓))
  Type⇓ (T ‘’ x) Γ⇓ = Type⇓ T (Γ⇓ , Term⇓ x Γ⇓)
  Type⇓ ‘Typeε’ Γ⇓ = Lifted (Type ε)
  Type⇓ ‘□’ Γ⇓ = Lifted (Term {ε} (lower (Σ.proj₂ Γ⇓)))
  Type⇓ (A ‘→’ B) Γ⇓ = Type⇓ A Γ⇓ → Type⇓ B Γ⇓
  Type⇓ ‘⊤’ Γ⇓ = ⊤
  Type⇓ ‘⊥’ Γ⇓ = ⊥
  Type⇓ (Quine φ) Γ⇓ = Type⇓ φ (Γ⇓ , (lift (Quine φ)))

  Term⇓ : ∀ {Γ : Context} {T : Type Γ} → Term T → (Γ⇓ : Context⇓ Γ) → Type⇓ T Γ⇓
  Term⇓ ⌜ x ⌝ Γ⇓ = lift x
  Term⇓ ⌜ x ⌝t Γ⇓ = lift x
  Term⇓ ‘⌜‘VAR₀’⌝t’ Γ⇓ = lift ⌜ (lower (Σ.proj₂ Γ⇓)) ⌝t
  Term⇓ (f ‘’ₐ x) Γ⇓ = Term⇓ f Γ⇓ (Term⇓ x Γ⇓)
  Term⇓ ‘tt’ Γ⇓ = tt
  Term⇓ (quine→ {φ}) Γ⇓ x = x
  Term⇓ (quine← {φ}) Γ⇓ x = x
  Term⇓ (‘λ∙’ f) Γ⇓ x = Term⇓ f (Γ⇓ , x)
  Term⇓ ‘VAR₀’ Γ⇓ = Σ.proj₂ Γ⇓
  Term⇓ (←SW1SV→W f) = Term⇓ f
  Term⇓ (→SW1SV→W f) = Term⇓ f
  Term⇓ (w x) Γ⇓ = Term⇓ x (Σ.proj₁ Γ⇓)
  Term⇓ (w→ f) Γ⇓ = Term⇓ f (Σ.proj₁ Γ⇓)
  Term⇓ (g ‘∘’ f) Γ⇓ x = Term⇓ g Γ⇓ (Term⇓ f Γ⇓ x)
  Term⇓ (f w‘‘’’ₐ x) Γ⇓ = lift (lower (Term⇓ f Γ⇓) ‘’ₐ lower (Term⇓ x Γ⇓))

module inner (‘X’ : Type ε) (‘f’ : Term {ε} (‘□’ ‘’ ⌜ ‘X’ ⌝ ‘→’ ‘X’)) where
  ‘H’ : Type ε
  ‘H’ = Quine (W1 ‘□’ ‘’ ‘VAR₀’ ‘→’ W ‘X’)

  ‘toH’ : □ ((‘□’ ‘’ ⌜ ‘H’ ⌝ ‘→’ ‘X’) ‘→’ ‘H’)
  ‘toH’ = ←SW1SV→W quine←

  ‘fromH’ : □ (‘H’ ‘→’ (‘□’ ‘’ ⌜ ‘H’ ⌝ ‘→’ ‘X’))
  ‘fromH’ = →SW1SV→W quine→

  ‘□‘H’→□‘X’’ : □ (‘□’ ‘’ ⌜ ‘H’ ⌝ ‘→’ ‘□’ ‘’ ⌜ ‘X’ ⌝)
  ‘□‘H’→□‘X’’ = ‘λ∙’ (w ⌜ ‘fromH’ ⌝t w‘‘’’ₐ ‘VAR₀’ w‘‘’’ₐ ‘⌜‘VAR₀’⌝t’)

  ‘h’ : Term ‘H’
  ‘h’ = ‘toH’ ‘’ₐ (‘f’ ‘∘’ ‘□‘H’→□‘X’’)

  Lӧb : □ ‘X’
  Lӧb = ‘fromH’ ‘’ₐ ‘h’ ‘’ₐ ⌜ ‘h’ ⌝t

Lӧb : ∀ {X} → Term {ε} (‘□’ ‘’ ⌜ X ⌝ ‘→’ X) → Term {ε} X
Lӧb {X} f = inner.Lӧb X f

⌞_⌟ : Type ε → Set _
⌞ T ⌟ = Type⇓ T tt

‘¬’_ : ∀ {Γ} → Type Γ → Type Γ
‘¬’ T = T ‘→’ ‘⊥’

lӧb : ∀ {‘X’} → □ (‘□’ ‘’ ⌜ ‘X’ ⌝ ‘→’ ‘X’) → ⌞ ‘X’ ⌟
lӧb f = Term⇓ (Lӧb f) tt

incompleteness : ¬ □ (‘¬’ (‘□’ ‘’ ⌜ ‘⊥’ ⌝))
incompleteness = lӧb

soundness : ¬ □ ‘⊥’
soundness x = Term⇓ x tt

non-emptyness : Σ (Type ε) (λ T → □ T)
non-emptyness = ‘⊤’ , ‘tt’


{- 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.ImplShared.Base.Types

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import Util.PKCS
open import Util.Prelude
open import Yasm.Base

-- This module collects in one place the obligations an
-- implementation must meet in order to enjoy the properties
-- proved in Abstract.Properties.

module LibraBFT.Concrete.Obligations (iiah : SystemInitAndHandlers ℓ-RoundManager ConcSysParms) (𝓔 : EpochConfig) where
  import      LibraBFT.Concrete.Properties.PreferredRound iiah as PR
  import      LibraBFT.Concrete.Properties.VotesOnce      iiah as VO
  import      LibraBFT.Concrete.Properties.Common         iiah as Common

  open        SystemTypeParameters ConcSysParms
  open        SystemInitAndHandlers iiah
  open        ParamsWithInitAndHandlers iiah
  open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms iiah
                        PeerCanSignForPK PeerCanSignForPK-stable

  record ImplObligations : Set (ℓ+1 ℓ-RoundManager) where
    field
      -- Structural obligations:
      sps-cor : StepPeerState-AllValidParts

      -- Semantic obligations:
      --
      -- VotesOnce:
      bsvc : Common.ImplObl-bootstrapVotesConsistent 𝓔
      bsvr : Common.ImplObl-bootstrapVotesRound≡0 𝓔
      v≢0  : Common.ImplObl-NewVoteRound≢0 𝓔
      ∈BI? : (sig : Signature) → Dec (∈BootstrapInfo bootstrapInfo sig)
      v4rc : PR.ImplObligation-RC 𝓔
      iro  : Common.IncreasingRoundObligation 𝓔
      vo₂  : VO.ImplObligation₂ 𝓔

      -- PreferredRound:
      pr₁  : PR.ImplObligation₁ 𝓔
      pr₂  : PR.ImplObligation₂ 𝓔


module Syntacticosmos (Gnd : Set)(U : Set)(El : U -> Set) where

open import Basics
open import Pr
open import Nom
import Kind
open Kind Gnd U El public
import Cxt
open Cxt Kind public
import Loc
open Loc Kind public
import Term
open Term Gnd U El public
import Shift
open Shift Gnd U El public
import Eta
open Eta Gnd U El public
import Inst
open Inst Gnd U El public
import Subst
open Subst Gnd U El public


-- This file is the source Agda file
-- Edit this file not Type.hs
-- The warning below will be written to Type.hs

module PlutusCore.Generators.NEAT.Type where

-- warning to be written to Haskell file:
{-# FOREIGN AGDA2HS
{-
!!! THIS FILE IS GENERATED FROM Type.agda
!!! DO NOT EDIT THIS FILE. EDIT Type.agda
!!! AND THEN RUN agda2hs ON IT.
-}
#-}

{-# FOREIGN AGDA2HS
{-# OPTIONS_GHC -fno-warn-orphans      #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE StandaloneDeriving        #-}

import           Control.Enumerable
import           Control.Monad.Except
import           PlutusCore
import           PlutusCore.Generators.NEAT.Common

#-}

open import Relation.Binary.PropositionalEquality
open import Haskell.Prelude hiding (m)
open import PlutusCore.Generators.NEAT.Common

{-# FOREIGN AGDA2HS
newtype Neutral a = Neutral
  { unNeutral :: a
  }
#-}
-- * Enumeration

-- ** Enumerating types

data TypeBuiltinG : Set where
  TyByteStringG  : TypeBuiltinG
  TyIntegerG     : TypeBuiltinG
  TyBoolG        : TypeBuiltinG
  TyUnitG        : TypeBuiltinG
  TyStringG      : TypeBuiltinG
  TyListG        : TypeBuiltinG
  TyDataG        : TypeBuiltinG

{-# COMPILE AGDA2HS TypeBuiltinG deriving (Show, Eq, Ord) #-}

{-# FOREIGN AGDA2HS
deriveEnumerable ''TypeBuiltinG
#-}

-- NOTE: Unusually, the application case is annotated with a kind.
--       The reason is eagerness and efficiency. If we have the kind
--       information at the application site, we can check the two
--       subterms in parallel, while evaluating as little as possible.

variable
  n m o : Set

postulate Kind : Set → Set

data TypeG (n : Set) : Set where
  TyVarG : n → TypeG n
  TyFunG : TypeG n → TypeG n → TypeG n
  TyIFixG : TypeG n  → Kind ⊤ → TypeG n → TypeG n
  TyForallG : Kind ⊤ → TypeG (S n) → TypeG n
  TyBuiltinG : TypeBuiltinG → TypeG n
  TyLamG : TypeG (S n) → TypeG n
  TyAppG : TypeG n → TypeG n → Kind ⊤ → TypeG n

{-# COMPILE AGDA2HS TypeG deriving (Eq, Ord, Show) #-}

{-# FOREIGN AGDA2HS
deriving instance Ord (Kind ())

deriveEnumerable ''Kind

deriveEnumerable ''TypeG

type ClosedTypeG = TypeG Z

instance Functor TypeG where
  fmap = ren
#-}

ext : (m → n) → S m → S n
ext _ FZ     = FZ
ext f (FS x) = FS (f x)

{-# COMPILE AGDA2HS ext #-}

ren : (m → n) → TypeG m → TypeG n
ren f (TyVarG x) = TyVarG (f x)
ren f (TyFunG ty1 ty2) = TyFunG (ren f ty1) (ren f ty2)
ren f (TyIFixG ty1 k ty2) = TyIFixG (ren f ty1) k (ren f ty2)
ren f (TyForallG k ty) = TyForallG k (ren (ext f) ty)
ren _ (TyBuiltinG b) = TyBuiltinG b
ren f (TyLamG ty) = TyLamG (ren (ext f) ty)
ren f (TyAppG ty1 ty2 k) = TyAppG (ren f ty1) (ren f ty2) k

{-# COMPILE AGDA2HS ren #-}

ext-cong : {ρ ρ' : m → n} → (∀ x → ρ x ≡ ρ' x) → ∀ x → ext ρ x ≡ ext ρ' x
ext-cong p FZ     = refl
ext-cong p (FS x) = cong FS (p x)

ren-cong : {ρ ρ' : m → n} → (∀ x → ρ x ≡ ρ' x) → ∀ t → ren ρ t ≡ ren ρ' t
ren-cong p (TyVarG x)          = cong TyVarG (p x)
ren-cong p (TyFunG ty1 ty2)    = cong₂ TyFunG (ren-cong p ty1) (ren-cong p ty2)
ren-cong p (TyIFixG ty1 k ty2) =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (ren-cong p ty1) (ren-cong p ty2)
ren-cong p (TyForallG k ty)    = cong (TyForallG k) (ren-cong (ext-cong p) ty)
ren-cong p (TyBuiltinG b)      = refl
ren-cong p (TyLamG ty)         = cong TyLamG (ren-cong (ext-cong p) ty)
ren-cong p (TyAppG ty1 ty2 k)  =
  cong₂ (λ ty1 ty2 → TyAppG ty1 ty2 k) (ren-cong p ty1) (ren-cong p ty2)

-- ext (map for S) satisfies the functor laws

ext-id : (x : S m) → ext id x ≡ x
ext-id FZ     = refl
ext-id (FS x) = refl

ext-comp : (x : S m)(ρ : m → n)(ρ' : n → o) → ext (ρ' ∘ ρ) x ≡ ext ρ' (ext ρ x)
ext-comp FZ     ρ ρ' = refl
ext-comp (FS x) ρ ρ' = refl

-- ren (map for TypeG) satisfies the functor laws

ren-id : (ty : TypeG m) → ren id ty ≡ ty
ren-id (TyVarG _)          = refl
ren-id (TyFunG ty1 ty2)    = cong₂ TyFunG (ren-id ty1) (ren-id ty2)
ren-id (TyIFixG ty1 k ty2) =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (ren-id ty1) (ren-id ty2)
ren-id (TyForallG k ty)    =
  cong (TyForallG k) (trans (ren-cong ext-id ty) (ren-id ty))
ren-id (TyBuiltinG _)      = refl
ren-id (TyLamG ty)         =
  cong TyLamG (trans (ren-cong ext-id ty) (ren-id ty))
ren-id (TyAppG ty1 ty2 k)  =
  cong₂ (λ ty1 ty2 → TyAppG ty1 ty2 k) (ren-id ty1) (ren-id ty2)

ren-comp : (ty : TypeG m)(ρ : m → n)(ρ' : n → o)
         → ren (ρ' ∘ ρ) ty ≡ ren ρ' (ren ρ ty)
ren-comp (TyVarG x)          ρ ρ' = refl
ren-comp (TyFunG ty1 ty2)    ρ ρ' =
  cong₂ TyFunG (ren-comp ty1 ρ ρ') (ren-comp ty2 ρ ρ')
ren-comp (TyIFixG ty1 k ty2) ρ ρ' =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (ren-comp ty1 ρ ρ') (ren-comp ty2 ρ ρ')
ren-comp (TyForallG k ty)    ρ ρ' = cong
  (TyForallG k)
  (trans (ren-cong (λ x → ext-comp x ρ ρ') ty)
         (ren-comp ty (ext ρ) (ext ρ')))
ren-comp (TyBuiltinG b)      ρ ρ' = refl
ren-comp (TyLamG ty)         ρ ρ' = cong
  TyLamG
  (trans (ren-cong (λ x → ext-comp x ρ ρ') ty)
         (ren-comp ty (ext ρ) (ext ρ')))
ren-comp (TyAppG ty1 ty2 k)  ρ ρ' =
  cong₂ (λ ty1 ty2 → TyAppG ty1 ty2 k) (ren-comp ty1 ρ ρ') (ren-comp ty2 ρ ρ')

-- ** Type reduction

-- |Extend type substitutions.
exts : (n → TypeG m) -> S n → TypeG (S m)
exts _ FZ     = TyVarG FZ
exts s (FS i) = ren FS (s i) -- FS <$> s i

{-# COMPILE AGDA2HS exts #-}

-- |Simultaneous substitution of type variables.
sub : (n -> TypeG m) -> TypeG n -> TypeG m
sub s (TyVarG i)             = s i
sub s (TyFunG ty1 ty2)       =
  TyFunG (sub s ty1) (sub s ty2)
sub s (TyIFixG ty1 k ty2)    =
  TyIFixG (sub s ty1) k (sub s ty2)
sub s (TyForallG k ty)       = TyForallG k (sub (exts s) ty)
sub _ (TyBuiltinG tyBuiltin) = TyBuiltinG tyBuiltin
sub s (TyLamG ty)            = TyLamG (sub (exts s) ty)
sub s (TyAppG ty1 ty2 k)     =
  TyAppG (sub s ty1) (sub s ty2) k

{-# COMPILE AGDA2HS sub #-}

{-# FOREIGN AGDA2HS
instance Monad TypeG where
  a >>= f = sub f a
--  return = pure

instance Applicative TypeG where
  (<*>) = ap
  pure = TyVarG
#-}

-- sub ((=<<) for TypeG) satisfies the monad laws

exts-cong : {σ σ' : m → TypeG n} → (∀ x → σ x ≡ σ' x)
          → ∀ x → exts σ x ≡ exts σ' x
exts-cong p FZ     = refl
exts-cong p (FS x) = cong (ren FS) (p x)

sub-cong : {σ σ' : m → TypeG n} → (∀ x → σ x ≡ σ' x)
         → ∀ ty → sub σ ty ≡ sub σ' ty
sub-cong p (TyVarG x)          = p x
sub-cong p (TyFunG ty1 ty2)    = cong₂ TyFunG (sub-cong p ty1) (sub-cong p ty2)
sub-cong p (TyIFixG ty1 k ty2) =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (sub-cong p ty1) (sub-cong p ty2)
sub-cong p (TyForallG k ty)    = cong (TyForallG k) (sub-cong (exts-cong p) ty)
sub-cong p (TyBuiltinG b)      = refl
sub-cong p (TyLamG ty)         = cong TyLamG (sub-cong (exts-cong p) ty)
sub-cong p (TyAppG ty1 ty2 k)  =
  cong₂ (λ ty1 ty2 → TyAppG ty1 ty2 k) (sub-cong p ty1) (sub-cong p ty2)

exts-id : (x : S m) → exts TyVarG x ≡ TyVarG x
exts-id FZ     = refl
exts-id (FS x) = refl

sub-id : (t : TypeG m) → sub TyVarG t ≡ t
sub-id (TyVarG x)          = refl
sub-id (TyFunG ty1 ty2)    = cong₂ TyFunG (sub-id ty1) (sub-id ty2)
sub-id (TyIFixG ty1 k ty2) =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (sub-id ty1) (sub-id ty2)
sub-id (TyForallG k ty)    = cong
  (TyForallG k)
  (trans (sub-cong exts-id ty) (sub-id ty))
sub-id (TyBuiltinG b)      = refl
sub-id (TyLamG ty)         = cong
  TyLamG
  (trans (sub-cong exts-id ty) (sub-id ty))
sub-id (TyAppG ty1 ty2 k)  = cong₂
  (λ ty1 ty2 → TyAppG ty1 ty2 k)
  (sub-id ty1)
  (sub-id ty2)

exts-ext : (x : S m)(ρ : m → n)(σ : n → TypeG o)
         → exts (σ ∘ ρ) x ≡ exts σ (ext ρ x)
exts-ext FZ     σ ρ = refl
exts-ext (FS x) σ ρ = refl

sub-ren : (t : TypeG m)(ρ : m → n)(σ : n → TypeG o)
         → sub (σ ∘ ρ) t ≡ sub σ (ren ρ t)
sub-ren (TyVarG x)          ρ σ = refl
sub-ren (TyFunG ty1 ty2)    ρ σ =
  cong₂ TyFunG (sub-ren ty1 ρ σ) (sub-ren ty2 ρ σ)
sub-ren (TyIFixG ty1 k ty2) ρ σ =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (sub-ren ty1 ρ σ) (sub-ren ty2 ρ σ)

sub-ren (TyForallG k ty)    ρ σ = cong
  (TyForallG k)
  (trans (sub-cong (λ x → exts-ext x ρ σ) ty)
         (sub-ren ty (ext ρ) (exts σ)))
sub-ren (TyBuiltinG b)      ρ σ = refl
sub-ren (TyLamG ty)         ρ σ = cong
  TyLamG
  (trans (sub-cong (λ x → exts-ext x ρ σ) ty)
         (sub-ren ty (ext ρ) (exts σ)))
sub-ren (TyAppG ty1 ty2 k)  ρ σ =
  cong₂ (λ ty1 ty2 → TyAppG ty1 ty2 k) (sub-ren ty1 ρ σ) (sub-ren ty2 ρ σ)

ext-exts : (x : S m)(σ : m → TypeG n)(ρ : n → o)
         → exts (ren ρ ∘ σ) x ≡ ren (ext ρ) (exts σ x)
ext-exts FZ     σ ρ = refl
ext-exts (FS x) σ ρ = trans
  (sym (ren-comp (σ x) ρ FS))
  (ren-comp (σ x) FS (ext ρ))

ren-sub : (t : TypeG m)(σ : m → TypeG n)(ρ : n → o)
         → sub (ren ρ ∘ σ) t ≡ ren ρ (sub σ t)
ren-sub (TyVarG x)          σ ρ = refl
ren-sub (TyFunG ty1 ty2)    σ ρ =
  cong₂ TyFunG (ren-sub ty1 σ ρ) (ren-sub ty2 σ ρ)
ren-sub (TyIFixG ty1 k ty2) σ ρ =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (ren-sub ty1 σ ρ) (ren-sub ty2 σ ρ)
ren-sub (TyForallG k ty)    σ ρ = cong
  (TyForallG k)
  (trans (sub-cong (λ x → ext-exts x σ ρ) ty)
         (ren-sub ty (exts σ) (ext ρ)))
ren-sub (TyBuiltinG b)      σ ρ = refl
ren-sub (TyLamG ty)         σ ρ = cong
  TyLamG
  (trans (sub-cong (λ x → ext-exts x σ ρ) ty)
         (ren-sub ty (exts σ) (ext ρ)))
ren-sub (TyAppG ty1 ty2 k)  σ ρ =
  cong₂ (λ ty1 ty2 → TyAppG ty1 ty2 k) (ren-sub ty1 σ ρ) (ren-sub ty2 σ ρ)

exts-comp : (x : S m)(σ : m → TypeG n)(σ' : n → TypeG o)
         → exts (sub σ' ∘ σ) x ≡ sub (exts σ') (exts σ x)
exts-comp FZ     σ σ' = refl
exts-comp (FS x) σ σ' = trans
  (sym (ren-sub (σ x) σ' FS))
  (sub-ren (σ x) FS (exts σ'))

sub-comp : (ty : TypeG m)(σ : m → TypeG n)(σ' : n → TypeG o)
         → sub (sub σ' ∘ σ) ty ≡ sub σ' (sub σ ty)
sub-comp (TyVarG x)          σ σ' = refl
sub-comp (TyFunG ty1 ty2)    σ σ' =
  cong₂ TyFunG (sub-comp ty1 σ σ') (sub-comp ty2 σ σ')
sub-comp (TyIFixG ty1 k ty2) σ σ' =
  cong₂ (λ ty1 ty2 → TyIFixG ty1 k ty2) (sub-comp ty1 σ σ') (sub-comp ty2 σ σ')
sub-comp (TyForallG k ty)    σ σ' = cong
  (TyForallG k)
  (trans (sub-cong (λ x → exts-comp x σ σ') ty)
         (sub-comp ty (exts σ) (exts σ')))
sub-comp (TyBuiltinG b)      σ σ' = refl
sub-comp (TyLamG ty)         σ σ' = cong
  TyLamG
  (trans (sub-cong (λ x → exts-comp x σ σ') ty)
         (sub-comp ty (exts σ) (exts σ')))
sub-comp (TyAppG ty1 ty2 k)  σ σ' =
  cong₂ (λ ty1 ty2 → TyAppG ty1 ty2 k) (sub-comp ty1 σ σ') (sub-comp ty2 σ σ')


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.Emptyrec {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
import Definition.Typed.Weakening as T
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
import Definition.LogicalRelation.Substitution.Irrelevance as S
open import Definition.LogicalRelation.Substitution.Reflexivity
open import Definition.LogicalRelation.Substitution.Weakening
open import Definition.LogicalRelation.Substitution.Introductions.Empty
open import Definition.LogicalRelation.Substitution.Introductions.Pi
open import Definition.LogicalRelation.Substitution.Introductions.SingleSubst

open import Tools.Product
open import Tools.Unit
open import Tools.Empty
open import Tools.Nat

import Tools.PropositionalEquality as PE

-- Empty elimination closure reduction (requires reducible terms and equality).
Emptyrec-subst* : ∀ {Γ C n n′ l}
              → Γ ⊢ C
              → Γ ⊢ n ⇒* n′ ∷ Empty
              → ([Empty] : Γ ⊩⟨ l ⟩ Empty)
              → Γ ⊩⟨ l ⟩ n′ ∷ Empty / [Empty]
              → Γ ⊢ Emptyrec C n ⇒* Emptyrec C n′ ∷ C
Emptyrec-subst* C (id x) [Empty] [n′] = id (Emptyrecⱼ C x)
Emptyrec-subst* C (x ⇨ n⇒n′) [Empty] [n′] =
  let q , w = redSubst*Term n⇒n′ [Empty] [n′]
      a , s = redSubstTerm x [Empty] q
  in  Emptyrec-subst C x ⇨ conv* (Emptyrec-subst* C n⇒n′ [Empty] [n′]) (refl C)

-- Reducibility of empty elimination under a valid substitution.
EmptyrecTerm : ∀ {F n Γ Δ σ l}
             ([Γ]  : ⊩ᵛ Γ)
             ([F]  : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
             (⊢Δ   : ⊢ Δ)
             ([σ]  : Δ ⊩ˢ σ ∷ Γ / [Γ] / ⊢Δ)
             ([σn] : Δ ⊩⟨ l ⟩ n ∷ Empty / Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ)))
           → Δ ⊩⟨ l ⟩ Emptyrec (subst σ F) n
               ∷ subst σ F
               / proj₁ ([F] ⊢Δ [σ])
EmptyrecTerm {F} {n} {Γ} {Δ} {σ} {l} [Γ] [F] ⊢Δ [σ]
           (Emptyₜ m d n≡n (ne (neNfₜ neM ⊢m m≡m))) =
  let [Empty] = Emptyᵛ {l = l} [Γ]
      [σEmpty] = proj₁ ([Empty] ⊢Δ [σ])
      [σm] = neuTerm [σEmpty] neM ⊢m m≡m
      [σF] = proj₁ ([F] ⊢Δ [σ])
      ⊢F = escape [σF]
      ⊢F≡F = escapeEq [σF] (reflEq [σF])
      EmptyrecM = neuTerm [σF] (Emptyrecₙ neM) (Emptyrecⱼ ⊢F ⊢m)
                        (~-Emptyrec ⊢F≡F m≡m)
      reduction = Emptyrec-subst* ⊢F (redₜ d) [σEmpty] [σm]
  in proj₁ (redSubst*Term reduction [σF] EmptyrecM)

-- Reducibility of empty elimination congruence under a valid substitution equality.
Emptyrec-congTerm : ∀ {F F′ n m Γ Δ σ σ′ l}
                  ([Γ]      : ⊩ᵛ Γ)
                  ([F]      : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
                  ([F′]     : Γ ⊩ᵛ⟨ l ⟩ F′ / [Γ])
                  ([F≡F′]   : Γ ⊩ᵛ⟨ l ⟩ F ≡ F′ / [Γ] / [F])
                  (⊢Δ       : ⊢ Δ)
                  ([σ]      : Δ ⊩ˢ σ  ∷ Γ / [Γ] / ⊢Δ)
                  ([σ′]     : Δ ⊩ˢ σ′ ∷ Γ / [Γ] / ⊢Δ)
                  ([σ≡σ′]   : Δ ⊩ˢ σ ≡ σ′ ∷ Γ / [Γ] / ⊢Δ / [σ])
                  ([σn]     : Δ ⊩⟨ l ⟩ n ∷ Empty / Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ)))
                  ([σm]     : Δ ⊩⟨ l ⟩ m ∷ Empty / Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ)))
                  ([σn≡σm]  : Δ ⊩⟨ l ⟩ n ≡ m ∷ Empty / Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ)))
                → Δ ⊩⟨ l ⟩ Emptyrec (subst σ F) n
                    ≡ Emptyrec (subst σ′ F′) m
                    ∷ subst σ F
                    / proj₁ ([F] ⊢Δ [σ])
Emptyrec-congTerm {F} {F′} {n} {m} {Γ} {Δ} {σ} {σ′} {l}
                [Γ] [F] [F′] [F≡F′]
                ⊢Δ [σ] [σ′] [σ≡σ′]
                (Emptyₜ n′ d n≡n (ne (neNfₜ neN′ ⊢n′ n≡n₁)))
                (Emptyₜ m′ d′ m≡m (ne (neNfₜ neM′ ⊢m′ m≡m₁)))
                (Emptyₜ₌ n″ m″ d₁ d₁′ t≡u (ne (neNfₜ₌ x₂ x₃ prop₂))) =
  let n″≡n′ = whrDet*Term (redₜ d₁ , ne x₂) (redₜ d , ne neN′)
      m″≡m′ = whrDet*Term (redₜ d₁′ , ne x₃) (redₜ d′ , ne neM′)
      [Empty] = Emptyᵛ {l = l} [Γ]
      [σEmpty] = proj₁ ([Empty] ⊢Δ [σ])
      [σ′Empty] = proj₁ ([Empty] ⊢Δ [σ′])
      [σF] = proj₁ ([F] ⊢Δ [σ])
      [σ′F] = proj₁ ([F] ⊢Δ [σ′])
      [σ′F′] = proj₁ ([F′] ⊢Δ [σ′])
      [σn′] = neuTerm [σEmpty] neN′ ⊢n′ n≡n₁
      [σ′m′] = neuTerm [σ′Empty] neM′ ⊢m′ m≡m₁
      ⊢F = escape [σF]
      ⊢F≡F = escapeEq [σF] (reflEq [σF])
      ⊢F′ = escape [σ′F′]
      ⊢F′≡F′ = escapeEq [σ′F′] (reflEq [σ′F′])
      ⊢σF≡σ′F = escapeEq [σF] (proj₂ ([F] ⊢Δ [σ]) [σ′] [σ≡σ′])
      ⊢σ′F≡σ′F′ = escapeEq [σ′F] ([F≡F′] ⊢Δ [σ′])
      ⊢F≡F′ = ≅-trans ⊢σF≡σ′F ⊢σ′F≡σ′F′
      [σF≡σ′F] = proj₂ ([F] ⊢Δ [σ]) [σ′] [σ≡σ′]
      [σ′F≡σ′F′] = [F≡F′] ⊢Δ [σ′]
      [σF≡σ′F′] = transEq [σF] [σ′F] [σ′F′] [σF≡σ′F] [σ′F≡σ′F′]
      EmptyrecN = neuTerm [σF] (Emptyrecₙ neN′) (Emptyrecⱼ ⊢F ⊢n′)
                        (~-Emptyrec ⊢F≡F n≡n₁)
      EmptyrecM = neuTerm [σ′F′] (Emptyrecₙ neM′) (Emptyrecⱼ ⊢F′ ⊢m′)
                        (~-Emptyrec ⊢F′≡F′ m≡m₁)
      EmptyrecN≡M =
          (neuEqTerm [σF] (Emptyrecₙ neN′) (Emptyrecₙ neM′)
                     (Emptyrecⱼ ⊢F ⊢n′)
                     (conv (Emptyrecⱼ ⊢F′ ⊢m′)
                            (sym (≅-eq (escapeEq [σF]
                              (transEq [σF] [σ′F] [σ′F′] [σF≡σ′F] [σ′F≡σ′F′])))))
                     (~-Emptyrec ⊢F≡F′
                               (PE.subst₂ (λ x y → _ ⊢ x ~ y ∷ _)
                                          n″≡n′ m″≡m′ prop₂)))
      reduction₁ = Emptyrec-subst* ⊢F (redₜ d) [σEmpty] [σn′]
      reduction₂ = Emptyrec-subst* ⊢F′ (redₜ d′) [σ′Empty] [σ′m′]
      eq₁ = proj₂ (redSubst*Term reduction₁ [σF] EmptyrecN)
      eq₂ = proj₂ (redSubst*Term reduction₂ [σ′F′] EmptyrecM)
  in transEqTerm [σF] eq₁
                 (transEqTerm [σF] EmptyrecN≡M
                              (convEqTerm₂ [σF] [σ′F′] [σF≡σ′F′]
                                           (symEqTerm [σ′F′] eq₂)))

-- Validity of empty elimination.
Emptyrecᵛ : ∀ {F n Γ l} ([Γ] : ⊩ᵛ Γ)
          ([Empty]  : Γ ⊩ᵛ⟨ l ⟩ Empty / [Γ])
          ([F]  : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
        → ([n] : Γ ⊩ᵛ⟨ l ⟩ n ∷ Empty / [Γ] / [Empty])
        → Γ ⊩ᵛ⟨ l ⟩ Emptyrec F n ∷ F / [Γ] / [F]
Emptyrecᵛ {F} {n} {l = l} [Γ] [Empty] [F] [n]
        {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let [σn] = irrelevanceTerm {l′ = l} (proj₁ ([Empty] ⊢Δ [σ]))
                             (Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ))) (proj₁ ([n] ⊢Δ [σ]))
  in EmptyrecTerm {F = F} [Γ] [F] ⊢Δ [σ] [σn]
    , λ {σ'} [σ′] [σ≡σ′] →
      let [σ′n] = irrelevanceTerm {l′ = l} (proj₁ ([Empty] ⊢Δ [σ′]))
                                  (Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ))) (proj₁ ([n] ⊢Δ [σ′]))
          [σn≡σ′n] = irrelevanceEqTerm {l′ = l} (proj₁ ([Empty] ⊢Δ [σ]))
                                       (Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ)))
                                       (proj₂ ([n] ⊢Δ [σ]) [σ′] [σ≡σ′])
          congTerm = Emptyrec-congTerm {F = F} {F′ = F} [Γ] [F] [F] (reflᵛ {F} {l = l} [Γ] [F])
                                       ⊢Δ [σ] [σ′] [σ≡σ′] [σn] [σ′n] [σn≡σ′n]
      in congTerm

-- Validity of empty elimination congruence.
Emptyrec-congᵛ : ∀ {F F′ n n′ Γ l} ([Γ] : ⊩ᵛ Γ)
          ([Empty]  : Γ ⊩ᵛ⟨ l ⟩ Empty / [Γ])
          ([F]  : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
          ([F′]  : Γ ⊩ᵛ⟨ l ⟩ F′ / [Γ])
          ([F≡F′]  : Γ ⊩ᵛ⟨ l ⟩ F ≡ F′ / [Γ] / [F])
          ([n] : Γ ⊩ᵛ⟨ l ⟩ n ∷ Empty / [Γ] / [Empty])
          ([n′] : Γ ⊩ᵛ⟨ l ⟩ n′ ∷ Empty / [Γ] / [Empty])
          ([n≡n′] : Γ ⊩ᵛ⟨ l ⟩ n ≡ n′ ∷ Empty / [Γ] / [Empty])
        → Γ ⊩ᵛ⟨ l ⟩ Emptyrec F n ≡ Emptyrec F′ n′ ∷ F / [Γ] / [F]
Emptyrec-congᵛ {F} {F′} {n} {n′} {l = l}
             [Γ] [Empty] [F] [F′] [F≡F′]
             [n] [n′] [n≡n′] {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let [σn] = irrelevanceTerm {l′ = l} (proj₁ ([Empty] ⊢Δ [σ]))
                             (Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ))) (proj₁ ([n] ⊢Δ [σ]))
      [σn′] = irrelevanceTerm {l′ = l} (proj₁ ([Empty] ⊢Δ [σ]))
                             (Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ))) (proj₁ ([n′] ⊢Δ [σ]))
      [σn≡σn′] = irrelevanceEqTerm {l′ = l} (proj₁ ([Empty] ⊢Δ [σ]))
                                   (Emptyᵣ (idRed:*: (Emptyⱼ ⊢Δ))) ([n≡n′] ⊢Δ [σ])
      congTerm = Emptyrec-congTerm {F} {F′} [Γ] [F] [F′] [F≡F′]
                                   ⊢Δ [σ] [σ] (reflSubst [Γ] ⊢Δ [σ]) [σn] [σn′] [σn≡σn′]
  in congTerm


{-# OPTIONS --show-implicit --show-irrelevant #-}
-- {-# OPTIONS -v tc.conv.irr:20 -v tc.constr.findInScope:20 -v tc.meta:20 -v tc.conv.type:50 -v tc.conv.term:30 -v tc.conv.atom:50 -v tc.inj.use:20 #-}
module Issue631 where

import Common.Level  -- for debug messages

data Bool : Set where
  false true : Bool

F : Bool → Set
F true  = Bool
F false = Bool

postulate
  BAD   : ∀ {u} → F u
  Goal  : Set
  score  : .Goal → Set

buggy : Set
buggy = score _ -- {!!}
-- should remain unsolved


module hello-agda where

open import IO using (run; putStrLn)
import Agda.Builtin.IO as Builtin using (IO)
open import Data.Unit.Polymorphic.Base using (⊤)
open import Agda.Primitive using (lzero)

main : Builtin.IO {lzero} ⊤
main = run (putStrLn "Hello, Agda!")


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

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

open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
open import LibraBFT.Prelude
import      LibraBFT.Yasm.Base   as LYB
import      LibraBFT.Yasm.System as LYS

-- This module provides a single import for all Yasm modules

module LibraBFT.Yasm.Yasm
   (ℓ-PeerState : Level)
   (ℓ-VSFP      : Level)
   (parms       : LYB.SystemTypeParameters ℓ-PeerState)
   (iiah  : LYB.SystemInitAndHandlers ℓ-PeerState parms)
   (ValidSenderForPK        : LYS.WithInitAndHandlers.ValidSenderForPK-type        ℓ-PeerState ℓ-VSFP parms iiah)
   (ValidSenderForPK-stable : LYS.WithInitAndHandlers.ValidSenderForPK-stable-type ℓ-PeerState ℓ-VSFP parms iiah ValidSenderForPK)
  where
 open LYB.SystemTypeParameters  parms
 open LYB.SystemInitAndHandlers iiah
 open import LibraBFT.Yasm.Base                                                                              public
 open import LibraBFT.Yasm.Types                                                                             public
 open import LibraBFT.Yasm.System     ℓ-PeerState ℓ-VSFP parms                                               public
 open import LibraBFT.Yasm.Properties ℓ-PeerState ℓ-VSFP parms iiah ValidSenderForPK ValidSenderForPK-stable public
 open        WithInitAndHandlers iiah                                                                        public
 open import Util.FunctionOverride    PeerId _≟PeerId_                                                       public


module rewriting where

open import lib

open import cedille-types
open import conversion
open import ctxt
open import general-util
open import is-free
open import lift
open import rename
open import subst
open import syntax-util

private

  mk-phi : var → (eq t t' : term) → term
  mk-phi x eq t t' =
    Phi posinfo-gen
      (Rho posinfo-gen RhoPlain NoNums eq
        (Guide posinfo-gen x (TpEq posinfo-gen t t' posinfo-gen))
        (Beta posinfo-gen (SomeTerm t posinfo-gen) (SomeTerm id-term posinfo-gen)))
      t t' posinfo-gen

  head-types-match : ctxt → trie term → (complete partial : type) → 𝔹
  head-types-match Γ σ (TpApp T _) (TpApp T' _) = conv-type Γ T (substs Γ σ T')
  head-types-match Γ σ (TpAppt T _) (TpAppt T' _) = conv-type Γ T (substs Γ σ T')
  head-types-match Γ σ T T' = tt

rewrite-t : Set → Set
rewrite-t T = ctxt → (is-plus : 𝔹) → (nums : maybe stringset) →
              (eq left : term) → (right : var) → (total-matches : ℕ) →
              T {- Returned value -} ×
              ℕ {- Number of rewrites actually performed -} ×
              ℕ {- Total number of matches, including skipped ones -}

infixl 4 _≫rewrite_

_≫rewrite_ : ∀ {A B : Set} → rewrite-t (A → B) → rewrite-t A → rewrite-t B
(f ≫rewrite a) Γ op on eq t₁ t₂ n with f Γ op on eq t₁ t₂ n
...| f' , n' , sn with a Γ op on eq t₁ t₂ sn
...| b , n'' , sn' = f' b , n' + n'' , sn'

rewriteR : ∀ {A : Set} → A → rewrite-t A
rewriteR a Γ op on eq t₁ t₂ n = a , 0 , n

{-# TERMINATING #-}
rewrite-term        : term        → rewrite-t term
rewrite-terma       : term        → rewrite-t term
rewrite-termh       : term        → rewrite-t term
rewrite-type        : type        → rewrite-t type
rewrite-typeh       : type        → rewrite-t type
rewrite-kind        : kind        → rewrite-t kind
rewrite-tk          : tk          → rewrite-t tk
rewrite-liftingType : liftingType → rewrite-t liftingType

rewrite-rename-var : ∀ {A} → var → (var → rewrite-t A) → rewrite-t A
rewrite-rename-var x r Γ op on eq t₁ t₂ n =
  let x' = rename-var-if Γ (renamectxt-insert empty-renamectxt t₂ t₂) x t₁ in
  r x' Γ op on eq t₁ t₂ n

rewrite-abs : ∀ {ed} → var → var → (⟦ ed ⟧ → rewrite-t ⟦ ed ⟧) → ⟦ ed ⟧ → rewrite-t ⟦ ed ⟧
rewrite-abs x x' g a Γ = let Γ = ctxt-var-decl x' Γ in g (rename-var Γ x x' a) Γ

rewrite-term t Γ op on eq t₁ t₂ sn =
  case rewrite-terma (erase-term t) Γ op on eq t₁ t₂ sn of λ where
    (t' , 0 , sn') → t , 0 , sn'
    (t' , n , sn') → mk-phi t₂ eq t t' , n , sn'

rewrite-terma t Γ op on eq t₁ t₂ sn =
  case conv-term Γ t₁ t of λ where
  tt → case on of λ where
    (just ns) → case trie-contains ns (ℕ-to-string (suc sn)) of λ where
      tt → Var posinfo-gen t₂ , 1 , suc sn -- ρ nums contains n
      ff → t , 0 , suc sn -- ρ nums does not contain n
    nothing → Var posinfo-gen t₂ , 1 , suc sn
  ff → case op of λ where
    tt → case rewrite-termh (hnf Γ unfold-head t tt) Γ op on eq t₁ t₂ sn of λ where
      (t' , 0 , sn') → t , 0 , sn' -- if no rewrites were performed, return the pre-hnf t
      (t' , n' , sn') → t' , n' , sn'
    ff → rewrite-termh t Γ op on eq t₁ t₂ sn

rewrite-termh (App t e t') =
  rewriteR App ≫rewrite rewrite-terma t ≫rewrite rewriteR e ≫rewrite rewrite-terma t'
rewrite-termh (Lam pi NotErased pi' y NoClass t) =
  rewrite-rename-var y λ y' → rewriteR (Lam pi NotErased pi' y' NoClass) ≫rewrite
  rewrite-abs y y' rewrite-terma t
rewrite-termh (Var pi x) = rewriteR (Var pi x)
rewrite-termh = rewriteR

rewrite-type T Γ tt on eq t₁ t₂ sn
  with rewrite-typeh (hnf Γ unfold-head-no-lift T tt) Γ tt on eq t₁ t₂ sn
...| T' , 0 , sn' = T  , 0 , sn'
...| T' , n , sn' = T' , n , sn'
rewrite-type = rewrite-typeh

rewrite-typeh (Abs pi b pi' x atk T) =
  rewrite-rename-var x λ x' →
  rewriteR (Abs pi b pi' x') ≫rewrite rewrite-tk atk ≫rewrite
  rewrite-abs x x' rewrite-type T
rewrite-typeh (Iota pi pi' x T T') =
  rewrite-rename-var x λ x' →
  rewriteR (Iota pi pi' x') ≫rewrite rewrite-type T ≫rewrite
  rewrite-abs x x' rewrite-type T'
rewrite-typeh (Lft pi pi' x t l) =
  rewrite-rename-var x λ x' →
  rewriteR (Lft pi pi' x') ≫rewrite
  rewrite-abs x x' rewrite-term t ≫rewrite
  rewrite-liftingType l
rewrite-typeh (TpApp T T') =
  rewriteR TpApp ≫rewrite rewrite-typeh T ≫rewrite rewrite-type T'
rewrite-typeh (TpAppt T t) =
  rewriteR TpAppt ≫rewrite rewrite-typeh T ≫rewrite rewrite-term t
rewrite-typeh (TpEq pi t₁ t₂ pi') =
  rewriteR (TpEq pi) ≫rewrite rewrite-term t₁ ≫rewrite
  rewrite-term t₂ ≫rewrite rewriteR pi'
rewrite-typeh (TpLambda pi pi' x atk T) =
  rewrite-rename-var x λ x' →
  rewriteR (TpLambda pi pi' x') ≫rewrite rewrite-tk atk ≫rewrite
  rewrite-abs x x' rewrite-type T
rewrite-typeh (TpArrow T a T') =
  rewriteR TpArrow ≫rewrite rewrite-type T ≫rewrite rewriteR a ≫rewrite rewrite-type T'
rewrite-typeh (TpLet pi (DefTerm pi' x T t) T') Γ =
  rewrite-type (subst Γ (Chi posinfo-gen T t) x T') Γ
rewrite-typeh (TpLet pi (DefType pi' x k T) T') Γ =
  rewrite-type (subst Γ T x T') Γ
rewrite-typeh (TpParens _ T _) = rewrite-type T
rewrite-typeh (NoSpans T _) = rewrite-type T
rewrite-typeh (TpHole pi) = rewriteR (TpHole pi)
rewrite-typeh (TpVar pi x) = rewriteR (TpVar pi x)

-- If we ever implement kind-level rewriting, we will need to go through
-- all the types of kind pi binding a term or type-to-kind arrow
-- if the right-hand side variable is free in the types of the bound variable,
-- and substitute each occurence of the term variable (eta-expanding if necessary)
-- in the body of the type with itself surrounded by a rewrite back the original
-- expected type (unless we lifted a term, then it gets really tricky because
-- we may not want to rewrite back?).
rewrite-kind = rewriteR
rewrite-liftingType = rewriteR

rewrite-tk (Tkt T) = rewriteR Tkt ≫rewrite rewrite-type T
rewrite-tk (Tkk k) = rewriteR Tkk ≫rewrite rewrite-kind k

post-rewriteh : ctxt → var → term → (ctxt → var → term → tk → tk) → (var → tk → ctxt → ctxt) → type → type × kind

post-rewriteh Γ x eq prtk tk-decl (Abs pi b pi' x' atk T) =
  let atk' = prtk Γ x eq atk in
  Abs pi b pi' x' atk' (fst (post-rewriteh (tk-decl x' atk' Γ) x eq prtk tk-decl T)) , star
post-rewriteh Γ x eq prtk tk-decl (Iota pi pi' x' T T') =
  let T = fst (post-rewriteh Γ x eq prtk tk-decl T) in
  Iota pi pi' x' T (fst (post-rewriteh (tk-decl x' (Tkt T) Γ) x eq prtk tk-decl T')) , star
post-rewriteh Γ x eq prtk tk-decl (Lft pi pi' x' t lT) =
  Lft pi pi' x' t lT , liftingType-to-kind lT
post-rewriteh Γ x eq prtk tk-decl (TpApp T T') =
  flip uncurry (post-rewriteh Γ x eq prtk tk-decl T') λ T' k' →
  flip uncurry (post-rewriteh Γ x eq prtk tk-decl T) λ where
    T (KndPi pi pi' x' atk k) → TpApp T T' , hnf Γ unfold-head-no-lift (subst Γ T' x' k) tt
    T (KndArrow k k'') → TpApp T T' , hnf Γ unfold-head-no-lift k'' tt
    T k → TpApp T T' , k
post-rewriteh Γ x eq prtk tk-decl (TpAppt T t) =
  let t2 T' = if is-free-in check-erased x T' then Rho posinfo-gen RhoPlain NoNums eq (Guide posinfo-gen x T') t else t in
  flip uncurry (post-rewriteh Γ x eq prtk tk-decl T) λ where
    T (KndPi pi pi' x' (Tkt T') k) →
      let t3 = t2 T' in TpAppt T t3 , hnf Γ unfold-head-no-lift (subst Γ t3 x' k) tt
    T (KndTpArrow T' k) → TpAppt T (t2 T') , hnf Γ unfold-head-no-lift k tt
    T k → TpAppt T t , k
post-rewriteh Γ x eq prtk tk-decl (TpArrow T a T') = TpArrow (fst (post-rewriteh Γ x eq prtk tk-decl T)) a (fst (post-rewriteh Γ x eq prtk tk-decl T')) , star
post-rewriteh Γ x eq prtk tk-decl (TpLambda pi pi' x' atk T) =
  let atk' = prtk Γ x eq atk in
  flip uncurry (post-rewriteh (tk-decl x' atk' Γ) x eq prtk tk-decl T) λ T k →
  TpLambda pi pi' x' atk' T , KndPi pi pi' x' atk' k
post-rewriteh Γ x eq prtk tk-decl (TpParens pi T pi') = post-rewriteh Γ x eq prtk tk-decl T
post-rewriteh Γ x eq prtk tk-decl (TpVar pi x') with env-lookup Γ x'
...| just (type-decl k , _) = mtpvar x' , hnf Γ unfold-head-no-lift k tt
...| just (type-def nothing _ T k , _) = mtpvar x' , hnf Γ unfold-head-no-lift k tt
...| just (type-def (just ps) _ T k , _) = mtpvar x' , abs-expand-kind ps (hnf Γ unfold-head-no-lift k tt)
...| _ = mtpvar x' , star
post-rewriteh Γ x eq prtk tk-decl T = T , star

{-# TERMINATING #-}
post-rewrite : ctxt → var → (eq t₂ : term) → type → type
post-rewrite Γ x eq t₂ T = subst Γ t₂ x (fst (post-rewriteh Γ x eq prtk tk-decl T)) where
  prtk : ctxt → var → term → tk → tk
  tk-decl : var → tk → ctxt → ctxt
  prtk Γ x t (Tkt T) = Tkt (fst (post-rewriteh Γ x t prtk tk-decl T))
  prtk Γ x t (Tkk k) = Tkk (hnf Γ unfold-head-no-lift k tt)
  tk-decl x atk (mk-ctxt mod ss is os d) =
    mk-ctxt mod ss (trie-insert is x (h atk , "" , "")) os d where
    h : tk → ctxt-info
    h (Tkt T) = term-decl T
    h (Tkk k) = type-decl k

-- Functions for substituting the type T in ρ e @ x . T - t
{-# TERMINATING #-}
rewrite-at : ctxt → var → term → 𝔹 → type → type → type
rewrite-ath : ctxt → var → term → 𝔹 → type → type → type
rewrite-at-tk : ctxt → var → term → 𝔹 → tk → tk → tk

rewrite-at-tk Γ x eq b (Tkt T) (Tkt T') = Tkt (rewrite-at Γ x eq b T T')
rewrite-at-tk Γ x eq b atk atk' = atk

rewrite-at Γ x eq b T T' =
  if ~ is-free-in tt x T'
    then T
    else if b && ~ head-types-match Γ (trie-single x (Hole posinfo-gen)) T T'
      then rewrite-ath Γ x eq ff (hnf Γ unfold-head-no-lift T tt) (hnf Γ unfold-head-no-lift T' tt)
      else rewrite-ath Γ x eq b T T'

rewrite-ath Γ x eq b (Abs pi1 b1 pi1' x1 atk1 T1) (Abs pi2 b2 pi2' x2 atk2 T2) =
  Abs pi1 b1 pi1' x1 (rewrite-at-tk Γ x eq tt atk1 atk2) (rewrite-at (ctxt-var-decl x1 Γ) x eq b T1 (rename-var Γ x2 x1 T2))
rewrite-ath Γ x eq b (Iota pi1 pi1' x1 T1 T1') (Iota pi2 pi2' x2 T2 T2') =
  Iota pi1 pi1' x1 (rewrite-at Γ x eq tt T1 T2) (rewrite-at (ctxt-var-decl x1 Γ) x eq b T1' (rename-var Γ x2 x1 T2'))
rewrite-ath Γ x eq b (Lft pi1 pi1' x1 t1 lT1) (Lft pi2 pi2' x2 t2 lT2) =
  Lft pi1 pi1' x1 (if is-free-in tt x (mlam x2 t2) then mk-phi x eq t1 t2 else t1) lT1
rewrite-ath Γ x eq b (TpApp T1 T1') (TpApp T2 T2') =
  TpApp (rewrite-at Γ x eq b T1 T2) (rewrite-at Γ x eq b T1' T2')
rewrite-ath Γ x eq b (TpAppt T1 t1) (TpAppt T2 t2) =
  TpAppt (rewrite-at Γ x eq b T1 T2) (if is-free-in tt x t2 then mk-phi x eq t1 t2 else t1)
rewrite-ath Γ x eq b (TpArrow T1 a1 T1') (TpArrow T2 a2 T2') =
  TpArrow (rewrite-at Γ x eq tt T1 T2) a1 (rewrite-at Γ x eq tt T1' T2')
rewrite-ath Γ x eq b (TpEq pi1 t1 t1' pi1') (TpEq pi2 t2 t2' pi2') =
  TpEq pi1 t2 t2' pi1'
rewrite-ath Γ x eq b (TpLambda pi1 pi1' x1 atk1 T1) (TpLambda pi2 pi2' x2 atk2 T2) =
  TpLambda pi1 pi1' x1 (rewrite-at-tk Γ x eq tt atk1 atk2) (rewrite-at (ctxt-var-decl x1 Γ) x eq b T1 (rename-var Γ x2 x1 T2))
rewrite-ath Γ x eq b (TpLet pi1 (DefTerm pi1' x1 oc1 t1) T1) T2 = rewrite-at Γ x eq b (subst Γ t1 x1 T1) T2
rewrite-ath Γ x eq b T1 (TpLet pi2 (DefTerm pi2' x2 oc2 t2) T2) = rewrite-at Γ x eq b T1 (subst Γ t2 x2 T2)
rewrite-ath Γ x eq b (TpLet pi1 (DefType pi1' x1 k1 T1ₗ) T1) T2 = rewrite-at Γ x eq b (subst Γ T1ₗ x1 T1) T2
rewrite-ath Γ x eq b T1 (TpLet pi2 (DefType pi2' x2 k2 T2ₗ) T2) = rewrite-at Γ x eq b T1 (subst Γ T2ₗ x2 T2)
rewrite-ath Γ x eq b (TpVar pi1 x1) (TpVar pi2 x2) = TpVar pi1 x1
rewrite-ath Γ x eq b (TpHole pi1) (TpHole pi2) = TpHole pi1
rewrite-ath Γ x eq b (TpParens pi1 T1 pi1') T2 = rewrite-at Γ x eq b T1 T2
rewrite-ath Γ x eq b T1 (TpParens pi2 T2 pi2') = rewrite-at Γ x eq b T1 T2
rewrite-ath Γ x eq b (NoSpans T1 pi1) T2 = rewrite-at Γ x eq b T1 T2
rewrite-ath Γ x eq b T1 (NoSpans T2 pi2) = rewrite-at Γ x eq b T1 T2
rewrite-ath Γ x eq tt T1 T2 = rewrite-at Γ x eq ff (hnf Γ unfold-head-no-lift T1 tt) (hnf Γ unfold-head-no-lift T2 tt)
rewrite-ath Γ x eq ff T1 T2 = T1


--------------------------------------------------------------------------------
-- This file provides the generateCFG function that turns a list of strings of
-- the current syntax for grammars into a grammar as defined in Parser.agda
--------------------------------------------------------------------------------

{-# OPTIONS --type-in-type #-}

module Parse.Generate where

open import Class.Monad.Except
open import Data.Fin.Map
import Data.List.NonEmpty as NE
open NE using (List⁺; _∷_)
open import Data.String using (toList; fromChar; uncons) renaming (fromList to fromListS)
open import Data.Vec using (Vec; lookup; fromList; []; _∷_; _[_]%=_)
open import Data.Vec.Exts

open import Parse.LL1
open import Parse.MarkedString
open import Parse.MultiChar
open import Parse.Escape

open import Prelude
open import Prelude.Strings

-- Grammar with show functions for rules and non-terminals
Grammar = ∃[ n ]
  Σ[ G ∈ CFG (Fin (suc n)) MultiChar ] (CFG.Rule G → String) × (Fin (suc n) → String)

NonTerminal : Grammar → Set
NonTerminal (n , _) = Fin (suc n)

initNT : (G : Grammar) → NonTerminal G
initNT (_ , G , _) = CFG.S G

findNT : (G : Grammar) → String → Maybe (NonTerminal G)
findNT (n , _ , _ , showNT) NT = findIndex (NT ≟_) (Data.Vec.tabulate showNT)

checkRuleName : String → String × List MarkedString → Set
checkRuleName s r = s ≡ proj₁ r

checkRuleNameDec : ∀ s → Decidable (checkRuleName s)
checkRuleNameDec s (s' , _) = s ≟ s'

module _ {M} {{_ : Monad M}} {{_ : MonadExcept M String}} where

  -- Read until the closing marker
  bracketHelper : Marker → MarkedString → M (List⁺ String × MarkedString)
  bracketHelper m [] = throwError "Unexpected end of string! Expected a marker!"
  bracketHelper m (inj₁ x ∷ s) = do
    (head ∷ tail , rest) ← bracketHelper m s
    return (fromChar x + head ∷ tail , rest)
  bracketHelper m (inj₂ x ∷ s) =
    if x ≣ m
      then return (NE.[ "" ] , s)
      else
        if x ≣ WildcardSeparator
          then if (m ≣ WildcardBracket true) ∨ (m ≣ WildcardBracket false)
            then (do
              (res , rest) ← bracketHelper m s
              return ("" NE.∷⁺ res , rest))
            else throwError "Found a wildcard separator outside of a wildcard bracket!"
          else throwError "Found unexpected marker!"

  preParseCFG : List MarkedString → M (∃[ n ] Vec (String × List MarkedString) n)
  preParseCFG [] = return $ zero , []
  preParseCFG (x ∷ l) with break (_≟ inj₂ NameDivider) x
  ... | name , rule' = if null name
    then throwError $ "Parsing rule has no/empty name! Rule: " + markedStringToString x
    else do
      _ , rules ← preParseCFG l
      let rule = dropHeadIfAny rule'
      return $ case findIndex (checkRuleNameDec $ markedStringToString name) rules of λ
        { (just x) → -, rules [ x ]%= map₂ (rule ∷_)
        ; nothing → -, (markedStringToString name , [ rule ]) ∷ rules}

  {-# TERMINATING #-}
  generateCFG' : ∀ {n} → String → Vec (String × List MarkedString) (suc n) → M Grammar
  generateCFG' {n} start rules = do
    ruleTable ← parseRuleTable
    case findIndex (checkRuleNameDec start) rules of λ where
      (just i) →
        return $
          (-, record
            { S = i
            ; R = Fin ∘ numOfRules
            ; AllRules = allFin ∘ numOfRules
            ; Rstring'' = λ {v} → ruleTable v }
          , (λ where (NT , rule) → let (NT' , rules') = lookup rules NT
                                   in NT' + "$" + markedStringToString (lookup (fromList rules') rule))
          , proj₁ ∘ lookup rules)
      nothing → throwError $ "No non-terminal named " + start + " found!"
    where
      numOfRules : Fin (suc n) → ℕ
      numOfRules = length ∘ proj₂ ∘ lookup rules

      RuleTable : Set → Set
      RuleTable T = DepFinMap (suc n) (λ v → FinMap (numOfRules v) T)

      RuleString : Set
      RuleString = List ((Fin (suc n) × Bool) ⊎ MultiChar ⊎ String)

      sequenceRuleTable : ∀ {A} → RuleTable (M A) → M (RuleTable A)
      sequenceRuleTable f = sequenceDepFinMap (sequenceDepFinMap ∘ f)

      addCharToRuleString : Char → RuleString → RuleString
      addCharToRuleString c [] = [ inj₂ (inj₂ $ fromChar c) ]
      addCharToRuleString c s@(inj₁ _ ∷ _) = inj₂ (inj₂ $ fromChar c) ∷ s
      addCharToRuleString c s@(inj₂ (inj₁ _) ∷ _) = inj₂ (inj₂ $ fromChar c) ∷ s
      addCharToRuleString c (inj₂ (inj₂ y) ∷ s) = inj₂ (inj₂ (fromChar c + y)) ∷ s

      markedStringToRule : MarkedString → M RuleString
      markedStringToRule [] = return []
      markedStringToRule (inj₁ x ∷ s) = do
        res ← markedStringToRule s
        return (addCharToRuleString x res)
      -- this terminates because 'rest' is shorter than 's'
      markedStringToRule (inj₂ (NonTerminalBracket b) ∷ s) = do
        (nonTerm ∷ _ , rest) ← bracketHelper (NonTerminalBracket b) s
        res ← markedStringToRule rest
        nonTerm' ← maybeToError
          (findIndex (checkRuleNameDec nonTerm) rules)
          ("Couldn't find a non-terminal named '" + nonTerm + "'")
        return (inj₁ (nonTerm' , b) ∷ res)
      markedStringToRule (inj₂ NameDivider ∷ s) =
        throwError "The rule cannot contain a name divider!"
      markedStringToRule (inj₂ (WildcardBracket b) ∷ s) = do
        (multiChar , rest) ← bracketHelper (WildcardBracket b) s
        inj₂ (inj₁ $ parseMultiCharNE b multiChar) ∷_ <$> markedStringToRule rest
      markedStringToRule (inj₂ WildcardSeparator ∷ s) =
        throwError "Wildcard separator outside of a wildcard!"

      parseRuleTable : M (RuleTable RuleString)
      parseRuleTable = sequenceRuleTable
        λ v x → let y = lookup (fromList $ proj₂ (lookup rules v)) x in
          appendIfError (markedStringToRule y) (" In: " + show y)

  -- The first parameter describes the non-terminal the grammar should start with
  generateCFGNonEscaped : String → List String → M Grammar
  generateCFGNonEscaped start l = do
    (suc k , y) ← preParseCFG $ map convertToMarked l
      where _ → throwError "The grammar is empty!"
    generateCFG' start y

  -- The first parameter describes the non-terminal the grammar should start with
  generateCFG : String → List String → M Grammar
  generateCFG start l =
    maybe (generateCFGNonEscaped start)
      (throwError "Error while un-escaping parsing rules!")
      (sequence $ ((_<$>_ fromListS) ∘ translate ∘ toList) <$> l)


{-# OPTIONS --cubical --save-metas #-}

open import Agda.Builtin.IO
open import Agda.Builtin.String
open import Agda.Builtin.Unit

open import Erased-cubical-Pattern-matching-Cubical
open import Erased-cubical-Pattern-matching-Erased

postulate
  putStr : String → IO ⊤

{-# FOREIGN GHC import qualified Data.Text.IO #-}
{-# COMPILE GHC putStr = Data.Text.IO.putStr #-}
{-# COMPILE JS putStr =
    function (x) {
      return function(cb) {
        process.stdout.write(x); cb(0); }; } #-}

main : IO ⊤
main = putStr (f c₁)


open import Data.Graph

module Data.Graph.Path.Finite {ℓᵥ ℓₑ} (g : FiniteGraph ℓᵥ ℓₑ) where

open import Category.Monad
open import Data.Bool as Bool
open import Data.Graph.Path.Cut g hiding (_∈_)
open import Data.List as List hiding (_∷ʳ_)
open import Data.List.Any as Any
open import Data.List.Any.Properties
open import Data.List.Membership.Propositional
open import Data.List.Membership.Propositional.Properties hiding (finite)
open import Data.List.Categorical as ListCat
open import Data.Nat using (ℕ; zero; suc; _≤_; z≤n; s≤s)
open import Data.Nat.Properties
open import Data.Product as Σ
open import Data.Unit using (⊤; tt)
open import Data.Sum as ⊎
open import Data.Vec as Vec using (Vec; []; _∷_)
import Level as ℓ
open import Finite
open import Function
open import Function.Equality using (Π)
open import Function.Equivalence using (Equivalence)
open import Function.Inverse using (Inverse)
open import Function.LeftInverse using (LeftInverse; leftInverse)
open import Relation.Binary
open import Relation.Binary.Construct.Closure.ReflexiveTransitive hiding (_>>=_)
open import Relation.Binary.PropositionalEquality as ≡
open import Relation.Binary.HeterogeneousEquality as ≅
open import Relation.Nullary hiding (module Dec)
open import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Negation

open Π using (_⟨$⟩_)
open Equivalence using (to; from)
open FiniteGraph g
open Inverse using (to; from)
open IsFinite
open RawMonad {ℓᵥ ℓ.⊔ ℓₑ} ListCat.monad

isubst : ∀ {ℓ₁ ℓ₂ ℓ₃} {I : Set ℓ₁}
  (A : I → Set ℓ₂) (B : ∀ {k} → A k → Set ℓ₃)
  {i j : I} {x : A i} {y : A j} →
  i ≡ j → x ≅ y →
  B x → B y
isubst A B refl refl = id

True-unique : ∀ {ℓ} {A : Set ℓ} (A? : Dec A) (x y : True A?) → x ≡ y
True-unique A? x y with A?
True-unique A? tt tt | yes a = refl
True-unique A? () y | no ¬a

True-unique-≅ : ∀
  {ℓ₁ ℓ₂} {A : Set ℓ₁} {B : Set ℓ₂}
  (A? : Dec A) (B? : Dec B)
  (x : True A?) (y : True B?) →
  x ≅ y
True-unique-≅ A? B? x y with A? | B?
True-unique-≅ A? B? tt tt | yes a | yes b = refl
True-unique-≅ A? B? x () | _ | no ¬b
True-unique-≅ A? B? () y | no ¬a | _

∃-≅ : ∀
  {ℓ₁ ℓ₂} {A : Set ℓ₁} {P : A → Set ℓ₂}
  {x y : A} {p : P x} {q : P y} →
  x ≡ y → p ≅ q → (∃ P ∋ (x , p)) ≡ (y , q)
∃-≅ refl refl = refl

nexts : ∀ {a b n} → Path a b n → List (∃ λ b → Path a b (suc n))
nexts {a} {b} p = List.map (λ where (_ , e) → -, p ∷ʳ e) (elements (edgeFinite b))

∈-nexts : ∀ {a c n} →
  (pf : IsFinite (∃ λ b → Path a b n)) →
  (p : Path a c (suc n)) →
  (c , p) ∈ (elements pf >>= (nexts ∘ proj₂))
∈-nexts pf p =
  case unsnoc p of λ where
    (_ , p′ , e′ , refl) →
      to >>=-∈↔ ⟨$⟩
        (-,
          membership pf (-, p′) ,
          ∈-map⁺ (membership (edgeFinite _) (-, e′)))

Path-finite : ∀ n a → IsFinite (∃ λ b → Path a b n)
Path-finite zero a = finite List.[ -, [] ] λ where (_ , []) → here refl
Path-finite (suc n) a =
  let pf = Path-finite n a in
    finite (elements pf >>= (nexts ∘ proj₂)) (∈-nexts pf ∘ proj₂)

≤-top? : ∀ {x y} → x ≤ suc y → x ≤ y ⊎ x ≡ suc y
≤-top? z≤n = inj₁ z≤n
≤-top? {y = zero} (s≤s z≤n) = inj₂ refl
≤-top? {y = suc y} (s≤s p) =
  case ≤-top? p of λ where
    (inj₁ le) → inj₁ (s≤s le)
    (inj₂ refl) → inj₂ refl

Path≤-finite : ∀ n a → IsFinite (∃ λ b → Path≤ a b n)
Path≤-finite zero a = finite List.[ -, -, z≤n , [] ] λ where (_ , _ , z≤n , []) → here refl
Path≤-finite (suc n) a =
  let
    finite xs elem = Path≤-finite n a
    finite xs′ elem′ = Path-finite (suc n) a
  in
    finite
      (List.map (Σ.map₂ (Σ.map₂ (Σ.map₁ ≤-step))) xs List.++
        List.map (Σ.map₂ (_,_ (suc n) ∘ _,_ ≤-refl)) xs′)
      λ where
        (b , m , le , p) → case ≤-top? le of λ where
          (inj₁ le′) →
            to ++↔ ⟨$⟩
              inj₁
                (to map-∈↔ ⟨$⟩
                  (-, (elem (b , m , le′ , p)) ,
                    ≡.cong (λ q → b , m , q , p) (≤-irrelevance le (≤-step le′))))
          (inj₂ refl) →
            to (++↔ {xs = List.map _ xs}) ⟨$⟩
              inj₂
                (to map-∈↔ ⟨$⟩
                  (-, elem′ (-, p) ,
                    ≡.cong (λ q → b , m , q , p) (≤-irrelevance le (s≤s ≤-refl))))

AcyclicPath-finite : ∀ a → IsFinite (∃₂ λ b n → ∃ λ (p : Path a b n) → True (acyclic? p))
AcyclicPath-finite a =
  via-left-inverse (IsFinite.filter (Path≤-finite (size vertexFinite) a) _) $
    leftInverse
      (λ where (b , n , p , acp) → (b , n , acyclic-length-≤ p (toWitness acp) , p) , acp)
      (λ where ((b , n , le , p) , acp) → b , n , p , acp)
      λ where _ → refl

AcyclicStar : Vertex → Vertex → Set _
AcyclicStar a b = ∃ λ (p : Star Edge a b) → True (acyclic? (fromStar p))

AcyclicStar-finite : ∀ a → IsFinite (∃ (AcyclicStar a))
AcyclicStar-finite a =
  via-left-inverse (AcyclicPath-finite a) $
    leftInverse
      (λ where
        (b , p , acp) →
          b , starLength p , fromStar p , acp)
      (λ where
        (b , n , p , acp) →
          b , toStar p ,
            isubst (Path a b) (True ∘ acyclic?)
              (starLength-toStar p) (fromStar-toStar p)
              acp)
      (λ where
        (b , p , acp) →
          ≡.cong (b ,_) $
            ∃-≅
              (≡.sym (toStar-fromStar p))
              (True-unique-≅ _ _ _ _))


module _ where

open import Data.Nat using (_+_ ;  _≤′_ ; suc)
open import Induction.Nat using (<-rec)
open import Esterel.Lang.CanFunction
open import Function using (_∋_ ; _∘_ ; id ; _$_)
open import Data.Nat.Properties.Simple using ( +-comm ; +-assoc)
open import utility
open import noetherian using (noetherian ; ∥_∥s)
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 using ([] ; [_] ; _∷_ ; List ; _++_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; sym ; subst ; cong ; trans ; module ≡-Reasoning ; cong₂ ; subst₂ ; inspect)
open import Data.Empty
open import sn-calculus
open import context-properties -- get view, E-views
open import Esterel.Lang.Binding
open import Data.Maybe using ( just )
-- open import coherence
open import Data.List.Any
open import Data.List.Any.Properties
open import Esterel.Lang.CanFunction.Base
open import eval
open import blocked
open import Data.List.All
open import eval

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

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

open import Data.OrderedListMap Signal Signal.unwrap Signal.Status as SigM
open import Data.OrderedListMap SharedVar SharedVar.unwrap (Σ SharedVar.Status (λ _ → ℕ)) as ShrM
open import Data.OrderedListMap SeqVar SeqVar.unwrap ℕ as SeqM

open import binding-preserve

open import sn-calculus-props
open import par-swap
open import par-swap.union-properties
open import calculus
open import calculus.properties

evalsn≡ₑ-consistent : ∀{output output'} θ p → CB (ρ⟨ θ , GO ⟩· p) → evalsn≡ₑ p θ output → evalsn≡ₑ p θ output' → output ≡ output'
evalsn≡ₑ-consistent θ p ⊢cb-p (evalsn-complete ρθ·p≡q complete-q) (evalsn-complete ρθ·p≡r complete-r)
  with sn≡ₑ-consistent (proj₂ (sn≡ₑ-preserve-cb ⊢cb-p ρθ·p≡q)) (rtrn (rsym ρθ·p≡q  ⊢cb-p) ρθ·p≡r)
... | (s , qsn⟶*s , rsn⟶*s)
  with inescapability-of-complete-sn complete-q qsn⟶*s
... | complete-s
   with ρ-stays-ρ-sn⟶* qsn⟶*s | ρ-stays-ρ-sn⟶* rsn⟶*s
... | θq , _ , _ , refl | θr , _ , _ , refl
   with equality-of-complete-sn⟶* complete-q qsn⟶*s
      | equality-of-complete-sn⟶* complete-r rsn⟶*s
... | refl , refl | refl , refl = refl

eval∥R∪sn≡ₑ-consistent : ∀ {output output'} θ p →
  CB (ρ⟨ θ , GO ⟩· p) →
  eval∥R∪sn≡ₑ p θ output →
  eval∥R∪sn≡ₑ p θ output' →
  output ≡ output'
eval∥R∪sn≡ₑ-consistent θ p ⊢cb-p (eval∥R∪sn-complete ρθ·p≡q complete-q) (eval∥R∪sn-complete ρθ·p≡r complete-r)
  with ∥R∪sn≡ₑ-consistent (proj₂ (∥R∪sn≡ₑ-preserve-cb ⊢cb-p ρθ·p≡q)) (∪trn (∪sym ρθ·p≡q  ⊢cb-p) ρθ·p≡r)
... | (s , qsn⟶*s , rsn⟶*s)
  with inescapability-of-complete-∪ complete-q qsn⟶*s
... | complete-s
   with ρ-stays-ρ-∪ qsn⟶*s | ρ-stays-ρ-∪ rsn⟶*s
... | θq , _ , _ , refl | θr , _ , _ , refl
   with equality-of-complete-∪ complete-q qsn⟶*s
      | equality-of-complete-∪ complete-r rsn⟶*s
... | refl , refl | refl , refl = refl

eval≡ₑ->eval∥R∪sn≡ : ∀ {p θ output} ->
  eval≡ₑ p θ output →
  eval∥R∪sn≡ₑ p θ output
eval≡ₑ->eval∥R∪sn≡ (eval-complete ρθ·p≡q complete-q) =
  eval∥R∪sn-complete (≡ₑ-to-∥R∪sn≡ₑ ρθ·p≡q) complete-q

eval≡ₑ-consistent : ∀ {output output'} θ p →
  CB (ρ⟨ θ , GO ⟩· p) →
  eval≡ₑ p θ output →
  eval≡ₑ p θ output' →
  output ≡ output'
eval≡ₑ-consistent θ p CBρp eval≡₁ eval≡₂
  = eval∥R∪sn≡ₑ-consistent θ p CBρp
      (eval≡ₑ->eval∥R∪sn≡ eval≡₁)
      (eval≡ₑ->eval∥R∪sn≡ eval≡₂)

sn≡ₑ=>eval : ∀ p θp outputp q θq outputq → CB (ρ⟨ θp , GO ⟩· p) → (ρ⟨ θp , GO ⟩· p) sn≡ₑ (ρ⟨ θq , GO ⟩· q) → evalsn≡ₑ p θp outputp → evalsn≡ₑ q θq outputq → outputp ≡ outputq
sn≡ₑ=>eval _ _ _ _ _ _ CB eq (evalsn-complete ρθ·p≡q complete-q) (evalsn-complete ρθ·p≡q₁ complete-q₁)
  with sn≡ₑ-consistent (proj₂ (sn≡ₑ-preserve-cb CB ρθ·p≡q)) (rtrn (rsym ρθ·p≡q  CB) (rtrn eq ρθ·p≡q₁))
... | (s , qsn⟶*s , rsn⟶*s)
  with inescapability-of-complete-sn complete-q qsn⟶*s
... | complete-s
   with ρ-stays-ρ-sn⟶* qsn⟶*s | ρ-stays-ρ-sn⟶* rsn⟶*s
... | θq , _ , _ , refl | θr , _ , _ , refl
   with equality-of-complete-sn⟶* complete-q qsn⟶*s
      | equality-of-complete-sn⟶* complete-q₁ rsn⟶*s
... | refl , refl | refl , refl = refl

∥R∪sn≡ₑ=>eval : ∀ p θp outputp q θq outputq →
  CB (ρ⟨ θp , GO ⟩· p) →
  (ρ⟨ θp , GO ⟩· p) ∥R∪sn≡ₑ (ρ⟨ θq , GO ⟩· q) →
  eval∥R∪sn≡ₑ p θp outputp →
  eval∥R∪sn≡ₑ q θq outputq →
  outputp ≡ outputq
∥R∪sn≡ₑ=>eval _ _ _ _ _ _ CB eq (eval∥R∪sn-complete ρθ·p≡q complete-q) (eval∥R∪sn-complete ρθ·p≡q₁ complete-q₁)
  with ∥R∪sn≡ₑ-consistent (proj₂ (∥R∪sn≡ₑ-preserve-cb CB ρθ·p≡q)) (∪trn (∪sym ρθ·p≡q  CB) (∪trn eq ρθ·p≡q₁))
... | (s , qsn⟶*s , rsn⟶*s)
  with inescapability-of-complete-∪ complete-q qsn⟶*s
... | complete-s
   with ρ-stays-ρ-∪ qsn⟶*s | ρ-stays-ρ-∪ rsn⟶*s
... | θq , _ , _ , refl | θr , _ , _ , refl
   with equality-of-complete-∪ complete-q qsn⟶*s
      | equality-of-complete-∪ complete-q₁ rsn⟶*s
... | refl , refl | refl , refl = refl

≡ₑ=>eval : ∀ p θp outputp q θq outputq →
  CB (ρ⟨ θp , GO ⟩· p) →
  (ρ⟨ θp , GO ⟩· p) ≡ₑ (ρ⟨ θq , GO ⟩· q) # [] →
  eval≡ₑ p θp outputp →
  eval≡ₑ q θq outputq →
  outputp ≡ outputq
≡ₑ=>eval p θp outputp q θq outputq CBρp ρp≡ₑρq eval≡₁ eval≡₂
  = ∥R∪sn≡ₑ=>eval p θp outputp q θq outputq CBρp
      (≡ₑ-to-∥R∪sn≡ₑ ρp≡ₑρq)
      (eval≡ₑ->eval∥R∪sn≡ eval≡₁)
      (eval≡ₑ->eval∥R∪sn≡ eval≡₂)


module Options-in-right-order where

data Unit : Set where
  unit : Unit

postulate
  IO : Set → Set

{-# COMPILE GHC IO = type IO #-}
{-# BUILTIN IO IO #-}

postulate
  return : {A : Set} → A → IO A

{-# COMPILE GHC return = \_ -> return #-}

main = return unit


module Generic.Reflection.DeriveEq where

open import Generic.Core
open import Generic.Function.FoldMono
open import Generic.Reflection.ReadData

fromToClausesOf : Data Type -> Name -> List Clause
fromToClausesOf (packData d a b cs ns) f = unmap (λ {a} -> clauseOf a) ns where
  vars : ℕ -> ℕ -> Type -> List (Maybe (String × ℕ) × ℕ)
  vars (suc i) j (explPi r s a b) = if isSomeName d a
    then (just (s , j) , i) ∷ vars i (suc j) b
    else (nothing      , i) ∷ vars i  j      b
  vars  i      j (pi       s a b) = vars i j b
  vars  i      j  b               = []

  clauseOf : Type -> Name -> Clause
  clauseOf c n = clause lhs rhs where
    es   = explPisToNames c
    i    = length es
    mxs  = vars i 0 c
    xs   = mapMaybe proj₁ mxs
    k    = length xs
    lhs  = explRelArg (patCon n (patVars es)) ∷ []
    lams = λ t -> foldr (explLam ∘ proj₁) t xs
    each = λ m i -> maybe (proj₂ >>> λ j -> pureVar (k ∸ suc j)) (pureVar (i + k)) m
    args = map (uncurry each) mxs
    grow = lams (vis appCon n args)
    rs   = mapMaybe (uncurry λ m i -> vis# 1 appDef f (pureVar i) <$ m) mxs
    rhs  = vis appDef (quote congn) $ reify k ∷ grow ∷ rs

toTypeOf : Data Type -> Name -> Type
toTypeOf (packData d a b cs ns) d′ = let ab = appendType a b; k = countPis ab in
  appendType (implicitize ab) $ appDef d (pisToArgVars k ab) ‵→ appDef d′ (pisToArgVars (suc k) ab)

fromTypeOf : Data Type -> Name -> Type
fromTypeOf (packData d a b cs ns) d′ = let ab = appendType a b; k  = countPis ab in
  appendType (implicitize ab) $ appDef d′ (pisToArgVars k ab) ‵→ appDef d (pisToArgVars (suc k) ab)

fromToTypeOf : Data Type -> Name -> Name -> Name -> Type
fromToTypeOf (packData d a b cs ns) d′ to from = let ab = appendType a b; k = countPis ab in
  appendType (implicitize ab) ∘ pi "x" (explRelArg (appDef d (pisToArgVars k ab))) $
    sate _≡_ (vis# 1 appDef from (vis# 1 appDef to (pureVar 0))) (pureVar 0)

injTypeOf : Data Type -> Name -> Type
injTypeOf (packData d a b cs ns) d′ =
  let ab  = appendType a b
      k   = countPis ab
      avs = pisToArgVars k ab
  in appendType (implicitize ab) $ sate _↦_ (appDef d avs) (appDef d′ avs)

deriveDesc : Name -> Data Type -> TC Name
deriveDesc d D =
  freshName (showName d ++ˢ "′") >>= λ d′ ->
  getType d >>= λ a ->
  declareDef (explRelArg d′) a >>
  d′ <$ (quoteData D >>= defineTerm d′)

deriveTo : Data Type -> Name -> Name -> TC Name
deriveTo D d′ fd =
  freshName ("to" ++ˢ showName d′) >>= λ to ->
  declareDef (explRelArg to) (toTypeOf D d′) >>
  to <$ defineTerm to (sateMacro gcoerce (pureDef fd))

deriveFrom : Data Type -> Name -> TC Name
deriveFrom D d′ =
  freshName ("from" ++ˢ showName d′) >>= λ from ->
  declareDef (explRelArg from) (fromTypeOf D d′) >>
  from <$ defineTerm from (guncoercePure D)

deriveFromTo : Data Type -> Name -> Name -> Name -> TC Name
deriveFromTo D d′ to from =
  freshName ("fromTo" ++ˢ showName d′) >>= λ from-to ->
  declareDef (explRelArg from-to) (fromToTypeOf D d′ to from) >>
  from-to <$ defineFun from-to (fromToClausesOf D from-to)

deriveInj : Data Type -> Name -> Name -> Name -> Name -> TC Name
deriveInj D d′ to from from-to =
  freshName ("inj" ++ˢ showName d′) >>= λ inj ->
  declareDef (explRelArg inj) (injTypeOf D d′) >>
  inj <$ defineTerm inj (sate packInj (pureDef to) (pureDef from) (pureDef from-to))

deriveEqTo : Name -> Name -> TC _
deriveEqTo e d =
  getData d >>= λ D ->
  deriveDesc d D >>= λ d′ ->
  deriveFold d D >>= λ f ->
  deriveTo D d′ f >>= λ to ->
  deriveFrom D d′ >>= λ from ->
  deriveFromTo D d′ to from >>= λ from-to ->
  deriveInj D d′ to from from-to >>= λ inj ->
  defineTerm e (sate viaInj (pureDef inj))


module utm where

open import turing
open import Data.Product
-- open import Data.Bool
open import Data.List
open import Data.Nat
open import logic

data utmStates : Set where
     reads : utmStates
     read0 : utmStates
     read1 : utmStates
     read2 : utmStates
     read3 : utmStates
     read4 : utmStates
     read5 : utmStates
     read6 : utmStates

     loc0 : utmStates
     loc1 : utmStates
     loc2 : utmStates
     loc3 : utmStates
     loc4 : utmStates
     loc5 : utmStates
     loc6 : utmStates

     fetch0 : utmStates
     fetch1 : utmStates
     fetch2 : utmStates
     fetch3 : utmStates
     fetch4 : utmStates
     fetch5 : utmStates
     fetch6 : utmStates
     fetch7 : utmStates

     print0 : utmStates
     print1 : utmStates
     print2 : utmStates
     print3 : utmStates
     print4 : utmStates
     print5 : utmStates
     print6 : utmStates
     print7 : utmStates

     mov0 : utmStates
     mov1 : utmStates
     mov2 : utmStates
     mov3 : utmStates
     mov4 : utmStates
     mov5 : utmStates
     mov6 : utmStates

     tidy0 : utmStates
     tidy1 : utmStates
     halt : utmStates

data utmΣ : Set where
    ０ : utmΣ
    １ : utmΣ
    B : utmΣ
    * : utmΣ
    $ : utmΣ
    ^ : utmΣ
    X : utmΣ
    Y : utmΣ
    Z : utmΣ
    ＠ : utmΣ
    b : utmΣ

utmδ :  utmStates →  utmΣ  → utmStates × (Write utmΣ) × Move
utmδ reads  x = read0 , wnone , mnone
utmδ read0  * = read1 , write * , left
utmδ read0  x = read0 , write x , right
utmδ read1  x = read2 , write ＠ , right
utmδ read2  ^ = read3 , write ^ , right
utmδ read2  x = read2 , write x , right
utmδ read3  ０ = read4 , write ０ , left
utmδ read3  １ = read5 , write １ , left
utmδ read3  b = read6 , write b , left
utmδ read4  ＠ = loc0 , write ０ , right
utmδ read4  x = read4 , write x , left
utmδ read5  ＠ = loc0 , write １ , right
utmδ read5  x = read5 , write x , left
utmδ read6  ＠ = loc0 , write B , right
utmδ read6  x = read6 , write x , left
utmδ loc0  ０ = loc0 , write X , left
utmδ loc0  １ = loc0 , write Y , left
utmδ loc0  B = loc0 , write Z , left
utmδ loc0  $ = loc1 , write $ , right
utmδ loc0  x = loc0 , write x , left
utmδ loc1  X = loc2 , write ０ , right
utmδ loc1  Y = loc3 , write １ , right
utmδ loc1  Z = loc4 , write B , right
utmδ loc1  * = fetch0 , write * , right
utmδ loc1  x = loc1 , write x , right
utmδ loc2  ０ = loc5 , write X , right
utmδ loc2  １ = loc6 , write Y , right
utmδ loc2  B = loc6 , write Z , right
utmδ loc2  x = loc2 , write x , right
utmδ loc3  １ = loc5 , write Y , right
utmδ loc3  ０ = loc6 , write X , right
utmδ loc3  B = loc6 , write Z , right
utmδ loc3  x = loc3 , write x , right
utmδ loc4  B = loc5 , write Z , right
utmδ loc4  ０ = loc6 , write X , right
utmδ loc4  １ = loc6 , write Y , right
utmδ loc4  x = loc4 , write x , right
utmδ loc5  $ = loc1 , write $ , right
utmδ loc5  x = loc5 , write x , left
utmδ loc6  $ = halt , write $ , right
utmδ loc6  * = loc0 , write * , left
utmδ loc6  x = loc6 , write x , right
utmδ fetch0  ０ = fetch1 , write X , left
utmδ fetch0  １ = fetch2 , write Y , left
utmδ fetch0  B = fetch3 , write Z , left
utmδ fetch0  x = fetch0 , write x , right
utmδ fetch1  $ = fetch4 , write $ , right
utmδ fetch1  x = fetch1 , write x , left
utmδ fetch2  $ = fetch5 , write $ , right
utmδ fetch2  x = fetch2 , write x , left
utmδ fetch3  $ = fetch6 , write $ , right
utmδ fetch3  x = fetch3 , write x , left
utmδ fetch4  ０ = fetch7 , write X , right
utmδ fetch4  １ = fetch7 , write X , right
utmδ fetch4  B = fetch7 , write X , right
utmδ fetch4  * = print0 , write * , left
utmδ fetch4  x = fetch4 , write x , right
utmδ fetch5  ０ = fetch7 , write Y , right
utmδ fetch5  １ = fetch7 , write Y , right
utmδ fetch5  B = fetch7 , write Y , right
utmδ fetch5  * = print0 , write * , left
utmδ fetch5  x = fetch5 , write x , right
utmδ fetch6  ０ = fetch7 , write Z , right
utmδ fetch6  １ = fetch7 , write Z , right
utmδ fetch6  B = fetch7 , write Z , right
utmδ fetch6  * = print0 , write * , left
utmδ fetch6  x = fetch6 , write x , right
utmδ fetch7  * = fetch0 , write * , right
utmδ fetch7  x = fetch7 , write x , right
utmδ print0  X = print1 , write X , right
utmδ print0  Y = print2 , write Y , right
utmδ print0  Z = print3 , write Z , right
utmδ print1  ^ = print4 , write ^ , right
utmδ print1  x = print1 , write x , right
utmδ print2  ^ = print5 , write ^ , right
utmδ print2  x = print2 , write x , right
utmδ print3  ^ = print6 , write ^ , right
utmδ print3  x = print3 , write x , right
utmδ print4  x = print7 , write ０ , left
utmδ print5  x = print7 , write １ , left
utmδ print6  x = print7 , write B , left
utmδ print7  X = mov0 , write X , right
utmδ print7  Y = mov1 , write Y , right
utmδ print7  x = print7 , write x , left
utmδ mov0  ^ = mov2 , write ^ , left
utmδ mov0  x = mov0 , write x , right
utmδ mov1  ^ = mov3 , write ^ , right
utmδ mov1  x = mov1 , write x , right
utmδ mov2  ０ = mov4 , write ^ , right
utmδ mov2  １ = mov5 , write ^ , right
utmδ mov2  B = mov6 , write ^ , right
utmδ mov3  ０ = mov4 , write ^ , left
utmδ mov3  １ = mov5 , write ^ , left
utmδ mov3  B = mov6 , write ^ , left
utmδ mov4  ^ = tidy0 , write ０ , left
utmδ mov5  ^ = tidy0 , write １ , left
utmδ mov6  ^ = tidy0 , write B , left
utmδ tidy0  $ = tidy1 , write $ , left
utmδ tidy0  x = tidy0 , write x , left
utmδ tidy1  X = tidy1 , write ０ , left
utmδ tidy1  Y = tidy1 , write １ , left
utmδ tidy1  Z = tidy1 , write B , left
utmδ tidy1  $ = reads , write $ , right
utmδ tidy1  x = tidy1 , write x , left
utmδ _  x = halt , write x , mnone

U-TM : Turing utmStates utmΣ
U-TM = record {
        tδ = utmδ
     ;  tstart = read0
     ;  tend = tend
     ;  tnone =  b
  } where
      tend : utmStates →  Bool
      tend halt = true
      tend _ = false

-- Copyδ :  CopyStates →  ℕ  → CopyStates × ( Write  ℕ ) × Move
-- Copyδ s1 0  = H    , wnone       , mnone
-- Copyδ s1 1  = s2   , write 0 , right
-- Copyδ s2 0  = s3   , write 0 , right
-- Copyδ s2 1  = s2   , write 1 , right
-- Copyδ s3 0  = s4   , write 1 , left
-- Copyδ s3 1  = s3   , write 1 , right
-- Copyδ s4 0  = s5   , write 0 , left
-- Copyδ s4 1  = s4   , write 1 , left
-- Copyδ s5 0  = s1   , write 1 , right
-- Copyδ s5 1  = s5   , write 1 , left
-- Copyδ H  _  = H    , wnone   , mnone
-- Copyδ _  (suc (suc _))      = H    , wnone       , mnone

Copyδ-encode : List utmΣ
Copyδ-encode =
       ０  ∷ ０  ∷ １  ∷ ０  ∷  １ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ ０ ∷   -- s1 0  = H    , wnone       , mnone
  *  ∷ ０  ∷ ０  ∷ １  ∷ １  ∷  ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷   -- s1 1  = s2   , write 0 , right
  *  ∷ ０  ∷ １  ∷ ０  ∷ ０  ∷  ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ １ ∷   -- s2 0  = s3   , write 0 , right
  *  ∷ ０  ∷ １  ∷ ０  ∷ １  ∷  ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷   -- s2 1  = s2   , write 1 , right
  *  ∷ ０  ∷ １  ∷ １  ∷ ０  ∷  １ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷   -- s3 0  = s4   , write 1 , left
  *  ∷ ０  ∷ １  ∷ １  ∷ １  ∷  ０ ∷ １ ∷ １ ∷ １ ∷ ０ ∷ １ ∷   -- s3 1  = s3   , write 1 , right
  *  ∷ １  ∷ ０  ∷ ０  ∷ ０  ∷  １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷   -- s4 0  = s5   , write 0 , left
  *  ∷ １  ∷ ０  ∷ ０  ∷ １  ∷  １ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷   -- s4 1  = s4   , write 1 , left
  *  ∷ １  ∷ ０  ∷ １  ∷ ０  ∷  ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ １ ∷   -- s5 0  = s1   , write 1 , right
  *  ∷ １  ∷ ０  ∷ １  ∷ １  ∷  １ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷   -- s5 1  = s5   , write 1 , left
  []

input-encode : List utmΣ
input-encode =  １  ∷ １  ∷ ０  ∷ ０  ∷  ０ ∷ []

input+Copyδ : List utmΣ
input+Copyδ = ( $  ∷ ０  ∷ ０  ∷  ０ ∷  ０ ∷  * ∷  [] ) -- start state
        ++   Copyδ-encode
        ++ ( $ ∷ ^ ∷ input-encode )

short-input : List utmΣ
short-input = $  ∷ ０  ∷ ０  ∷  ０ ∷  * ∷
    ０  ∷ ０  ∷  ０ ∷  １  ∷ ０  ∷ １ ∷ １  ∷  * ∷
    ０  ∷ ０  ∷  １ ∷  ０  ∷ １  ∷ １ ∷ １  ∷  * ∷
    ０  ∷ １  ∷  B  ∷  １ ∷  ０  ∷ １ ∷ ０  ∷  * ∷
    １  ∷ ０  ∷  ０ ∷  ０ ∷  １  ∷ １ ∷ １  ∷  $ ∷
    ^   ∷ ０  ∷  ０ ∷  １  ∷ １ ∷ []

utm-test1 : List  utmΣ → utmStates × ( List  utmΣ ) × ( List  utmΣ )
utm-test1 inp = Turing.taccept U-TM  inp

{-# TERMINATING #-}
utm-test2 : ℕ  → List  utmΣ  → utmStates × ( List  utmΣ ) × ( List  utmΣ )
utm-test2 n inp  = loop n (Turing.tstart U-TM) inp []
  where
        loop :  ℕ → utmStates → ( List  utmΣ ) → ( List  utmΣ ) → utmStates × ( List  utmΣ ) × ( List  utmΣ )
        loop zero q L R = ( q , L , R )
        loop (suc n) q L R with  move {utmStates} {utmΣ} {０} {utmδ} q L R | q
        ... | nq , nL , nR | reads = loop n nq nL nR
        ... | nq , nL , nR | _ = loop (suc n) nq nL nR

t1 = utm-test2 20 short-input

t : (n : ℕ)  → utmStates × ( List  utmΣ ) × ( List  utmΣ )
-- t n = utm-test2 n input+Copyδ
t n = utm-test2 n short-input


open import Nat
open import Prelude
open import List

open import contexts
open import core

open import lemmas-general
open import lemmas-env
open import lemmas-progress

open import results-checks
open import decidability
open import completeness
open import preservation
open import progress
open import finality
open import eval-checks


module _ where

open import Agda.Builtin.List
open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit

record Id (A : Set) : Set where
  field id : A → A

open Id {{...}}

postulate
  T    : {A : Set} → A → Set
  cong : ∀ {A B : Set} (f : A → B) {x} → T x → T (f x)

  X : Set
  lem  : (x : X) → T x

instance
  IdX : Id X
  IdX .id n = n

macro
  follows-from : Term → Term → TC ⊤
  follows-from prf hole = do
    typeError (termErr prf ∷ [])

loops : (x : X) → T x
loops x =
  follows-from (cong id (lem x))


module Lemmachine.Default.Proofs where
open import Lemmachine
import Lemmachine.Default
import Lemmachine.Lemmas
open import Lemmachine.Default.Lemmas
open Lemmachine.Lemmas Lemmachine.Default.resource
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import Data.Maybe
open import Data.Product hiding (map)
open import Data.Function using (const)
open import Data.List.Any

methodNotAllowed : ∀ r → method r ∉ allowedMethods r
                       → resolveStatus r ≡ MethodNotAllowed
methodNotAllowed r p with methodAlwaysKnown r | methodIsntAllowed r p
... | p₂ | p₃ rewrite p₂ | p₃ = refl

optionsOK : ∀ r → method r ∈ allowedMethods r
                → method r ≡ OPTIONS
                → resolveStatus r ≡ OK
optionsOK r p p₂ with methodAlwaysKnown r | methodIsAllowed r p
... | p₃ | p₄  rewrite p₃ | p₄ | p₂ = refl


open import Prelude

module Implicits.Substitutions.Lemmas where

open import Implicits.Syntax.Type
open import Implicits.Syntax.Term hiding (var)
open import Implicits.Syntax.Context
open import Implicits.WellTyped
open import Implicits.Substitutions
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Vec.Properties
open import Extensions.Substitution
import Category.Applicative.Indexed as Applicative
open Applicative.Morphism using (op-<$>)

module TypeLemmas where
  open import Implicits.Substitutions.Lemmas.Type public

open import Implicits.Substitutions.Lemmas.MetaType public

{-
module SubstLemmas (_⊢ᵣ_ : ∀ {ν} → ICtx ν → Type ν → Set) where

  open TypingRules _⊢ᵣ_

  private
    ⊢subst : ∀ {m n} {Γ₁ Γ₂ : Ktx n m} {t₁ t₂ : Term n m} {a₁ a₂ : Type n} →
      Γ₁ ≡ Γ₂ → t₁ ≡ t₂ → a₁ ≡ a₂ → Γ₁ ⊢ t₁ ∈ a₁ → Γ₂ ⊢ t₂ ∈ a₂
    ⊢subst refl refl refl hyp = hyp

    ⊢substCtx : ∀ {m n} {Γ₁ Γ₂ : Ktx n m} {t : Term n m} {a : Type n} →
      Γ₁ ≡ Γ₂ → Γ₁ ⊢ t ∈ a → Γ₂ ⊢ t ∈ a
    ⊢substCtx refl hyp = hyp

    ⊢substTp : ∀ {m n} {Γ : Ktx n m} {t : Term n m} {a₁ a₂ : Type n} →
      a₁ ≡ a₂ → Γ ⊢ t ∈ a₁ → Γ ⊢ t ∈ a₂
    ⊢substTp refl hyp = hyp

  module WtTermLemmas where
    weaken : ∀ {ν n} {K : Ktx ν n} {t : Term ν n} {a b : Type ν} →
                       K ⊢ t ∈ a → b ∷Γ K ⊢ tmtm-weaken t ∈ a
    -- weaken {Γ = Γ} {b = b} ⊢t = Var.wk /Var ⊢substCtx (C.wkVar-/Var-∷ Γ b) ⊢t

  module TermTypeLemmas where
    open TermTypeSubst

    private module T = TypeLemmas
    private module TS = TypeSubst
    private module V = VarLemmas

    /-↑⋆ :
      ∀ {T₁ T₂} {lift₁ : Lift T₁ Type} {lift₂ : Lift T₂ Type} →
      let open TS.Lifted lift₁ using () renaming (_↑⋆_ to _↑⋆₁_; _/_ to _/tp₁_)
          open   Lifted lift₁ using () renaming (_/_  to _/₁_)
          open TS.Lifted lift₂ using () renaming (_↑⋆_ to _↑⋆₂_; _/_ to _/tp₂_)
          open   Lifted lift₂ using () renaming (_/_  to _/₂_)
      in
      ∀ {n k} (ρ₁ : Sub T₁ n k) (ρ₂ : Sub T₂ n k) →
      (∀ i x → tvar x /tp₁ ρ₁ ↑⋆₁ i ≡ tvar x /tp₂ ρ₂ ↑⋆₂ i) →
       ∀ i {m} (t : Term (i N+ n) m)  → t /₁ ρ₁ ↑⋆₁ i ≡ t /₂ ρ₂ ↑⋆₂ i
    /-↑⋆ ρ₁ ρ₂ hyp i (new x)      = refl
    /-↑⋆ ρ₁ ρ₂ hyp i (var x)      = refl
    /-↑⋆ ρ₁ ρ₂ hyp i (Λ t)        = cong Λ      (/-↑⋆ ρ₁ ρ₂ hyp (1 N+ i) t)
    /-↑⋆ ρ₁ ρ₂ hyp i (λ' a t)     =
      cong₂ λ'     (T./-↑⋆ ρ₁ ρ₂ hyp i a)       (/-↑⋆ ρ₁ ρ₂ hyp i t)
    /-↑⋆ ρ₁ ρ₂ hyp i (t [ b ])    =
      cong₂ _[_]     (/-↑⋆ ρ₁ ρ₂ hyp i t)     (T./-↑⋆ ρ₁ ρ₂ hyp i b)
    /-↑⋆ ρ₁ ρ₂ hyp i (s · t)      =
      cong₂ _·_      (/-↑⋆ ρ₁ ρ₂ hyp i s)       (/-↑⋆ ρ₁ ρ₂ hyp i t)
    /-↑⋆ ρ₁ ρ₂ hyp i (x)      = {!!}

    /-wk : ∀ {m n} (t : Term m n) → t / TypeSubst.wk ≡ weaken t
    /-wk t = /-↑⋆ TypeSubst.wk VarSubst.wk (λ k x → begin
      tvar x T./ T.wk T.↑⋆ k ≡⟨ T.var-/-wk-↑⋆ k x ⟩
      tvar (finlift k suc x) ≡⟨ cong tvar (sym (V.var-/-wk-↑⋆ k x)) ⟩
      tvar (lookup x (V.wk V.↑⋆ k)) ≡⟨ refl ⟩
      tvar x TS./Var V.wk V.↑⋆ k ∎) 0 t

  module KtxLemmas where
    open KtxSubst hiding (ktx-map)

    private module Tp  = TypeLemmas
    private module Var = VarSubst

    ktx-map-cong : ∀ {ν μ n} {f g : Type ν → Type μ} →
                   f ≗ g → _≗_ {A = Ktx ν n} (ktx-map f) (ktx-map g)
    ktx-map-cong K = ?

    -- Term variable substitution (renaming) commutes with type
    -- substitution.
    {-
    /Var-/ : ∀ {m ν n l} (ρ : Sub Fin m n) (Γ : Ktx ν n) (σ : Sub Type ν l) →
             (Γ /Var ρ) / σ ≡ Γ /Var (ρ / σ)
    /Var-/ ρ Γ σ = begin
        (ρ /Var Γ) / σ
      ≡⟨ sym (map-∘ _ _ ρ) ⟩
        map (λ x → (lookup x Γ) Tp./ σ) ρ
      ≡⟨ map-cong (λ x → sym (Tp.lookup-⊙ x)) ρ ⟩
        map (λ x → lookup x (Γ / σ)) ρ
      ∎

    -- Term variable substitution (renaming) commutes with weakening of
    -- typing contexts with an additional type variable.

    /Var-weaken : ∀ {m n k} (ρ : Sub Fin m k) (Γ : Ctx n k) →
                  weaken (ρ /Var Γ) ≡ ρ /Var (weaken Γ)
    /Var-weaken ρ Γ = begin
      (ρ /Var Γ) / Tp.wk   ≡⟨ ? ⟩ --/Var-/ ρ Γ Tp.wk
      ρ /Var (weaken Γ)    ∎
      -}

    -- Term variable substitution (renaming) commutes with term variable
    -- lookup in typing context.
    {-
    /Var-lookup : ∀ {m n k} (x : Fin m) (ρ : Sub Fin m k) (Γ : Ctx n k) →
                  lookup x (ρ /Var Γ) ≡ lookup (lookup x ρ) Γ
    /Var-lookup x ρ Γ = op-<$> (lookup-morphism x) _ _

    -- Term variable substitution (renaming) commutes with weakening of
    -- typing contexts with an additional term variable.
    /Var-∷ : ∀ {m n k} (a : Type n) (ρ : Sub Fin m k) (Γ : Ctx n k) →
             a ∷ (ρ /Var Γ) ≡ (ρ Var.↑) /Var (a ∷ Γ)
    /Var-∷ a []      Γ = refl
    /Var-∷ a (x ∷ ρ) Γ = cong (_∷_ a) (cong (_∷_ (lookup x Γ)) (begin
      map (λ x → lookup x Γ) ρ                   ≡⟨ refl ⟩
      map (λ x → lookup (suc x) (a ∷ Γ)) ρ       ≡⟨ map-∘ _ _ ρ ⟩
      map (λ x → lookup x (a ∷ Γ)) (map suc ρ)   ∎))

    -- Invariants of term variable substitution (renaming)
    idVar-/Var   : ∀ {m n} (Γ : Ctx n m) → Γ ≡ (Var.id /Var Γ)
    wkVar-/Var-∷ : ∀ {m n} (Γ : Ctx n m) (a : Type n) → Γ ≡ (Var.wk /Var (a ∷ Γ))

    idVar-/Var []      = refl
    idVar-/Var (a ∷ Γ) = cong (_∷_ a) (wkVar-/Var-∷ Γ a)

    wkVar-/Var-∷ Γ a = begin
      Γ ≡⟨ idVar-/Var Γ ⟩
      Var.id /Var Γ ≡⟨ map-∘ _ _ VarSubst.id ⟩
      Var.wk /Var (a ∷ Γ) ∎

    ctx-weaken-sub-vanishes : ∀ {ν n} {Γ : Ktx ν n} {a} → (ktx-weaken Γ) / (Tp.sub a) ≡ Γ
    ctx-weaken-sub-vanishes {Γ = Γ} {a} = begin
      (Γ / Tp.wk) / (Tp.sub a)
        ≡⟨ sym $ map-∘ (λ s → s tp/tp Tp.sub a) (λ s → s tp/tp Tp.wk) Γ ⟩
      (map (λ s → s tp/tp Tp.wk tp/tp (Tp.sub a)) Γ)
        ≡⟨ map-cong (TypeLemmas.wk-sub-vanishes) Γ ⟩
      (map (λ s → s) Γ) ≡⟨ map-id Γ ⟩
      Γ ∎
    -}

  module WtTypeLemmas where
    open TypeLemmas hiding (_/_; weaken)
    private
      module Tp = TypeLemmas
      module TmTp = TermTypeLemmas
      module C  = KtxLemmas

    infixl 8 _/_

    -- Type substitutions lifted to well-typed terms
    _/_ : ∀ {m n k} {Γ : Ktx n m} {t : Term n m} {a : Type n} →
          Γ ⊢ t ∈ a → (σ : Sub Type n k) → Γ ktx/ σ ⊢ t tm/tp σ ∈ a Tp./ σ
    new c             / σ = new c
    var x             / σ = ⊢substTp (lookup-⊙ x) (var x)
    _/_ {Γ = Γ} (Λ ⊢t)  σ = Λ (⊢substCtx eq (⊢t / σ ↑))
      where
        eq : (ktx-weaken Γ) ktx/ (σ Tp.↑) ≡ ktx-weaken (Γ ktx/ σ)
    {-
        eq = begin
          (ktx-map (λ s → s tp/tp Tp.wk) Γ) ktx/ (σ Tp.↑)
            ≡⟨ KtxLemmas.ktx-map-cong (λ a → a ktx/ (σ Tp.↑))
              (KtxLemmas.ktx-map-cong (λ a → Tp./-wk {t = a}) Γ) ⟩
          (ktx-map Tp.weaken Γ) ⊙ (σ Tp.↑)
            ≡⟨ sym $ map-weaken-⊙ Γ σ ⟩
          map Tp.weaken (Γ ⊙ σ)
            ≡⟨ (map-cong (λ a → sym $ Tp./-wk {t = a}) (Γ ⊙ σ)) ⟩
          ktx-weaken (Γ ktx/ σ) ∎
          -}
    λ' a ⊢t           / σ = λ' (a Tp./ σ) (⊢t / σ)
    _[_] {a = a} ⊢t b / σ = ⊢substTp (sym (sub-commutes a)) ((⊢t / σ) [ b Tp./ σ ])
    ⊢s · ⊢t           / σ = (⊢s / σ) · (⊢t / σ)
    x / σ = ?

    -- Weakening of terms with additional type variables lifted to
    -- well-typed terms.
    weaken : ∀ {m n} {Γ : Ktx n m} {t : Term n m} {a : Type n} →
             Γ ⊢ t ∈ a → ktx-weaken Γ ⊢ tm-weaken t ∈ Tp.weaken a
    weaken {t = t} {a = a} ⊢t = ⊢subst refl (TmTp./-wk t) (/-wk {t = a}) (⊢t / wk)

    -- Weakening of terms with additional type variables lifted to
    -- collections of well-typed terms.
    weakenAll : ∀ {m n k} {Γ : Ktx n m} {ts : Vec (Term n m) k}
                  {as : Vec (Type n) k} → Γ ⊢ⁿ ts ∈ as →
                  ktx-weaken Γ ⊢ⁿ map tm-weaken ts ∈ map Tp.weaken as
    weakenAll {ts = []}    {[]}    []         = []
    weakenAll {ts = _ ∷ _} {_ ∷ _} (⊢t ∷ ⊢ts) = weaken ⊢t ∷ weakenAll ⊢ts

    -- Shorthand for single-variable type substitutions in well-typed
    -- terms.
    _[/_] : ∀ {m n} {Γ : Ktx (1 N+ n) m} {t a} →
            Γ ⊢ t ∈ a → (b : Type n) → Γ ktx/ sub b ⊢ t tm/tp sub b ∈ a Tp./ sub b
    ⊢t [/ b ] = ⊢t / sub b

    {-
    tm[/tp]-preserves : ∀ {ν n} {Γ : Ctx ν n} {t τ} → Γ ⊢ Λ t ∈ ∀' τ → ∀ a → Γ ⊢ (t tm[/tp a ]) ∈ τ tp[/tp a ]
    tm[/tp]-preserves {Γ = Γ} {t} {τ} (Λ p) a = ctx-subst C.ctx-weaken-sub-vanishes (p / (Tp.sub a))
      where
        ctx-subst = Prelude.subst (λ c → c ⊢ t tm[/tp a ] ∈ τ tp[/tp a ])
        -}

  module WtTermLemmas where
    private
      module Tp  = TypeLemmas
      module TmTp  = TermTypeLemmas
      module TmTm  = TermTermSubst
      module Var = VarSubst
      module C   = KtxLemmas
      TmSub = TmTm.TermSub Term

    infix 4 _⇒_⊢_

    -- Well-typed term substitutions are collections of well-typed terms.
    _⇒_⊢_ : ∀ {ν m k} → Ktx ν m → Ktx ν k → TmSub ν m k → Set
    Γ ⇒ Δ ⊢ s = Δ ⊢ⁿ s ∈ (proj₁ Γ)

    infixl 8  _/_ _/Var_
    infix  10 _↑

    -- Application of term variable substitutions (renaming) lifted to
    -- well-typed terms.
    _/Var_ : ∀ {ν m n} {K : Ktx ν n} {t : Term ν m} {a : Type ν}
               (s : Sub Fin m n) → s ktx/Var K ⊢ t ∈ a → K ⊢ t TmTm./Var s ∈ a
    _/Var_ {K = K} s (new c)   = new c
    _/Var_ {K = K} s (var x)   = ?
      -- ⊢substTp (sym (ktx/Var-lookup x ρ Γ)) (var (lookup x ρ))
    _/Var_ {K = K} s (Λ ⊢t)    = ?
      -- Λ    (ρ      /Var ⊢substCtx (ktx/Var-weaken ρ Γ) ⊢t)
    _/Var_ {K = K} s (λ' a ⊢t) = ?
      -- λ' a (ρ Var.↑ /Var ⊢substCtx (ktx/Var-∷ a ρ Γ) ⊢t)
    s /Var (⊢t [ b ])          = (s /Var ⊢t) [ b ]
    s /Var (⊢s · ⊢t)           = (s /Var ⊢s) · (s /Var ⊢t)
    s /Var (x)           = ?

    -- Weakening of terms with additional term variables lifted to
    -- well-typed terms.
    weaken : ∀ {ν n} {K : Ktx ν n} {t : Term ν n} {a b : Type ν} →
             K ⊢ t ∈ a → b ∷Γ K ⊢ TmTm.weaken t ∈ a
    weaken {K = K} {b = b} ⊢t = ? -- Var.wk /Var ⊢substCtx (C.wkVar-/Var-∷ Γ b) ⊢t

    -- Weakening of terms with additional term variables lifted to
    -- collections of well-typed terms.
    weakenAll : ∀ {ν n k} {K : Ktx ν n} {ts : Vec (Term ν n) k}
                  {as : Vec (Type ν) k} {b : Type ν} →
                K ⊢ⁿ ts ∈ as → (b ∷Γ K) ⊢ⁿ map TmTm.weaken ts ∈ as
    weakenAll {ts = []}    {[]}    []         = []
    weakenAll {ts = _ ∷ _} {_ ∷ _} (⊢t ∷ ⊢ts) = weaken ⊢t ∷ weakenAll ⊢ts

    -- Lifting of well-typed term substitutions.
    _↑ : ∀ {ν n} {Γ : Ktx ν n} {Δ : Ktx ν n} {ρ b} →
         Γ ⇒ Δ ⊢ ρ → b ∷Γ Γ ⇒ b ∷Γ Δ ⊢ ρ TmTm.↑
    ⊢ρ ↑ = var zero ∷ weakenAll ⊢ρ

    -- The well-typed identity substitution.
    id : ∀ {ν n} {K : Ktx ν n} → K ⇒ K ⊢ TmTm.id
    id {K = K} = ?
    -- id {zero}  {._} {K = [] , _}    = []
    -- id {suc _} {._} {K = a ∷ Γ , _} = id ↑

    -- Well-typed weakening (as a substitution).
    wk : ∀ {m n} {Γ : Ktx n m} {a} → Γ ⇒ a ∷Γ Γ ⊢ TmTm.wk
    wk = weakenAll id

    -- A well-typed substitution which only replaces the first variable.
    sub : ∀ {ν n} {K : Ktx ν n} {t a} → K ⊢ t ∈ a → a ∷Γ K ⇒ K ⊢ TmTm.sub t
    sub ⊢t = ⊢t ∷ id

    -- Application of term substitutions lifted to well-typed terms
    _/_ : ∀ {ν n} {K : Ktx ν n} {Δ : Ktx ν n} {t a s} →
          K ⊢ t ∈ a → K ⇒ Δ ⊢ s → Δ ⊢ t TmTm./ s ∈ a
    new c       / ⊢ρ = new c
    var x       / ⊢ρ = lookup-⊢ x ⊢ρ
    _/_ {K = K} {Δ = Δ} {s = s} (Λ ⊢t) ⊢ρ = Λ (⊢t / weaken-⊢p)
      where
        weaken-⊢p : ktx-weaken K ⇒ ktx-weaken Δ ⊢ map tm-weaken s
        weaken-⊢p = (WtTypeLemmas.weakenAll ⊢ρ)
    λ' a ⊢t     / ⊢ρ = λ' a (⊢t / ⊢ρ ↑)
    (⊢t [ a ])  / ⊢ρ = (⊢t / ⊢ρ) [ a ]
    (⊢s · ⊢t)   / ⊢ρ = (⊢s / ⊢ρ) · (⊢t / ⊢ρ)

    -- Shorthand for well-typed single-variable term substitutions.
    _[/_] : ∀ {m n} {Γ : Ctx n m} {s t a b} →
            b ∷ Γ ⊢ s ∈ a → Γ ⊢ t ∈ b → Γ ⊢ s TmTm./ TmTm.sub t ∈ a
    ⊢s [/ ⊢t ] = ⊢s / sub ⊢t

    tm[/tm]-preserves : ∀ {ν n} {Γ : Ctx ν n} {t u a b} →
                        b ∷ Γ ⊢ t ∈ a → Γ ⊢ u ∈ b → Γ ⊢ (t tm[/tm u ]) ∈ a
    tm[/tm]-preserves ⊢s ⊢t = ⊢s / sub ⊢t

  open WtTypeLemmas public using ()
    renaming (weaken to ⊢tp-weaken)
  open WtTermLemmas public using ()
    renaming (_/_ to _⊢/tp_; _[/_] to _⊢[/_]; weaken to ⊢weaken)
  -}


module Luau.Substitution where

open import Luau.Syntax using (Expr; Stat; Block; nil; addr; var; function_is_end; _$_; block_is_end; local_←_; _∙_; done; return; _⟨_⟩ ; name; fun; arg; number; binexp)
open import Luau.Value using (Value; val)
open import Luau.Var using (Var; _≡ⱽ_)
open import Properties.Dec using (Dec; yes; no)

_[_/_]ᴱ : ∀ {a} → Expr a → Value → Var → Expr a
_[_/_]ᴮ : ∀ {a} → Block a → Value → Var → Block a
var_[_/_]ᴱwhenever_ : ∀ {a P} → Var → Value → Var → (Dec P) → Expr a
_[_/_]ᴮunless_ : ∀ {a P} → Block a → Value → Var → (Dec P) → Block a

nil [ v / x ]ᴱ = nil
var y [ v / x ]ᴱ = var y [ v / x ]ᴱwhenever (x ≡ⱽ y)
addr a [ v / x ]ᴱ = addr a
(number y) [ v / x ]ᴱ = number y
(M $ N) [ v / x ]ᴱ = (M [ v / x ]ᴱ) $ (N [ v / x ]ᴱ)
function F is C end [ v / x ]ᴱ = function F is C [ v / x ]ᴮunless (x ≡ⱽ name(arg F)) end
block b is C end [ v / x ]ᴱ = block b is C [ v / x ]ᴮ end
(binexp e₁ op e₂) [ v / x ]ᴱ = binexp (e₁ [ v / x ]ᴱ) op (e₂ [ v / x ]ᴱ)

(function F is C end ∙ B) [ v / x ]ᴮ = function F is (C [ v / x ]ᴮunless (x ≡ⱽ name(arg F))) end ∙ (B [ v / x ]ᴮunless (x ≡ⱽ fun F))
(local y ← M ∙ B) [ v / x ]ᴮ = local y ← (M [ v / x ]ᴱ) ∙ (B [ v / x ]ᴮunless (x ≡ⱽ name y))
(return M ∙ B) [ v / x ]ᴮ = return (M [ v / x ]ᴱ) ∙ (B [ v / x ]ᴮ)
done [ v / x ]ᴮ = done

var y [ v / x ]ᴱwhenever yes p = val v
var y [ v / x ]ᴱwhenever no p = var y

B [ v / x ]ᴮunless yes p = B
B [ v / x ]ᴮunless no p = B [ v / x ]ᴮ


open import Agda.Builtin.Equality

postulate
   A : Set

Phantom : A → Set
Phantom _ = A

postulate
  rigid : A → A

mutual
  X : A → A → A → A
  X = _

  Y : (x y : A) → Phantom x
  Y = _

  -- This constraint triggers pruning of X in an attempt to remove the non-linearity.
  -- It doesn't get rid of the non-linearity but prunes x setting X x y z := Z y z,
  -- for a fresh meta Z.
  c₁ : (x y : A) → X x y y ≡ rigid y
  c₁ x y = refl

  -- Here we end up with Z y z == rigid (Y x y) which requires pruning x from Y. This
  -- fails due to the phantom dependency on x in the type of Y and the constraint is
  -- left unsolved. If we hadn't pruned x from X we could have solved this with
  -- X x y z := rigid (Y x y), turning the first constraint into rigid (Y x y) == rigid y,
  -- which is solved by Y x y := y.
  c₂ : (x y z : A) → X x y z ≡ rigid (Y x y)
  c₂ x y z =  refl