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

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

open import LibraBFT.Base.Types
open import LibraBFT.Impl.OBM.Rust.Duration     as Duration
open import LibraBFT.Impl.OBM.Rust.RustTypes
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Consensus.Liveness.ExponentialTimeInterval where

new : Duration → F64 → Usize → ExponentialTimeInterval
new base exponentBase maxExponent =
{- TODO-1
  if | maxExponent >= 32
       -> errorExit [ "ExponentialTimeInterval", "new"
                    , "maxExponent for PacemakerTimeInterval should be < 32", show maxExponent ]
     | ceiling (exponentBase ** fromIntegral maxExponent) >= {-F64-} (maxBound::Int)
       -> errorExit [ "ExponentialTimeInterval", "new"
                    , "maximum interval multiplier should be less then u32::Max"]
     | otherwise
       ->
-}        mkExponentialTimeInterval
            (Duration.asMillis base)
            exponentBase
            maxExponent


{- 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 Util.Prelude

-- This module defines types used in the specification of a SystemModel.
module Yasm.Types where

-- Actions that can be performed by peers.
--
-- For now, the SystemModel supports only one kind of action: to send a
-- message. Later it might include things like logging, crashes, assertion
-- failures, etc. For example, if an assertion fires, this
-- could "kill the process" and make it not send any messages in the future.
-- We could also then prove that the handlers do not crash, certain
-- messages are logged under certain circumstances, etc.
--
-- Alternatively, certain actions can be kept outside the system model by
-- defining an application-specific PeerState type (see `Yasm.Base`).
-- For example:
--
-- > libraHandle : Msg → Status × Log × LState → Status × LState × List Action
-- > libraHandle _ (Crashed , l , s) = Crashed , s , [] -- i.e., crashed peers never send messages
-- >
-- > handle = filter isSend ∘ libraHandle
data Action (Msg : Set) : Set where
  send : (m : Msg) → Action Msg

-- Injectivity of `send`.
action-send-injective : ∀ {Msg}{m m' : Msg} → send m ≡ send m' → m ≡ m'
action-send-injective refl = refl


open import Agda.Builtin.Nat

-- Matching against negative numbers

lit : Nat → Nat
lit -20 = 0  -- Error thrown here
lit _   = 1


-- Andreas, 2015-07-13  Better parse errors for illegal type signatures

-1 : Set1
-1 = Set


module CTL.Proof where

open import CTL.Proof.AG public
open import CTL.Proof.EG public


------------------------------------------------------------------------
-- A labelled transition system for the delay monad
------------------------------------------------------------------------

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

open import Prelude

module Labelled-transition-system.Delay-monad {a} (A : Type a) where

open import Delay-monad hiding (steps)
open import Equality.Propositional
open import Prelude.Size

open import Labelled-transition-system

------------------------------------------------------------------------
-- Transitions

infix 4 _[_]⟶_

data _[_]⟶_ : Delay A ∞ → Maybe A → Delay A ∞ → Type a where
  now   : ∀ {x} → now   x [ just x  ]⟶ now   x
  later : ∀ {x} → later x [ nothing ]⟶ force x

delay-monad : LTS a
delay-monad = record
  { Proc      = Delay A ∞
  ; Label     = Maybe A
  ; _[_]⟶_    = _[_]⟶_
  ; is-silent = if_then true else false
  }

open LTS delay-monad public hiding (_[_]⟶_)

------------------------------------------------------------------------
-- Some simple lemmas

-- If now x can make a sequence of silent transitions to y, then y
-- is equal to now x.

now[nothing]⟶ : ∀ {x y} → now x [ nothing ]⟶ y → y ≡ now x
now[nothing]⟶ ()

now⇒ : ∀ {x y} → now x ⇒ y → y ≡ now x
now⇒ done            = refl
now⇒ (step () now _)

now[nothing]⇒ : ∀ {x y} → now x [ nothing ]⇒ y → y ≡ now x
now[nothing]⇒ (steps nx⇒x′ x′⟶x″ x″⇒y)
  rewrite now⇒ nx⇒x′ | now[nothing]⟶ x′⟶x″ = now⇒ x″⇒y

now[nothing]⇒̂ : ∀ {x y} → now x [ nothing ]⇒̂ y → y ≡ now x
now[nothing]⇒̂ (silent _ tr)     = now⇒ tr
now[nothing]⇒̂ (non-silent ¬s _) = ⊥-elim (¬s _)

now[nothing]⟶̂ : ∀ {x y} → now x [ nothing ]⟶̂ y → y ≡ now x
now[nothing]⟶̂ (done _)  = refl
now[nothing]⟶̂ (step tr) = now[nothing]⟶ tr

-- If now x can make a just y-transition, then x is equal to y.

now[just]⟶ : ∀ {x y z} → now x [ just y ]⟶ z → x ≡ y
now[just]⟶ now = refl

now[just]⇒ : ∀ {x y z} → now x [ just y ]⇒ z → x ≡ y
now[just]⇒ (steps tr₁ tr₂ _) =
  now[just]⟶ (subst (_[ _ ]⟶ _) (now⇒ tr₁) tr₂)

now[just]⇒̂ : ∀ {x y z} → now x [ just y ]⇒̂ z → x ≡ y
now[just]⇒̂ (silent () _)
now[just]⇒̂ (non-silent _ tr) = now[just]⇒ tr

now[just]⟶̂ : ∀ {x y z} → now x [ just y ]⟶̂ z → x ≡ y
now[just]⟶̂ (done ())
now[just]⟶̂ (step tr) = now[just]⟶ tr

-- The computation never can only transition to itself.

never⟶never : ∀ {μ x} → never [ μ ]⟶ x → x ≡ never
never⟶never later = refl

never⇒never : ∀ {x} → never ⇒ x → x ≡ never
never⇒never done               = refl
never⇒never (step _ later ne⇒) = never⇒never ne⇒

never[]⇒never : ∀ {μ x} → never [ μ ]⇒ x → x ≡ never
never[]⇒never (steps ne⇒x x⟶y y⇒z)
  rewrite never⇒never ne⇒x | never⟶never x⟶y = never⇒never y⇒z

never⇒̂never : ∀ {μ x} → never [ μ ]⇒̂ x → x ≡ never
never⇒̂never (silent     _ ne⇒) = never⇒never ne⇒
never⇒̂never (non-silent _ ne⇒) = never[]⇒never ne⇒

never⟶̂never : ∀ {μ x} → never [ μ ]⟶̂ x → x ≡ never
never⟶̂never (done _)   = refl
never⟶̂never (step ne⟶) = never⟶never ne⟶

-- If never can make a μ-transition, then μ is silent.

never⟶→silent : ∀ {μ x} → never [ μ ]⟶ x → Silent μ
never⟶→silent later = _

never[]⇒→silent : ∀ {μ x} → never [ μ ]⇒ x → Silent μ
never[]⇒→silent (steps ne⇒x  x⟶  _) with never⇒never ne⇒x
never[]⇒→silent (steps ne⇒ne ne⟶ _) | refl = never⟶→silent ne⟶

never⇒̂→silent : ∀ {μ x} → never [ μ ]⇒̂ x → Silent μ
never⇒̂→silent (silent s _)       = s
never⇒̂→silent (non-silent _ ne⇒) = never[]⇒→silent ne⇒

never⟶̂→silent : ∀ {μ x} → never [ μ ]⟶̂ x → Silent μ
never⟶̂→silent (done s)   = s
never⟶̂→silent (step ne⟶) = never⟶→silent ne⟶

-- If x can make a non-silent transition, with label just y, to z,
-- then z is equal to now y.

[just]⟶ : ∀ {x y z} → x [ just y ]⟶ z → z ≡ now y
[just]⟶ now = refl

[just]⇒ : ∀ {x y z} → x [ just y ]⇒ z → z ≡ now y
[just]⇒ (steps _ now ny⇒z) = now⇒ ny⇒z

[just]⇒̂ : ∀ {x y z} → x [ just y ]⇒̂ z → z ≡ now y
[just]⇒̂ (silent () _)
[just]⇒̂ (non-silent _ x⇒z) = [just]⇒ x⇒z

[just]⟶̂ : ∀ {x y z} → x [ just y ]⟶̂ z → z ≡ now y
[just]⟶̂ (done ())
[just]⟶̂ (step x⟶z) = [just]⟶ x⟶z

-- In some cases x is also equal to now y.

[just]⟶→≡now : ∀ {x y z} → x [ just y ]⟶ z → x ≡ now y
[just]⟶→≡now now = refl

[just]⟶̂→≡now : ∀ {x y z} → x [ just y ]⟶̂ z → x ≡ now y
[just]⟶̂→≡now (done ())
[just]⟶̂→≡now (step x⟶z) = [just]⟶→≡now x⟶z

-- If force x can make a weak μ-transition (_[_]⇒_ or _[_]⇒̂_) to y,
-- then later x can also make a weak μ-transition (of the same kind)
-- to y.

later[]⇒ : ∀ {μ x y} → force x [ μ ]⇒ y → later x [ μ ]⇒ y
later[]⇒ = ⇒[]⇒-transitive (⟶→⇒ _ later)

later⇒̂ : ∀ {μ x y} → force x [ μ ]⇒̂ y → later x [ μ ]⇒̂ y
later⇒̂ = ⇒⇒̂-transitive (⟶→⇒ _ later)

-- The process x can make a silent transition to drop-later x.

⇒drop-later : ∀ {x} → x ⇒ drop-later x
⇒drop-later {now x}   = done
⇒drop-later {later x} = step _ later done

-- If x can make a transition to y, then drop-later x can in some
-- cases make a transition of the same kind to drop-later y.

drop-later-cong⟶ :
  ∀ {x μ y} →
  ¬ Silent μ → x [ μ ]⟶ y → drop-later x [ μ ]⟶ drop-later y
drop-later-cong⟶ _  now   = now
drop-later-cong⟶ ¬s later = ⊥-elim (¬s _)

drop-later-cong⇒ : ∀ {x y} → x ⇒ y → drop-later x ⇒ drop-later y
drop-later-cong⇒ done                = done
drop-later-cong⇒ (step () now   _)
drop-later-cong⇒ (step _  later x⇒y) =
  ⇒-transitive ⇒drop-later (drop-later-cong⇒ x⇒y)

drop-later-cong[]⇒ :
  ∀ {x μ y} →
  ¬ Silent μ → x [ μ ]⇒ y → drop-later x [ μ ]⇒ drop-later y
drop-later-cong[]⇒ ¬s (steps x⇒y y⟶z z⇒u) =
  steps (drop-later-cong⇒ x⇒y) (drop-later-cong⟶ ¬s y⟶z)
        (drop-later-cong⇒ z⇒u)

drop-later-cong⇒̂ :
  ∀ {x μ y} → x [ μ ]⇒̂ y → drop-later x [ μ ]⇒̂ drop-later y
drop-later-cong⇒̂ (silent s x⇒y)      = silent s (drop-later-cong⇒ x⇒y)
drop-later-cong⇒̂ (non-silent ¬s x⇒y) =
  non-silent ¬s (drop-later-cong[]⇒ ¬s x⇒y)

drop-later-cong⟶̂ :
  ∀ {x μ y} →
  ¬ Silent μ → x [ μ ]⟶̂ y → drop-later x [ μ ]⟶̂ drop-later y
drop-later-cong⟶̂ _  (done s)   = done s
drop-later-cong⟶̂ ¬s (step x⟶y) = step (drop-later-cong⟶ ¬s x⟶y)

-- If later x can make a transition to later y, then force x can
-- make a transition (of the same kind) to force y.

drop-later⟶ :
  ∀ {μ x y} → later x [ μ ]⟶ later y → force x [ μ ]⟶ force y
drop-later⟶ lx⟶ly = helper lx⟶ly refl refl
  where
  helper : ∀ {μ x x′ y y′} →
           later x [ μ ]⟶ y′ →
           y′ ≡ later y →
           x′ ≡ force x →
           x′ [ μ ]⟶ force y
  helper {x = x} {x′} {y} later x≡ly x′≡x =
    subst (_[ _ ]⟶ _) ly≡x′ later
    where
    ly≡x′ =
      later y  ≡⟨ sym x≡ly ⟩
      force x  ≡⟨ sym x′≡x ⟩∎
      x′       ∎

drop-later⇒ : ∀ {x y} → later x ⇒ later y → force x ⇒ force y
drop-later⇒ = drop-later-cong⇒

drop-later[]⇒ :
  ∀ {μ x y} → later x [ μ ]⇒ later y → force x [ μ ]⇒ force y
drop-later[]⇒ (steps lx⇒ly later y⇒lz) =
  ⇒[]⇒-transitive (⇒-transitive (drop-later⇒ lx⇒ly) y⇒lz)
                  (⟶→[]⇒ later)
drop-later[]⇒ (steps _ now ny⇒lz) with now⇒ ny⇒lz
... | ()

drop-later⇒̂ :
  ∀ {μ x y} → later x [ μ ]⇒̂ later y → force x [ μ ]⇒̂ force y
drop-later⇒̂ = drop-later-cong⇒̂

drop-later⟶̂ :
  ∀ {μ x y} → later x [ μ ]⟶̂ later y → force x [ μ ]⟶̂ force y
drop-later⟶̂ (done s)     = done s
drop-later⟶̂ (step lx⟶ly) = step (drop-later⟶ lx⟶ly)

-- If x makes silent transitions to both y and z, then one of y and
-- z makes silent transitions to the other.

⇒×⇒→… : ∀ {x y z} → x ⇒ y → x ⇒ z → y ⇒ z ⊎ z ⇒ y
⇒×⇒→… done               x⇒z                = inj₁ x⇒z
⇒×⇒→… x⇒y                done               = inj₂ x⇒y
⇒×⇒→… (step _ later x⇒y) (step _ later x⇒z) = ⇒×⇒→… x⇒y x⇒z
⇒×⇒→… (step () now _)

-- If x makes silent transitions to y and a non-silent weak
-- μ-transition (of one kind) to z, then y makes a weak μ-transition
-- to z.

⇒×⇒[]→… :
  ∀ {x y z μ} →
  ¬ Silent μ → x ⇒ y → x [ μ ]⇒ z → y [ μ ]⇒ z
⇒×⇒[]→… _ x⇒y (steps x⇒x′ x′⟶x″ x″⇒z) with ⇒×⇒→… x⇒y x⇒x′
⇒×⇒[]→… _ _   (steps _    x′⟶x″ x″⇒z) | inj₁ y⇒x′ = steps y⇒x′ x′⟶x″ x″⇒z
⇒×⇒[]→… _ _   (steps _    now   n⇒z)  | inj₂ done = steps done now   n⇒z

⇒×⇒[]→… _  _  _                 | inj₂ (step () now _)
⇒×⇒[]→… ¬s _  (steps _ later _) | _ = ⊥-elim (¬s _)

-- If x makes silent transitions to y and a weak μ-transition (of
-- one kind) to z, then either y makes a weak μ-transition to z, or
-- μ is silent and z makes silent transitions to y.

⇒×⇒̂→… :
  ∀ {x y z μ} → x ⇒ y → x [ μ ]⇒̂ z → y [ μ ]⇒̂ z ⊎ Silent μ × z ⇒ y
⇒×⇒̂→… x⇒y (silent     s  x⇒z) = ⊎-map (silent s) (s ,_)
                                      (⇒×⇒→… x⇒y x⇒z)
⇒×⇒̂→… x⇒y (non-silent ¬s x⇒z) =
  inj₁ (non-silent ¬s (⇒×⇒[]→… ¬s x⇒y x⇒z))


module _ where

open import Common.Prelude
open import Common.Reflection
open import Common.Equality

record Foo (A : Set) : Set where
  field
    foo : A → Nat

open Foo {{...}}

instance
  FooNat : Foo Nat
  foo {{FooNat}} n = n

  FooBool : Foo Bool
  foo {{FooBool}} true  = 1
  foo {{FooBool}} false = 0

macro
  do-foo : ∀ {A} {{_ : Foo A}} → A → Tactic
  do-foo x = give (lit (nat (foo x)))

test₁ : do-foo 5 ≡ 5
test₁ = refl

test₂ : do-foo false ≡ 0
test₂ = refl

macro
  lastHidden : {n : Nat} → Tactic
  lastHidden {n} = give (lit (nat n))

test₃ : lastHidden {4} ≡ 4
test₃ = refl

macro
  hiddenTerm : {a : Term} → Tactic
  hiddenTerm {a} = give a

test₄ : hiddenTerm {4} ≡ 4
test₄ = refl


open import Prelude

module Implicits.Semantics where

open import Implicits.Syntax
open import Implicits.WellTyped
open import Implicits.Semantics.Type public
open import Implicits.Semantics.Context public
open import Implicits.Semantics.RewriteContext public
open import Implicits.Semantics.Term public
open import Implicits.Semantics.Preservation public

open import SystemF.Everything as F using ()

module Semantics
  (_⊢ᵣ_ : ∀ {ν} → ICtx ν → Type ν → Set)
  (⟦_,_⟧r : ∀ {ν n} {K : Ktx ν n} {a} → (proj₂ K) ⊢ᵣ a → K# K →
            ∃ λ t → ⟦ proj₁ K ⟧ctx→ F.⊢ t ∈ ⟦ a ⟧tp→) where

  open TypingRules _⊢ᵣ_
  open TermSemantics _⊢ᵣ_ ⟦_,_⟧r public
  open Preservation _⊢ᵣ_ ⟦_,_⟧r public


module _ where

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

data ⊥ : Set where

record Pair : Set where
  constructor _,_
  field fst snd : String

open Pair

record ERing : Set where
  constructor ering
  field divRem : (⊥ → ⊥) → Pair

open ERing

eRing : ERing
eRing = ering λ _ → "fst" , "snd"

test : String
test = snd (divRem eRing (λ ()))

main : IO Unit
main = putStrLn test


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

module Data.Binary.Definition where

open import Level
open import Data.Bits public renaming (Bits to 𝔹; [] to 0ᵇ; 0∷_ to 1ᵇ_; 1∷_ to 2ᵇ_)

-- The following causes a performance hit:

-- open import Agda.Builtin.List using ([]; _∷_; List)
-- open import Agda.Builtin.Bool using (Bool; true; false)

-- 𝔹 : Type
-- 𝔹 = List Bool

-- infixr 8 1ᵇ_ 2ᵇ_
-- pattern 0ᵇ = []
-- pattern 1ᵇ_ xs = false ∷ xs
-- pattern 2ᵇ_ xs = true  ∷ xs


-- Andreas, 2020-04-15, issue #4586
-- Better error message when `let` contains a `where` clause.

foo : Set₁
foo = let x = Set
              where y = Set
      in  Set

-- WAS:
-- Not a valid let-declaration
-- when scope checking
-- let x = Set
--       where
--         y = Set
-- in Set

-- EXPECTED:
-- No `where' clauses allowed in let binding
-- when scope checking
-- let x = Set
--       where
--         y = Set
-- in Set


module STLC2.Kovacs.Completeness where

open import STLC2.Kovacs.Normalisation public
open import STLC2.Kovacs.Convertibility public

-- TODO: Remove this
postulate
  █ : ∀ {ℓ} → {X : Set ℓ} → X

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

-- (_≈_)
mutual
  infix 3 _≫_
  _≫_ : ∀ {A Γ} → Γ ⊢ A → Γ ⊩ A → Set

  _≫_ {⎵}      {Γ} M N = M ∼ embⁿᶠ N

  _≫_ {A ⇒ B} {Γ} M f = ∀ {Γ′} → (η : Γ′ ⊇ Γ)
                                → {N : Γ′ ⊢ A} {∂a : Γ′ ∂⊩ A}
                                → N ∂≫ ∂a
                                → ren η M ∙ N ∂≫ f η ∂a

  _≫_ {A ⩕ B}  {Γ} M s = π₁ M ∂≫ proj₁ s × π₂ M ∂≫ proj₂ s

  _≫_ {⫪}     {Γ} M s = ⊤

  _≫_ {⫫}     {Γ} M s = ⊥

  _≫_ {A ⩖ B}  {Γ} M s = elim⊎ s (λ ∂a → Σ (Γ ⊢ A) (λ M₁ → M₁ ∂≫ ∂a))
                                 (λ ∂b → Σ (Γ ⊢ B) (λ M₂ → M₂ ∂≫ ∂b))

  infix 3 _∂≫_
  _∂≫_ : ∀ {Γ A} → Γ ⊢ A → Γ ∂⊩ A → Set

  _∂≫_ {Γ} {A} M ∂a
    = ∀ {Γ′ C} → (η : Γ′ ⊇ Γ)
               → {N : Γ′ ⊢ C}
               → {Nⁿᶠ : Γ′ ⊢ⁿᶠ C}
               → (f : ∀ {Γ″} → (η′ : Γ″ ⊇ Γ′)
                              → {a : Γ″ ⊩ A}
                              → ren (η ○ η′) M ≫ a
                              → ren η′ N ∼ embⁿᶠ (renⁿᶠ η′ Nⁿᶠ))
               → N ∼ embⁿᶠ Nⁿᶠ

-- (_≈ᶜ_)
infix 3 _∂≫⋆_
data _∂≫⋆_ : ∀ {Γ Ξ} → Γ ⊢⋆ Ξ → Γ ∂⊩⋆ Ξ → Set
  where
    ∅   : ∀ {Γ} → ∅ {Γ} ∂≫⋆ ∅

    _,_ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ∂⊩⋆ Ξ}
                    → (χ : σ ∂≫⋆ ρ)
                    → {M : Γ ⊢ A} {∂a : Γ ∂⊩ A}
                    → (∂q : M ∂≫ ∂a)
                    → σ , M ∂≫⋆ ρ , ∂a

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

-- (_∼◾≈_)
mutual
  coe≫ : ∀ {A Γ} → {M₁ M₂ : Γ ⊢ A}
                 → M₁ ∼ M₂ → {a : Γ ⊩ A} → M₁ ≫ a
                 → M₂ ≫ a
  coe≫ {⎵}      p {N}      q = p ⁻¹ ⦙ q
  coe≫ {A ⇒ B} p {f}      g = λ η {N} {∂a} ∂q →
                                 ∂coe≫ {∂a = λ η′ f′ → f η ∂a η′ f′}
                                       (ren∼ η p ∙∼ (refl∼ {M = N}))
                                       (g η {N} {∂a} ∂q)
  coe≫ {A ⩕ B}  p {s}      q = ∂coe≫ {∂a = proj₁ s} (π₁∼ p) (proj₁ q) ,
                               ∂coe≫ {∂a = proj₂ s} (π₂∼ p) (proj₂ q)
  coe≫ {⫪}     p {s}      q = tt
  coe≫ {⫫}     p {s}      q = elim⊥ s
  coe≫ {A ⩖ B}  p {inj₁ a} q = q
  coe≫ {A ⩖ B}  p {inj₂ b} q = q

  ∂coe≫ : ∀ {A Γ} → {M₁ M₂ : Γ ⊢ A} {∂a : Γ ∂⊩ A}
                  → M₁ ∼ M₂ → M₁ ∂≫ ∂a
                  → M₂ ∂≫ ∂a

  ∂coe≫ p ∂q
    = λ η {N} {Nⁿᶠ} f →
        ∂q η {N} {Nⁿᶠ} (λ η′ {a} q →
          f η′ (coe≫ (ren∼ (η ○ η′) p)
                     q))

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

-- (≈ₑ)
mutual
  acc≫ : ∀ {A Γ Γ′} → (η : Γ′ ⊇ Γ)
                    → {M : Γ ⊢ A} {a : Γ ⊩ A}
                    → M ≫ a
                    → ren η M ≫ acc η a
  acc≫ {⎵}      η {M} {N}      p         = coe ((λ N′ → ren η M ∼ N′)
                                                & natembⁿᶠ η N ⁻¹)
                                               (ren∼ η p)
  acc≫ {A ⇒ B} η {M} {f}      g         η′ {N} {∂a}
                                         rewrite ren○ η′ η M ⁻¹
                                         = g (η ○ η′) {N} {∂a}
  acc≫ {A ⩕ B}  η {M} {s}      q         = ∂acc≫ η {π₁ M} {proj₁ s} (proj₁ q)
                                         , ∂acc≫ η {π₂ M} {proj₂ s} (proj₂ q)
  acc≫ {⫪}     η {M} {s}      q         = tt
  acc≫ {⫫}     η {M} {s}      q         = elim⊥ s
  acc≫ {A ⩖ B}  η {M} {inj₁ a} (M₁ , ∂a) = ren η M₁ , ∂acc≫ η {M₁} {a} ∂a
  acc≫ {A ⩖ B}  η {M} {inj₂ b} (M₂ , ∂b) = ren η M₂ , ∂acc≫ η {M₂} {b} ∂b

  ∂acc≫ : ∀ {A Γ Γ′} → (η : Γ′ ⊇ Γ)
                     → {M : Γ ⊢ A} {∂a : Γ ∂⊩ A}
                     → M ∂≫ ∂a
                     → ren η M ∂≫ ∂acc η ∂a

  ∂acc≫ η {M} ∂q
    = λ η′ {N} {Nⁿᶠ} f →
        ∂q (η ○ η′) {N} {Nⁿᶠ} (λ η″ q →
          f η″ (coe≫ (coe (_∼_ & ((λ η‴ → ren η‴ M) & assoc○ η″ η′ η ⁻¹)
                               ⊗ ren○ (η′ ○ η″) η M)
                          refl∼)
                     q))

-- (≈ᶜₑ)
-- NOTE: _⬖≫_ = ∂acc≫⋆
_⬖≫_ : ∀ {Γ Γ′ Ξ} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ∂⊩⋆ Ξ}
                  → (χ : σ ∂≫⋆ ρ) (η : Γ′ ⊇ Γ)
                  → σ ◐ η ∂≫⋆ ρ ⬖ η
∅                 ⬖≫ η = ∅
_,_ χ {M} {∂a} ∂q ⬖≫ η = χ ⬖≫ η , ∂acc≫ η {M} {∂a} ∂q

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

return≫ : ∀ {A Γ} → {M : Γ ⊢ A} {a : Γ ⊩ A}
                  → M ≫ a → M ∂≫ return a

return≫ {M = M} {a} q
  = λ η {N} {Nⁿᶠ} f →
      coe (_∼_ & idren N
               ⊗ embⁿᶠ & idrenⁿᶠ Nⁿᶠ)
          (f idₑ {acc η a}
                 (coe≫ (coe ((λ η′ → ren η M ∼ ren η′ M)
                             & (rid○ η ⁻¹))
                            refl∼)
                       (acc≫ η {M} {a} q)))

bind≫ : ∀ {A C Γ} → {M : Γ ⊢ A} {∂a : Γ ∂⊩ A}
                     {N : Γ ⊢ C} {∂c : Γ ∂⊩ C}
                  → M ∂≫ ∂a → (∀ {Γ′} → (η : Γ′ ⊇ Γ)
                                        → {a : Γ′ ⊩ A}
                                        → ren η M ≫ a
                                        → ren η N ∂≫ ∂acc η ∂c)
                  → N ∂≫ ∂c

bind≫ {M = M} {∂a} {N} {∂c} ∂q f
  = λ η {N′} {Nⁿᶠ′} f′ →
      ∂q η {N′} {Nⁿᶠ′} (λ η′ {a} q →
        f (η ○ η′) {a} q idₑ {ren η′ N′} {renⁿᶠ η′ Nⁿᶠ′} (λ η″ {c} q′ →
          coe (_∼_ & ren○ η″ η′ N′
                   ⊗ embⁿᶠ & renⁿᶠ○ η″ η′ Nⁿᶠ′)
              (f′ (η′ ○ η″) (coe≫ (coe (_∼_ & ren○ (idₑ ○ η″) (η ○ η′) N
                                            ⊗ (λ η‴ → ren η‴ N)
                                              & ( (λ η‴ → (η ○ η′) ○ η‴)
                                                  & lid○ η″
                                                ⦙ assoc○ η″ η′ η
                                                ))
                                       refl∼)
                                  q′))))

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

-- (∈≈)
get≫ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ∂⊩⋆ Ξ}
                 → σ ∂≫⋆ ρ → (i : Ξ ∋ A)
                 → getₛ σ i ∂≫ getᵥ ρ i
get≫ (χ , p) zero    = p
get≫ (χ , p) (suc i) = get≫ χ i

-- (Tm≈)
eval≫ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ∂⊩⋆ Ξ}
                 → σ ∂≫⋆ ρ → (M : Ξ ⊢ A)
                 → sub σ M ∂≫ eval ρ M

eval≫ {σ = σ} {ρ} χ (𝓋 i)
  = get≫ χ i

eval≫ {σ = σ} {ρ} χ (ƛ M)
  = return≫ {M = ƛ (sub (liftₛ σ) M)}
            {a = λ {Γ′} η ∂a → eval (ρ ⬖ η , ∂a) M}
            (λ {Γ′} η {N} {∂a} ∂q →
              ∂coe≫ {∂a = eval (ρ ⬖ η , ∂a) M}
                    (coe (((ƛ (ren (liftₑ η) (sub (liftₛ σ) M)) ∙ N) ∼_)
                          & ( sub◑ (idₛ , N) (liftₑ η) (sub (liftₛ σ) M) ⁻¹
                            ⦙ sub● (liftₑ η ◑ (idₛ , N)) (liftₛ σ) M ⁻¹
                            ⦙ (λ σ′ → sub (σ′ , N) M)
                              & ( comp●◑ (η ◑ idₛ , N) (wkₑ idₑ) σ
                                ⦙ (σ ●_) & lid◑ (η ◑ idₛ)
                                ⦙ comp●◑ idₛ η σ ⁻¹
                                ⦙ rid● (σ ◐ η)
                                )
                            ))
                         (red⇒ (ren (liftₑ η) (sub (liftₛ σ) M)) N) ⁻¹)
                    (eval≫ (_,_ (χ ⬖≫ η) {∂a = ∂a} (∂q)) M))

eval≫ {σ = σ} {ρ} χ (M ∙ N)
  = bind≫ {M  = sub σ M}
          {∂a = eval ρ M}
          {N  = sub σ M ∙ sub σ N}
          {∂c = eval ρ M ∂!∙ eval ρ N}
          (eval≫ χ M)
          (λ η {f} g →
            ∂coe≫ {∂a = eval (ρ ⬖ η) M ∂!∙ eval (ρ ⬖ η) N}
                  (coe (_∼_ & ((λ M′ → M′ ∙ ren η (sub σ N))
                               & ( (λ η′ → ren η′ (sub σ M))
                                   & (rid○ η ⁻¹)
                                 ⦙ ren○ idₑ η (sub σ M)
                                 ))
                            ⊗ refl)
                       refl∼)
                  (g idₑ {∂a = ∂acc η (eval ρ N)}
                         (∂coe≫ {∂a = eval (ρ ⬖ η) N}
                                (≡→∼ (sub◐ η σ N))
                                (eval≫ (χ ⬖≫ η) N))))

eval≫ {σ = σ} {ρ} χ (M , N)
  = return≫ {M = sub σ M , sub σ N}
            {a = eval ρ M , eval ρ N}
            ( ∂coe≫ {∂a = eval ρ M}
                    (red⩕₁ (sub σ M) (sub σ N) ⁻¹)
                    (eval≫ χ M)
            , ∂coe≫ {∂a = eval ρ N}
                    (red⩕₂ (sub σ M) (sub σ N) ⁻¹)
                    (eval≫ χ N)
            )

eval≫ {σ = σ} {ρ} χ (π₁ M)
  = bind≫ {M  = sub σ M}
          {∂a = eval ρ M}
          {N  = π₁ (sub σ M)}
          {∂c = ∂!π₁ (eval ρ M)}
          (eval≫ χ M)
          (λ η q → proj₁ q)

eval≫ {σ = σ} {ρ} χ (π₂ M)
  = bind≫ {M  = sub σ M}
          {∂a = eval ρ M}
          {N  = π₂ (sub σ M)}
          {∂c = ∂!π₂ (eval ρ M)}
          (eval≫ χ M)
          (λ η q → proj₂ q)

eval≫ {σ = σ} {ρ} χ τ
  = return≫ {M = τ} tt

eval≫ {σ = σ} {ρ} χ (φ M)
  = bind≫ {M  = sub σ M}
          {∂a = eval ρ M}
          {N  = φ (sub σ M)}
          {∂c = ∂!φ (eval ρ M)}
          (eval≫ χ M)
          (λ η q → elim⊥ q)

eval≫ {σ = σ} {ρ} χ (ι₁ M)
  = return≫ {M = ι₁ (sub σ M)}
            {a = inj₁ (eval ρ M)}
            (sub σ M , eval≫ χ M)

eval≫ {σ = σ} {ρ} χ (ι₂ M)
  = return≫ {M = ι₂ (sub σ M)}
            {a = inj₂ (eval ρ M)}
            (sub σ M , eval≫ χ M)

eval≫ {σ = σ} {ρ} χ (M ⁇ N₁ ∥ N₂)
  = bind≫ {M  = sub σ M}
          {∂a = eval ρ M}
          {N  = sub σ M ⁇ sub (liftₛ σ) N₁
                        ∥ sub (liftₛ σ) N₂}
          {∂c = eval ρ M ∂!⁇ (λ η ∂a → eval (ρ ⬖ η , ∂a) N₁)
                         ∂!∥ (λ η ∂b → eval (ρ ⬖ η , ∂b) N₂)}
          (eval≫ χ M)
          (λ { η {inj₁ ∂a} (M₁ , ∂q) →
                 λ η′ {N} {Nⁿᶠ} f →
                   ∂q η′ {N} {Nⁿᶠ} (λ η″ {a} q →
                     █)
             ; η {inj₂ ∂b} (M₂ , ∂q) →
                 λ η′ {N} {Nⁿᶠ} f →
                   ∂q η′ {N} {Nⁿᶠ} (λ η″ {a} q →
                     █)
             })

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

mutual
  -- (q≈)
  reify≫ : ∀ {A Γ} → {M : Γ ⊢ A} {a : Γ ∂⊩ A}
                   → (∂q : M ∂≫ a)
                   → M ∼ embⁿᶠ (reify a)

  reify≫ {⎵} {M = M} {∂a} ∂q
    = ∂q idₑ {M} {reify ∂a} (λ η {N} p →
        █)

  reify≫ {A ⇒ B} {M = M} {∂a} ∂q
    = ∂q idₑ {M} {reify ∂a} (λ η {f} g →
        █)

  reify≫ {A ⩕ B} {M = M} {∂a} ∂q
    = ∂q idₑ {M} {reify ∂a} (λ η {s} q →
        █)

  reify≫ {⫪} {M = M} {∂a} ∂q
    = ∂q idₑ {M} {reify ∂a} (λ η {s} q →
        coe ((λ M′ → ren η M ∼ M′)
             & natembⁿᶠ η (∂a idₑ (λ η′ s′ → τ)) ⁻¹)
            (ren∼ {M₁ = M}
                  {M₂ = embⁿᶠ (∂a idₑ (λ η′ s′ → τ))}
                  η
                  █))

  reify≫ {⫫} {M = M} {∂a} ∂q
    = ∂q idₑ {M} {reify ∂a} (λ η {s} q →
        █)

  reify≫ {A ⩖ B} {M = M} {∂a} ∂q
    = ∂q idₑ {M} {reify ∂a} (λ η {s} q →
        █)

  -- (u≈)
  reflect≫ : ∀ {A Γ} → (M : Γ ⊢ⁿᵉ A)
                     → embⁿᵉ M ∂≫ reflect M

  reflect≫ {⎵} M
    = return≫ {M = embⁿᵉ M}
              {a = ne M}
              refl∼

  reflect≫ {A ⇒ B} M
    = return≫ {M = embⁿᵉ M}
              {a = λ η ∂a → reflect (renⁿᵉ η M ∙ reify ∂a)}
              (λ η {N} {∂a} ∂q →
                ∂coe≫ {∂a = ∂acc η (reflect M) ∂!∙ ∂a}
                      (≡→∼ (natembⁿᵉ η M ⁻¹) ∙∼ reify≫ ∂q ⁻¹)
                      (reflect≫ (renⁿᵉ η M ∙ reify ∂a)))

  reflect≫ {A ⩕ B} M
    = return≫ {M = embⁿᵉ M}
              {a = reflect (π₁ M) , reflect (π₂ M)}
              (reflect≫ (π₁ M) , reflect≫ (π₂ M))

  reflect≫ {⫪} M
    = return≫ {M = embⁿᵉ M}
              {a = tt}
              tt

  reflect≫ {⫫} M
    = λ η {N} {Nⁿᶠ} f →
        coe (_∼_ & idren N
                 ⊗ embⁿᶠ & idrenⁿᶠ Nⁿᶠ)
            (f idₑ {█} █)

  reflect≫ {A ⩖ B} M
    = λ η {N} {Nⁿᶠ} f →
        coe (_∼_ & idren N
                 ⊗ embⁿᶠ & idrenⁿᶠ Nⁿᶠ)
            (f idₑ {█} █)

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

-- (uᶜ≈)
id≫⋆ : ∀ {Γ} → idₛ {Γ} ∂≫⋆ idᵥ
id≫⋆ {∅}     = ∅
id≫⋆ {Γ , A} = id≫⋆ ⬖≫ wkₑ idₑ , reflect≫ 0

complete : ∀ {Γ A} → (M : Γ ⊢ A)
                   → M ∼ embⁿᶠ (nf M)
complete M = coe ((_∼ embⁿᶠ (reify (eval idᵥ M))) & idsub M)
                 (reify≫ (eval≫ id≫⋆ M))

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


module Theory where

open import Data.List using (List; []; _∷_; _++_)
open import Data.Fin using () renaming (zero to fzero; suc to fsuc)

open import Relation.Binary using (Rel)

open import Level using (suc; _⊔_)

open import Syntax

record Theory ℓ₁ ℓ₂ ℓ₃ : Set (suc (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)) where
  field
    Sg : Signature ℓ₁ ℓ₂

  open Signature Sg
  open Term Sg

  field
    Ax : forall Γ A -> Rel (Γ ⊢ A) ℓ₃

  infix 3 _⊢_≡_
  infix 3 _⊨_≡_

  data _⊢_≡_ : forall Γ {A} -> Γ ⊢ A -> Γ ⊢ A -> Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)
  data _⊨_≡_ : forall Γ {Γ′} -> Γ ⊨ Γ′ -> Γ ⊨ Γ′ -> Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)

  -- Theorems
  data _⊢_≡_ where
    ax : forall {Γ A e₁ e₂} -> Ax Γ A e₁ e₂ -> Γ ⊢ e₁ ≡ e₂

    refl : forall {Γ} {A} {e : Γ ⊢ A} -> Γ ⊢ e ≡ e
    sym : forall {Γ} {A} {e₁ : Γ ⊢ A} {e₂} -> Γ ⊢ e₁ ≡ e₂ -> Γ ⊢ e₂ ≡ e₁
    trans : forall {Γ} {A} {e₁ : Γ ⊢ A} {e₂ e₃} -> Γ ⊢ e₁ ≡ e₂ -> Γ ⊢ e₂ ≡ e₃ -> Γ ⊢ e₁ ≡ e₃

    sub/id : forall {Γ} {A} {e : Γ ⊢ A} -> Γ ⊢ e [ id ] ≡ e
    sub/∙ : forall {Γ} {A} {Γ′ Γ′′} {e : Γ′′ ⊢ A} {γ : Γ′ ⊨ Γ′′} {δ}
      -> Γ ⊢ e [ γ ∙ δ ] ≡ e [ γ ] [ δ ]

    eta/Unit : forall {Γ} (e : Γ ⊢ Unit) -> Γ ⊢ unit ≡ e

    beta/*₁ : forall {Γ} {A B} (e₁ : Γ ⊢ A) (e₂ : Γ ⊢ B) -> Γ ⊢ fst (pair e₁ e₂) ≡ e₁
    beta/*₂ : forall {Γ} {A B} (e₁ : Γ ⊢ A) (e₂ : Γ ⊢ B) -> Γ ⊢ snd (pair e₁ e₂) ≡ e₂
    eta/* : forall {Γ} {A B} (e : Γ ⊢ A * B) -> Γ ⊢ pair (fst e) (snd e) ≡ e

    beta/=> : forall {Γ} {A B} (e : A ∷ Γ ⊢ B) (e′ : Γ ⊢ A) -> Γ ⊢ app (abs e) e′ ≡ e [ ext id e′ ]
    eta/=> : forall {Γ} {A B} (e : Γ ⊢ A => B) -> Γ ⊢ abs (app (e [ weaken ]) var) ≡ e

    -- cong
    cong/func : forall {Γ} {f : Func} {e e′ : Γ ⊢ dom f}
      -> Γ ⊢ e ≡ e′
      -> Γ ⊢ func f e ≡ func f e′
    cong/sub : forall {Γ Γ′} {γ γ′ : Γ ⊨ Γ′} {A} {e e′ : Γ′ ⊢ A}
      -> Γ ⊨ γ ≡ γ′
      -> Γ′ ⊢ e ≡ e′
      -> Γ ⊢ e [ γ ] ≡ e′ [ γ′ ]
    cong/pair : forall {Γ} {A B} {e₁ e₁′ : Γ ⊢ A} {e₂ e₂′ : Γ ⊢ B}
      -> Γ ⊢ e₁ ≡ e₁′
      -> Γ ⊢ e₂ ≡ e₂′
      -> Γ ⊢ pair e₁ e₂ ≡ pair e₁′ e₂′
    cong/fst : forall {Γ} {A B} {e e′ : Γ ⊢ A * B}
      -> Γ ⊢ e ≡ e′
      -> Γ ⊢ fst e ≡ fst e′
    cong/snd : forall {Γ} {A B} {e e′ : Γ ⊢ A * B}
      -> Γ ⊢ e ≡ e′
      -> Γ ⊢ snd e ≡ snd e′
    cong/abs : forall {Γ} {A B} {e e′ : A ∷ Γ ⊢ B}
      -> A ∷ Γ ⊢ e ≡ e′
      -> Γ ⊢ abs e ≡ abs e′
    cong/app : forall {Γ} {A B} {e₁ e₁′ : Γ ⊢ A => B} {e₂ e₂′ : Γ ⊢ A}
      -> Γ ⊢ e₁ ≡ e₁′
      -> Γ ⊢ e₂ ≡ e₂′
      -> Γ ⊢ app e₁ e₂ ≡ app e₁′ e₂′

    -- subst commutes with term formers
    comm/func : forall Γ Γ′ (γ : Γ ⊨ Γ′) f e
      -> Γ ⊢ func f e [ γ ] ≡ func f (e [ γ ])

    comm/unit : forall Γ Γ′ (γ : Γ ⊨ Γ′)
      -> Γ ⊢ unit [ γ ] ≡ unit

    comm/pair : forall {Γ Γ′} {γ : Γ ⊨ Γ′} {A B} {e₁ : Γ′ ⊢ A} {e₂ : Γ′ ⊢ B}
      -> Γ ⊢ pair e₁ e₂ [ γ ] ≡ pair (e₁ [ γ ]) (e₂ [ γ ])
    comm/fst : forall {Γ Γ′} {γ : Γ ⊨ Γ′} {A B} {e : Γ′ ⊢ A * B}
      -> Γ ⊢ fst e [ γ ] ≡ fst (e [ γ ])
    comm/snd : forall {Γ Γ′} {γ : Γ ⊨ Γ′} {A B} {e : Γ′ ⊢ A * B}
      -> Γ ⊢ snd e [ γ ] ≡ snd (e [ γ ])

    comm/abs : forall {Γ Γ′} {γ : Γ ⊨ Γ′} {A B} {e : A ∷ Γ′ ⊢ B}
      -> Γ ⊢ (abs e) [ γ ] ≡ abs (e [ ext (γ ∙ weaken) var ])
    comm/app : forall {Γ Γ′} {γ : Γ ⊨ Γ′} {A B} {e₁ : Γ′ ⊢ A => B} {e₂}
      -> Γ ⊢ app e₁ e₂ [ γ ] ≡ app (e₁ [ γ ]) (e₂ [ γ ])

    var/ext : forall {Γ Γ′} (γ : Γ ⊨ Γ′) {A} (e : Γ ⊢ A)
      -> Γ ⊢ var [ ext γ e ] ≡ e

  data _⊨_≡_ where
    refl : forall {Γ Γ′} {γ : Γ ⊨ Γ′} -> Γ ⊨ γ ≡ γ
    sym : forall {Γ Γ′} {γ γ′ : Γ ⊨ Γ′} -> Γ ⊨ γ ≡ γ′ -> Γ ⊨ γ′ ≡ γ
    trans : forall {Γ Γ′} {γ₁ γ₂ γ₃ : Γ ⊨ Γ′}
      -> Γ ⊨ γ₁ ≡ γ₂
      -> Γ ⊨ γ₂ ≡ γ₃
      -> Γ ⊨ γ₁ ≡ γ₃

    id∙ˡ : forall {Γ Γ′} {γ : Γ ⊨ Γ′} -> Γ ⊨ id ∙ γ ≡ γ
    id∙ʳ : forall {Γ Γ′} {γ : Γ ⊨ Γ′} -> Γ ⊨ γ ∙ id ≡ γ

    assoc∙ : forall {Γ Γ′ Γ′′ Γ′′′} {γ₁ : Γ′′ ⊨ Γ′′′} {γ₂ : Γ′ ⊨ Γ′′} {γ₃ : Γ ⊨ Γ′}
      -> Γ ⊨ (γ₁ ∙ γ₂) ∙ γ₃ ≡ γ₁ ∙ (γ₂ ∙ γ₃)

    !-unique : forall {Γ} {γ : Γ ⊨ []} -> Γ ⊨ ! ≡ γ
    η-pair : forall {Γ : Context} {A : Type}
      -> A ∷ Γ ⊨ ext weaken var ≡ id
    ext∙ : forall {Γ Γ′ Γ′′} {γ : Γ′ ⊨ Γ′′} {γ′ : Γ ⊨ Γ′} {A} {e : Γ′ ⊢ A}
      -> Γ ⊨ ext γ e ∙ γ′ ≡ ext (γ ∙ γ′) (e [ γ′ ])

    weaken/ext : forall {Γ Γ′} {γ : Γ ⊨ Γ′} {A} {e : Γ ⊢ A}
      -> Γ ⊨ weaken ∙ ext γ e ≡ γ

    cong/ext : forall {Γ Γ′} {γ γ′ : Γ ⊨ Γ′} {A} {e e′ : Γ ⊢ A}
      -> Γ ⊨ γ ≡ γ′
      -> Γ ⊢ e ≡ e′
      -> Γ ⊨ ext γ e ≡ ext γ′ e′
    cong/∙ : forall {Γ Γ′ Γ′′} {γ γ′ : Γ′ ⊨ Γ′′} {δ δ′ : Γ ⊨ Γ′}
      -> Γ′ ⊨ γ ≡ γ′
      -> Γ ⊨ δ ≡ δ′
      -> Γ ⊨ γ ∙ δ ≡ γ′ ∙ δ′

  ×id′-∙ : forall {Γ Γ′ Γ′′} {γ′ : Γ ⊨ Γ′} {γ : Γ′ ⊨ Γ′′} {A}
    -> A ∷ Γ ⊨ γ ×id′ ∙ γ′ ×id′ ≡ (γ ∙ γ′) ×id′
  ×id′-∙ = trans ext∙ (cong/ext (trans assoc∙ (trans (cong/∙ refl weaken/ext) (sym assoc∙))) (var/ext _ _))

  ×id′-ext : forall {Γ Γ′ Γ′′} {γ′ : Γ ⊨ Γ′} {γ : Γ′ ⊨ Γ′′} {A} {e : Γ ⊢ A}
    -> Γ ⊨ γ ×id′ ∙ ext γ′ e ≡ ext (γ ∙ γ′) e
  ×id′-ext = trans ext∙ (cong/ext (trans assoc∙ (cong/∙ refl weaken/ext)) (var/ext _ _))

  open import Relation.Binary.Bundles

  TermSetoid : forall {Γ : Context} {A : Type} -> Setoid (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)
  TermSetoid {Γ} {A} = record
             { Carrier = Γ ⊢ A
             ; _≈_ = λ e₁ e₂ → Γ ⊢ e₁ ≡ e₂
             ;isEquivalence = record { refl = refl ; sym = sym ; trans = trans }
             }

  SubstSetoid : forall {Γ : Context} {Γ′ : Context} -> Setoid (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)
  SubstSetoid {Γ} {Γ′} = record
             { Carrier = Γ ⊨ Γ′
             ; _≈_ = λ γ₁ γ₂ → Γ ⊨ γ₁ ≡ γ₂
             ;isEquivalence = record { refl = refl ; sym = sym ; trans = trans }
             }

open import Categories.Category
open import Categories.Category.CartesianClosed

module _ {o ℓ e} (𝒞 : Category o ℓ e) (CC : CartesianClosed 𝒞) {ℓ₁ ℓ₂ ℓ₃} (Th : Theory ℓ₁ ℓ₂ ℓ₃) where
  open Category 𝒞
  open import Data.Product using (Σ-syntax)
  open Theory Th
  open import Semantics 𝒞 CC Sg

  Model : Set (o ⊔ ℓ ⊔ e ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)
  Model = Σ[ M ∈ Structure ] forall {Γ A e₁ e₂} -> Ax Γ A e₁ e₂ -> ⟦ e₁ ⟧ M ≈ ⟦ e₂ ⟧ M


open import Common.IO
open import Agda.Builtin.String
open import Agda.Builtin.Unit
open import Agda.Builtin.Nat
open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality
open import Agda.Builtin.Bool
open import Agda.Builtin.Strict

data ∋⋆ : Set where
  Z : ∋⋆

data ⊢⋆ : Set where
  size⋆ : Nat → ⊢⋆

⋆Sub : Set
⋆Sub = ∋⋆ → ⊢⋆

data TermCon : ⊢⋆ → Set where
  integer : (s : Nat) → TermCon (size⋆ s)

data ⊢_ : ⊢⋆ → Set where
  con : ∀ {s} → TermCon (size⋆ s) → ⊢ size⋆ s

data Value : {A : ⊢⋆} → ⊢ A → Set where
  V-con : ∀ {n} → (cn : TermCon (size⋆ n)) → Value (con cn)

notErased : Nat → Bool
notErased n = primForce n λ _ → true

BUILTIN : (σ : ⋆Sub) (vtel : Σ (⊢ σ Z) Value) → Bool
BUILTIN σ vtel with σ Z
BUILTIN σ (_ , V-con (integer s)) | _ = notErased s
-- Either of these work:
-- BUILTIN σ (_ , V-con (integer s)) | size⋆ s = notErased s
-- BUILTIN σ (con (integer s) , V-con (integer s)) | _ = notErased s

con2 : ⊢ size⋆ 8
con2 = con (integer 8)

vcon2 : Value con2
vcon2 = V-con (integer 8)

builtin2plus2 : Bool
builtin2plus2 = BUILTIN (λ _ → size⋆ 8) (con2 , vcon2)

help : Bool → String
help true  = "4"
help false = "something went wrong"

check : "4" ≡ help builtin2plus2
check = refl

main : IO ⊤
main = putStrLn (help builtin2plus2)


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

open import Definition.Typed.EqualityRelation

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

open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Substitution
open import Definition.Untyped using (Con ; Term)

open import Tools.Nat
open import Tools.Product

private
  variable
    n : Nat
    Γ : Con Term n

-- Any level can be embedded into the highest level (validity variant).
maybeEmbᵛ : ∀ {l A}
            ([Γ] : ⊩ᵛ Γ)
          → Γ ⊩ᵛ⟨ l ⟩ A / [Γ]
          → Γ ⊩ᵛ⟨ ¹ ⟩ A / [Γ]
maybeEmbᵛ {l = ⁰} [Γ] [A] ⊢Δ [σ] =
  let [σA]  = proj₁ ([A] ⊢Δ [σ])
      [σA]′ = maybeEmb (proj₁ ([A] ⊢Δ [σ]))
  in  [σA]′
  ,   (λ [σ′] [σ≡σ′] → irrelevanceEq [σA] [σA]′ (proj₂ ([A] ⊢Δ [σ]) [σ′] [σ≡σ′]))
maybeEmbᵛ {l = ¹} [Γ] [A] = [A]

-- The lowest level can be embedded in any level (validity variant).
maybeEmbₛ′ : ∀ {l A}
             ([Γ] : ⊩ᵛ Γ)
           → Γ ⊩ᵛ⟨ ⁰ ⟩ A / [Γ]
           → Γ ⊩ᵛ⟨ l ⟩ A / [Γ]
maybeEmbₛ′ {l = ⁰} [Γ] [A] = [A]
maybeEmbₛ′ {l = ¹} [Γ] [A] ⊢Δ [σ] =
  let [σA]  = proj₁ ([A] ⊢Δ [σ])
      [σA]′ = maybeEmb′ (proj₁ ([A] ⊢Δ [σ]))
  in  [σA]′
  ,   (λ [σ′] [σ≡σ′] → irrelevanceEq [σA] [σA]′ (proj₂ ([A] ⊢Δ [σ]) [σ′] [σ≡σ′]))


module Categories.Coend where


open import Prelude renaming (_≟_ to _N≟_)

module Implicits.Syntax.Type.Unification.McBride where

open import Implicits.Syntax
open import Implicits.Syntax.MetaType

open import Data.Vec hiding (_>>=_)
open import Data.Vec.Properties
open import Data.Nat as N using ()
open import Data.Nat.Properties.Simple
open import Data.Product

open import Category.Monad

open import Data.Maybe hiding (module Maybe; map)
open import Data.Maybe as Maybe using (monad; functor)
open import Level using () renaming (zero to level₀)
open RawMonad {level₀} monad using (_>>=_; return)
open import Category.Functor
open RawFunctor {level₀} functor
open import Data.Star hiding (_>>=_)

open import Data.Fin.Properties as FinProp using ()
open import Data.Fin.Substitution
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas

private
  module M = MetaTypeMetaSubst
  module T = MetaTypeTypeSubst

thin : ∀ {n} → Fin (suc n) → Fin n → Fin (suc n)
thin zero y = suc y
thin (suc x) zero = zero
thin (suc x) (suc y) = suc (thin x y)

thick : ∀ {n} → (x y : Fin (suc n)) → Maybe (Fin n)
thick zero zero = nothing
thick zero (suc y) = just y
thick {zero} (suc ()) zero
thick {suc n} (suc x) zero = just zero
thick {zero} (suc ()) _
thick {suc n} (suc x) (suc y) = suc <$> (thick x y)

check' : ∀ {ν} → Fin (suc ν) → Type (suc ν) → Maybe (Type ν)
check' n (simpl (tvar m)) = (λ n → simpl (tvar n)) <$> (thick n m)
check' n (simpl (tc x)) = just (simpl (tc x))
check' n (simpl (a →' b)) with check' n a | check' n b
check' n (simpl (a →' b)) | just x | just y = just (simpl (x →' y))
check' n (simpl (a →' b)) | _ | nothing = nothing
check' n (simpl (a →' b)) | nothing | _ = nothing
check' n (a ⇒ b) with check' n a | check' n b
check' n (a ⇒ b) | just x | just y = just (x ⇒ y)
check' n (a ⇒ b) | _ | nothing = nothing
check' n (a ⇒ b) | nothing | _ = nothing
check' n (∀' t) with check' (suc n) t
check' n (∀' t) | just x = just (∀' x)
check' n (∀' t) | nothing = nothing

substitute : {ν m n : ℕ} → (Fin m → MetaType n ν) → MetaType m ν → MetaType n ν
substitute f a = a M./ (tabulate f)

_for_ : ∀ {n ν} → Type ν → Fin (suc n) → Fin (suc n) → MetaType n ν
_for_ t' x y with thick x y
_for_ t' x y | just y' = simpl (mvar y')
_for_ t' x y | nothing = to-meta t'

data ASub (ν : ℕ) : ℕ → ℕ → Set where
  _//_ : ∀ {m} → (t' : Type ν) → Fin (suc m) → ASub ν (suc m) m

AList : ℕ → ℕ → ℕ → Set
AList ν m n = Star (ASub ν) m n

asub-tp-weaken : ∀ {ν m n} → ASub ν m n → ASub (suc ν) m n
asub-tp-weaken (t' // x) = tp-weaken t' // x

asub-weaken : ∀ {ν m n} → ASub ν m n → ASub ν (suc m) (suc n)
asub-weaken (t' // x) = t' // (suc x)

alist-weaken : ∀ {ν m n} → AList ν m n → AList (suc ν) m n
alist-weaken s = gmap Prelude.id (λ x → asub-tp-weaken x) s

_◇_ : ∀ {l m n ν} → (Fin m → MetaType n ν) → (Fin l → MetaType m ν) → (Fin l → MetaType n ν)
f ◇ g = substitute f ∘ g

asub' : ∀ {ν m n} → (σ : AList ν m n) → Fin m → MetaType n ν
asub' ε = λ n → simpl (mvar n)
asub' (t' // x ◅ y) =  asub' y ◇ (t' for x)

asub : ∀ {ν m n} → (σ : AList ν m n) → Sub (flip MetaType ν) m n
asub s = tabulate (asub' s)

mgu : ∀ {m ν} → MetaType m ν → Type ν → Maybe (∃ (AList ν m))
mgu {ν} s t = amgu s t (ν , ε)
  where
    amgu : ∀ {ν m} (s : MetaType m ν) → (t : Type ν)→ ∃ (AList ν m) → Maybe (∃ (AList ν m))
    -- non-matching constructors
    amgu (simpl (tc x)) (_ ⇒ _) acc = nothing
    amgu (simpl (tc _)) (∀' _) x = nothing
    amgu (simpl (tc x)) (simpl (_ →' _)) acc = nothing
    amgu (simpl (tc _)) (simpl (tvar _)) x = nothing
    amgu (simpl (_ →' _)) (∀' _) x = nothing
    amgu (simpl (_ →' _)) (_ ⇒ _) x = nothing
    amgu (simpl (_ →' _)) (simpl (tc _)) acc = nothing
    amgu (simpl (_ →' _)) (simpl (tvar _)) x = nothing
    amgu (_ ⇒ _) (simpl x) acc = nothing
    amgu (_ ⇒ _) (∀' _) x = nothing
    amgu (∀' _) (_ ⇒ _) x = nothing
    amgu (∀' _) (simpl _) x = nothing
    amgu (simpl (tvar _)) (_ ⇒ _) x = nothing
    amgu (simpl (tvar _)) (∀' _) x = nothing
    amgu (simpl (tvar _)) (simpl (tc _)) x = nothing
    amgu (simpl (tvar _)) (simpl (_ →' _)) acc = nothing

    -- matching constructors
    amgu (a ⇒ b) (a' ⇒ b') acc = _>>=_ (amgu b b' acc) (amgu a a')
    amgu (simpl (a →' b)) (simpl (a' →' b')) acc = _>>=_ (amgu b b' acc) (amgu a a')
    amgu (simpl (tc x)) (simpl (tc y)) acc with x N≟ y
    amgu (simpl (tc x)) (simpl (tc y)) acc | yes p = just (, ε)
    amgu (simpl (tc x)) (simpl (tc y)) acc | no ¬p = nothing
    amgu (∀' a) (∀' b) (m , acc) = σ >>= strengthen'
      where
        σ = amgu a b (m , alist-weaken acc)
        strengthen' : ∀ {ν n} → ∃ (AList (suc ν) n) → Maybe (∃ (AList ν n))
        strengthen' (m , ε) = just (m , ε)
        strengthen' (m , t' // x ◅ acc) with check' zero t'
        strengthen' (m , t' // x ◅ acc) | just z =
          (λ { (m , u) → m , z // x ◅ u }) <$> (strengthen' (m , acc))
        strengthen' (m , t' // x ◅ acc) | nothing = nothing

    -- var-var
    amgu ((simpl (tvar x))) ((simpl (tvar y))) (m , ε) with x FinProp.≟ y
    amgu ((simpl (tvar x))) ((simpl (tvar y))) (m , ε) | yes _ = just (, ε)
    amgu ((simpl (tvar x))) ((simpl (tvar y))) (m , ε) | no _ = nothing

    -- var-rigid / rigid-var
    amgu (simpl (mvar ())) t (zero , ε)
    amgu (simpl (mvar x)) t (suc m , ε) = just (m , t // x ◅ ε)

    amgu s t (m , t' // x ◅ us) with amgu (substitute (t' for x) s) t (m , us)
    amgu s t (m , t' // x ◅ us) | just (m' , us') = just (m' , t' // x ◅ us')
    amgu s t (m , t' // x ◅ us) | nothing = nothing


module Sections where

open import Haskell.Prelude

test₁ : Nat → Nat
test₁ = 5 +_

test₂ : Nat → Nat
test₂ = _+ 5

test₃ : Nat → Nat
test₃ = _+_ 5

test₄ : Nat → Nat
test₄ = λ x → x + 5

test₅ : Nat → Nat
test₅ = λ x → 5 + x -- Agda eta-contracts this before we get to see it

{-# COMPILE AGDA2HS test₁ #-}
{-# COMPILE AGDA2HS test₂ #-}
{-# COMPILE AGDA2HS test₃ #-}
{-# COMPILE AGDA2HS test₄ #-}
{-# COMPILE AGDA2HS test₅ #-}


{- 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
-}
-- This is a selection of useful functions and definitions
-- from the standard library that we tend to use a lot.
module LibraBFT.Prelude where

  open import Level
    renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_)
    public

  1ℓ : Level
  1ℓ = ℓ+1 0ℓ

  open import Agda.Builtin.Unit
    public

  open import Function
    using (_∘_; _∘′_; id; case_of_; _on_; typeOf; flip; const; _∋_; _$_)
    public

  identity = id

  infixl 1 _&_
  _&_ = Function._|>_

  open import Data.Unit.NonEta
    public

  open import Data.Empty
    public

  -- NOTE: This function is defined to give extra documentation when discharging
  -- absurd cases where Agda can tell by pattern matching that `A` is not
  -- inhabited. For example:
  -- > absurd (just v ≡ nothing) case impossibleProof of λ ()
  infix 0 absurd_case_of_
  absurd_case_of_ : ∀ {ℓ₁ ℓ₂} (A : Set ℓ₁) {B : Set ℓ₂} → A → (A → ⊥) → B
  absurd A case x of f = ⊥-elim (f x)

  open import Data.Nat
    renaming (_≟_ to _≟ℕ_; _≤?_ to _≤?ℕ_; _≥?_ to _≥?ℕ_; compare to compareℕ; Ordering to Orderingℕ)
    public

  max = _⊔_
  min = _⊓_

  open import Data.Nat.DivMod using (_/_)
  div = _/_

  open import Data.Nat.Properties
    hiding (≡-irrelevant ; _≟_)
    public

  open import Data.List
    renaming (map to List-map ; filter to List-filter ; lookup to List-lookup;
              tabulate to List-tabulate; foldl to List-foldl)
    hiding (fromMaybe; [_])
    public

  foldl' = List-foldl

  open import Data.List.Properties
    renaming (≡-dec to List-≡-dec; length-map to List-length-map; map-compose to List-map-compose; filter-++ to List-filter-++; length-filter to List-length-filter)
    using (∷-injective; length-++; map-++-commute; sum-++-commute; map-tabulate; tabulate-lookup; ++-identityʳ; ++-identityˡ)
    public

  open import Data.List.Relation.Binary.Subset.Propositional
    renaming (_⊆_ to _⊆List_)
    public

  open import Data.List.Relation.Unary.Any
    using (Any; here; there)
    renaming (lookup to Any-lookup; map to Any-map; satisfied to Any-satisfied
             ;index to Any-index; any to Any-any)
    public

  open import Data.List.Relation.Unary.Any.Properties
    using    (¬Any[])
    renaming ( map⁺       to Any-map⁺
             ; map⁻       to Any-map⁻
             ; concat⁺    to Any-concat⁺
             ; concat⁻    to Any-concat⁻
             ; ++⁻        to Any-++⁻
             ; ++⁺ʳ       to Any-++ʳ
             ; ++⁺ˡ       to Any-++ˡ
             ; singleton⁻ to Any-singleton⁻
             ; tabulate⁺  to Any-tabulate⁺
             ; filter⁻    to Any-filter⁻
             )
    public

  open import Data.List.Relation.Unary.All
    using (All; []; _∷_)
    renaming (head     to All-head;   tail     to All-tail;
              lookup   to All-lookup; tabulate to All-tabulate;
              reduce   to All-reduce; map      to All-map)
    public

  open import Data.List.Relation.Unary.All.Properties
    hiding   (All-map)
    renaming ( tabulate⁻ to All-tabulate⁻
             ; tabulate⁺ to All-tabulate⁺
             ; map⁺      to All-map⁺
             ; map⁻      to All-map⁻
             ; ++⁺       to All-++
             )
    public

  open import Data.List.Membership.Propositional
    using (_∈_; _∉_)
    public

  open import Data.List.Membership.Propositional.Properties
    renaming (∈-filter⁺ to List-∈-filter⁺; ∈-filter⁻ to List-∈-filter⁻)
    public

  open import Data.Vec
    using (Vec; []; _∷_)
    renaming (replicate to Vec-replicate; lookup to Vec-lookup
             ;map to Vec-map; head to Vec-head; tail to Vec-tail
             ;updateAt to Vec-updateAt; tabulate to Vec-tabulate
             ;allFin to Vec-allFin; toList to Vec-toList; fromList to Vec-fromList
             ;_++_ to _Vec-++_)
    public

  open import Data.Vec.Relation.Unary.All
    using ([]; _∷_)
    renaming (All to Vec-All; lookup to Vec-All-lookup)
    public

  open import Data.Vec.Properties
    using ()
    renaming (updateAt-minimal to Vec-updateAt-minimal
             ;[]=⇒lookup to Vec-[]=⇒lookup
             ;lookup⇒[]= to Vec-lookup⇒[]=
             ;lookup∘tabulate to Vec-lookup∘tabulate
             ;≡-dec to Vec-≡-dec)
    public

  open import Data.List.Relation.Binary.Pointwise
    using (decidable-≡)
    public

  open import Data.Bool
    renaming (_≟_ to _≟Bool_)
    hiding (_≤?_; _<_; _<?_; _≤_; not)
    public

  open import Data.Maybe
    renaming (map to Maybe-map; zip to Maybe-zip ; _>>=_ to _Maybe->>=_)
    hiding (align; alignWith; zipWith)
    public

  -- a non-dependent eliminator
  maybeS : ∀ {a b} {A : Set a} {B : Set b} →
           (x : Maybe A) → B → ((x : A) → B) → B
  maybeS {B = B} x f t = maybe {B = const B} t f x

  maybeHsk : ∀ {A B : Set} → B → (A → B) → Maybe A → B
  maybeHsk b a→b = λ where
    nothing  → b
    (just a) → a→b a

  open import Data.Maybe.Relation.Unary.Any
    renaming (Any to Maybe-Any; dec to Maybe-Any-dec)
    hiding (map; zip; zipWith; unzip ; unzipWith)
    public

  maybe-any-⊥ : ∀{a}{A : Set a} → Maybe-Any {A = A} (λ _ → ⊤) nothing → ⊥
  maybe-any-⊥ ()

  headMay : ∀ {A : Set} → List A → Maybe A
  headMay     []  = nothing
  headMay (x ∷ _) = just x

  lastMay : ∀ {A : Set} → List A → Maybe A
  lastMay          []  = nothing
  lastMay     (x ∷ []) = just x
  lastMay (_ ∷ x ∷ xs) = lastMay (x ∷ xs)

  open import Data.Maybe.Properties
    using (just-injective)
    renaming (≡-dec to Maybe-≡-dec)
    public

  open import Data.Fin
    using (Fin; suc; zero; fromℕ; fromℕ< ; toℕ ; cast)
    renaming (_≟_ to _≟Fin_; _≤?_ to _≤?Fin_; _≤_ to _≤Fin_ ; _<_ to _<Fin_;
              inject₁ to Fin-inject₁; inject+ to Fin-inject+; inject≤ to Fin-inject≤)
    public

  fins : (n : ℕ) → List (Fin n)
  fins n = Vec-toList (Vec-allFin n)

  open import Data.Fin.Properties
    using (toℕ-injective; toℕ<n)
    renaming (<-cmp to Fin-<-cmp; <⇒≢ to <⇒≢Fin; suc-injective to Fin-suc-injective)
    public

  open import Relation.Binary.PropositionalEquality
    hiding (decSetoid)
    public

  open import Relation.Binary.HeterogeneousEquality
    using (_≅_)
    renaming (cong to ≅-cong; cong₂ to ≅-cong₂)
    public

  open import Relation.Binary
    public

  data Ordering : Set where
    LT EQ GT : Ordering

  compare : ℕ → ℕ → Ordering
  compare m n
    with <-cmp m n
  ... | tri< a ¬b ¬c = LT
  ... | tri≈ ¬a b ¬c = EQ
  ... | tri> ¬a ¬b c = GT

  ≡-irrelevant : ∀{a}{A : Set a} → Irrelevant {a} {A} _≡_
  ≡-irrelevant refl refl = refl

  to-witness-lemma : ∀{ℓ}{A : Set ℓ}{a : A}{f : Maybe A}(x : Is-just f)
                   → to-witness x ≡ a → f ≡ just a
  to-witness-lemma (just x) refl = refl

  open import Relation.Nullary
    hiding (Irrelevant; proof)
    public

  open import Relation.Nullary.Decidable
    hiding (map)
    public

  open import Data.Sum
    renaming ([_,_] to either; map to ⊎-map; map₁ to ⊎-map₁; map₂ to ⊎-map₂)
    public

  open import Data.Sum.Properties
    using (inj₁-injective ; inj₂-injective)
    public

  ⊎-elimˡ : ∀ {ℓ₀ ℓ₁}{A₀ : Set ℓ₀}{A₁ : Set ℓ₁} → ¬ A₀ → A₀ ⊎ A₁ → A₁
  ⊎-elimˡ ¬a = either (⊥-elim ∘ ¬a) id

  ⊎-elimʳ : ∀ {ℓ₀ ℓ₁}{A₀ : Set ℓ₀}{A₁ : Set ℓ₁} → ¬ A₁ → A₀ ⊎ A₁ → A₀
  ⊎-elimʳ ¬a = either id (⊥-elim ∘ ¬a)

  open import Data.Product
    renaming (map to ×-map; map₂ to ×-map₂; map₁ to ×-map₁; <_,_> to split; swap to ×-swap)
    hiding (zip)
    public

  fst = proj₁

  open import Data.Product.Properties
    public

  module _ {ℓA} {A : Set ℓA} where
    NoneOfKind : ∀ {ℓ} {P : A → Set ℓ} → List A → (p : (a : A) → Dec (P a)) → Set ℓA
    NoneOfKind xs p = List-filter p xs ≡ []

    postulate -- TODO-1: Replace with or prove using library properties?  Move to Lemmas?
      NoneOfKind⇒ : ∀ {ℓ} {P : A → Set ℓ} {Q : A → Set ℓ} {xs : List A}
                  → (p : (a : A) → Dec (P a))
                  → {q : (a : A) → Dec (Q a)}
                  → (∀ {a} → P a → Q a)  -- TODO-1: Use proper notation (Relation.Unary?)
                  → NoneOfKind xs q
                  → NoneOfKind xs p

  infix 4 _<?ℕ_
  _<?ℕ_ : Decidable _<_
  m <?ℕ n = suc m ≤?ℕ n

  infix 0 if-yes_then_else_
  infix 0 if-dec_then_else_
  if-yes_then_else_ : ∀ {ℓA ℓB} {A : Set ℓA} {B : Set ℓB} → Dec A → (A → B) → (¬ A → B) → B
  if-yes (yes prf) then f else _ = f prf
  if-yes (no  prf) then _ else g = g prf

  if-dec_then_else_ : ∀ {ℓA ℓB} {A : Set ℓA} {B : Set ℓB} → Dec A → B → B → B
  if-dec x then f else g = if-yes x then const f else const g

  open import Relation.Nullary.Negation
    using (contradiction; contraposition)
    public

  open import Relation.Binary
    using (Setoid; IsPreorder)
    public

  open import Relation.Unary
    using (_∪_)
    public

  open import Relation.Unary.Properties
    using (_∪?_)
    public

  -- Injectivity for a function of two potentially different types (A and B) via functions to a
  -- common type (C).

  Injective' : ∀ {b c d e}{B : Set b}{C : Set c}{D : Set d} → (hB : B → D) → (hC : C → D) → (_≈_ : B → C → Set e) → Set _
  Injective' {C = C} hB hC _≈_ = ∀ {b c} → hB b ≡ hC c → b ≈ c

  Injective  : ∀ {c d e}{C : Set c}{D : Set d} → (h : C → D) → (_≈_ : Rel C e) → Set _
  Injective h _≈_ = Injective' h h _≈_

  Injective-≡ : ∀ {c d}{C : Set c}{D : Set d} → (h : C → D) → Set _
  Injective-≡ h = Injective h _≡_

  Injective-int : ∀{a b c d e}{A : Set a}{B : Set b}{C : Set c}{D : Set d}
                → (_≈_ : A → B → Set e)
                → (h  : C → D)
                → (f₁ : A → C)
                → (f₂ : B → C)
                → Set (a ℓ⊔ b ℓ⊔ d ℓ⊔ e)
  Injective-int _≈_ h f₁ f₂ = ∀ {a₁} {b₁} → h (f₁ a₁) ≡ h (f₂ b₁) → a₁ ≈ b₁

  NonInjective : ∀{a b c}{A : Set a}{B : Set b}
               → (_≈_ : Rel A c)
               → (A → B) → Set (a ℓ⊔ b ℓ⊔ c)
  NonInjective {A = A} _≈_ f
    = Σ (A × A) (λ { (x₁ , x₂) → ¬ (x₁ ≈ x₂) × f x₁ ≡ f x₂ })

  NonInjective-≡ : ∀{a b}{A : Set a}{B : Set b}
                 → (A → B) → Set (a ℓ⊔ b)
  NonInjective-≡ = NonInjective _≡_

  NonInjective-≡-preds : ∀{a b}{A : Set a}{B : Set b}{ℓ₁ ℓ₂ : Level}
                      → (A → Set ℓ₁)
                      → (A → Set ℓ₂)
                      → (A → B) → Set (a ℓ⊔ b ℓ⊔ ℓ₁ ℓ⊔ ℓ₂)
  NonInjective-≡-preds Pred1 Pred2 f = Σ (NonInjective _≡_ f) λ { ((a₀ , a₁) , _ , _) → Pred1 a₀ × Pred2 a₁ }

  NonInjective-≡-pred : ∀{a b}{A : Set a}{B : Set b}{ℓ : Level}
                      → (P : A → Set ℓ)
                      → (A → B) → Set (a ℓ⊔ b ℓ⊔ ℓ)
  NonInjective-≡-pred Pred = NonInjective-≡-preds Pred Pred

  NonInjective-∘ : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
                 → {f : A → B}(g : B → C)
                 → NonInjective-≡  f
                 → NonInjective-≡ (g ∘ f)
  NonInjective-∘ g ((x0 , x1) , (x0≢x1 , fx0≡fx1))
    = ((x0 , x1) , x0≢x1 , (cong g fx0≡fx1))

  --------------------------------------------
  -- Handy fmap and bind for specific types --

  _<M$>_ : ∀{a b}{A : Set a}{B : Set b}
         → (f : A → B)
         → Maybe A → Maybe B
  _<M$>_ = Maybe-map

  <M$>-univ : ∀{a b}{A : Set a}{B : Set b}
            → (f : A → B)(x : Maybe A)
            → {y : B} → f <M$> x ≡ just y
            → ∃[ x' ] (x ≡ just x' × f x' ≡ y)
  <M$>-univ f (just x) refl = x , (refl , refl)

  maybe-lift : {A : Set}
             → {mx : Maybe A}{x : A}
             → (P : A → Set)
             → P x → mx ≡ just x
             → maybe {B = const Set} P ⊥ mx
  maybe-lift {mx = just .x} {x} P px refl = px

  <M$>-nothing : ∀ {a b}{A : Set a}{B : Set b}(f : A → B)
               → f <M$> nothing ≡ nothing
  <M$>-nothing _ = refl

  _<⊎$>_ : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
         → (A → B) → C ⊎ A → C ⊎ B
  f <⊎$> (inj₁ hb) = inj₁ hb
  f <⊎$> (inj₂ x)  = inj₂ (f x)

  _⊎⟫=_ : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
        → C ⊎ A → (A → C ⊎ B) → C ⊎ B
  (inj₁ x) ⊎⟫= _ = inj₁ x
  (inj₂ a) ⊎⟫= f = f a

  -- Syntactic support for more faithful model of Haskell code
  Either : ∀ {a b} → Set a → Set b → Set (a ℓ⊔ b)
  Either A B = A ⊎ B
  pattern Left  x = inj₁ x
  pattern Right x = inj₂ x

  isLeft : ∀ {a b} {A : Set a} {B : Set b} → Either A B → Bool
  isLeft (Left _)  = true
  isLeft (Right _) = false

  isRight : ∀ {a b} {A : Set a} {B : Set b} → Either A B → Bool
  isRight = Data.Bool.not ∘ isLeft

  -- a non-dependent eliminator
  eitherS : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
            (x : Either A B) → ((x : A) → C) → ((x : B) → C) → C
  eitherS eab fa fb = case eab of λ where
    (Left  a) → fa a
    (Right b) → fb b

  module _ {ℓ₀ ℓ₁ ℓ₂ : Level} where
    EL-type = Set ℓ₁ → Set ℓ₂ → Set ℓ₀
    EL-level = ℓ₁ ℓ⊔ ℓ₂ ℓ⊔ ℓ₀

    -- Utility to make passing between `Either` and `EitherD` more convenient
    record EitherLike (E : EL-type) : Set (ℓ+1 EL-level) where
      field
        fromEither : ∀ {A : Set ℓ₁} {B : Set ℓ₂} → Either A B → E A B
        toEither   : ∀ {A : Set ℓ₁} {B : Set ℓ₂} → E A B → Either A B
    open EitherLike ⦃ ... ⦄ public

    EL-func : EL-type → Set (ℓ+1 EL-level)
    EL-func EL = ⦃ mel : EitherLike EL ⦄ → Set EL-level

  instance
    EitherLike-Either : ∀ {ℓ₁ ℓ₂} → EitherLike{ℓ₁ ℓ⊔ ℓ₂}{ℓ₁}{ℓ₂} Either
    EitherLike.fromEither EitherLike-Either = id
    EitherLike.toEither   EitherLike-Either = id

  -- an approximation of Haskell's backtick notation for making infix operators; in Agda, must have
  -- spaces between f and backticks
  flip' : _     -- Avoids warning about definition and syntax declaration being in different scopes
  flip' = flip
  syntax flip' f = ` f `

  open import Data.String as String
    hiding (_==_ ; _≟_ ; concat)

  check : Bool → List String → Either String Unit
  check b t = if b then inj₂ unit else inj₁ (String.intersperse "; " t)

  -- TODO-1: Maybe this belongs somewhere else?  It's in a similar
  -- category as Optics, so maybe should similarly be in a module that
  -- is separate from the main project?
  ------------------
  -- Guard Syntax --
  --
  -- Example Usage:
  --
  -- > f : ℕ → ℕ
  -- > f x = grd‖ x ≟ℕ 10  ≔ 12
  -- >          ‖ otherwise≔ 40 + 2
  --
  --
  -- > g : ℕ ⊎ ℕ → ℕ
  -- > g x = case x of λ
  -- >     { (inj₁ x) → grd‖ x ≤? 10  ≔ 2 * x
  -- >                     ‖ otherwise≔ 42
  -- >     ; (inj₂ y) → y
  -- >     }
  --
  -- To type: ‖  -->  \Vert
  --          ≔  -->  \:=

  record ToBool {a}(A : Set a) : Set a where
    field
      toBool : A → Bool
  open ToBool {{ ... }} public

  not : ∀ {b} {B : Set b} ⦃ _ : ToBool B ⦄ → B → Bool
  not b = Data.Bool.not (toBool b)

  instance
    ToBool-Bool : ToBool Bool
    ToBool-Bool = record { toBool = id }

    ToBool-Dec : ∀{a}{A : Set a} → ToBool (Dec A)
    ToBool-Dec = record { toBool = ⌊_⌋ }

  toWitnessT : ∀{ℓ}{P : Set ℓ}{d : Dec P} → ⌊ d ⌋ ≡ true → P
  toWitnessT {d = yes proof} _ = proof

  toWitnessF : ∀{ℓ}{P : Set ℓ}{d : Dec P} → ⌊ d ⌋ ≡ false → ¬ P
  toWitnessF{d = no proof} _ = proof

  infix 3 _≔_
  data GuardClause {a}{b}(A : Set a) : Set (a ℓ⊔ ℓ+1 b) where
    _≔_ : {B : Set b}{{ bb : ToBool B }} → B → A → GuardClause A

  infix 3 otherwise≔_
  data Guards {a}{b}(A : Set a) : Set (a ℓ⊔ ℓ+1 b) where
   otherwise≔_ : A → Guards A
   clause     : GuardClause{a}{b} A → Guards{a}{b} A → Guards A

  infixr 2 _‖_
  _‖_ : ∀{a}{b}{A : Set a} → GuardClause{a}{b} A → Guards A → Guards A
  _‖_ = clause

  infix 1 grd‖_
  grd‖_ : ∀{a}{b}{A : Set a} → Guards{a}{b} A → A
  grd‖_ (otherwise≔ a) = a
  grd‖_ (clause (b ≔ a) g)  = if toBool b then a else (grd‖ g)

  Any-satisfied-∈ : ∀{a ℓ}{A : Set a}{P : A → Set ℓ}{xs : List A}
                  → Any P xs → Σ A (λ x → P x × x ∈ xs)
  Any-satisfied-∈ (here px) = _ , (px , here refl)
  Any-satisfied-∈ (there p) = let (a , px , prf) = Any-satisfied-∈ p
                               in (a , px , there prf)

  f-sum : ∀{a}{A : Set a} → (A → ℕ) → List A → ℕ
  f-sum f = sum ∘ List-map f

  record Functor  {ℓ₁ ℓ₂ : Level} (F : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where
    infixl 4 _<$>_
    field
      _<$>_ : ∀ {A B : Set ℓ₁} → (A → B) → F A → F B
    fmap = _<$>_

  open Functor ⦃ ... ⦄ public

  record Applicative {ℓ₁ ℓ₂ : Level} (F : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where
    infixl 4 _<*>_
    field
      pure  : ∀ {A : Set ℓ₁} → A → F A
      _<*>_ : ∀ {A B : Set ℓ₁} → F (A → B) → F A → F B

  open Applicative ⦃ ... ⦄ public
  instance
    ApplicativeFunctor : ∀ {ℓ₁ ℓ₂} {F : Set ℓ₁ → Set ℓ₂} ⦃ _ : Applicative F ⦄ → Functor F
    Functor._<$>_ ApplicativeFunctor f xs = pure f <*> xs

  record Monad {ℓ₁ ℓ₂ : Level} (M : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where
    infixl 1 _>>=_ _>>_
    field
      return : ∀ {A : Set ℓ₁} → A → M A
      _>>=_  : ∀ {A B : Set ℓ₁} → M A → (A → M B) → M B

    _>>_ : ∀ {A B : Set ℓ₁} → M A → M B → M B
    m₁ >> m₂ = m₁ >>= λ _ → m₂

  open Monad ⦃ ... ⦄ public

  instance
    MonadApplicative : ∀ {ℓ₁ ℓ₂} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : Monad M ⦄ → Applicative M
    Applicative.pure MonadApplicative = return
    Applicative._<*>_ MonadApplicative fs xs = do
      f ← fs
      x ← xs
      return (f x)

  instance
    Monad-Either : ∀ {ℓ}{C : Set ℓ} → Monad{ℓ}{ℓ} (Either C)
    Monad.return (Monad-Either{ℓ}{C}) = inj₂
    Monad._>>=_ (Monad-Either{ℓ}{C}) = either (const ∘ inj₁) _&_

    Monad-Maybe : ∀ {ℓ} → Monad {ℓ} {ℓ} Maybe
    Monad.return (Monad-Maybe{ℓ}) = just
    Monad._>>=_  (Monad-Maybe{ℓ}) = _Maybe->>=_

    Monad-List : ∀ {ℓ} → Monad {ℓ}{ℓ} List
    Monad.return Monad-List x = x ∷ []
    Monad._>>=_  Monad-List x f = concat (List-map f x)

  maybeSMP : ∀ {ℓ} {A B : Set} {m : Set → Set ℓ} ⦃ _ : Monad m ⦄ → m (Maybe A) → B → (A → m B) → m B
  maybeSMP ma b f = do
    x ← ma
    case x of λ where
      nothing  → pure b
      (just j) → f j

  fromMaybeM : ∀ {ℓ} {A : Set} {m : Set → Set ℓ} ⦃ _ : Monad m ⦄ → m A → m (Maybe A) → m A
  fromMaybeM ma mma = do
    mma >>= λ where
      nothing  → ma
      (just a) → pure a

  forM_ : ∀ {ℓ} {A B : Set} {M : Set → Set ℓ} ⦃ _ : Monad M ⦄ → List A → (A → M B) → M Unit
  forM_      []  _ = return unit
  forM_ (x ∷ xs) f = f x >> forM_ xs f

  -- NOTE: because 'forM_' is defined above, it is necessary to
  -- call 'forM' with parenthesis (e.g., recursive call in definition)
  -- to disambiguate it for the Agda parser.
  forM : ∀ {ℓ} {A B : Set} {M : Set → Set ℓ} ⦃ _ : Monad M ⦄ → List A → (A → M B) → M (List B)
  forM      []  _ = return []
  forM (x ∷ xs) f = do
    fx  ← f x
    fxs ← (forM) xs f
    return (fx ∷ fxs)

  foldrM : ∀ {ℓ₁ ℓ₂} {A B : Set ℓ₁} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : Monad M ⦄ → (A → B → M B) → B → List A → M B
  foldrM _ b      []  = return b
  foldrM f b (a ∷ as) = foldrM f b as >>= f a

  foldlM : ∀ {ℓ₁ ℓ₂} {A B : Set ℓ₁} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : Monad M ⦄ → (B → A → M B) → B → List A → M B
  foldlM _ z      []  = pure z
  foldlM f z (x ∷ xs) = do
    z' ← f z x
    foldlM f z' xs

  foldM = foldlM

  foldM_ : {A B : Set} {M : Set → Set} ⦃ _ : Monad M ⦄ → (B → A → M B) → B → List A → M Unit
  foldM_ f a xs = foldlM f a xs >> pure unit

  open import LibraBFT.Base.Util public

  record Eq {a} (A : Set a) : Set a where
    infix 4 _≟_ _==_ _/=_
    field
      _≟_ : (a b : A) → Dec (a ≡ b)

    _==_   : A → A → Bool
    a == b = toBool $ a ≟ b

    _/=_ : A → A → Bool
    a /= b = not (a == b)
  open Eq ⦃ ... ⦄ public

  elem : ∀ {ℓ} {A : Set ℓ} ⦃ _ : Eq A ⦄ → A → List A → Bool
  elem x = toBool ∘ Any-any (x ≟_)

  instance
    Eq-Nat : Eq ℕ
    Eq._≟_ Eq-Nat = _≟ℕ_

    Eq-Maybe : ∀ {a} {A : Set a} ⦃ _ : Eq A ⦄ → Eq (Maybe A)
    Eq._≟_ Eq-Maybe nothing nothing = yes refl
    Eq._≟_ Eq-Maybe (just _) nothing = no λ ()
    Eq._≟_ Eq-Maybe nothing (just _) = no λ ()
    Eq._≟_ Eq-Maybe (just a) (just b)
       with a ≟ b
    ... | no  proof = no λ where refl → proof refl
    ... | yes refl = yes refl

  infixl 9 _!?_
  _!?_ : {A : Set} → List A → ℕ → Maybe A
  []       !?      _   = nothing
  (x ∷ _ ) !?      0   = just x
  (_ ∷ xs) !? (suc n)  = xs !? n

  -- Like a Haskell list-comprehension for ℕ : [ n | n <- [from .. to] ]
  fromToList : ℕ → ℕ → List ℕ
  fromToList from to with from ≤′? to
  ... | no ¬pr = []
  ... | yes pr = fromToList-le from to pr []
   where
    fromToList-le : ∀ (from to : ℕ) (klel : from ≤′ to) (acc : List ℕ) → List ℕ
    fromToList-le from ._        ≤′-refl       acc = from ∷ acc
    fromToList-le from (suc to) (≤′-step klel) acc = fromToList-le from to klel (suc to ∷ acc)

  _ : fromToList 1 1 ≡ 1 ∷ []
  _ = refl
  _ : fromToList 1 2 ≡ 1 ∷ 2 ∷ []
  _ = refl
  _ : fromToList 2 1 ≡ []
  _ = refl


-- Andreas, 2019-06-18, LAIM 2019, issue #3855:
-- Successful tests for the erasure (@0) modality.

module _ where

open import Agda.Builtin.Bool
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality
open import Agda.Builtin.Coinduction

open import Common.IO

module WhereInErasedDeclaration where

  @0 n : Nat
  n = 4711

  @0 m : Nat
  m = n'
    where
    n' = n

module ErasedDeclarationInWhere where

  F : (G : @0 Set → Set) (@0 A : Set) → Set
  F G A = G B
    where
    @0 B : Set
    B = A

module FlatErasure where

  @0 resurrect-λ : (A : Set) (@0 x : A) → A
  resurrect-λ A = λ x → x

  @0 resurrect-λ-where : (A : Set) (@0 x : A) → A
  resurrect-λ-where A = λ where x → x

  @0 resurrect-app : (A : Set) (@0 x : A) → A
  resurrect-app A x = x

module ErasedEquality where

  -- Should maybe not work --without-K
  -- should definitely not work in --cubical

  cast : ∀{A B : Set} → @0 A ≡ B → A → B
  cast refl x = x

  J : ∀{A : Set} {a : A} (P : (x : A) → a ≡ x → Set) {b : A}
      (@0 eq : a ≡ b) → P a refl → P b eq
  J P refl p = p

module ParametersAreErased where

  test : (@0 A : Set) → A ≡ A
  test A = refl {x = _}           -- TODO: A instead of _

module Records where

  record R (A : Set) : Set where
    field
      el : A
    Par : Set
    Par = A    -- record module parameters are NOT erased, so, this should be accepted

  proj : (A : Set) → R A → A  -- TODO: @0 A instead of A
  proj A r = R.el {A = _} r

  MyPar : (A : Set) → R A → Set
  MyPar A = R.Par {A = A}

  record RB (b : Bool) : Set where
    bPar : Bool
    bPar = b

  myBPar : (b : Bool) → RB b → Bool
  myBPar b r = RB.bPar {b = b} r

module CoinductionWithErasure (A : Set) where

  data Stream : Set where
    cons : (x : A) (xs : ∞ Stream) → Stream

  @0 repeat : (@0 a : A) → Stream
  repeat a = cons a (♯ (repeat a))

main = putStrLn "Hello, world!"


{-# OPTIONS --without-K -v 2 #-}
module Leftovers.Equality where

open import Leftovers.Utils
-- open import Leftovers.Leftovers

import Level as Level
-- open import Reflection
open import Reflection.Term
open import Reflection.Pattern as P
open import Reflection.TypeChecking.Monad.Instances

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary

open import Data.Unit
open import Data.Nat as Nat hiding (_⊓_)
open import Data.Bool
open import Data.Product
open import Data.List as List
open import Data.Char as Char
open import Data.String as String

open import Leftovers.Monad

import Data.List.Categorical
open Data.List.Categorical.TraversableM {m = Level.zero} leftoversMonad

--This file was adapted from https://github.com/alhassy/gentle-intro-to-reflection

open import Reflection.Show
import Data.Nat.Show as NShow

--Unify the goal with a function that does a case-split on an argument of the type with the given name
-- Return the metavariables, along with telescopes, for each branch
cases : Name → Term → Leftovers ⊤
cases typeName hole -- thm-you-hope-is-provable-by-refls
    = do
      -- let η = nom
      δ ← getDefinition typeName
      holeType ← inferType hole
      debugPrint "refl-cases" 2 (strErr " hole type to start " ∷ termErr holeType ∷ [])
      clauses ← forM (constructors δ) (mk-cls holeType)
      -- declareDef (vArg η) holeType
      let retFun = (pat-lam clauses [])
      normFun ← reduce retFun
      debugPrint "refl-cases" 2 (strErr "reflcases ret non-norm " ∷ termErr retFun ∷ [])
      unify hole normFun
      normHole ← reduce hole
      debugPrint "refl-cases" 2 (strErr "reflCases final " ∷ termErr normHole ∷ [])
    where
      -- For each constructor, generate the clause,
      -- along with the metavariable term for its right-hand side
      mk-cls : Type → Name → Leftovers (Clause )
      mk-cls holeType ctor =
         do
           debugPrint "mk-cls" 2 (strErr "mk-cls with ctor " ∷ nameErr ctor ∷ [])
           fullyApplied <- fully-applied-pattern ctor
           let
             patArgs = List.map CtorArg.pat fullyApplied
             patTerm = List.map CtorArg.term fullyApplied
             patTypes = List.map CtorArg.type fullyApplied
           extendContexts patTypes do
               debugPrint "" 2 (strErr "before retType " ∷ termErr holeType ∷ strErr "   and   " ∷ termErr (con ctor patTerm) ∷  [])
               retType ← returnTypeFor holeType (con ctor patTerm)
               debugPrint "mk-cls" 2 (strErr "retType is  " ∷ termErr retType ∷ [])
               -- Make the right-hand side in an extended context
               -- with new pattern-match variables
               rhs ← freshMeta retType
               let
                 teles =
                   List.map
                     (λ (x , n) → ( "arg" String.++ NShow.show n , x ))
                     (List.zip patTypes (List.upTo (List.length patTypes)))
               debugPrint "mk-cls" 2 (strErr "Pat" ∷ strErr (showPatterns patArgs) ∷ [] )
               let
                 ret =
                   (clause
                     teles
                     [ vArg (con ctor patArgs) ]
                     (rhs ⦂ retType))

               debugPrint "mk-cls" 2  (strErr "retClause" ∷ strErr (showClause ret) ∷ [])
               -- tryUnify rhs (con (quote refl) [])
               pure ret

-- ≡-type-info : Term → Leftovers (Arg Term × Arg Term × Term × Term)
-- ≡-type-info (def (quote _≡_) (𝓁 ∷ 𝒯 ∷ arg _ l ∷ arg _ r ∷ [])) = return (𝓁 , 𝒯 , l , r)
-- ≡-type-info _ = typeError [ strErr "Term is not a ≡-type." ]

-- {- If we have “f $ args” return “f”. -}
-- $-head : Term → Term
-- $-head (var v args) = var v []
-- $-head (con c args) = con c []
-- $-head (def f args) = def f []
-- $-head (pat-lam cs args) = pat-lam cs []
-- $-head t = t

-- import Agda.Builtin.Reflection as Builtin

-- _$-≟_ : Term → Term → Bool
-- con c args $-≟ con c′ args′ = Builtin.primQNameEquality c c′
-- def f args $-≟ def f′ args′ = Builtin.primQNameEquality f f′
-- var x args $-≟ var x′ args′ = does (x Nat.≟ x′)
-- _ $-≟ _ = false

-- {- Only gets heads and as much common args, not anywhere deep. :'( -}
-- infix 5 _⊓_
-- {-# TERMINATING #-} {- Fix this by adding fuel (con c args) ≔ 1 + length args -}
-- _⊓_ : Term → Term → Term
-- l ⊓ r with l $-≟ r | l | r
-- ...| false | x | y = unknown
-- ...| true | var f args | var f′ args′ = var f (List.zipWith (λ{ (arg i!! t) (arg j!! s) → arg i!! (t ⊓ s) }) args args′)
-- ...| true | con f args | con f′ args′ = con f (List.zipWith (λ{ (arg i!! t) (arg j!! s) → arg i!! (t ⊓ s) }) args args′)
-- ...| true | def f args | def f′ args′ = def f (List.zipWith (λ{ (arg i!! t) (arg j!! s) → arg i!! (t ⊓ s) }) args args′)
-- ...| true | ll | _ = ll {- Left biased; using ‘unknown’ does not ensure idempotence. -}

-- {- ‘unknown’ goes to a variable, a De Bruijn index -}
-- unknown-elim : ℕ → List (Arg Term) → List (Arg Term)
-- unknown-elim n [] = []
-- unknown-elim n (arg i unknown ∷ xs) = arg i (var n []) ∷ unknown-elim (n + 1) xs
-- unknown-elim n (arg i (var x args) ∷ xs) = arg i (var (n + suc x) args) ∷ unknown-elim n xs
-- unknown-elim n (arg i x ∷ xs)       = arg i x ∷ unknown-elim n xs
-- {- Essentially we want: body(unknownᵢ)  ⇒  λ _ → body(var 0)
--    However, now all “var 0” references in “body” refer to the wrong argument;
--    they now refer to “one more lambda away than before”. -}

-- unknown-count : List (Arg Term) → ℕ
-- unknown-count [] = 0
-- unknown-count (arg i unknown ∷ xs) = 1 + unknown-count xs
-- unknown-count (arg i _ ∷ xs) = unknown-count xs

-- unknown-λ : ℕ → Term → Term
-- unknown-λ zero body = body
-- unknown-λ (suc n) body = unknown-λ n (λv "section" ↦ body)

-- {- Replace ‘unknown’ with sections -}
-- patch : Term → Term
-- patch it@(def f args) = unknown-λ (unknown-count args) (def f (unknown-elim 0 args))
-- patch it@(var f args) = unknown-λ (unknown-count args) (var f (unknown-elim 0 args))
-- patch it@(con f args) = unknown-λ (unknown-count args) (con f (unknown-elim 0 args))
-- patch t = t

-- macro
--   spine : Term → Term → Leftovers ⊤
--   spine p goal =
--     do τ ← inferType p
--        _ , _ , l , r ← ≡-type-info τ
--        unify goal (patch (l ⊓ r))

-- macro
--   applyEq : Term → Term → Leftovers ⊤
--   applyEq p hole =
--     do
--        τ ← inferType hole
--        _ , _ , l , r ← ≡-type-info τ
--        unify hole ((def (quote cong) (vArg (patch (l ⊓ r)) ∷ vArg p ∷ [])))


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

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView

open import Tools.Embedding
open import Tools.Product
import Tools.PropositionalEquality as PE

-- Irrelevance for propositionally equal types
irrelevance′ : ∀ {A A′ Γ l}
             → A PE.≡ A′
             → Γ ⊩⟨ l ⟩ A
             → Γ ⊩⟨ l ⟩ A′
irrelevance′ PE.refl [A] = [A]

-- Irrelevance for propositionally equal types and contexts
irrelevanceΓ′ : ∀ {l A A′ Γ Γ′}
              → Γ PE.≡ Γ′
              → A PE.≡ A′
              → Γ  ⊩⟨ l ⟩ A
              → Γ′ ⊩⟨ l ⟩ A′
irrelevanceΓ′ PE.refl PE.refl [A] = [A]

mutual
  -- Irrelevance for type equality
  irrelevanceEq : ∀ {Γ A B l l′} (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A)
                → Γ ⊩⟨ l ⟩ A ≡ B / p → Γ ⊩⟨ l′ ⟩ A ≡ B / q
  irrelevanceEq p q A≡B = irrelevanceEqT (goodCasesRefl p q) A≡B

  -- Irrelevance for type equality with propositionally equal first types
  irrelevanceEq′ : ∀ {Γ A A′ B l l′} (eq : A PE.≡ A′)
                   (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A′)
                 → Γ ⊩⟨ l ⟩ A ≡ B / p → Γ ⊩⟨ l′ ⟩ A′ ≡ B / q
  irrelevanceEq′ PE.refl p q A≡B = irrelevanceEq p q A≡B

  -- Irrelevance for type equality with propositionally equal types
  irrelevanceEq″ : ∀ {Γ A A′ B B′ l l′} (eqA : A PE.≡ A′) (eqB : B PE.≡ B′)
                    (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A′)
                  → Γ ⊩⟨ l ⟩ A ≡ B / p → Γ ⊩⟨ l′ ⟩ A′ ≡ B′ / q
  irrelevanceEq″ PE.refl PE.refl p q A≡B = irrelevanceEq p q A≡B

  -- Irrelevance for type equality with propositionally equal second types
  irrelevanceEqR′ : ∀ {Γ A B B′ l} (eqB : B PE.≡ B′) (p : Γ ⊩⟨ l ⟩ A)
                  → Γ ⊩⟨ l ⟩ A ≡ B / p → Γ ⊩⟨ l ⟩ A ≡ B′ / p
  irrelevanceEqR′ PE.refl p A≡B = A≡B

  -- Irrelevance for type equality with propositionally equal types and
  -- a lifting of propositionally equal types
  irrelevanceEqLift″ : ∀ {Γ A A′ B B′ C C′ l l′}
                        (eqA : A PE.≡ A′) (eqB : B PE.≡ B′) (eqC : C PE.≡ C′)
                        (p : Γ ∙ C ⊩⟨ l ⟩ A) (q : Γ ∙ C′ ⊩⟨ l′ ⟩ A′)
                      → Γ ∙ C ⊩⟨ l ⟩ A ≡ B / p → Γ ∙ C′ ⊩⟨ l′ ⟩ A′ ≡ B′ / q
  irrelevanceEqLift″ PE.refl PE.refl PE.refl p q A≡B = irrelevanceEq p q A≡B

  -- Helper for irrelevance of type equality using shape view
  irrelevanceEqT : ∀ {Γ A B l l′} {p : Γ ⊩⟨ l ⟩ A} {q : Γ ⊩⟨ l′ ⟩ A}
                       → ShapeView Γ l l′ A A p q
                       → Γ ⊩⟨ l ⟩ A ≡ B / p → Γ ⊩⟨ l′ ⟩ A ≡ B / q
  irrelevanceEqT (ℕᵥ ℕA ℕB) (ιx (ℕ₌ x)) = ιx (ℕ₌ x)
  irrelevanceEqT (ne (ne K D neK _) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
                 rewrite whrDet* (red D , ne neK) (red D₁ , ne neK₁) =
    ιx (ne₌ M D′ neM K≡M)
  irrelevanceEqT {Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                 (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
    let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ)
        F≡F₁ , G≡G₁ = Π-PE-injectivity ΠFG≡ΠF₁G₁
    in  Π₌ F′ G′ D′ (PE.subst (λ x → Γ ⊢ x ≅ Π F′ ▹ G′) ΠFG≡ΠF₁G₁ A≡B)
           (λ {ρ} [ρ] ⊢Δ → irrelevanceEq′ (PE.cong (wk ρ) F≡F₁) ([F] [ρ] ⊢Δ)
                                    ([F]₁ [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ))
           (λ {ρ} [ρ] ⊢Δ [a]₁ →
              let [a] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁))
                                         ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) [a]₁
              in  irrelevanceEq′ (PE.cong (λ y → wk (lift ρ) y [ _ ]) G≡G₁)
                                 ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁) ([G≡G′] [ρ] ⊢Δ [a]))
  irrelevanceEqT (Uᵥ _ _ _ _ _ _) (U₌ B≡U) = U₌ B≡U
  irrelevanceEqT (emb⁰¹ PE.refl x) (ιx A≡B) = irrelevanceEqT x A≡B
  irrelevanceEqT {Γ} {A} {B} {l} {.¹} (emb¹⁰ PE.refl x) A≡B = ιx (irrelevanceEqT x A≡B)

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

  -- Irrelevance for terms
  irrelevanceTerm : ∀ {Γ A t l l′} (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A)
                  → Γ ⊩⟨ l ⟩ t ∷ A / p → Γ ⊩⟨ l′ ⟩ t ∷ A / q
  irrelevanceTerm p q t = irrelevanceTermT (goodCasesRefl p q) t

  -- Irrelevance for terms with propositionally equal types
  irrelevanceTerm′ : ∀ {Γ A A′ t l l′} (eq : A PE.≡ A′)
                     (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A′)
                   → Γ ⊩⟨ l ⟩ t ∷ A / p → Γ ⊩⟨ l′ ⟩ t ∷ A′ / q
  irrelevanceTerm′ PE.refl p q t = irrelevanceTerm p q t

  -- Irrelevance for terms with propositionally equal types and terms
  irrelevanceTerm″ : ∀ {Γ A A′ t t′ l l′}
                      (eqA : A PE.≡ A′) (eqt : t PE.≡ t′)
                      (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A′)
                    → Γ ⊩⟨ l ⟩ t ∷ A / p → Γ ⊩⟨ l′ ⟩ t′ ∷ A′ / q
  irrelevanceTerm″ PE.refl PE.refl p q t = irrelevanceTerm p q t

  -- Irrelevance for terms with propositionally equal types, terms and contexts
  irrelevanceTermΓ″ : ∀ {l l′ A A′ t t′ Γ Γ′}
                     → Γ PE.≡ Γ′
                     → A PE.≡ A′
                     → t PE.≡ t′
                     → ([A]  : Γ  ⊩⟨ l  ⟩ A)
                       ([A′] : Γ′ ⊩⟨ l′ ⟩ A′)
                     → Γ  ⊩⟨ l  ⟩ t ∷ A  / [A]
                     → Γ′ ⊩⟨ l′ ⟩ t′ ∷ A′ / [A′]
  irrelevanceTermΓ″ PE.refl PE.refl PE.refl [A] [A′] [t] = irrelevanceTerm [A] [A′] [t]

  -- Helper for irrelevance of terms using shape view
  irrelevanceTermT : ∀ {Γ A t l l′} {p : Γ ⊩⟨ l ⟩ A} {q : Γ ⊩⟨ l′ ⟩ A}
                         → ShapeView Γ l l′ A A p q
                         → Γ ⊩⟨ l ⟩ t ∷ A / p → Γ ⊩⟨ l′ ⟩ t ∷ A / q
  irrelevanceTermT (ℕᵥ D D′) (ιx (ℕₜ n d n≡n prop)) = ιx (ℕₜ n d n≡n prop)
  irrelevanceTermT (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (neₜ k d nf))
                   with whrDet* (red D₁ , ne neK₁) (red D , ne neK)
  irrelevanceTermT (ne (ne K D neK K≡K) (ne .K D₁ neK₁ K≡K₁)) (ιx (neₜ k d nf))
    | PE.refl = ιx (neₜ k d nf)
  irrelevanceTermT {Γ} {t = t} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                                   (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                   (Πₜ f d funcF f≡f [f] [f]₁) =
    let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ)
        F≡F₁ , G≡G₁ = Π-PE-injectivity ΠFG≡ΠF₁G₁
    in  Πₜ f (PE.subst (λ x → Γ ⊢ t :⇒*: f ∷ x) ΠFG≡ΠF₁G₁ d) funcF
           (PE.subst (λ x → Γ ⊢ f ≅ f ∷ x) ΠFG≡ΠF₁G₁ f≡f)
           (λ {ρ} [ρ] ⊢Δ [a]₁ [b]₁ [a≡b]₁ →
              let [a]   = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁))
                                           ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) [a]₁
                  [b]   = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁))
                                           ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) [b]₁
                  [a≡b] = irrelevanceEqTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁))
                                             ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) [a≡b]₁
              in  irrelevanceEqTerm′ (PE.cong (λ G → wk (lift ρ) G [ _ ]) G≡G₁)
                                     ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                                     ([f] [ρ] ⊢Δ [a] [b] [a≡b]))
          (λ {ρ} [ρ] ⊢Δ [a]₁ →
             let [a] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁))
                                        ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) [a]₁
             in  irrelevanceTerm′ (PE.cong (λ G → wk (lift ρ) G [ _ ]) G≡G₁)
                                  ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁) ([f]₁ [ρ] ⊢Δ [a]))
  irrelevanceTermT (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 _) t = t
  irrelevanceTermT (emb⁰¹ PE.refl x) (ιx t) = irrelevanceTermT x t
  irrelevanceTermT (emb¹⁰ PE.refl x) t = ιx (irrelevanceTermT x t)

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

  -- Irrelevance for term equality
  irrelevanceEqTerm : ∀ {Γ A t u l l′} (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A)
                    → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / p → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ A / q
  irrelevanceEqTerm p q t≡u = irrelevanceEqTermT (goodCasesRefl p q) t≡u

  -- Irrelevance for term equality with propositionally equal types
  irrelevanceEqTerm′ : ∀ {Γ A A′ t u l l′} (eq : A PE.≡ A′)
                       (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A′)
                     → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / p → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ A′ / q
  irrelevanceEqTerm′ PE.refl p q t≡u = irrelevanceEqTerm p q t≡u

  -- Irrelevance for term equality with propositionally equal types and terms
  irrelevanceEqTerm″ : ∀ {Γ A A′ t t′ u u′ l l′}
                        (eqt : t PE.≡ t′) (equ : u PE.≡ u′) (eqA : A PE.≡ A′)
                        (p : Γ ⊩⟨ l ⟩ A) (q : Γ ⊩⟨ l′ ⟩ A′)
                      → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / p → Γ ⊩⟨ l′ ⟩ t′ ≡ u′ ∷ A′ / q
  irrelevanceEqTerm″ PE.refl PE.refl PE.refl p q t≡u = irrelevanceEqTerm p q t≡u

  -- Helper for irrelevance of term equality using shape view
  irrelevanceEqTermT : ∀ {Γ A t u} {l l′} {p : Γ ⊩⟨ l ⟩ A} {q : Γ ⊩⟨ l′ ⟩ A}
                           → ShapeView Γ l l′ A A p q
                           → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / p → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ A / q
  irrelevanceEqTermT (ℕᵥ D D′) (ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)) = ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)
  irrelevanceEqTermT (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (neₜ₌ k m d d′ nf))
                     with whrDet* (red D₁ , ne neK₁) (red D , ne neK)
  irrelevanceEqTermT (ne (ne K D neK K≡K) (ne .K D₁ neK₁ K≡K₁)) (ιx (neₜ₌ k m d d′ nf))
    | PE.refl = ιx (neₜ₌ k m d d′ nf)
  irrelevanceEqTermT {Γ} {t = t} {u = u}
                     (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                     (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
    let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ)
        F≡F₁ , G≡G₁ = Π-PE-injectivity ΠFG≡ΠF₁G₁
        [A]         = Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext
        [A]₁        = Πᵣ′ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁
    in  Πₜ₌ f g (PE.subst (λ x → Γ ⊢ t :⇒*: f ∷ x) ΠFG≡ΠF₁G₁ d)
            (PE.subst (λ x → Γ ⊢ u :⇒*: g ∷ x) ΠFG≡ΠF₁G₁ d′) funcF funcG
            (PE.subst (λ x → Γ ⊢ f ≅ g ∷ x) ΠFG≡ΠF₁G₁ f≡g)
            (irrelevanceTerm [A] [A]₁ [f]) (irrelevanceTerm [A] [A]₁ [g])
            (λ {ρ} [ρ] ⊢Δ [a]₁ →
               let [a] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁))
                                          ([F]₁ [ρ] ⊢Δ) ([F] [ρ] ⊢Δ) [a]₁
               in  irrelevanceEqTerm′ (PE.cong (λ G → wk (lift ρ) G [ _ ]) G≡G₁)
                                     ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁) ([f≡g] [ρ] ⊢Δ [a]))
  irrelevanceEqTermT (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) t≡u = t≡u
  irrelevanceEqTermT (emb⁰¹ PE.refl x) (ιx t≡u) = irrelevanceEqTermT x t≡u
  irrelevanceEqTermT (emb¹⁰ PE.refl x) t≡u = ιx (irrelevanceEqTermT x t≡u)


--
-- In this module we conclude our proof: we have shown that t, derive-dterm t
-- and produce related values (in the sense of the fundamental property,
-- rfundamental3), and for related values v1, dv and v2 we have v1 ⊕ dv ≡
-- v2 (because ⊕ agrees with validity, rrelV3→⊕).
--
-- We now put these facts together via derive-correct-si and derive-correct.
-- This is immediate, even though I spend so much code on it:
-- Indeed, all theorems are immediate corollaries of what we established (as
-- explained above); only the statements are longer, especially because I bother
-- expanding them.

module Thesis.SIRelBigStep.DeriveCorrect where

open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Thesis.SIRelBigStep.IlcSILR
open import Thesis.SIRelBigStep.FundamentalProperty

-- Theorem statement. This theorem still mentions step-indexes explicitly.
derive-correct-si-type =
  ∀ {τ Γ k} (t : Term Γ τ) ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3-skeleton (λ v1 dv v2 _ → v1 ⊕ dv ≡ v2) t (derive-dterm t) t ρ1 dρ ρ2 k

-- A verified expansion of the theorem statement.
derive-correct-si-type-means :
  derive-correct-si-type ≡
  ∀ {τ Γ k} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  (v1 v2 : Val τ) →
  ∀ j (j<k : j < k) →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct-si-type-means = refl

derive-correct-si : derive-correct-si-type
derive-correct-si t ρ1 dρ ρ2 ρρ = rrelT3→⊕ t (derive-dterm t) t ρ1 dρ ρ2 (rfundamental3 _ t ρ1 dρ ρ2 ρρ)

-- Infinitely related environments:
rrelρ3-inf : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3-inf Γ ρ1 dρ ρ2 = ∀ k → rrelρ3 Γ ρ1 dρ ρ2 k

-- A theorem statement for infinitely-related environments. On paper, if we informally
-- omit the arbitrary derivation step-index as usual, we get a statement without
-- step-indexes.
derive-correct :
  ∀ {τ Γ} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3-inf Γ ρ1 dρ ρ2) →
  (v1 v2 : Val τ) →
  ∀ j →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct t ρ1 dρ ρ2 ρρ v1 v2 j = derive-correct-si t ρ1 dρ ρ2 (ρρ (suc j)) v1 v2 j ≤-refl

open import Data.Unit

nilρ : ∀ {Γ n} (ρ : ⟦ Γ ⟧Context) → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ dρ ρ n
nilV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n
nilV (closure t ρ) = let dρ , ρρ = nilρ ρ in dclosure (derive-dterm t) ρ dρ , rfundamental3svv _ (abs t) ρ dρ ρ ρρ
nilV (natV n₁) = dnatV zero , refl
nilV (pairV a b) = let 0a , aa = nilV a; 0b , bb = nilV b in dpairV 0a 0b , aa , bb

nilρ ∅ = ∅ , tt
nilρ (v • ρ) = let dv , vv = nilV v ; dρ , ρρ = nilρ ρ in dv • dρ , vv , ρρ

-- -- Try to prove to define validity-preserving change composition.
-- -- If we don't store proofs that environment changes in closures are valid, we
-- -- can't finish the proof for the closure case using the Fundamental property.
-- -- But it seems that's not the approach we need to use: we might need
-- -- environment validity elsewhere.
-- -- Moreover, the proof is annoying to do unless we build a datatype to invert
-- -- validity proofs (as suggested by Ezyang in
-- -- http://blog.ezyang.com/2013/09/induction-and-logical-relations/).

-- ocomposeρ : ∀ {Γ} n ρ1 dρ1 ρ2 dρ2 ρ3 → rrelρ3 Γ ρ1 dρ1 ρ2 n → rrelρ3 Γ ρ2 dρ2 ρ3 n → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ1 dρ ρ3 n

-- ocomposev : ∀ {τ} n v1 dv1 v2 dv2 v3 → rrelV3 τ v1 dv1 v2 n → rrelV3 τ v2 dv2 v3 n → Σ[ dv ∈ DVal τ ] rrelV3 τ v1 dv v3 n
-- ocomposev n v1 dv1 v2 (bang v3) .v3 vv1 refl = bang v3 , refl
-- ocomposev n v1 (bang x) v2 (dclosure dt ρ dρ) v3 vv1 vv2 = {!!}
-- ocomposev n (closure t ρ) (dclosure .(derive-dterm t) .ρ dρ1) (closure .t .(ρ ⊕ρ dρ1)) (dclosure .(derive-dterm t) .(ρ ⊕ρ dρ1) dρ2) (closure .t .((ρ ⊕ρ dρ1) ⊕ρ dρ2)) ((refl , refl) , refl , refl , refl , refl , vv1) ((refl , refl) , refl , refl , refl , refl , vv2) =
--   let dρ , ρρ = ocomposeρ n ρ dρ1 (ρ ⊕ρ dρ1) dρ2 ((ρ ⊕ρ dρ1) ⊕ρ dρ2) {!!} {!!}
--   in dclosure (derive-dterm t) ρ dρ , (refl , refl) , refl , {!!} , refl , refl ,
--     λ { k (s≤s k≤n) v1 dv v2 vv →
--       let nilv2 , nilv2v = nilV v2
--       -- vv1 k ? v1 dv v2 vv
--       -- vv2 k ? v2 nilv2 v2 nilv2v
--       in {!!}
--       }
--       -- rfundamental3 k t (v1 • ρ) (dv • dρ) (v2 • ((ρ ⊕ρ dρ1) ⊕ρ dρ2)) (vv , rrelρ3-mono k n (≤-step k<n) _ ρ dρ ((ρ ⊕ρ dρ1) ⊕ρ dρ2) ρρ)}
-- -- p1 , p2 , p3 , p4 , p5
-- ocomposev n v1 dv1 v2 (dnatV n₁) v3 vv1 vv2 = {!!}
-- ocomposev n v1 dv1 v2 (dpairV dv2 dv3) v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (bang v2) .v2 dv2 v3 refl vv2 = bang (v2 ⊕ dv2) , rrelV3→⊕ v2 dv2 v3 vv2
-- -- ocomposev n v1 (dclosure dt ρ dρ) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dnatV n₁) v2 dv2 v3 vv1 vv2 = {!!}
-- -- ocomposev n v1 (dpairV dv1 dv2) v2 dv3 v3 vv1 vv2 = {!!}
-- -- ocomposeV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n

-- ocomposeρ {∅} n ∅ dρ1 ρ2 dρ2 ∅ ρρ1 ρρ2 = ∅ , tt
-- ocomposeρ {τ • Γ} n (v1 • ρ1) (dv1 • dρ1) (v2 • ρ2) (dv2 • dρ2) (v3 • ρ3) (vv1 , ρρ1) (vv2 , ρρ2) =
--   let dv , vv = ocomposev n v1 dv1 v2 dv2 v3 vv1 vv2
--       dρ , ρρ = ocomposeρ n ρ1 dρ1 ρ2 dρ2 ρ3 ρρ1 ρρ2
--   in  dv • dρ , vv , ρρ

-- -- But we sort of know how to store environments validity proofs in closures, you just need to use well-founded inductions, even if you're using types. Sad, yes, that's insanely tedious. Let's leave that to Coq.
-- -- What is also interesting: if that were fixed, could we prove correct
-- -- composition for change *terms* and rrelT3? And for *open expressions*? The
-- -- last is the main problem Ahmed run into.

-- 1: the proof of transitivity of rrelT by Ahmed is for the case where the second rrelT holds at arbitrary step counts :-)
-- 2: that proof doesn't go through for us. If de1 : e1 -> e2 and de2 : e2 ->
-- e3, we must show that if e1 and e3 evaluate something happens, but to use our
-- hypothesis we need that e2 also terminates, which in our case does not
-- follow. For Ahmed 2006, instead, e1 terminates and e1 ≤ e2 implies that e2
-- terminates.
--
-- Indeed, it seems that we can have a change from e1 to looping e2 and a change
-- from looping e2 to e3, and I don't expect the composition of such changes to
-- satisfy anything.
--
-- Indeed, "Imperative self-adjusting computation" does not mention any
-- transitivity result (even in the technical report).


{-# OPTIONS --rewriting #-}

module FFI.Data.Aeson where

open import Agda.Builtin.Equality using (_≡_)
open import Agda.Builtin.Equality.Rewrite using ()
open import Agda.Builtin.Bool using (Bool)
open import Agda.Builtin.String using (String)

open import FFI.Data.ByteString using (ByteString)
open import FFI.Data.HaskellString using (HaskellString; pack)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import FFI.Data.Either using (Either; mapL)
open import FFI.Data.Scientific using (Scientific)
open import FFI.Data.Vector using (Vector)

open import Properties.Equality using (_≢_)

{-# FOREIGN GHC import qualified Data.Aeson #-}
{-# FOREIGN GHC import qualified Data.Aeson.Key #-}
{-# FOREIGN GHC import qualified Data.Aeson.KeyMap #-}

postulate
  KeyMap : Set → Set
  Key : Set
  fromString : String → Key
  toString : Key → String
  empty : ∀ {A} → KeyMap A
  singleton : ∀ {A} → Key → A → (KeyMap A)
  insert : ∀ {A} → Key → A → (KeyMap A) → (KeyMap A)
  delete : ∀ {A} → Key → (KeyMap A) → (KeyMap A)
  unionWith : ∀ {A} → (A → A → A) → (KeyMap A) → (KeyMap A) → (KeyMap A)
  lookup : ∀ {A} → Key -> KeyMap A -> Maybe A
{-# POLARITY KeyMap ++ #-}
{-# COMPILE GHC KeyMap = type Data.Aeson.KeyMap.KeyMap #-}
{-# COMPILE GHC Key = type Data.Aeson.Key.Key #-}
{-# COMPILE GHC fromString = Data.Aeson.Key.fromText #-}
{-# COMPILE GHC toString = Data.Aeson.Key.toText #-}
{-# COMPILE GHC empty = \_ -> Data.Aeson.KeyMap.empty #-}
{-# COMPILE GHC singleton = \_ -> Data.Aeson.KeyMap.singleton #-}
{-# COMPILE GHC insert = \_ -> Data.Aeson.KeyMap.insert #-}
{-# COMPILE GHC delete = \_ -> Data.Aeson.KeyMap.delete #-}
{-# COMPILE GHC unionWith = \_ -> Data.Aeson.KeyMap.unionWith #-}
{-# COMPILE GHC lookup = \_ -> Data.Aeson.KeyMap.lookup #-}

postulate lookup-insert : ∀ {A} k v (m : KeyMap A) → (lookup k (insert k v m) ≡ just v)
postulate lookup-empty : ∀ {A} k → (lookup {A} k empty ≡ nothing)
postulate lookup-insert-not : ∀ {A} j k v (m : KeyMap A) → (j ≢ k) → (lookup k m ≡ lookup k (insert j v m))
postulate singleton-insert-empty : ∀ {A} k (v : A) → (singleton k v ≡ insert k v empty)
postulate insert-swap : ∀ {A} j k (v w : A) m → (j ≢ k) → insert j v (insert k w m) ≡ insert k w (insert j v m)
postulate insert-over : ∀ {A} j k (v w : A) m → (j ≡ k) → insert j v (insert k w m) ≡ insert j v m
postulate to-from : ∀ k → toString(fromString k) ≡ k
postulate from-to : ∀ k → fromString(toString k) ≡ k

{-# REWRITE lookup-insert lookup-empty singleton-insert-empty #-}

data Value : Set where
  object : KeyMap Value → Value
  array : Vector Value → Value
  string : String → Value
  number : Scientific → Value
  bool : Bool → Value
  null : Value
{-# COMPILE GHC Value = data Data.Aeson.Value (Data.Aeson.Object|Data.Aeson.Array|Data.Aeson.String|Data.Aeson.Number|Data.Aeson.Bool|Data.Aeson.Null) #-}

Object = KeyMap Value
Array = Vector Value

postulate
  decode : ByteString → Maybe Value
  eitherHDecode : ByteString → Either HaskellString Value
{-# COMPILE GHC decode = Data.Aeson.decodeStrict #-}
{-# COMPILE GHC eitherHDecode = Data.Aeson.eitherDecodeStrict #-}

eitherDecode : ByteString → Either String Value
eitherDecode bytes = mapL pack (eitherHDecode bytes)


module AsP where

f
  : {A : Set}
  → A
  → A
  → A
f x@y z@w
  = x

g
  : {A : Set}
  → A
  → A
  → A
g x@y z'@w'
  with y
... | _
  = x


------------------------------------------------------------------------
-- Propierties of abstract typing contexts
------------------------------------------------------------------------

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

module Data.Context.Properties where

open import Data.Fin using (Fin; zero; suc; lift; raise)
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Product using (_×_; _,_)
open import Data.Vec as Vec using (Vec; []; _∷_)
import Data.Vec.Properties as VecProps
open import Function as Fun using (_∘_; flip)
open import Relation.Binary.PropositionalEquality hiding (subst-∘)
open ≡-Reasoning
open import Relation.Unary using (Pred)

open import Data.Context
open import Data.Context.WellFormed

------------------------------------------------------------------------
-- Properties of abstract contexts and context extensions.

-- Properties of the `map' functions.

module _ {ℓ₁ ℓ₂} {T₁ : Pred ℕ ℓ₁} {T₂ : Pred ℕ ℓ₂} where

  -- pointwise equality is a congruence w.r.t. map and mapExt.

  map-cong : ∀ {n} {f g : ∀ {k} → T₁ k → T₂ k} → (∀ {k} → f {k} ≗ g {k}) →
             _≗_ {A = Ctx T₁ n} (map f) (map g)
  map-cong f≗g []        = refl
  map-cong f≗g (_∷_ t Γ) = cong₂ _∷_ (f≗g t) (map-cong f≗g Γ)

  mapExt-cong : ∀ {k m n} {f g : ∀ i → T₁ (i + m) → T₂ (i + n)} →
                (∀ {i} → f i ≗ g i) →
                _≗_ {A = CtxExt T₁ m k} (mapExt {T₂ = T₂} f) (mapExt g)
  mapExt-cong f≗g []            = refl
  mapExt-cong f≗g (_∷_ {l} t Γ) = cong₂ _∷_ (f≗g {l} t) (mapExt-cong f≗g Γ)

module _ {ℓ} {T : Pred ℕ ℓ} where

  -- map and mapExt are functorial.

  map-id : ∀ {n} → _≗_ {A = Ctx T n} (map Fun.id) Fun.id
  map-id []      = refl
  map-id (t ∷ Γ) = cong (t ∷_) (map-id Γ)

  mapExt-id : ∀ {m n} → _≗_ {A = CtxExt T m n} (mapExt λ _ t → t) Fun.id
  mapExt-id []      = refl
  mapExt-id (t ∷ Γ) = cong (t ∷_) (mapExt-id Γ)

module _ {ℓ₁ ℓ₂ ℓ₃} {T₁ : Pred ℕ ℓ₁} {T₂ : Pred ℕ ℓ₂} {T₃ : Pred ℕ ℓ₃} where

  map-∘ : ∀ {n} (f : ∀ {k} → T₂ k → T₃ k) (g : ∀ {k} → T₁ k → T₂ k)
          (Γ : Ctx T₁ n) → map {T₂ = T₃} (f ∘ g) Γ ≡ map {T₁ = T₂} f (map g Γ)
  map-∘ f g []      = refl
  map-∘ f g (t ∷ Γ) = cong (_ ∷_) (map-∘ f g Γ)

  mapExt-∘ : ∀ {k l m n}
             (f : ∀ i → T₂ (i + m) → T₃ (i + n))
             (g : ∀ i → T₁ (i + l) → T₂ (i + m)) →
             (Γ : CtxExt T₁ l k) →
             mapExt {T₂ = T₃} (λ i t → f i (g i t)) Γ ≡
               mapExt {T₁ = T₂} f (mapExt g Γ)
  mapExt-∘ f g []      = refl
  mapExt-∘ f g (t ∷ Γ) = cong (_ ∷_) (mapExt-∘ f g Γ)

-- Lemmas about operations on contexts that require weakening of
-- types.

module WeakenOpsLemmas {ℓ} {T : Pred ℕ ℓ} (extension : Extension T) where

  -- The underlyig operations.
  open WeakenOps extension

  -- Conversion to vector representation commutes with
  -- concatenation.

  toVec-++ : ∀ {m n} (Δ : CtxExt T m n) (Γ : Ctx T m) →
             toVec (Δ ++ Γ) ≡ extToVec Δ (toVec Γ)
  toVec-++ []      Γ = refl
  toVec-++ (t ∷ Δ) Γ =
    cong ((_ ∷_) ∘ Vec.map weaken) (toVec-++ Δ Γ)

  -- Lookup commutes with concatenation.

  lookup-++ : ∀ {m n} (Δ : CtxExt T m n) (Γ : Ctx T m) x →
              lookup (Δ ++ Γ) x ≡ extLookup Δ (toVec Γ) x
  lookup-++ Δ Γ x = cong (flip Vec.lookup x) (toVec-++ Δ Γ)

  -- We can skip the first element when looking up others.

  lookup-suc : ∀ {n} t (Γ : Ctx T n) x →
               lookup (t ∷ Γ) (suc x) ≡ weaken (lookup Γ x)
  lookup-suc t Γ x = VecProps.lookup-map x weaken (toVec Γ)

  extLookup-suc : ∀ {k m n} t (Γ : CtxExt T m n) (ts : Vec (T m) k) x →
                  extLookup (t ∷ Γ) ts (suc x) ≡ weaken (extLookup Γ ts x)
  extLookup-suc t Γ ts x = VecProps.lookup-map x weaken (extToVec Γ ts)

  -- We can skip a spliced-in element when looking up others.

  lookup-lift : ∀ {k m n} (Γ : CtxExt T m n) t (ts : Vec (T m) k) x →
                extLookup Γ ts x ≡ extLookup Γ (t ∷ ts) (lift n suc x)
  lookup-lift             []      t ts x       = refl
  lookup-lift             (u ∷ Δ) t ts zero    = refl
  lookup-lift {n = suc n} (u ∷ Δ) t ts (suc x) = begin
      extLookup (u ∷ Δ) ts (suc x)
    ≡⟨ extLookup-suc u Δ ts x ⟩
      weaken (extLookup Δ ts x)
    ≡⟨ cong weaken (lookup-lift Δ t ts x) ⟩
      weaken (extLookup Δ (t ∷ ts) (lift n suc x))
    ≡⟨ sym (extLookup-suc u Δ (t ∷ ts) (lift n suc x)) ⟩
      extLookup (u ∷ Δ) (t ∷ ts) (suc (lift n suc x))
    ∎

  -- Lookup in the prefix of a concatenation results in weakening.

  lookup-weaken⋆ : ∀ {m} n (Δ : CtxExt T m n) (Γ : Ctx T m) x →
                   lookup (Δ ++ Γ) (raise n x) ≡ weaken⋆ n (lookup Γ x)
  lookup-weaken⋆ zero    []      Γ x = refl
  lookup-weaken⋆ (suc n) (t ∷ Δ) Γ x = begin
      lookup (t ∷ Δ ++ Γ) (suc (raise n x))
    ≡⟨ VecProps.lookup-map (raise n x) weaken (toVec (Δ ++ Γ)) ⟩
      weaken (lookup (Δ ++ Γ) (raise n x))
    ≡⟨ cong weaken (lookup-weaken⋆ n Δ Γ x) ⟩
      weaken (weaken⋆ n (lookup Γ x))
    ∎

-- Lemmas relating conversions of context extensions to vector
-- representation with conversions of the underling entries.

module ConversionLemmas {T₁ T₂ : ℕ → Set}
                        (extension₁ : Extension T₁)
                        (extension₂ : Extension T₂) where
  private
    module W₁ = WeakenOps extension₁
    module W₂ = WeakenOps extension₂

  toVec-map : ∀ {n} (f : ∀ {k} → T₁ k → T₂ k) (Γ : Ctx T₁ n) →
              (∀ {k} (t : T₁ k) → W₂.weaken (f t) ≡ f (W₁.weaken t)) →
              W₂.toVec (map f Γ) ≡ Vec.map f (W₁.toVec Γ)
  toVec-map f []        _   = refl
  toVec-map f (_∷_ t Γ) hyp = cong₂ _∷_ (hyp t) (begin
      Vec.map W₂.weaken (W₂.toVec (map f Γ))
    ≡⟨ cong (Vec.map W₂.weaken) (toVec-map f Γ hyp) ⟩
      (Vec.map W₂.weaken (Vec.map f (W₁.toVec Γ)))
    ≡⟨ sym (VecProps.map-∘ W₂.weaken f (W₁.toVec Γ)) ⟩
      (Vec.map (W₂.weaken ∘ f) (W₁.toVec Γ))
    ≡⟨ VecProps.map-cong hyp (W₁.toVec Γ) ⟩
      (Vec.map (f ∘ W₁.weaken) (W₁.toVec Γ))
    ≡⟨ VecProps.map-∘ f W₁.weaken (W₁.toVec Γ) ⟩
      (Vec.map f (Vec.map W₁.weaken (W₁.toVec Γ)))
    ∎)

  -- Lookup commutes with re-indexing, provided that the reindexing
  -- function commutes with weakening.

  lookup-map : ∀ {n} (f : ∀ {k} → T₁ k → T₂ k) (Γ : Ctx T₁ n) x →
               (∀ {k} (t : T₁ k) → W₂.weaken (f t) ≡ f (W₁.weaken t)) →
               W₂.lookup (map f Γ) x ≡ f (W₁.lookup Γ x)
  lookup-map f Γ x hyp = begin
      W₂.lookup (map f Γ) x
    ≡⟨ cong (flip Vec.lookup x) (toVec-map f Γ hyp) ⟩
      Vec.lookup (Vec.map f (W₁.toVec Γ)) x
    ≡⟨ VecProps.lookup-map x f (W₁.toVec Γ) ⟩
      f (W₁.lookup Γ x)
    ∎

-- Lemmas about well-formed contexts and context extensions.

module ContextFormationLemmas {t ℓ} {T : Pred ℕ t}
                              (_⊢_wf : Wf T T ℓ) where
  open ContextFormation _⊢_wf

  -- Concatenation preserves well-formedness of contexts.

  wf-++-wfExt : ∀ {m n} {Δ : CtxExt T m n} {Γ : Ctx T m} →
                Γ ⊢ Δ wfExt → Γ wf → Δ ++ Γ wf
  wf-++-wfExt []               Γ-wf = Γ-wf
  wf-++-wfExt (t-wf ∷ Δ-wfExt) Γ-wf = t-wf ∷ wf-++-wfExt Δ-wfExt Γ-wf

  -- Splitting of well-formed contexts.
  wf-split : ∀ {m n} {Δ : CtxExt T m n} {Γ : Ctx T m} →
             Δ ++ Γ wf → Γ ⊢ Δ wfExt × Γ wf
  wf-split {Δ = []}    Γ-wf             = [] , Γ-wf
  wf-split {Δ = t ∷ Δ} (t-wf ∷ Δ++Γ-wf) =
    let Δ-wfExt , Γ-wf = wf-split Δ++Γ-wf
    in t-wf ∷ Δ-wfExt , Γ-wf