module nodcap.NF.CutND where

open import Algebra
open import Category.Monad
open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺
open import Data.List as L using (List; []; _∷_; _++_; map)
open import Data.List.Any as LA using (Any; here; there)
open import Data.List.Any.BagAndSetEquality as B
open import Data.Product as PR using (∃; _×_; _,_; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_; _∘_; flip)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as I using ()
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)

open import Data.Environment
open import nodcap.Base
open import nodcap.NF.Typing
open import nodcap.NF.Contract
open import nodcap.NF.Expand
open import nodcap.NF.Cut

open I.Inverse using (to; from)
private
  open module LM {ℓ} = RawMonadPlus (L.monadPlus {ℓ})
private module ++ {a} {A : Set a} = Monoid (L.monoid A)

{-# TERMINATING #-}
-- Theorem:
--   Nondeterministic cut elimination.
mutual
  cutND : {Γ Δ : Environment} {A : Type} →

    ⊢ⁿᶠ A ∷ Γ → ⊢ⁿᶠ A ^ ∷ Δ →
    ---------------------
    List (⊢ⁿᶠ Γ ++ Δ)

  cutND {_} {Δ} {A = 𝟏} halt (wait y)
    = return y
  cutND {Γ} {_} {A = ⊥} (wait x) halt
    = return
    $ P.subst ⊢ⁿᶠ_ (P.sym (proj₂ ++.identity Γ)) x
  cutND {_} {Θ} {A = A ⊗ B} (send {Γ} {Δ} x y) (recv z)
    = return
    ∘ P.subst ⊢ⁿᶠ_ (P.sym (++.assoc Γ Δ Θ))
    ∘ exch (swp [] Γ Δ)
    =<< cutND y
    ∘ exch (fwd [] Γ)
    =<< cutND x z
  cutND {Θ} {_} {A = A ⅋ B} (recv x) (send {Γ} {Δ} y z)
    = return
    ∘ P.subst ⊢ⁿᶠ_ (++.assoc Θ Γ Δ)
    =<< flip cutND z
    =<< cutND x y
  cutND {Γ} {Δ} {A = A ⊕ B} (sel₁ x) (case y z)
    = cutND x y
  cutND {Γ} {Δ} {A = A ⊕ B} (sel₂ x) (case y z)
    = cutND x z
  cutND {Γ} {Δ} {A = A & B} (case x y) (sel₁ z)
    = cutND x z
  cutND {Γ} {Δ} {A = A & B} (case x y) (sel₂ z)
    = cutND y z
  cutND {Γ} {Δ} {A = ![ n ] A} x y
    = all (replicate⁺ n (A ^)) >>= return ∘ withPerm ∘ proj₂
    where
      withPerm : {Θ : Environment} → replicate⁺ n (A ^) ∼[ bag ] Θ → ⊢ⁿᶠ Γ ++ Δ
      withPerm {Θ} b
        = cut x
        $ contract
        $ exch (B.++-cong (P.subst (_ ∼[ bag ]_) (all-replicate⁺ n (I.sym b)) b) I.id)
        $ expand y
  cutND {Γ} {Δ} {A = ?[ n ] A} x y
    = all (replicate⁺ n A) >>= return ∘ withPerm ∘ proj₂
    where
      withPerm : {Θ : Environment} → replicate⁺ n A ∼[ bag ] Θ → ⊢ⁿᶠ Γ ++ Δ
      withPerm {Θ} b
        = exch (swp₂ Γ)
        $ cut y
        $ P.subst (λ A → ⊢ⁿᶠ ?[ n ] A ∷ Γ) (P.sym (^-inv A))
        $ contract
        $ exch (B.++-cong (P.subst (_ ∼[ bag ]_) (all-replicate⁺ n (I.sym b)) b) I.id)
        $ expand x
  cutND {Γ} {Δ} {A} (exch b x) y
    = return
    ∘ exch (B.++-cong {ys₁ = Δ} (del-from b (here P.refl)) I.id)
    =<< cutNDIn (from b ⟨$⟩ here P.refl) (here P.refl) x y
  cutND {Γ} {Δ} {A} x (exch b y)
    = return
    ∘ exch (B.++-cong {xs₁ = Γ} I.id (del-from b (here P.refl)))
    =<< cutNDIn (here P.refl) (from b ⟨$⟩ here P.refl) x y

  cutNDIn : {Γ Δ : Environment} {A : Type} (i : A ∈ Γ) (j : A ^ ∈ Δ) →

    ⊢ⁿᶠ Γ → ⊢ⁿᶠ Δ →
    -----------------------
    List (⊢ⁿᶠ Γ - i ++ Δ - j)

  cutNDIn (here P.refl) (here P.refl) x y = cutND x y

  cutNDIn {_} {Θ} (there i) j (send {Γ} {Δ} x y) z
    with split Γ i
  ... | inj₁ (k , p) rewrite p
      = return
      ∘ P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ - k) Δ (Θ - j)))
      ∘  exch (swp₃ (_ ∷ Γ - k) Δ)
      ∘  P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Γ - k) (Θ - j) Δ)
      ∘ flip send y
      =<< cutNDIn (there k) j x z
  ... | inj₂ (k , p) rewrite p
      = return
      ∘ P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ) (Δ - k) (Θ - j)))
      ∘ send x
      =<< cutNDIn (there k) j y z
  cutNDIn (there i) j (recv x) y
    = return
    ∘ recv
    =<< cutNDIn (there (there i)) j x y
  cutNDIn (there i) j (sel₁ x) y
    = return
    ∘ sel₁
    =<< cutNDIn (there i) j x y
  cutNDIn (there i) j (sel₂ x) y
    = return
    ∘ sel₂
    =<< cutNDIn (there i) j x y
  cutNDIn (there i) j (case x y) z
    = cutNDIn (there i) j x z >>= λ xz
    → cutNDIn (there i) j y z >>= λ yz
    → return
    $ case xz yz
  cutNDIn (there ()) j halt y
  cutNDIn (there i) j (wait x) y
    = return
    ∘ wait
    =<< cutNDIn i j x y
  cutNDIn (there i) j loop y
    = return
    $ loop
  cutNDIn {Γ} {Δ} (there i) j (mk?₁ x) y
    = return
    ∘ mk?₁
    =<< cutNDIn (there i) j x y
  cutNDIn {Γ} {Δ} (there i) j (mk!₁ x) y
    = return
    ∘ mk!₁
    =<< cutNDIn (there i) j x y
  cutNDIn {Γ} {Δ} (there i) j (cont x) y
    = return
    ∘ cont
    =<< cutNDIn (there (there i)) j x y
  cutNDIn {_} {Θ} (there i) j (pool {Γ} {Δ} x y) z
    with split Γ i
  ... | inj₁ (k , p) rewrite p
      = return
      ∘ P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ - k) Δ (Θ - j)))
      ∘ exch (swp₃ (_ ∷ Γ - k) Δ)
      ∘ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Γ - k) (Θ - j) Δ)
      ∘ flip pool y
      =<< cutNDIn (there k) j x z
  ... | inj₂ (k , p) rewrite p
      = return
      ∘ P.subst ⊢ⁿᶠ_ (P.sym (++.assoc (_ ∷ Γ) (Δ - k) (Θ - j)))
      ∘ pool x
      =<< cutNDIn (there k) j y z

  cutNDIn {Θ} {_} i (there j) x (send {Γ} {Δ} y z)
    with split Γ j
  ... | inj₁ (k , p) rewrite p
      = return
      ∘ exch (bwd [] (Θ - i))
      ∘ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Θ - i) (Γ - k) Δ)
      ∘ flip send z
      ∘ exch (fwd [] (Θ - i))
      =<< cutNDIn i (there k) x y
  ... | inj₂ (k , p) rewrite p
      = return
      ∘ exch (swp [] (Θ - i) (_ ∷ Γ))
      ∘ send y
      ∘ exch (fwd [] (Θ - i))
      =<< cutNDIn i (there k) x z
  cutNDIn {Γ} i (there j) x (recv {Δ} y)
    = return
    ∘ exch (bwd [] (Γ - i))
    ∘ recv
    ∘ exch (swp [] (_ ∷ _ ∷ []) (Γ - i))
    =<< cutNDIn i (there (there j)) x y
  cutNDIn {Γ} {Δ} i (there j) x (sel₁ y)
    = return
    ∘ exch (bwd [] (Γ - i))
    ∘ sel₁
    ∘ exch (fwd [] (Γ - i))
    =<< cutNDIn i (there j) x y
  cutNDIn {Γ} {Δ} i (there j) x (sel₂ y)
    = return
    ∘ exch (bwd [] (Γ - i))
    ∘ sel₂
    ∘ exch (fwd [] (Γ - i))
    =<< cutNDIn i (there j) x y
  cutNDIn {Γ} {Δ} i (there j) x (case y z)
    = cutNDIn i (there j) x y >>= λ xy
    → cutNDIn i (there j) x z >>= λ xz
    → return
    $ exch (bwd [] (Γ - i))
    $ case
    ( exch (fwd [] (Γ - i)) xy )
    ( exch (fwd [] (Γ - i)) xz )
  cutNDIn {Γ} i (there ()) x halt
  cutNDIn {Γ} {Δ} i (there j) x (wait y)
    = return
    ∘ exch (bwd [] (Γ - i))
    ∘ wait
    =<< cutNDIn i j x y
  cutNDIn {Γ} {Δ} i (there j) x loop
    = return
    ∘ exch (bwd [] (Γ - i))
    $ loop
  cutNDIn {Γ} {Δ} i (there j) x (mk?₁ y)
    = return
    ∘ exch (bwd [] (Γ - i))
    ∘ mk?₁
    ∘ exch (fwd [] (Γ - i))
    =<< cutNDIn i (there j) x y
  cutNDIn {Γ} {Δ} i (there j) x (mk!₁ y)
    = return
    ∘ exch (bwd [] (Γ - i))
    ∘ mk!₁
    ∘ exch (fwd [] (Γ - i))
    =<< cutNDIn i (there j) x y
  cutNDIn {Γ} {Δ} i (there j) x (cont y)
    = return
    ∘ exch (bwd [] (Γ - i))
    ∘ cont
    ∘ exch (swp [] (_ ∷ _ ∷ []) (Γ - i))
    =<< cutNDIn i (there (there j)) x y
  cutNDIn {Θ} {_} i (there j) x (pool {Γ} {Δ} y z)
    with split Γ j
  ... | inj₁ (k , p) rewrite p
      = return
      ∘ exch (bwd [] (Θ - i))
      ∘ P.subst ⊢ⁿᶠ_ (++.assoc (_ ∷ Θ - i) (Γ - k) Δ)
      ∘ flip pool z
      ∘ exch (fwd [] (Θ - i))
      =<< cutNDIn i (there k) x y
  ... | inj₂ (k , p) rewrite p
      = return
      ∘ exch (swp [] (Θ - i) (_ ∷ Γ))
      ∘ pool y
      ∘ exch (fwd [] (Θ - i))
      =<< cutNDIn i (there k) x z

  cutNDIn {Γ} {Δ} i j (exch b x) y
    = return
    ∘ exch (B.++-cong {ys₁ = Δ - j} (del-from b i ) I.id)
    =<< cutNDIn (from b ⟨$⟩ i) j x y
  cutNDIn {Γ} {Δ} i j x (exch b y)
    = return
    ∘ exch (B.++-cong {xs₁ = Γ - i} I.id (del-from b j))
    =<< cutNDIn i (from b ⟨$⟩ j) x y

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


------------------------------------------------------------------------------
-- All the distributive laws modules
------------------------------------------------------------------------------

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

module DistributiveLaws.Everything where

open import DistributiveLaws.Base
open import DistributiveLaws.Base.Consistency.Axioms
open import DistributiveLaws.PropertiesI

open import DistributiveLaws.Lemma3-ATP
open import DistributiveLaws.Lemma4-ATP
open import DistributiveLaws.Lemma5-ATP
open import DistributiveLaws.Lemma6-ATP

open import DistributiveLaws.TaskB-AllStepsATP
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP
open import DistributiveLaws.TaskB.UnprovedATP


-- WARNING: This file was generated automatically by Vehicle
-- and should not be modified manually!
-- Metadata
--  - Agda version: 2.6.2
--  - AISEC version: 0.1.0.1
--  - Time generated: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Data.Unit
open import Data.Integer as ℤ using (ℤ)
open import Data.List
open import Data.List.Relation.Unary.All as List

module quantifierIn-output where

private
  VEHICLE_PROJECT_FILE = "TODO_projectFile"

emptyList : List ℤ
emptyList = []

abstract
  empty : List.All (λ (x : ℤ) → ⊤) emptyList
  empty = checkProperty record
    { projectFile  = VEHICLE_PROJECT_FILE
    ; propertyUUID = "TODO_propertyUUID"
    }


-- Andreas, 2017-08-28, issue #2723, reported by Andrea

{-# OPTIONS --allow-unsolved-metas #-}

-- {-# OPTIONS --warning=error #-}
-- {-# OPTIONS -v tc.cover:30 #-}

record Test : Set1 where
  field
    one two : Set
open Test

foo : Test
foo .one = {!!}
foo = {!!}
foo .two = {!!}

-- WAS: internal error in clause compiler

-- NOW: warning about unreachable clause


postulate B : Set

module M where
  record ⊤ : Set where

module P (A : Set) where
  open M public

module PB = P B


-- This combination should not be allowed:

{-# OPTIONS --guardedness --sized-types --safe #-}


open import Silica
open import HeapProperties

open import Data.List.Membership.DecSetoid ≡-decSetoid
open import Data.List.Relation.Unary.Any

open TypeEnvContext

------------ Lemmas --------------
-- If an expression is well-typed in Δ, then all locations in the expression are in Δ.
locationsInExprAreInContext : ∀ {Δ Δ' e T fl}
                              → ∀ {l : IndirectRef}
                              → Δ ⊢ e ⦂ T ⊣ Δ'
                              → FreeLocations e fl
                              → l ∈ fl
                              ----------------
                              → ∃[ T' ] ((StaticEnv.locEnv Δ) ∋ l ⦂ T')

-- fl is empty, so l is in fl leads to a contradiction.
locationsInExprAreInContext (varTy x spl) varFL ()
-- l is related to e, so therefore we can point to where l is in Δ.
locationsInExprAreInContext (locTy {Δ = Δ''} {T₁ = T₁} l spl) (locFL l) (here refl) =  ⟨ T₁ , Z ⟩
locationsInExprAreInContext (locTy {Δ = Δ''} {T₁} l spl) (locFL l) (there ())
locationsInExprAreInContext (objTy o spl) objValFL ()
locationsInExprAreInContext (boolTy b) boolFL ()
locationsInExprAreInContext ty voidFL ()

-- TODO: relax progress a little per statement of Theorem 5.1.
data Progress : Expr → Set where
  step : ∀ (Σ Σ' : RuntimeEnv)
         → ∀ (e e' : Expr)
         → (Σ , e ⟶ Σ' , e')
         -------------
         → Progress e

  done : ∀ {e : Value}
         ---------
         → Progress (valExpr e)

progress : ∀ {e T Δ Δ'}
           → ∀ (Σ : RuntimeEnv)
           → Closed e
           → Σ & Δ ok
           → Δ ⊢ e ⦂ T ⊣ Δ'
           ---------------
           → Progress e

progress Σ (closed (simpleExpr (var x)) ()) consis (varTy x split) -- Contradiction: var x has free variables, but we assumed e was closed.
-- TODO: Refactor these cases to avoid duplication!
progress Σ cl consis@(ok {Σ} _ _ _ _ _) ty@(locTy l voidSplit) =
  let
    locationExistsInContext = locationsInExprAreInContext ty (locFL l) (here refl)
    lInDelta = proj₂ locationExistsInContext
    heapLookupResult = voidLookup consis lInDelta
  in
    step Σ Σ (simpleExpr (loc l)) (valExpr voidVal) (SElookup ty heapLookupResult)
progress Σ cl consis@(ok {Σ} _ _ _ _ _) ty@(locTy l booleanSplit) =
  let
    locationExistsInContext = locationsInExprAreInContext ty (locFL l) (here refl)
    lInDelta = proj₂ locationExistsInContext
    heapLookupResult = boolLookup consis lInDelta
  in
    step Σ Σ (simpleExpr (loc l)) (valExpr (boolVal (proj₁ heapLookupResult))) (SElookup ty (proj₂ heapLookupResult))
progress Σ cl consis@(ok {Σ} _ _ _ _ _) ty@(locTy l (unownedSplit _ _ _ _)) =
  let
    locationExistsInContext = locationsInExprAreInContext ty (locFL l) (here refl)
    lInDelta = proj₂ locationExistsInContext
    heapLookupResult = locLookup consis lInDelta
    heapLookupFound = proj₁ (proj₂ heapLookupResult)
    o = proj₁ heapLookupResult
  in
    step Σ Σ (simpleExpr (loc l)) (valExpr (objVal o)) (SElookup ty heapLookupFound)
progress Σ cl consis@(ok {Σ} _ _ _ _ _) ty@(locTy l (shared-shared-shared _)) =
  let
    locationExistsInContext = locationsInExprAreInContext ty (locFL l) (here refl)
    lInDelta = proj₂ locationExistsInContext
    heapLookupResult = locLookup consis lInDelta
    heapLookupFound = proj₁ (proj₂ heapLookupResult)
    o = proj₁ heapLookupResult
  in
    step Σ Σ (simpleExpr (loc l)) (valExpr (objVal o)) (SElookup ty heapLookupFound)
progress Σ cl consis@(ok {Σ} _ _ _ _ _) ty@(locTy l (owned-shared _)) =
  let
    locationExistsInContext = locationsInExprAreInContext ty (locFL l) (here refl)
    lInDelta = proj₂ locationExistsInContext
    heapLookupResult = locLookup consis lInDelta
    heapLookupFound = proj₁ (proj₂ heapLookupResult)
    o = proj₁ heapLookupResult
  in
    step Σ Σ (simpleExpr (loc l)) (valExpr (objVal o)) (SElookup ty heapLookupFound)
progress Σ cl consis@(ok {Σ} _ _ _ _ _) ty@(locTy l (states-shared _)) =
  let
    locationExistsInContext = locationsInExprAreInContext ty (locFL l) (here refl)
    lInDelta = proj₂ locationExistsInContext
    heapLookupResult = locLookup consis lInDelta
    heapLookupFound = proj₁ (proj₂ heapLookupResult)
    o = proj₁ heapLookupResult
  in
    step Σ Σ (simpleExpr (loc l)) (valExpr (objVal o)) (SElookup ty heapLookupFound)

progress Σ cl consis (objTy o split) =  done
progress Σ cl consis (boolTy b) = done
progress Σ cl consis (voidTy) = done
progress Σ cl consis (assertTyₗ {s₁ = s} {l = l} tcEq subset) = step Σ Σ (assertₗ l s) (valExpr voidVal) (SEassertₗ {Σ} l s)
progress Σ cl consis (assertTyₓ {s₁ = s} {x = x} tcEq subset) = step Σ Σ (assertₓ x s) (valExpr voidVal) (SEassertₓ {Σ} x s)

progress Σ cl consis (newTy {Γ} {Δ} {Δ'} {Δ''} {states} {C} {st} {x₁} {x₂} stOK x₁Ty x₂Ty CInΓ refl) =
  let
    oFresh = ObjectRefContext.fresh (RuntimeEnv.μ Σ)
    o = proj₁ oFresh
    μ' =  (RuntimeEnv.μ Σ) ObjectRefContext., o ⦂ record { contractName = C ; stateName = st ; x₁ = x₁ ; x₂ = x₂ }
    Σ' = record Σ {μ = μ'}

  in
    step Σ Σ' (new C st x₁ x₂)  (valExpr (objVal o)) (SEnew (proj₁ (proj₂ oFresh)) refl refl)


module Base.Free.Properties where

open import Relation.Binary.PropositionalEquality using (_≢_)

open import Base.Free                             using (Free; pure; impure)

discriminate : ∀ {S P A} {s : S} {pf : P s → Free S P A} {a : A} → impure s pf ≢ pure a
discriminate = λ ()


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

open import Agda.Primitive
open import Prelude
import GSeTT.Typed-Syntax
import Globular-TT.Syntax

{- Structure of CwF of a globular type theory : Cut admissibility is significantly harder and has to be proved together with it -}
module Globular-TT.CwF-Structure {l} (index : Set l) (rule : index → GSeTT.Typed-Syntax.Ctx × (Globular-TT.Syntax.Pre-Ty index)) where
  open import Globular-TT.Syntax index
  open import Globular-TT.Rules index rule

  A∈Γ→Γ⊢A : ∀ {Γ x A} →  Γ ⊢C → x # A ∈ Γ → Γ ⊢T A
  A∈Γ→Γ⊢A Γ+⊢@(cc Γ⊢ Γ⊢B idp) (inl A∈Γ) = wkT (A∈Γ→Γ⊢A Γ⊢ A∈Γ) Γ+⊢
  A∈Γ→Γ⊢A Γ+⊢@(cc Γ⊢ Γ⊢A idp) (inr (idp , idp)) = wkT Γ⊢A Γ+⊢

  {- cut-admissibility -}
  -- notational shortcut : if A = B a term of type A is also of type B
  trT : ∀ {Γ A B t} → A == B → Γ ⊢t t # A → Γ ⊢t t # B
  trT idp Γ⊢t:A = Γ⊢t:A

  {- action on weakened types and terms -}
  n∉Γ : ∀ {Γ A n} → Γ ⊢C → (C-length Γ ≤ n) → ¬ (n # A ∈ Γ)
  n∉Γ (cc Γ⊢ _ idp) l+1≤n (inl n∈Γ) = n∉Γ Γ⊢ (Sn≤m→n≤m l+1≤n) n∈Γ
  n∉Γ (cc Γ⊢ _ idp) Sn≤n (inr (idp , idp)) = Sn≰n _ Sn≤n

  lΓ∉Γ : ∀ {Γ A} → Γ ⊢C → ¬ ((C-length Γ) # A ∈ Γ)
  lΓ∉Γ Γ⊢ = n∉Γ Γ⊢ (n≤n _)

  wk[]T : ∀ {Γ Δ γ x u A B} → Γ ⊢T A → Δ ⊢S < γ , x ↦ u > > (Γ ∙ x # B) → (A [ < γ , x ↦ u > ]Pre-Ty) == (A [ γ ]Pre-Ty)
  wk[]t : ∀ {Γ Δ γ x u A t B} → Γ ⊢t t # A → Δ ⊢S < γ , x ↦ u > > (Γ ∙ x # B) → (t [ < γ , x ↦ u > ]Pre-Tm) == (t [ γ ]Pre-Tm)
  wk[]S : ∀ {Γ Δ γ x u B Θ θ} → Γ ⊢S θ > Θ → Δ ⊢S < γ , x ↦ u > > (Γ ∙ x # B) → (θ ∘ < γ , x ↦ u >) == (θ ∘ γ)
  []T : ∀ {Γ A Δ γ} → Γ ⊢T A → Δ ⊢S γ > Γ → Δ ⊢T (A [ γ ]Pre-Ty)
  []t : ∀ {Γ A t Δ γ} → Γ ⊢t t # A → Δ ⊢S γ > Γ → Δ ⊢t (t [ γ ]Pre-Tm) # (A [ γ ]Pre-Ty)
  [∘]T : ∀ {Γ Δ Θ A γ δ} → Γ ⊢T A → Δ ⊢S γ > Γ → Θ ⊢S δ > Δ → ((A [ γ ]Pre-Ty) [ δ ]Pre-Ty) == (A [ γ ∘ δ ]Pre-Ty)
  [∘]t : ∀ {Γ Δ Θ A t γ δ} → Γ ⊢t t # A → Δ ⊢S γ > Γ → Θ ⊢S δ > Δ → ((t [ γ ]Pre-Tm) [ δ ]Pre-Tm) == (t [ γ ∘ δ ]Pre-Tm)
  ∘-admissibility : ∀ {Γ Δ Θ γ δ} → Δ ⊢S γ > Γ → Θ ⊢S δ > Δ → Θ ⊢S (γ ∘ δ) > Γ
  ∘-associativity : ∀ {Γ Δ Θ Ξ γ δ θ} → Δ ⊢S γ > Γ → Θ ⊢S δ > Δ → Ξ ⊢S θ > Θ → ((γ ∘ δ) ∘ θ) == (γ ∘ (δ ∘ θ))

  wk[]T (ob Γ⊢) _ = idp
  wk[]T (ar Γ⊢A Γ⊢t:A Γ⊢u:A) Δ⊢γ+:Γ+ = ⇒= (wk[]T Γ⊢A Δ⊢γ+:Γ+) (wk[]t Γ⊢t:A Δ⊢γ+:Γ+) (wk[]t Γ⊢u:A Δ⊢γ+:Γ+)
  wk[]t {x = x} (var {x = y} Γ⊢ y∈Γ) Δ⊢γ+:Γ+             with (eqdecℕ y x)
  ...                                                    | inr _ = idp
  wk[]t (var Γ⊢ l∈Γ) (sc Δ⊢γ:Γ (cc _ _ idp) _ _) | inl idp = ⊥-elim (lΓ∉Γ Γ⊢ l∈Γ)
  wk[]t (tm _ Γ⊢θ:Θ idp) Δ⊢γ+:Γ+ = Tm-constructor= idp (wk[]S Γ⊢θ:Θ Δ⊢γ+:Γ+)
  wk[]S (es _) _ = idp
  wk[]S (sc Γ⊢θ:Θ _ Γ⊢t:A[θ] idp) Δ⊢γ+:Γ+ = <,>= (wk[]S Γ⊢θ:Θ Δ⊢γ+:Γ+) idp (wk[]t Γ⊢t:A[θ] Δ⊢γ+:Γ+)

  []T (ob Γ⊢) Δ⊢γ:Γ = ob (Δ⊢γ:Γ→Δ⊢ Δ⊢γ:Γ)
  []T (ar Γ⊢A Γ⊢t:A Γ⊢u:A) Δ⊢γ:Γ = ar ([]T Γ⊢A Δ⊢γ:Γ) ([]t Γ⊢t:A Δ⊢γ:Γ) ([]t Γ⊢u:A Δ⊢γ:Γ)
  []t {t = Tm-constructor i _} (tm Ci⊢Ti x idp) Δ⊢γ:Γ = trT ([∘]T Ci⊢Ti x Δ⊢γ:Γ ^) (tm Ci⊢Ti (∘-admissibility x Δ⊢γ:Γ) idp)
  []t {Γ = (Γ ∙ _ # _)} {t = Var x} (var Γ+⊢@(cc Γ⊢ _ idp) (inl x∈Γ)) Δ⊢γ+:Γ+@(sc Δ⊢γ:Γ _ _ idp) with (eqdecℕ x (C-length Γ))
  ...                                                                                | inl idp = ⊥-elim (lΓ∉Γ Γ⊢ x∈Γ)
  ...                                                                                | inr _ = trT (wk[]T (A∈Γ→Γ⊢A Γ⊢ x∈Γ) Δ⊢γ+:Γ+ ^) ([]t (var Γ⊢ x∈Γ) Δ⊢γ:Γ)
  []t {Γ = (Γ ∙ _ # _)} {t = Var x} (var Γ+⊢@(cc Γ⊢ Γ⊢A idp) (inr (idp , idp))) Δ⊢γ+:Γ+@(sc Δ⊢γ:Γ x₁ Δ⊢t:A[γ] idp) with (eqdecℕ x (C-length Γ))
  ...                                                                                | inl p = trT (wk[]T Γ⊢A Δ⊢γ+:Γ+ ^) Δ⊢t:A[γ]
  ...                                                                                | inr x≠x = ⊥-elim (x≠x idp)

  [∘]T (ob _) _ _ = idp
  [∘]T (ar Γ⊢A Γ⊢t:A Γ⊢u:A) Δ⊢γ:Γ Θ⊢δ:Δ = ⇒= ([∘]T Γ⊢A Δ⊢γ:Γ Θ⊢δ:Δ) ([∘]t Γ⊢t:A Δ⊢γ:Γ Θ⊢δ:Δ) ([∘]t Γ⊢u:A Δ⊢γ:Γ Θ⊢δ:Δ)
  [∘]t (tm Ci⊢Ti x idp) Δ⊢γ:Γ Θ⊢δ:Δ = Tm-constructor= idp (∘-associativity x Δ⊢γ:Γ Θ⊢δ:Δ )
  [∘]t (var {x = x} Γ,y:A⊢ x∈Γ+) (sc {x = y} Δ⊢γ:Γ _ Δ⊢t:A[γ] idp) Θ⊢δ:Δ with (eqdecℕ x y )
  ...                                                                | inl idp = idp
  [∘]t (var Γ,y:A⊢ (inr (idp , idp))) (sc Δ⊢γ:Γ _ Δ⊢t:A[γ] idp) Θ⊢δ:Δ | inr x≠x = ⊥-elim (x≠x idp)
  [∘]t (var (cc Γ⊢ _ idp) (inl x∈Γ)) (sc Δ⊢γ:Γ _ Δ⊢t:A[γ] idp) Θ⊢δ:Δ | inr _ = [∘]t (var Γ⊢ x∈Γ) Δ⊢γ:Γ Θ⊢δ:Δ

  ∘-admissibility (es Δ⊢) Θ⊢δ:Δ = es (Δ⊢γ:Γ→Δ⊢ Θ⊢δ:Δ)
  ∘-admissibility (sc Δ⊢γ:Γ Γ,x:A⊢@(cc _ Γ⊢A idp) Δ⊢t:A[γ] idp) Θ⊢δ:Δ = sc (∘-admissibility Δ⊢γ:Γ Θ⊢δ:Δ) Γ,x:A⊢ (trT ([∘]T Γ⊢A Δ⊢γ:Γ Θ⊢δ:Δ) ([]t Δ⊢t:A[γ] Θ⊢δ:Δ)) idp

  ∘-associativity (es _) _ _ = idp
  ∘-associativity (sc Δ⊢γ:Γ _ Δ⊢t:A[γ] idp) Θ⊢δ:Δ Ξ⊢θ:Θ = <,>= (∘-associativity Δ⊢γ:Γ Θ⊢δ:Δ Ξ⊢θ:Θ) idp ([∘]t Δ⊢t:A[γ] Θ⊢δ:Δ Ξ⊢θ:Θ)

  Γ⊢t:A→Γ⊢A : ∀ {Γ A t} → Γ ⊢t t # A → Γ ⊢T A
  Γ⊢t:A→Γ⊢A (var Γ,x:A⊢@(cc Γ⊢ Γ⊢A idp) (inl y∈Γ)) = wkT (Γ⊢t:A→Γ⊢A (var Γ⊢ y∈Γ)) Γ,x:A⊢
  Γ⊢t:A→Γ⊢A (var Γ,x:A⊢@(cc _ _ idp) (inr (idp , idp))) = Γ,x:A⊢→Γ,x:A⊢A Γ,x:A⊢
  Γ⊢t:A→Γ⊢A (tm Ci⊢Ti Γ⊢γ:Δ idp) = []T Ci⊢Ti Γ⊢γ:Δ

  {- action of identity on types terms and substitutions is trivial (true on syntax) -}
  [id]T : ∀ Γ A → (A [ Pre-id Γ ]Pre-Ty) == A
  [id]t : ∀ Γ t → (t [ Pre-id Γ ]Pre-Tm) == t
  ∘-right-unit : ∀ {Δ γ} →  (γ ∘ Pre-id Δ) == γ

  [id]T Γ ∗ = idp
  [id]T Γ (⇒ A t u) = ⇒= ([id]T Γ A) ([id]t Γ t) ([id]t Γ u)
  [id]t Γ (Tm-constructor i γ) = Tm-constructor= idp ∘-right-unit
  [id]t ⊘ (Var x) = idp
  [id]t (Γ ∙ y # B) (Var x) with (eqdecℕ x y)
  ...                              | inl x=y = Var= (x=y ^)
  ...                              | inr _ = [id]t Γ (Var x)
  ∘-right-unit {Δ} {<>} = idp
  ∘-right-unit {Δ} {< γ , y ↦ t >} = <,>= ∘-right-unit idp ([id]t Δ t) -- ::= ∘-right-unit (×= idp ([id]t Δ t))

  {- identity is well-formed -}
  Γ⊢id:Γ : ∀ {Γ} → Γ ⊢C → Γ ⊢S Pre-id Γ > Γ
  Γ⊢id:Γ ec = es ec
  Γ⊢id:Γ Γ,x:A⊢@(cc Γ⊢ Γ⊢A idp) = sc (wkS (Γ⊢id:Γ Γ⊢) Γ,x:A⊢) Γ,x:A⊢ (var Γ,x:A⊢ (inr (idp , [id]T _ _))) idp

  {- composition is associative -}

  ∘-left-unit : ∀{Γ Δ γ} → Δ ⊢S γ > Γ → (Pre-id Γ ∘ γ) == γ
  ∘-left-unit (es _) = idp
  ∘-left-unit Δ⊢γ+:Γ+@(sc {x = x} Δ⊢γ:Γ (cc Γ⊢ _ idp) _ idp) with (eqdecℕ x x)
  ...                                                  | inl p = <,>= (wk[]S (Γ⊢id:Γ Γ⊢) Δ⊢γ+:Γ+ >> ∘-left-unit Δ⊢γ:Γ) idp idp
  ...                                                  | inr x≠x = ⊥-elim (x≠x idp)

  {- Structure of CwF -}

  Γ,x:A⊢π:Γ : ∀ {Γ x A} → (Γ ∙ x # A) ⊢C → (Γ ∙ x # A) ⊢S Pre-π Γ x A > Γ
  Γ,x:A⊢π:Γ Γ,x:A⊢@(cc Γ⊢ _ idp) = wkS (Γ⊢id:Γ Γ⊢) Γ,x:A⊢
  -- TODO : finish


{-# OPTIONS --allow-unsolved-metas #-}

record R : Set₁ where
  field
    A : Set
    f : A → A

record Double {a} (A : Set a) : Set a where
  field
    double : A → A

open Double {{...}}

-- Type error (incomplete patterns in Patterns.Match)
doubleR : Double R
R.A (double {{doubleR}} x)   = R.A x
R.f (double {{doubleR}} x) z = R.f x (R.f x z)

-- Internal error (incomplete patterns in Reduce.Fast)
doubleR₁ : Double R
R.A (double {{doubleR₁}} x)   = R.A x
R.f (double {{doubleR₁}} x) z = {!R.f x (R.f x z)!}


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

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

open import LibraBFT.Base.Types
import      LibraBFT.Impl.Consensus.ConsensusTypes.Block             as Block
import      LibraBFT.Impl.Execution.ExecutorTypes.StateComputeResult as StateComputeResult
import      LibraBFT.Impl.OBM.Crypto                                 as Crypto
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Consensus.ConsensusTypes.ExecutedBlock where

isNilBlock : ExecutedBlock → Bool
isNilBlock eb = Block.isNilBlock (eb ^∙ ebBlock)

blockInfo : ExecutedBlock → BlockInfo
blockInfo eb =
  Block.genBlockInfo
    (eb ^∙ ebBlock)
    (Crypto.obmHashVersion -- OBM-LBFT-DIFF - see SafetyRules.extensionCheck
      (eb ^∙ ebStateComputeResult ∙ scrObmNumLeaves))
    (eb ^∙ ebStateComputeResult ∙ scrObmNumLeaves)
    (eb ^∙ ebStateComputeResult ∙ scrEpochState)

maybeSignedVoteProposal : ExecutedBlock → MaybeSignedVoteProposal
maybeSignedVoteProposal self =
  MaybeSignedVoteProposal∙new
    (VoteProposal∙new (StateComputeResult.extensionProof (self ^∙ ebStateComputeResult))
                      (self ^∙ ebBlock)
                      (self ^∙ ebStateComputeResult ∙ scrEpochState))


-- New NO_POSITIVITY_CHECK pragma for data definitions and mutual
-- blocks

-- Skipping a new-style mutual block: Anywhere before the declaration
-- or the definition of a data type in the block (case: before first
-- declaration).

{-# NO_POSITIVITY_CHECK #-}
data Cheat₁ : Set
data Oops₁  : Set

data Cheat₁ where
  cheat₁ : Oops₁ → Cheat₁

data Oops₁ where
  oops₁ : (Cheat₁ → Cheat₁) → Oops₁

-- Skipping a new-style mutual block: Anywhere before the declaration
-- or the definition of a data type in the block (case: before some
-- definition).

data Cheat₂ : Set
data Oops₂  : Set

data Cheat₂ where
  cheat₂ : Oops₂ → Cheat₂

{-# NO_POSITIVITY_CHECK #-}
data Oops₂ where
  oops₂ : (Cheat₂ → Cheat₂) → Oops₂


{- 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.Prelude
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
import      LibraBFT.Yasm.Base   as LYB
import      LibraBFT.Yasm.System as LYS

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

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


{-# OPTIONS --cubical-compatible #-}
{-# OPTIONS --allow-unsolved-metas #-}

-- This issue demonstrates that a failing termination check,
-- subsequently blocking reductions, makes some `impossible'
-- cases possible in the conversion checker.

module Issue921 where

infix 3 _==_
postulate
  _==_ : {A : Set} → A → A → Set
  transport : {A : Set} (B : A → Set) {x y : A} (p : x == y) → (B x → B y)
  ! : {A : Set} {x y : A} → (x == y → y == x)

infixr 1 _,_
record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst
open Σ public

infix 4 _≃_

_≃_ : ∀ (A : Set) (B : Set) → Set
A ≃ B = Σ (A → B) (λ _ → B → A)

postulate
  <– : {A : Set} {B : Set} → (A ≃ B) → B → A

infixr 4 _∘e_
_∘e_ : {A : Set} {B : Set} {C : Set} → B ≃ C → A ≃ B → A ≃ C
e1 ∘e e2 = ({!!} , λ c → snd e2 (snd e1 c))

module _ {A : Set} {B : A → Set} {C : (a : A) → B a → Set} where
  Σ-assoc : Σ (Σ A B) (λ z → C (fst z) (snd z)) ≃ Σ A (λ a → Σ (B a) (C a))
  Σ-assoc = ({!!} , λ {(a , (b , c)) → ((a , b) , c)})

data Ctx : Set

postulate
  Ty : Ctx → Set

data Ctx where
  _·_ : (Γ : Ctx) → Ty {!!} → Ctx

infix 5 _ctx-⇛_
_ctx-⇛_ : Ctx → Ctx → Set

-- swap these two lines and the internal error disappears
Tm : Σ Ctx Ty → Set
Γ ctx-⇛ (Δ · A) = Σ {!!} {!!}

infix 10 _*_

postulate
  _*_  : {Γ Δ : Ctx} (m : Γ ctx-⇛ Δ) → Ty {!!} → Ty {!!}

pullback : {Γ Δ : Ctx} {A : Ty Δ} → Tm (Δ , A) → (m : Γ ctx-⇛ Δ) → Tm (Γ , m * A)

infix 7 _·_
data Xtc (Γ : Ctx) : Set where
  _·_ : (A : Ty {!!}) → Xtc {!!} → Xtc Γ

infix 6 _⋯_
_⋯_ : (Γ : Ctx) → Xtc Γ → Ctx
Γ ⋯ (A · s) = (Γ · A) ⋯ s

module xtc where
  infix 5 _⇛_∣_
  _⇛_∣_ : (Γ : Ctx) {Δ : Ctx} (m : Γ ctx-⇛ Δ) → Xtc Δ → Set
  Γ ⇛ m ∣ A · T = Σ (Tm (Γ , m * A)) (λ t → Γ ⇛ (m , t) ∣ T)

  infix 5 _⇛_
  _⇛_ : (Γ : Ctx) → Σ Ctx (λ Δ → Xtc Δ) → Set
  Γ ⇛ (Δ , T) = Σ (Γ ctx-⇛ Δ) (λ m → Γ ⇛ m ∣ T)

  eq : {Γ Δ : Ctx} {T : Xtc Δ} → Γ ctx-⇛ Δ ⋯ T ≃ Γ ⇛ (Δ , T)
  eq {T = A · T} = Σ-assoc ∘e eq

weaken : (Γ : Ctx) {T : Xtc Γ} → Γ ⋯ T ctx-⇛ Γ

infix 10 _○_

_○_ : {Γ Δ Θ : Ctx} → Δ ctx-⇛ Θ → Γ ctx-⇛ Δ → Γ ctx-⇛ Θ

postulate
  _○=_ : {Γ Δ Θ : Ctx} (n : Δ ctx-⇛ Θ) (m : Γ ctx-⇛ {!!}) {A : Ty {!!}} → (n ○ m) * A == m * (n * A)

Tm P = Σ Ctx λ Γ → Σ (Ty {!!}) λ A → Σ (Xtc (Γ · A)) λ T → (Γ · A ⋯ T , weaken Γ {A · T} * A) == P

weaken (Γ · A) {T} = (weaken Γ {A · T} , (Γ , A , T , {!!}))

_○_ {Θ = Θ · _} (n , x) m = (n ○ m , transport (λ z → Tm (_ , z)) (! (n ○= m)) (pullback x m))

weaken-○-scope : {Γ Δ : Ctx} {T : Xtc Δ} (ms : Γ xtc.⇛ (Δ , T)) → weaken Δ {T} ○ snd xtc.eq ms == fst ms

pullback-var : {Γ Δ : Ctx} {A : Ty {!!}} {T : Xtc (Δ · A)}
               (ms : Γ xtc.⇛ (Δ , A · T))
             → Tm (Γ , snd xtc.eq ms * (weaken Δ {A · T} * A))
pullback-var {Γ} {Δ} {A} {T} ms =
  transport (λ z → Tm (Γ , z)) (weaken Δ {A · T} ○= snd xtc.eq ms)
    (transport (λ z → Tm (Γ , z * A)) (! (weaken-○-scope ms))
      (fst (snd ms)))

pullback (Δ' , _ , T , p) = transport (λ P → (m : _ ctx-⇛ fst P) → Tm (_ , m * snd P)) p (<– {!!} pullback-var)

weaken-○-scope {Γ} {Δ · A} {T} ((m , t) , ts) = {!!} where
  helper3 : transport (λ z → Tm (Γ , z))
                      (! (fst (weaken (Δ · A)) ○= snd xtc.eq ((m , t) , ts)))
                      (pullback-var {!!})
         == transport (λ z → Tm (Γ , z * A))
                      (! (weaken-○-scope (m , t , ts)))
                      t
  helper3 = {!!}


module _ where

open import Common.Prelude hiding (_>>=_)
open import Common.Reflection
open import Common.Equality

open import Imports.StaleMetaLiteral

macro
  unquoteMeta : Meta → Tactic
  unquoteMeta m = give (meta m [])

thm : unquoteMeta staleMeta ≡ 42
thm = refl


module MJ.Syntax.Scoped where

open import Prelude
open import Data.Maybe as Maybe using (Maybe; just)
open import Data.Maybe.All as MayAll
open import Data.Vec as Vec hiding (_∈_)
open import Data.Star.Indexed
open import Data.List
open import Data.List.Properties.Extra
open import Data.List.Prefix
open import Data.List.Any
open import Data.List.All as List∀ hiding (lookup)
open import Data.List.All.Properties.Extra
open import Relation.Binary.PropositionalEquality

import Data.Vec.All as Vec∀
open Membership-≡

open import MJ.Types

NativeBinOp = ℕ → ℕ → ℕ

data Expr {n : ℕ} (Γ : Ctx c n) : Ty c → Set where
  new  : (C : Fin c) → All (Expr Γ) (Class.constr (clookup C)) → Expr Γ (ref C)
  unit : Expr Γ void
  num  : ℕ → Expr Γ int
  iop  : NativeBinOp → (l r : Expr Γ int) → Expr Γ int
  call : ∀ {cid as b} →
        Expr Γ (ref cid) → Member Σ cid MTH (as , b) → All (Expr Γ) as →
        Expr Γ b
  var  : (i : Fin n) → Expr Γ (lookup i Γ)
  get  : ∀ {cid ty} → Expr Γ (ref cid) → Member Σ cid FLD ty → Expr Γ ty
  upcast : ∀ {c c'} → Σ ⊢ c <: c' → Expr Γ (ref c) → Expr Γ (ref c')

data Cmd {n}(I : Ctx c n)(r : Ty c) : ∀ {m} → (O : Ctx c m) → Set where
  loc  : ∀ a → Expr I a → Cmd I r (a ∷ I)
  asgn : ∀ (i : Fin n) → Expr I (lookup i I) → Cmd I r I
  set  : ∀ {C a} → Expr I (ref C) →
          Member Σ C FLD a → Expr I a → Cmd I r I
  do   : ∀ {a} → Expr I a → Cmd I r I
  ret  : Expr I r → Cmd I r I

Stmts : ∀ {n m}→ (Ctx c n) → Ty c → (Ctx c m) → Set
Stmts I r O = Star ℕ (λ n m (I : Ctx c n) (O : Ctx c m) → Cmd I r O) I O

data Body {n}(I : Ctx c n) : Ty c → Set where
  body : ∀ {m r}{O : Ctx c m} → Stmts I r O → Expr O r → Body I r

-- mapping of namespace typings to the type of their implementation
Def : ∀ {ns} → Fin c → typing ns c → Set
-- methods have bodies
Def {MTH} C (as , b) = Body (ref C ∷ (fromList as)) b
-- fields have initializers
Def {FLD} C a = Body (fromList (Class.constr (clookup C))) a

record Implementation (cid : Fin c) : Set where
  constructor impl
  open Class (clookup cid) public
  field
    -- mapping construct arguments to super constructor arguments
    super-args :
      Maybe.All
        (λ p → All (Expr (fromList constr)) (Class.constr (clookup p)))
        parent

    -- definitions for all local members
    defs : ∀ ns → All (Def cid) (decls ns)

-- implementation of a classtable
record Impl : Set where
  field
    bodies : ∀ (cid : Fin c) → Implementation cid

-- get member definition from a class
getDef : ∀ {ns ty}→ (cid : Fin c) → (m : Member Σ cid ns ty) → Impl → Def (proj₁ m) ty
getDef {ns = ns} cid (_ , refl , def) I with clookup cid | inspect clookup cid
... | C@(class parent constr decls) | [ refl ] with Impl.bodies I cid
... | impl _ defs = ∈-all def (defs ns)
getDef cid (P' , super {pid = pid} p P<:P' , def) I = getDef pid (P' , P<:P' , def) I

Prog : Ty c → Set
Prog a = Impl × (Body [] a)


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped as U
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Reflexivity

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

import Data.Fin as Fin
import Data.Nat as Nat

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

-- Specific reducible types with possible embedding

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

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

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

_⊩⟨_⟩ne_^[_,_] : (Γ : Con Term) (l : TypeLevel) (A : Term) (r : Relevance) (ll : Level) → Set
Γ ⊩⟨ l ⟩ne A ^[ r , ll ] = MaybeEmb l (λ l′ → Γ ⊩ne A ^[ r , ll ])

_⊩⟨_⟩Π_^[_,_] : (Γ : Con Term) (l : TypeLevel) (A : Term) → Relevance → Level → Set
Γ ⊩⟨ l ⟩Π A ^[ r , lΠ ] = MaybeEmb l (λ l′ → Γ ⊩′⟨ l′ ⟩Π A ^[ r , lΠ ])

_⊩⟨_⟩∃_^_ : (Γ : Con Term) (l : TypeLevel) (A : Term) (ll : Level) → Set
Γ ⊩⟨ l ⟩∃ A ^ ll = MaybeEmb l (λ l′ → Γ ⊩′⟨ l′ ⟩∃ A ^ ll)

-- Construct a general reducible type from a specific

U-intr : ∀ {l Γ A ll } → (UA : Γ ⊩⟨ l ⟩U A ^ ll) → Γ ⊩⟨ l ⟩ A ^ [ ! , ll ]
U-intr (noemb UA) = Uᵣ UA
U-intr {l = ι ¹} (emb emb< x) = emb emb< (U-intr x)
U-intr {l = ∞}  (emb ∞< x) = emb ∞< (U-intr x)

ℕ-intr : ∀ {l A Γ} → Γ ⊩⟨ l ⟩ℕ A → Γ ⊩⟨ l ⟩ A ^ [ ! , ι ⁰ ]
ℕ-intr (noemb x) = ℕᵣ x
ℕ-intr {l = ι ¹} (emb emb< x) = emb emb< (ℕ-intr x)
ℕ-intr {l = ∞}  (emb ∞< x) = emb ∞< (ℕ-intr x)

Empty-intr : ∀ {l A Γ ll} → Γ ⊩⟨ l ⟩Empty A ^ ll → Γ ⊩⟨ l ⟩ A ^ [ % , ι ll ]
Empty-intr (noemb x) = Emptyᵣ x
Empty-intr {l = ι ¹} (emb emb< x) = emb emb< (Empty-intr x)
Empty-intr {l = ∞}  (emb ∞< x) = emb ∞< (Empty-intr x)

ne-intr : ∀ {l A Γ r ll} → Γ ⊩⟨ l ⟩ne A ^[ r , ll ] → Γ ⊩⟨ l ⟩ A ^ [ r , ι ll ]
ne-intr (noemb x) = ne x
ne-intr {l = ι ¹} (emb emb< x) = emb emb< (ne-intr x)
ne-intr {l = ∞}  (emb ∞< x) = emb ∞< (ne-intr x)

Π-intr : ∀ {l A Γ r ll} → Γ ⊩⟨ l ⟩Π A ^[ r , ll ]  → Γ ⊩⟨ l ⟩ A ^ [ r , ι ll ]
Π-intr (noemb x) = Πᵣ x
Π-intr {l = ι ¹} (emb emb< x) = emb emb< (Π-intr x)
Π-intr {l = ∞}  (emb ∞< x) = emb ∞< (Π-intr x)

∃-intr : ∀ {l A Γ ll} → Γ ⊩⟨ l ⟩∃ A ^ ll → Γ ⊩⟨ l ⟩ A ^ [ % , ι ll ]
∃-intr (noemb x) = ∃ᵣ x
∃-intr {l = ι ¹} (emb emb< x) = emb emb< (∃-intr x)
∃-intr {l = ∞}  (emb ∞< x) = emb ∞< (∃-intr x)

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

U-elim′ : ∀ {l Γ A r l′ ll} → Γ ⊢ A ⇒* Univ r l′ ^ [ ! , ll ] → Γ ⊩⟨ l ⟩ A ^ [ ! , ll ] → Γ ⊩⟨ l ⟩U A ^ ll
U-elim′ D (Uᵣ′ A ll r l l< e D') = noemb (Uᵣ r l l< e D')
U-elim′ D (ℕᵣ D') =  ⊥-elim (U≢ℕ (whrDet* (D ,  Uₙ) (red D' , ℕₙ)))
U-elim′ D (ne′ K D' neK K≡K) =  ⊥-elim (U≢ne neK (whrDet* (D ,  Uₙ) (red D' , ne neK)))
U-elim′ D (Πᵣ′ rF lF lG _ _ F G D' ⊢F ⊢G A≡A [F] [G] G-ext) = ⊥-elim (U≢Π (whrDet* (D , Uₙ) (red D' , Πₙ)))
U-elim′ {ι ¹} D (emb emb< x) with U-elim′ D x
U-elim′ {ι ¹} D (emb emb< x) | noemb x₁ = emb emb< (noemb x₁)
U-elim′ {ι ¹} D (emb emb< x) | emb () x₁
U-elim′ {∞} D (emb ∞< x) with U-elim′ D x
U-elim′ {∞} D (emb ∞< x) | noemb x₁ = emb ∞< (noemb x₁)
U-elim′ {∞} D (emb ∞< x) | emb <l x₁ = emb {l′ = ι ¹} ∞< (emb <l x₁)

U-elim : ∀ {l Γ r l′ ll′} → Γ ⊩⟨ l ⟩ Univ r l′ ^ [ ! , ll′ ] → Γ ⊩⟨ l ⟩U Univ r l′ ^ ll′
U-elim [U] = U-elim′ (id (escape [U])) [U]

ℕ-elim′ : ∀ {l A Γ ll} → Γ ⊢ A ⇒* ℕ ^ [ ! , ll ]  → Γ ⊩⟨ l ⟩ A ^ [ ! , ll ] → Γ ⊩⟨ l ⟩ℕ A
ℕ-elim′ D (Uᵣ′ _ _ _ _ l< PE.refl [[ _ , _ , d ]]) = ⊥-elim (U≢ℕ (whrDet* (d , Uₙ) (D , ℕₙ)))
ℕ-elim′ D (ℕᵣ D′) = noemb D′
ℕ-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (ℕ≢ne neK (whrDet* (D , ℕₙ) (red D′ , ne neK)))
ℕ-elim′ D (Πᵣ′ rF lF lG _ _ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (ℕ≢Π (whrDet* (D , ℕₙ) (red D′ , Πₙ)))
ℕ-elim′ {ι ¹} D (emb emb< x) with ℕ-elim′ D x
ℕ-elim′ {ι ¹} D (emb emb< x) | noemb x₁ = emb emb< (noemb x₁)
ℕ-elim′ {ι ¹} D (emb emb< x) | emb () x₁
ℕ-elim′ {∞} D (emb ∞< x) with ℕ-elim′ D x
ℕ-elim′ {∞} D (emb ∞< x) | noemb x₁ = emb ∞< (noemb x₁)
ℕ-elim′ {∞} D (emb ∞< x) | emb <l x₁ = emb {l′ = ι ¹} ∞< (emb <l x₁)

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

Empty-elim′ : ∀ {l A ll Γ} → Γ ⊢ A ⇒* Empty ll ^ [ % , ι ll ] → Γ ⊩⟨ l ⟩ A ^ [ % , ι ll ] → Γ ⊩⟨ l ⟩Empty A ^ ll
Empty-elim′ D (Emptyᵣ D′) = noemb D′
Empty-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (Empty≢ne neK (whrDet* (D , Emptyₙ) (red D′ , ne neK)))
Empty-elim′ D (Πᵣ′ rF lF lG _ _ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (Empty≢Π (whrDet* (D , Emptyₙ) (red D′ , Πₙ)))
Empty-elim′ D (∃ᵣ′  F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (Empty≢∃ (whrDet* (D , Emptyₙ) (red D′ , ∃ₙ)))
Empty-elim′ {ι ¹} D (emb emb< x) with Empty-elim′ D x
Empty-elim′ {ι ¹} D (emb emb< x) | noemb x₁ = emb emb< (noemb x₁)
Empty-elim′ {ι ¹} D (emb emb< x) | emb () x₁
Empty-elim′ {∞} D (emb ∞< x) with Empty-elim′ D x
Empty-elim′ {∞} D (emb ∞< x) | noemb x₁ = emb ∞< (noemb x₁)
Empty-elim′ {∞} D (emb ∞< x) | emb <l x₁ = emb {l′ = ι ¹} ∞< (emb <l x₁)

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

ne-elim′ : ∀ {l A Γ K r ll ll'} → Γ ⊢ A ⇒* K ^ [ r , ι ll ] → Neutral K → Γ ⊩⟨ l ⟩ A ^ [ r , ll' ] → ι ll PE.≡  ll' → Γ ⊩⟨ l ⟩ne A ^[ r , ll ]
ne-elim′ D neK (Uᵣ′ _ _ _ _ l< PE.refl [[ _ , _ , d ]]) e = ⊥-elim (U≢ne neK (whrDet* (d , Uₙ) (D , ne neK)))
ne-elim′ D neK (ℕᵣ D′) e = ⊥-elim (ℕ≢ne neK (whrDet* (red D′ , ℕₙ) (D , ne neK)))
ne-elim′ D neK (ne (ne K D′ neK′ K≡K)) PE.refl = noemb (ne K D′ neK′ K≡K)
ne-elim′ D neK (Πᵣ′ rF lF lG _ _ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) e =
  ⊥-elim (Π≢ne neK (whrDet* (red D′ , Πₙ) (D , ne neK)))
ne-elim′ D neK (∃ᵣ′ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) e =
  ⊥-elim (∃≢ne neK (whrDet* (red D′ , ∃ₙ) (D , ne neK)))
ne-elim′ D neK (Emptyᵣ D′) e = ⊥-elim (Empty≢ne neK (whrDet* (red D′ , Emptyₙ) (D , ne neK)))
ne-elim′ {ι ¹} D neK (emb emb< x) e with ne-elim′ D neK x e
ne-elim′ {ι ¹} D neK (emb emb< x) e | noemb x₁ = emb emb< (noemb x₁)
ne-elim′ {ι ¹} D neK (emb emb< x) e | emb () x₁
ne-elim′ {∞} D neK (emb ∞< x) e with ne-elim′ D neK x e
ne-elim′ {∞} D _ (emb ∞< x) e | noemb x₁ = emb ∞< (noemb x₁)
ne-elim′ {∞} D _ (emb ∞< x) e | emb <l x₁ = emb {l′ = ι ¹} ∞< (emb <l x₁)

ne-elim : ∀ {Γ l K r ll} → Neutral K  → Γ ⊩⟨ l ⟩ K ^ [ r , ι ll ] → Γ ⊩⟨ l ⟩ne K ^[ r , ll ]
ne-elim neK [K] = ne-elim′ (id (escape [K])) neK [K] PE.refl

Π-elim′ : ∀ {l A Γ F G rF lF lG r lΠ} → Γ ⊢ A ⇒* Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ r , ι lΠ ] → Γ ⊩⟨ l ⟩ A ^ [ r , ι lΠ ]  → Γ ⊩⟨ l ⟩Π A ^[ r , lΠ ]
Π-elim′ D (Uᵣ′ _ _ _ _ l< X [[ _ , _ , d ]]) = ⊥-elim (U≢Π (whrDet* (d , Uₙ) (D , Πₙ)))
Π-elim′ D (ℕᵣ D′) = ⊥-elim (ℕ≢Π (whrDet* (red D′ , ℕₙ) (D , Πₙ)))
Π-elim′ D (Emptyᵣ D′) = ⊥-elim (Empty≢Π (whrDet* (red D′ , Emptyₙ) (D , Πₙ)))
Π-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (Π≢ne neK (whrDet* (D , Πₙ) (red D′ , ne neK)))
Π-elim′ D (Πᵣ′ rF lF lG lF≤ lG≤ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  noemb (Πᵣ rF lF lG lF≤ lG≤ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext)
Π-elim′ D (∃ᵣ′ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (Π≢∃ (whrDet* (D , Πₙ) (red D′ , ∃ₙ)))
Π-elim′ {ι ¹} D (emb emb< x) with Π-elim′ D x
Π-elim′ {ι ¹} D (emb emb< x) | noemb x₁ = emb emb< (noemb x₁)
Π-elim′ {ι ¹} D (emb emb< x) | emb () x₁
Π-elim′ {∞} D (emb ∞< x) with Π-elim′ D x
Π-elim′ {∞} D (emb ∞< x) | noemb x₁ = emb ∞< (noemb x₁)
Π-elim′ {∞} D (emb ∞< x) | emb <l x₁ = emb {l′ = ι ¹} ∞< (emb <l x₁)

Π-elim : ∀ {Γ F G rF lF lG r lΠ l} → Γ ⊩⟨ l ⟩ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ r , ι lΠ ] → Γ ⊩⟨ l ⟩Π Π F ^ rF ° lF ▹ G ° lG ° lΠ ^[ r , lΠ ]
Π-elim [Π] = Π-elim′ (id (escape [Π])) [Π]

∃-elim′ : ∀ {l A Γ F G ll} → Γ ⊢ A ⇒* ∃ F ▹ G ^ [ % , ι ll ] → Γ ⊩⟨ l ⟩ A ^ [ % , ι ll ] → Γ ⊩⟨ l ⟩∃ A  ^ ll
∃-elim′ D (Emptyᵣ D′) = ⊥-elim (Empty≢∃ (whrDet* (red D′ , Emptyₙ) (D , ∃ₙ)))
∃-elim′ D (ne′ K D′ neK K≡K) =
  ⊥-elim (∃≢ne neK (whrDet* (D , ∃ₙ) (red D′ , ne neK)))
∃-elim′ D (Πᵣ′ rF lF lG _ _ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  ⊥-elim (Π≢∃ (whrDet* (red D′ , Πₙ) (D , ∃ₙ)))
∃-elim′ D (∃ᵣ′ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  noemb (∃ᵣ F G D′ ⊢F ⊢G A≡A [F] [G] G-ext)
∃-elim′ {ι ¹} D (emb emb< x) with ∃-elim′ D x
∃-elim′ {ι ¹} D (emb emb< x) | noemb x₁ = emb emb< (noemb x₁)
∃-elim′ {ι ¹} D (emb emb< x) | emb () x₁
∃-elim′ {∞} D (emb ∞< x) with ∃-elim′ D x
∃-elim′ {∞} D (emb ∞< x) | noemb x₁ = emb ∞< (noemb x₁)
∃-elim′ {∞} D (emb ∞< x) | emb <l x₁ = emb {l′ = ι ¹} ∞< (emb <l x₁)

∃-elim : ∀ {Γ F G l ll} → Γ ⊩⟨ l ⟩ ∃ F ▹ G ^ [ % , ι ll ] → Γ ⊩⟨ l ⟩∃ (∃ F ▹ G) ^ ll
∃-elim [∃] = ∃-elim′ (id (escape [∃])) [∃]

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

-- A view for constructor equality of types where embeddings are ignored
data ShapeView Γ : ∀ l l′ A B r r' (p : Γ ⊩⟨ l ⟩ A ^ r) (q : Γ ⊩⟨ l′ ⟩ B ^ r') → Set where
  Uᵥ : ∀ {A B l l′ ll ll′} UA UB → ShapeView Γ l l′ A B [ ! , ll ] [ ! , ll′ ] (Uᵣ UA) (Uᵣ UB)
  ℕᵥ : ∀ {A B l l′} ℕA ℕB → ShapeView Γ l l′ A B [ ! , ι ⁰ ] [ ! , ι ⁰ ] (ℕᵣ ℕA) (ℕᵣ ℕB)
  Emptyᵥ : ∀ {A B l l′ ll ll'} EmptyA EmptyB → ShapeView Γ l l′ A B [ % , ι ll ] [ % , ι ll' ] (Emptyᵣ EmptyA) (Emptyᵣ EmptyB)
  ne  : ∀ {A B l l′ r lr r' lr'} neA neB
      → ShapeView Γ l l′ A B [ r , ι lr ] [ r' , ι lr' ] (ne neA) (ne neB)
  Πᵥ : ∀ {A B l l′ r r' lΠ lΠ' } ΠA ΠB
    → ShapeView Γ l l′ A B [ r , ι lΠ ] [ r' , ι lΠ' ] (Πᵣ ΠA) (Πᵣ ΠB)
  ∃ᵥ : ∀ {A B l l′ ll ll'} ∃A ∃B
    → ShapeView Γ l l′ A B [ % , ι ll ] [ % , ι ll' ] (∃ᵣ ∃A) (∃ᵣ ∃B)
  emb⁰¹ : ∀ {A B r r' l p q}
        → ShapeView Γ (ι ⁰) l A B r r' p q
        → ShapeView Γ (ι ¹) l A B r r' (emb emb< p) q
  emb¹⁰ : ∀ {A B r r' l p q}
        → ShapeView Γ l (ι ⁰) A B r r' p q
        → ShapeView Γ l (ι ¹) A B r r' p (emb emb< q)
  emb¹∞ : ∀ {A B r r' l p q}
        → ShapeView Γ (ι ¹) l A B r r' p q
        → ShapeView Γ ∞ l A B r r' (emb ∞< p) q
  emb∞¹ : ∀ {A B r r' l p q}
        → ShapeView Γ l (ι ¹) A B r r' p q
        → ShapeView Γ l ∞ A B r r' p (emb ∞< q)

-- Construct a shape view from an equality
goodCases : ∀ {l l′ Γ A B r r'} ([A] : Γ ⊩⟨ l ⟩ A ^ r) ([B] : Γ ⊩⟨ l′ ⟩ B ^ r')
          → Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A] → ShapeView Γ l l′ A B r r' [A] [B]
goodCases (Uᵣ UA) (Uᵣ UB) A≡B = Uᵥ UA UB
goodCases (Uᵣ′ _ _ _ _ _ _ ⊢Γ) (ℕᵣ D) D' = ⊥-elim (U≢ℕ (whrDet* (D' ,  Uₙ) (red D , ℕₙ)))
goodCases (Uᵣ′ _ _ _ _ _ _ ⊢Γ) (Emptyᵣ D) D' =  ⊥-elim (U≢Empty (whrDet* (D' ,  Uₙ) (red D , Emptyₙ)))
goodCases (Uᵣ′ _ _ _ _ _ _ ⊢Γ) (ne′ K D neK K≡K) D' = ⊥-elim (U≢ne neK (whrDet* (D' ,  Uₙ) (red D , ne neK)))
goodCases (Uᵣ′ _ _ _ _ _ _ ⊢Γ) (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) D' =
  ⊥-elim (U≢Π (whrDet* (D' , Uₙ) (red D , Πₙ)))
goodCases (Uᵣ′ _ _ _ _ _ _ ⊢Γ) (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) D' =
  ⊥-elim (U≢∃ (whrDet* (D' , Uₙ) (red D , ∃ₙ)))
goodCases (ℕᵣ D) (Uᵣ′ _ _ _ _ _ _ D') A≡B = ⊥-elim (U≢ℕ (whrDet* (red D' ,  Uₙ) (A≡B , ℕₙ)))
goodCases (ℕᵣ _) (Emptyᵣ D') D =
  ⊥-elim (ℕ≢Empty (whrDet* (D , ℕₙ) (red D' , Emptyₙ)))
goodCases (ℕᵣ ℕA) (ℕᵣ ℕB) A≡B = ℕᵥ ℕA ℕB
goodCases (ℕᵣ D) (ne′ K D₁ neK K≡K) A≡B =
  ⊥-elim (ℕ≢ne neK (whrDet* (A≡B , ℕₙ) (red D₁ , ne neK)))
goodCases (ℕᵣ D) (Πᵣ′ rF lF lG _ _ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) A≡B =
  ⊥-elim (ℕ≢Π (whrDet* (A≡B , ℕₙ) (red D₁ , Πₙ)))
goodCases (ℕᵣ D) (∃ᵣ′ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) A≡B =
  ⊥-elim (ℕ≢∃ (whrDet* (A≡B , ℕₙ) (red D₁ , ∃ₙ)))
goodCases (Emptyᵣ D) (Uᵣ′ _ _ _ _ _ _ D') A≡B = ⊥-elim (U≢Empty (whrDet* (red D' ,  Uₙ) (A≡B , Emptyₙ)))
goodCases (Emptyᵣ _) (ℕᵣ D') D =
   ⊥-elim (ℕ≢Empty (whrDet* (red D' , ℕₙ) (D , Emptyₙ)))
goodCases (Emptyᵣ EmptyA) (Emptyᵣ EmptyB) A≡B = Emptyᵥ EmptyA EmptyB
goodCases (Emptyᵣ D) (ne′ K D₁ neK K≡K) A≡B =
  ⊥-elim (Empty≢ne neK (whrDet* (A≡B , Emptyₙ) (red D₁ , ne neK)))
goodCases (Emptyᵣ D) (Πᵣ′ rF lF lG _ _ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) A≡B =
  ⊥-elim (Empty≢Π (whrDet* (A≡B , Emptyₙ) (red D₁ , Πₙ)))
goodCases (Emptyᵣ D) (∃ᵣ′ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) A≡B =
  ⊥-elim (Empty≢∃ (whrDet* (A≡B , Emptyₙ) (red D₁ , ∃ₙ)))
goodCases (ne′ K D neK K≡K) (Uᵣ′ _ _ _ _ _ _ D') (ne₌ M D'' neM K≡M) =
  ⊥-elim (U≢ne neM (whrDet* (red D' ,  Uₙ) (red D'' , ne neM)))
goodCases (ne′ K D neK K≡K) (ℕᵣ D₁) (ne₌ M D′ neM K≡M) =
  ⊥-elim (ℕ≢ne neM (whrDet* (red D₁ , ℕₙ) (red D′ , ne neM)))
goodCases (ne′ K D neK K≡K) (Emptyᵣ D₁) (ne₌ M D′ neM K≡M) =
  ⊥-elim (Empty≢ne neM (whrDet* (red D₁ , Emptyₙ) (red D′ , ne neM)))
goodCases (ne neA) (ne neB) A≡B = ne neA neB
goodCases (ne′ K D neK K≡K) (Πᵣ′ rF lF lG _ _ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) (ne₌ M D′ neM K≡M) =
  ⊥-elim (Π≢ne neM (whrDet* (red D₁ , Πₙ) (red D′ , ne neM)))
goodCases (ne′ K D neK K≡K) (∃ᵣ′ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext) (ne₌ M D′ neM K≡M) =
  ⊥-elim (∃≢ne neM (whrDet* (red D₁ , ∃ₙ) (red D′ , ne neM)))
goodCases (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Uᵣ′ _ _ _ _ _ _ D')
          (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (U≢Π (whrDet* (red D' ,  Uₙ) (D′ , Πₙ)))
goodCases (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ℕᵣ D₁)
          (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (ℕ≢Π (whrDet* (red D₁ , ℕₙ) (D′ , Πₙ)))
goodCases (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Emptyᵣ D₁)
          (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (Empty≢Π (whrDet* (red D₁ , Emptyₙ) (D′ , Πₙ)))
goodCases (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ne′ K D₁ neK K≡K)
          (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (Π≢ne neK (whrDet* (D′ , Πₙ) (red D₁ , ne neK)))
goodCases (Πᵣ ΠA) (Πᵣ ΠB) A≡B = Πᵥ ΠA ΠB
goodCases (Πᵣ′ rF lF lG _ _ 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′]) =
  ⊥-elim (Π≢∃ (whrDet* (D′ , Πₙ) (red D₁ , ∃ₙ)))
goodCases (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Uᵣ′ _ _ _ _ _ _ D')
          (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (U≢∃ (whrDet* (red D' ,  Uₙ) (D′ , ∃ₙ)))
goodCases (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ℕᵣ D₁)
          (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (ℕ≢∃ (whrDet* (red D₁ , ℕₙ) (D′ , ∃ₙ)))
goodCases (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Emptyᵣ D₁)
          (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (Empty≢∃ (whrDet* (red D₁ , Emptyₙ) (D′ , ∃ₙ)))
goodCases (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ne′ K D₁ neK K≡K)
          (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (∃≢ne neK (whrDet* (D′ , ∃ₙ) (red D₁ , ne neK)))
goodCases (∃ᵣ′ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁)
          (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
          (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ⊥-elim (Π≢∃ (whrDet* (red D , Πₙ) (D′ , ∃ₙ)))
goodCases (∃ᵣ ∃A) (∃ᵣ ∃B) A≡B = ∃ᵥ ∃A ∃B
goodCases {l} {ι ¹} [A] (emb emb< x) A≡B = emb¹⁰ (goodCases {l} {ι ⁰} [A] x A≡B)
goodCases {l} {∞} [A] (emb ∞< x) A≡B = emb∞¹ (goodCases {l} {ι ¹} [A] x A≡B)
goodCases {ι ¹} {l} (emb emb< x) [B] A≡B = emb⁰¹ (goodCases {ι ⁰} {l} x [B] A≡B)
goodCases {∞} {l} (emb ∞< x) [B] A≡B = emb¹∞ (goodCases {ι ¹} {l} x [B] A≡B)

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

-- A view for constructor equality between three types
data ShapeView₃ Γ : ∀ l l′ l″ A B C r1 r2 r3
                 (p : Γ ⊩⟨ l   ⟩ A ^ r1)
                 (q : Γ ⊩⟨ l′  ⟩ B ^ r2)
                 (r : Γ ⊩⟨ l″ ⟩ C ^ r3) → Set where
  Uᵥ : ∀ {A B C l l′ l″ ll ll′ ll″ } UA UB UC → ShapeView₃ Γ l l′ l″ A B C [ ! , ll ] [ ! , ll′ ] [ ! , ll″ ]
                                               (Uᵣ UA) (Uᵣ UB) (Uᵣ UC)
  ℕᵥ : ∀ {A B C l l′ l″} ℕA ℕB ℕC
    → ShapeView₃ Γ l l′ l″ A B C [ ! , ι ⁰ ] [ ! , ι ⁰ ] [ ! , ι ⁰ ] (ℕᵣ ℕA) (ℕᵣ ℕB) (ℕᵣ ℕC)
  Emptyᵥ : ∀ {A B C l l′ l″ ll ll′ ll″} EmptyA EmptyB EmptyC
    → ShapeView₃ Γ l l′ l″ A B C [ % , ι ll ] [ % , ι ll′ ] [ % , ι ll″ ] (Emptyᵣ EmptyA) (Emptyᵣ EmptyB) (Emptyᵣ EmptyC)
  ne  : ∀ {A B C r1 r2 r3 l1 l2 l3 l l′ l″} neA neB neC
      → ShapeView₃ Γ l l′ l″ A B C [ r1 , ι l1 ] [ r2 , ι l2 ] [ r3 , ι l3 ] (ne neA) (ne neB) (ne neC)
  Πᵥ : ∀ {A B C r1 r2 r3 lΠ1 lΠ2 lΠ3 l l′ l″} ΠA ΠB ΠC
    → ShapeView₃ Γ l l′ l″ A B C [ r1 , ι lΠ1 ] [ r2 , ι lΠ2 ] [ r3 , ι lΠ3 ] (Πᵣ ΠA) (Πᵣ ΠB) (Πᵣ ΠC)
  ∃ᵥ : ∀ {A B C l l′ l″ ll ll' ll''} ΠA ΠB ΠC
    → ShapeView₃ Γ l l′ l″ A B C [ % , ι ll ] [ % , ι ll' ] [ % , ι ll'' ] (∃ᵣ ΠA) (∃ᵣ ΠB) (∃ᵣ ΠC)
  emb⁰¹¹ : ∀ {A B C l l′ r1 r2 r3 p q r}
         → ShapeView₃ Γ (ι ⁰) l l′ A B C r1 r2 r3 p q r
         → ShapeView₃ Γ (ι ¹) l l′ A B C r1 r2 r3 (emb emb< p) q r
  emb¹⁰¹ : ∀ {A B C l l′ r1 r2 r3  p q r}
         → ShapeView₃ Γ l (ι ⁰) l′ A B C r1 r2 r3 p q r
         → ShapeView₃ Γ l (ι ¹) l′ A B C r1 r2 r3 p (emb emb< q) r
  emb¹¹⁰ : ∀ {A B C l l′ r1 r2 r3 p q r}
         → ShapeView₃ Γ l l′ (ι ⁰) A B C r1 r2 r3 p q r
         → ShapeView₃ Γ l l′ (ι ¹) A B C r1 r2 r3 p q (emb emb< r)
  emb¹∞∞ : ∀ {A B C l l′ r1 r2 r3 p q r}
         → ShapeView₃ Γ (ι ¹) l l′ A B C r1 r2 r3 p q r
         → ShapeView₃ Γ ∞ l l′ A B C r1 r2 r3 (emb ∞< p) q r
  emb∞¹∞ : ∀ {A B C l l′ r1 r2 r3  p q r}
         → ShapeView₃ Γ l (ι ¹) l′ A B C r1 r2 r3 p q r
         → ShapeView₃ Γ l ∞ l′ A B C r1 r2 r3 p (emb ∞< q) r
  emb∞∞¹ : ∀ {A B C l l′ r1 r2 r3 p q r}
         → ShapeView₃ Γ l l′ (ι ¹) A B C r1 r2 r3 p q r
         → ShapeView₃ Γ l l′ ∞ A B C r1 r2 r3 p q (emb ∞< r)

-- Combines two two-way views into a three-way view
combine : ∀ {Γ l l′ l″ l‴ A B C r1 r2 r2' r3 [A] [B] [B]′ [C]}
        → ShapeView Γ l l′ A B r1 r2 [A] [B]
        → ShapeView Γ l″ l‴ B C r2' r3 [B]′ [C]
        → ShapeView₃ Γ l l′ l‴ A B C r1 r2 r3 [A] [B] [C]
combine (Uᵥ UA UB) (Uᵥ UB' UC) = Uᵥ UA UB UC
combine (Uᵥ UA (Uᵣ r l′ l< PE.refl D)) (ℕᵥ ℕA ℕB) =
 ⊥-elim (U≢ℕ (whrDet* (red D ,  Uₙ) (red  ℕA , ℕₙ)))
combine (Uᵥ UA (Uᵣ r l′ l< PE.refl D)) (Emptyᵥ EmptyA EmptyB) =
 ⊥-elim (U≢Empty (whrDet* (red D ,  Uₙ) (red  EmptyA , Emptyₙ)))
combine (Uᵥ UA (Uᵣ r l′ l< PE.refl D)) (ne (ne K D' neK K≡K) neB) =
  ⊥-elim (U≢ne neK (whrDet* (red D ,  Uₙ) (red  D' , ne neK)))
combine (Uᵥ UA (Uᵣ r l′ l< PE.refl D)) (Πᵥ (Πᵣ rF lF lG _ _ F G D' ⊢F ⊢G A≡A [F] [G] G-ext) ΠB) =
 ⊥-elim (U≢Π (whrDet* (red D ,  Uₙ) (red  D' , Πₙ)))
combine (Uᵥ UA (Uᵣ r l′ l< PE.refl D)) (∃ᵥ (∃ᵣ F G D' ⊢F ⊢G A≡A [F] [G] G-ext) ∃B) =
 ⊥-elim (U≢∃ (whrDet* (red D ,  Uₙ) (red  D' , ∃ₙ)))
combine  (ℕᵥ ℕA ℕB) (Uᵥ (Uᵣ r l′ l< PE.refl D) UB) =
 ⊥-elim (U≢ℕ (whrDet* (red D ,  Uₙ) (red  ℕB , ℕₙ)))
combine  (ℕᵥ ℕA ℕB) (Emptyᵥ EmptyA EmptyB) =
   ⊥-elim (ℕ≢Empty (whrDet* (red ℕB , ℕₙ) (red EmptyA , Emptyₙ)))
combine  (ℕᵥ ℕA₁ ℕB₁) (ℕᵥ ℕA ℕB) = ℕᵥ ℕA₁ ℕB₁ ℕB
combine  (ℕᵥ ℕA ℕB) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (ℕ≢ne neK (whrDet* (red ℕB , ℕₙ) (red D , ne neK)))
combine  (ℕᵥ ℕA ℕB) (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ΠB) =
  ⊥-elim (ℕ≢Π (whrDet* (red ℕB , ℕₙ) (red D , Πₙ)))
combine  (ℕᵥ ℕA ℕB) (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ∃B) =
  ⊥-elim (ℕ≢∃ (whrDet* (red ℕB , ℕₙ) (red D , ∃ₙ)))
combine  (Emptyᵥ EmptyA EmptyB) (Uᵥ (Uᵣ r l′ l< PE.refl D) UB) =
 ⊥-elim (U≢Empty (whrDet* (red D ,  Uₙ) (red  EmptyB , Emptyₙ)))
combine  (Emptyᵥ EmptyA EmptyB) (ℕᵥ ℕA ℕB) =
   ⊥-elim (Empty≢ℕ (whrDet* (red EmptyB , Emptyₙ) (red ℕA , ℕₙ)))
combine  (Emptyᵥ EmptyA₁ EmptyB₁) (Emptyᵥ EmptyA EmptyB) = Emptyᵥ EmptyA₁ EmptyB₁ EmptyB
combine  (Emptyᵥ EmptyA EmptyB) (ne (ne K D neK K≡K) neB) =
   ⊥-elim (Empty≢ne neK (whrDet* (red EmptyB , Emptyₙ) (red D , ne neK)))
combine  (Emptyᵥ EmptyA EmptyB) (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ΠB) =
   ⊥-elim (Empty≢Π (whrDet* (red EmptyB , Emptyₙ) (red D , Πₙ)))
combine  (Emptyᵥ EmptyA EmptyB) (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ∃B) =
   ⊥-elim (Empty≢∃ (whrDet* (red EmptyB , Emptyₙ) (red D , ∃ₙ)))
combine  (ne neA (ne K D' neK K≡K)) (Uᵥ (Uᵣ r l′ l< PE.refl D) UB) =
  ⊥-elim (U≢ne neK (whrDet* (red D ,  Uₙ) (red  D' , ne neK)))
combine  (ne neA (ne K D neK K≡K)) (ℕᵥ ℕA ℕB) =
  ⊥-elim (ℕ≢ne neK (whrDet* (red ℕA , ℕₙ) (red D , ne neK)))
combine  (ne neA (ne K D neK K≡K)) (Emptyᵥ EmptyA EmptyB) =
  ⊥-elim (Empty≢ne neK (whrDet* (red EmptyA , Emptyₙ) (red D , ne neK)))
combine  (ne neA₁ neB₁) (ne neA neB) = ne neA₁ neB₁ neB
combine  (ne neA (ne K D₁ neK K≡K)) (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ΠB) =
  ⊥-elim (Π≢ne neK (whrDet* (red D , Πₙ) (red D₁ , ne neK)))
combine  (ne neA (ne K D₁ neK K≡K)) (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ∃B) =
  ⊥-elim (∃≢ne neK (whrDet* (red D , ∃ₙ) (red D₁ , ne neK)))
combine  (Πᵥ ΠA (Πᵣ rF lF lG _ _ F G D' ⊢F ⊢G A≡A [F] [G] G-ext)) (Uᵥ (Uᵣ r l′ l< PE.refl D) UB) =
 ⊥-elim (U≢Π (whrDet* (red D ,  Uₙ) (red  D' , Πₙ)))
combine  (Πᵥ ΠA (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (ℕᵥ ℕA ℕB) =
  ⊥-elim (ℕ≢Π (whrDet* (red ℕA , ℕₙ) (red D , Πₙ)))
combine  (Πᵥ ΠA (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Emptyᵥ EmptyA EmptyB) =
  ⊥-elim (Empty≢Π (whrDet* (red EmptyA , Emptyₙ) (red D , Πₙ)))
combine  (Πᵥ ΠA (Πᵣ rF lF lG _ _ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext)) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (Π≢ne neK (whrDet* (red D₁ , Πₙ) (red D , ne neK)))
combine  (Πᵥ ΠA₁ ΠB₁) (Πᵥ ΠA ΠB) = Πᵥ ΠA₁ ΠB₁ ΠB
combine  (Πᵥ ΠA (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext))
        (∃ᵥ (∃ᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁) ∃B) =
  ⊥-elim (Π≢∃ (whrDet* (red D , Πₙ) (red D₁ , ∃ₙ)))
combine  (∃ᵥ ∃A (∃ᵣ F G D' ⊢F ⊢G A≡A [F] [G] G-ext)) (Uᵥ (Uᵣ r l′ l< PE.refl D) UB) =
 ⊥-elim (U≢∃ (whrDet* (red D ,  Uₙ) (red  D' , ∃ₙ)))
combine  (∃ᵥ ∃A (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (ℕᵥ ℕA ℕB) =
  ⊥-elim (ℕ≢∃ (whrDet* (red ℕA , ℕₙ) (red D , ∃ₙ)))
combine  (∃ᵥ ∃A (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Emptyᵥ EmptyA EmptyB) =
  ⊥-elim (Empty≢∃ (whrDet* (red EmptyA , Emptyₙ) (red D , ∃ₙ)))
combine  (∃ᵥ ∃A (∃ᵣ F G D₁ ⊢F ⊢G A≡A [F] [G] G-ext)) (ne (ne K D neK K≡K) neB) =
  ⊥-elim (∃≢ne neK (whrDet* (red D₁ , ∃ₙ) (red D , ne neK)))
combine  (∃ᵥ ΠA (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext))
        (Πᵥ (Πᵣ rF₁ lF₁ lG₁ _ _ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁) ∃B) =
  ⊥-elim (Π≢∃ (whrDet* (red D₁ , Πₙ) (red D , ∃ₙ)))
combine  (∃ᵥ ∃A ∃B) (∃ᵥ ∃A₁ ∃B₁) = ∃ᵥ ∃A ∃B ∃B₁
combine (emb⁰¹ [AB]) [BC] = emb⁰¹¹ (combine [AB] [BC])
combine (emb¹⁰ [AB]) [BC] = emb¹⁰¹ (combine [AB] [BC])
combine [AB] (emb⁰¹ [BC]) = combine [AB] [BC]
combine [AB] (emb¹⁰ [BC]) = emb¹¹⁰ (combine [AB] [BC])
combine (emb¹∞ [AB]) [BC] = emb¹∞∞ (combine [AB] [BC])
combine (emb∞¹ [AB]) [BC] = emb∞¹∞ (combine [AB] [BC])
combine [AB] (emb¹∞ [BC]) = combine [AB] [BC]
combine [AB] (emb∞¹ [BC]) = emb∞∞¹ (combine [AB] [BC])


open import Categories
open import Functors
open import RMonads

module RMonads.CatofRAdj.TermRAdjHom {a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                                     {J : Fun C D}(M : RMonad J) where

open import Library
open import RAdjunctions
open import RMonads.CatofRAdj M
open import Categories.Terminal
open import RMonads.REM M
open import RMonads.REM.Adjunction M
open import RAdjunctions.RAdj2RMon
open import RMonads.CatofRAdj.TermRAdjObj M

open Cat
open Fun
open RAdj

alaw1lem : ∀{e f}{E : Cat {e}{f}}(T : Fun C D)(L : Fun C E)(R : Fun E D)
  (p : R ○ L ≅ T)
  (η : ∀ {X} → Hom D (OMap J X) (OMap T X)) →
  (right : ∀ {X Y} → Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y) →
  (left : ∀ {X Y} → Hom E (OMap L X) Y → Hom D (OMap J X) (OMap R Y)) →
  (ηlaw : ∀ {X} → left (iden E {OMap L X}) ≅ η {X}) →
  ∀ {X}{Z}{f : Hom D (OMap J Z) (OMap R X)} →
  (nat : comp D (HMap R (right f)) (comp D (left (iden E)) (HMap J (iden C)))
         ≅
         left (comp E (right f) (comp E (iden E) (HMap L (iden C))))) →
  (lawb : left (right f) ≅ f) →
  f
  ≅
  comp D (subst (λ Z → Hom D Z (OMap R X))
                (fcong Z (cong OMap p))
                (HMap R (right f)))
         η
alaw1lem {E = E} .(R ○ L) L R refl η right left ηlaw {X}{Z}{f} nat lawb =
  trans (trans (trans (sym lawb)
                      (cong left
                            (trans (sym (idr E))
                                   (cong (comp E (right f))
                                         (trans (sym (fid L))
                                                (sym (idl E)))))))
               (trans (sym nat)
                      (cong (comp D (HMap R (right f)))
                            (trans (cong (comp D (left (iden E))) (fid J))
                                   (idr D)))))
        (cong (comp D (HMap R (right f))) ηlaw)

alaw2lem : ∀{e f}{E : Cat {e}{f}}(T : Fun C D)(L : Fun C E)(R : Fun E D)
  (p : R ○ L ≅ T) →
  (right : ∀ {X Y} → Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y) →
  (bind : ∀{X Y} →
          Hom D (OMap J X) (OMap T Y) → Hom D (OMap T X) (OMap T Y)) →
  (natright : {X X' : Obj C} {Y Y' : Obj E} (f : Hom C X' X)
    (g : Hom E Y Y') (h : Hom D (OMap J X) (OMap R Y)) →
    right (comp D (HMap R g) (comp D h (HMap J f)))
    ≅
    comp E g (comp E (right h) (HMap L f))) →
  ∀{X}{Z}{W}
  {k : Hom D (OMap J Z) (OMap T W)}
  {f : Hom D (OMap J W) (OMap R X)} →
  (bindlaw : HMap R (right (subst (Hom D (OMap J Z))
                           (fcong W (cong OMap (sym p)))
                           k))
             ≅
             bind k) →
  subst (λ Z → Hom D Z (OMap R X))
  (fcong Z (cong OMap p))
  (HMap R
   (right
    (comp D
     (subst (λ Z → Hom D Z (OMap R X))
      (fcong W (cong OMap p)) (HMap R (right f)))
     k)))
  ≅
  comp D
  (subst (λ Z → Hom D Z (OMap R X))
   (fcong W (cong OMap p)) (HMap R (right f)))
  (bind k)
alaw2lem {E = E} .(R ○ L) L R refl right bind natright {k = k}{f = f} bl =
  trans (trans (cong (HMap R)
                     (trans (cong (λ k → right (comp D (HMap R (right f)) k))
                                  (trans (sym (idr D)) (cong (comp D k)
                                                             (sym (fid J)))))
                            (trans (trans (natright (iden C) (right f) k)
                                          (trans (sym (ass E))
                                                 (cong (comp E
                                                             (comp E
                                                                   (right f)
                                                                   (right k)))
                                                       (fid L))))
                                   (idr E))))
               (fcomp R))
        (cong (comp D (HMap R (right f))) bl)

ahomlem : ∀{e f}{E : Cat {e}{f}}(T : Fun C D)(L : Fun C E)(R : Fun E D)
  (p : R ○ L ≅ T) →
  (right : ∀ {X Y} → Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y) →
  (natright : {X X' : Obj C} {Y Y' : Obj E} (f : Hom C X' X)
    (g : Hom E Y Y') (h : Hom D (OMap J X) (OMap R Y)) →
    right (comp D (HMap R g) (comp D h (HMap J f)))
    ≅
    comp E g (comp E (right h) (HMap L f))) →
  {X : Obj E}{Y : Obj E}{f : Hom E X Y} →
  {Z : Obj C} {g : Hom D (OMap J Z) (OMap R X)} →
  comp D (HMap R f)
  (subst (λ Z → Hom D Z (OMap R X))
   (fcong Z (cong OMap p))
   (HMap R (right g)))
  ≅
  subst (λ Z → Hom D Z (OMap R Y))
  (fcong Z (cong OMap p))
  (HMap R (right (comp D (HMap R f) g)))
ahomlem {E = E} .(R ○ L) L R refl right natright {X}{Y}{f}{Z}{g} =
  trans (sym (fcomp R))
        (cong (HMap R)
              (trans (trans (sym (idr E))
                            (trans (cong (comp E (comp E f (right g)))
                                         (sym (fid L)))
                                   (trans (ass E)
                                          (sym (natright (iden C) f g)))))
                     (cong (λ g → right (comp D (HMap R f) g))
                           (trans (cong (comp D g) (fid J)) (idr D)))))
open ObjAdj

Llawlem : ∀{e f}{E : Cat {e}{f}}(T : Fun C D)(L : Fun C E)(R : Fun E D)
  (p : R ○ L ≅ T) →
  (right : ∀{X Y} → Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y) →
  (bind : ∀{X Y} →
          Hom D (OMap J X) (OMap T Y) → Hom D (OMap T X) (OMap T Y)) →
  (bindlaw : {X Y : Obj C} {f : Hom D (OMap J X) (OMap T Y)} →
    HMap R
    (right
     (subst (Hom D (OMap J X)) (fcong Y (cong OMap (sym p))) f))
    ≅ bind f) →
  ∀{X Z} →
  {f  : Hom D (OMap J Z) (OMap R (OMap L X))}
  {f' : Hom D (OMap J Z) (OMap T X)} → (q  : f ≅ f') →
  subst (λ Z → Hom D Z (OMap R (OMap L X)))
  (fcong Z (cong OMap p)) (HMap R (right f))
  ≅ bind f'
Llawlem .(R ○ L) L R refl right bind bindlaw {X}{Z}{f}{.f} refl = bindlaw

K : ∀{e f}(A : Obj (CatofAdj {e}{f})) → Fun (E A) (E EMObj)
K A = record {
  OMap = λ X → record {
    acar = OMap (R (adj A)) X;
    astr = λ {Z} f →
      subst (λ Z₁ → Hom D Z₁ (OMap (R (adj A)) X))
            (fcong Z (cong OMap (law A)))
            (HMap (R (adj A)) (right (adj A) f));
    alaw1 = λ {Z} {f} →
      alaw1lem
               (TFun M)
               (L (adj A))
               (R (adj A))
               (law A)
               η
               (right (adj A))
               (left (adj A))
               (ηlaw A)
               (natleft (adj A) (iden C) (right (adj A) f) (iden (E A)))
               (lawb (adj A) f);
    alaw2 = λ {Z} {W} {k} {f} →
      alaw2lem
               (TFun M)
               (L (adj A))
               (R (adj A))
               (law A)
               (right (adj A))
               bind
               (natright (adj A))
               (bindlaw A {_} {_} {k})};
  HMap = λ {X} {Y} f → record {
    amor = HMap (R (adj A)) f;
    ahom = λ {Z} {g} →
      ahomlem
              (TFun M)
              (L (adj A))
              (R (adj A))
              (law A)
              (right (adj A))
              (natright (adj A)) };
    fid = RAlgMorphEq (fid (R (adj A)));
    fcomp = RAlgMorphEq (fcomp (R (adj A)))}
  where open RMonad M

Llaw' : ∀{e f}(A : Obj (CatofAdj {e}{f})) →
        K A ○ L (adj A) ≅ L (adj EMObj)
Llaw' A = FunctorEq _ _
  (ext λ X → AlgEq (fcong X (cong OMap (law A)))
                   (iext λ Z → dext λ {f} {f'} →
                     Llawlem (TFun M)
                             (L (adj A))
                             (R (adj A))
                             (law A)
                             (right (adj A))
                             bind
                             (bindlaw A)))
  (iext λ X → iext λ Y → ext λ f →
      lemZ
      (AlgEq (fcong X (cong OMap (law A)))
       (iext λ Z →
          dext
          (Llawlem (TFun M) (L (adj A)) (R (adj A)) (law A) (right (adj A))
           bind (bindlaw A))))
      (AlgEq (fcong Y (cong OMap (law A)))
       (iext λ Z →
          dext
          (Llawlem (TFun M) (L (adj A)) (R (adj A)) (law A) (right (adj A))
           bind (bindlaw A))))
      (cong' refl
       (ext
        (λ _ →
           cong₂ (Hom D) (fcong X (cong OMap (law A)))
           (fcong Y (cong OMap (law A)))))
       (icong' refl
        (ext
         (λ Z →
            cong₂ (λ x y → Hom C X Z → Hom D x y) (fcong X (cong OMap (law A)))
            (fcong Z (cong OMap (law A)))))
        (icong' refl
         (ext
          (λ Z →
             cong
             (λ (F : Obj C → Obj D) →
                {Y₁ : Obj C} → Hom C Z Y₁ → Hom D (F Z) (F Y₁))
             (cong OMap (law A))))
         (cong HMap (law A)) (refl {x = X}))
        (refl {x = Y}))
       (refl {x = f})))
  where open RMonad M

Rlaw' : ∀{e f}(A : Obj (CatofAdj {e}{f})) →
        R (adj A) ≅ R (adj EMObj) ○ K A
Rlaw' A = FunctorEq _ _ refl refl

rightlaw' : ∀{e f}(A : Obj (CatofAdj {e}{f})) →
           {X : Obj C}{Y : Obj (E A)} →
           {f : Hom D (OMap J X) (OMap (R (adj A)) Y)} →
           HMap (K A) (right (adj A) f)
           ≅
           right (adj EMObj) {X} {OMap (K A) Y}
                 (subst (Hom D (OMap J X)) (fcong Y (cong OMap (Rlaw' A))) f)
rightlaw' A {X}{Y}{f} = lemZ
  (AlgEq (fcong X (cong OMap (law A)))
   (iext λ Z →
      dext
      (λ {g} {g'} p →
         Llawlem (TFun M) (L (adj A)) (R (adj A)) (law A) (right (adj A))
         bind (bindlaw A) p)))
  refl
  (trans
   (cong
    (λ (f₁ : Hom D (OMap J X) (OMap (R (adj A)) Y)) →
       HMap (R (adj A)) (right (adj A) f₁))
    (sym
       (stripsubst (Hom D (OMap J X)) f
        (fcong Y (cong OMap (Rlaw' A))))))
   (sym
    (stripsubst (λ (Z : Obj D) → Hom D Z (OMap (R (adj A)) Y)) _
     (fcong X (cong OMap (law A))))))
  where open RMonad M

EMHom : {A : Obj CatofAdj} → Hom CatofAdj A EMObj
EMHom {A} = record {
  K    = K A;
  Llaw = Llaw' A;
  Rlaw = Rlaw' A;
  rightlaw = rightlaw' A }

-- -}


mutual
  _ : Set
  _ : Set → Set


module _ where

open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

module M (n : Nat) (m : Nat) where

  foo : n ≡ 0 → Nat
  foo refl = 0
    module M' where
      bar : Nat
      bar = m

  bad : Nat
  bad = M'.bar -- internal error Monad.Signature:882


module ExpressionChanging where
open import ParseTree
open import Data.Maybe hiding (map)
open import Data.List.NonEmpty
open import ParseTreeOperations
open import AgdaHelperFunctions
open import Data.List
open import Data.Nat
open import Data.Vec using (Vec)
open import Data.Fin
open import ScopeState
import Data.Nat.Properties
open import Relation.Nullary
import Data.String
open import Data.Nat.Show
open import Data.Bool

{-# TERMINATING #-}
applyToExpressionsAndSubExpressions : (List⁺ Expr -> List⁺ Expr) -> Expr -> Expr
applyToExpressionsAndSubExpressions i e = listToExpression $ head newTop ∷ newRest
    where newTop = i  $ expressionToList e
          newRest = Data.List.map (applyToExpressionsAndSubExpressions i) $ tail newTop

applyToAllInSignature : (List⁺ Expr -> List⁺ Expr) -> TypeSignature -> TypeSignature
applyToAllInSignature i (typeSignature funcName funcType) = typeSignature funcName $ applyToExpressionsAndSubExpressions i funcType

applyToAllExpressions : (List⁺ Expr -> List⁺ Expr) -> ParseTree -> ParseTree
applyToAllExpressions instructions (signature signature₁ range₁) =
  signature (applyToAllInSignature instructions signature₁) range₁
applyToAllExpressions instructions (functionDefinition definitionOf params body range₁) =
  functionDefinition definitionOf (tail newParams)
  (applyToExpressionsAndSubExpressions instructions body) range₁
    where newParams = instructions (ident definitionOf ∷ Data.List.map (applyToExpressionsAndSubExpressions instructions) params)

applyToAllExpressions instructions (dataStructure dataName parameters indexInfo constructors range₁ {c} ) =
  dataStructure
  dataName
  (Data.List.map (applyToAllInSignature instructions) parameters)
  (applyToExpressionsAndSubExpressions instructions indexInfo)
  (Data.List.map (applyToAllInSignature instructions) constructors)
  range₁ {c}
applyToAllExpressions instructions x = x

applyToProgram : (List⁺ Expr -> List⁺ Expr) -> Data.List.List ParseTree -> Data.List.List ParseTree
applyToProgram i c = Data.List.map (applyToAllExpressions i) c

makeFin : {n : ℕ} -> Vec Expr (n) -> ℕ -> ScopeState (Fin n)
makeFin {n} v number with number Data.Nat.Properties.<? n
makeFin {n} v number | yes p = return $ fromℕ≤ p
makeFin {n} v number | no ¬p = fail $ "Got a non-existing argument: " Data.String.++ Data.Nat.Show.show n Data.String.++ Data.Nat.Show.show (Data.List.length $ Data.Vec.toList v)

makeFin2 : {n : ℕ} -> Vec Expr (suc n) -> ℕ -> ScopeState (Fin n)
makeFin2 {n} v number with number Data.Nat.Properties.<? n
makeFin2 {n} v number | yes p = return $ fromℕ≤ p
makeFin2 {n} v number | no ¬p = fail $ "Got a non-existing argument: " Data.String.++ Data.Nat.Show.show n Data.String.++ Data.Nat.Show.show (Data.List.length $ Data.Vec.toList v)

--TODO: try to give this a better type
updateSignature :  ℕ -> List⁺ Expr ->
  (alterSignature : {n : ℕ} -> Vec Expr (suc n)  -> Fin n -> ScopeState (Vec Expr (suc n))) ->
  ScopeState (List⁺ Expr)
updateSignature argNo type f
  with toVec type
... | c = do
-- In a signature, we always have at least one item which is not an argument: the result type
  newFin <- makeFin2 c argNo
  newVec <- f c newFin
  return  $ Data.List.NonEmpty.fromVec newVec

doForArgument : List ParseTree -> ℕ -> ℕ ->
  (alterSignature : {n : ℕ} -> Vec Expr (suc n)  -> Fin n -> ScopeState (Vec Expr (suc n))) ->
  (alterExpression : TypeSignature -> ℕ -> ScopeState (List⁺ Expr -> List⁺ Expr)) ->
  ScopeState (List ParseTree)
doForArgument [] funcID whichArgument f1 f2 = fail "funcId not found in doForArgument"
doForArgument (signature (typeSignature (identifier name isInRange scope declaration) funcType) range₁ ∷ code) funcID whichArgument f1 f2 with Data.Nat.compare declaration funcID
doForArgument (signature (typeSignature (identifier name isInRange scope declaration {e}{b} {a}) funcType) range₁ ∷ code) .declaration whichArgument f1 f2 | equal .declaration = do
    newType <- updateSignature whichArgument (typeToList funcType) f1
    instruction <- f2 ((typeSignature (identifier name isInRange scope declaration {e}{b} {a})) funcType) whichArgument
    return $ applyToProgram instruction $
      signature (typeSignature
                  (identifier name isInRange scope declaration {e}{b} {a})
                  (listToType newType)) range₁ ∷ code
doForArgument (signature (typeSignature (identifier name isInRange scope declaration {e}{b} {a}) funcType) range₁ ∷ code) funcID whichArgument f1 f2 | _ = do
  newxs <- doForArgument code funcID whichArgument f1 f2
  return $ (signature (typeSignature (identifier name isInRange scope declaration {e}{b} {a}) funcType) range₁) ∷ newxs
doForArgument (x ∷ xs) funcID whichArgument f1 f2 = do
  newxs <- doForArgument xs funcID whichArgument f1 f2
  return $ x ∷ newxs

makeInstruction : TypeSignature -> ℕ -> (makeIns : {n : ℕ} -> Vec Expr n -> Fin n -> (List Expr -> List Expr)) -> ScopeState (List⁺ Expr -> List⁺ Expr)
makeInstruction (typeSignature funcName funcType) argNo f
  with toVec (typeToList funcType)
... | c = do
    newFin <- makeFin c argNo
    return $ function $ f c newFin
    where function : (List Expr -> List Expr) -> (List⁺ Expr -> List⁺ Expr)
          function f (ident identifier₁ ∷ tail₁)
              with sameId identifier₁ funcName
          function f (ident identifier₁ ∷ tail₁) | false =
            (ident identifier₁ ∷ tail₁)
          function f (ident identifier₁ ∷ tail₁) | true =
              ident identifier₁ ∷ f tail₁
          function f list = list


module Luau.OpSem where

open import Agda.Builtin.Equality using (_≡_)
open import Agda.Builtin.Float using (Float; primFloatPlus; primFloatMinus; primFloatTimes; primFloatDiv)
open import FFI.Data.Maybe using (just)
open import Luau.Heap using (Heap; _≡_⊕_↦_; _[_]; function_is_end)
open import Luau.Substitution using (_[_/_]ᴮ)
open import Luau.Syntax using (Expr; Stat; Block; nil; addr; var; function_is_end; _$_; block_is_end; local_←_; _∙_; done; return; name; fun; arg; binexp; BinaryOperator; +; -; *; /; number)
open import Luau.Value using (addr; val; number)

evalBinOp : Float → BinaryOperator → Float → Float
evalBinOp x + y = primFloatPlus x y
evalBinOp x - y = primFloatMinus x y
evalBinOp x * y = primFloatTimes x y
evalBinOp x / y = primFloatDiv x y

data _⊢_⟶ᴮ_⊣_ {a} : Heap a → Block a → Block a → Heap a → Set
data _⊢_⟶ᴱ_⊣_ {a} : Heap a → Expr a → Expr a → Heap a → Set

data _⊢_⟶ᴱ_⊣_  where

  nil : ∀ {H} →

    -------------------
    H ⊢ nil ⟶ᴱ nil ⊣ H

  function : ∀ {H H′ a F B} →

    H′ ≡ H ⊕ a ↦ (function F is B end) →
    -------------------------------------------
    H ⊢ (function F is B end) ⟶ᴱ (addr a) ⊣ H′

  app₁ : ∀ {H H′ M M′ N} →

    H ⊢ M ⟶ᴱ M′ ⊣ H′ →
    -----------------------------
    H ⊢ (M $ N) ⟶ᴱ (M′ $ N) ⊣ H′

  app₂ : ∀ {H H′ V N N′} →

    H ⊢ N ⟶ᴱ N′ ⊣ H′ →
    -----------------------------
    H ⊢ (val V $ N) ⟶ᴱ (val V $ N′) ⊣ H′

  beta : ∀ {H a F B V} →

    H [ a ] ≡ just(function F is B end) →
    -----------------------------------------------------------------------------
    H ⊢ (addr a $ val V) ⟶ᴱ (block (fun F) is (B [ V / name(arg F) ]ᴮ) end) ⊣ H

  block : ∀ {H H′ B B′ b} →

    H ⊢ B ⟶ᴮ B′ ⊣ H′ →
    ----------------------------------------------------
    H ⊢ (block b is B end) ⟶ᴱ (block b is B′ end) ⊣ H′

  return : ∀ {H V B b} →

    --------------------------------------------------------
    H ⊢ (block b is return (val V) ∙ B end) ⟶ᴱ (val V) ⊣ H

  done : ∀ {H b} →

    ---------------------------------
    H ⊢ (block b is done end) ⟶ᴱ nil ⊣ H

  binOpEval :
    ∀ {H x op y} →
    --------------------------------------------------------------------------
    H ⊢ (binexp (number x) op (number y)) ⟶ᴱ (number (evalBinOp x op y)) ⊣ H

  binOp₁ :
    ∀ {H H′ x x′ op y} →
    H ⊢ x ⟶ᴱ x′ ⊣ H′ →
    ---------------------------------------------
    H ⊢ (binexp x op y) ⟶ᴱ (binexp x′ op y) ⊣ H′

  binOp₂ :
    ∀ {H H′ x op y y′} →
    H ⊢ y ⟶ᴱ y′ ⊣ H′ →
    ---------------------------------------------
    H ⊢ (binexp x op y) ⟶ᴱ (binexp x op y′) ⊣ H′

data _⊢_⟶ᴮ_⊣_  where

  local : ∀ {H H′ x M M′ B} →

    H ⊢ M ⟶ᴱ M′ ⊣ H′ →
    -------------------------------------------------
    H ⊢ (local x ← M ∙ B) ⟶ᴮ (local x ← M′ ∙ B) ⊣ H′

  subst : ∀ {H x v B} →

    ------------------------------------------------------
    H ⊢ (local x ← val v ∙ B) ⟶ᴮ (B [ v / name x ]ᴮ) ⊣ H

  function : ∀ {H H′ a F B C} →

    H′ ≡ H ⊕ a ↦ (function F is C end) →
    --------------------------------------------------------------
    H ⊢ (function F is C end ∙ B) ⟶ᴮ (B [ addr a / fun F ]ᴮ) ⊣ H′

  return : ∀ {H H′ M M′ B} →

    H ⊢ M ⟶ᴱ M′ ⊣ H′ →
    --------------------------------------------
    H ⊢ (return M ∙ B) ⟶ᴮ (return M′ ∙ B) ⊣ H′

data _⊢_⟶*_⊣_ {a} : Heap a → Block a → Block a → Heap a → Set where

  refl : ∀ {H B} →

    ----------------
    H ⊢ B ⟶* B ⊣ H

  step : ∀ {H H′ H″ B B′ B″} →
    H ⊢ B ⟶ᴮ B′ ⊣ H′ →
    H′ ⊢ B′ ⟶* B″ ⊣ H″ →
    ------------------
    H ⊢ B ⟶* B″ ⊣ H″


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Package where

open import Light.Level using (Setω)

record Meta : Setω where
      field Dependencies : Setω
      field Library : Dependencies → Setω

record Package (meta : Meta) : Setω where
      instance constructor package
      open Meta meta
      field ⦃ dependencies ⦄ : Dependencies
      field ⦃ library ⦄ : Library dependencies
open Package ⦃ ... ⦄ public


module Issue249-2 where

postulate
  A B : Set

module A where
  X = A
  Y = B

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

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


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use Data.List.Relation.Unary.Any
-- directly.
------------------------------------------------------------------------

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

module Data.List.Any where

open import Data.List.Relation.Unary.Any public


------------------------------------------------------------------------
-- A combinator for running two computations in parallel
------------------------------------------------------------------------

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

module Delay-monad.Parallel where

import Equality.Propositional as Eq
open import Prelude
open import Prelude.Size

open import Conat Eq.equality-with-J as Conat
  using (zero; suc; force; max)

open import Delay-monad
open import Delay-monad.Bisimilarity
open import Delay-monad.Bisimilarity.Kind
open import Delay-monad.Monad
import Delay-monad.Sequential as S

private

  variable
    a b             : Level
    A B             : Type a
    i               : Size
    k               : Kind
    f f₁ f₂ g       : Delay (A → B) ∞
    x x₁ x₂ y y₁ y₂ : Delay A ∞
    f′              : Delay′ (A → B) ∞
    x′              : Delay′ A ∞
    h               : A → B
    z               : A

------------------------------------------------------------------------
-- The _⊛_ operator

-- Parallel composition of computations.

infixl 6 _⊛_

_⊛_ : Delay (A → B) i → Delay A i → Delay B i
now f   ⊛ now x   = now (f x)
now f   ⊛ later x = later λ { .force → now f ⊛ x .force }
later f ⊛ now x   = later λ { .force → f .force ⊛ now x }
later f ⊛ later x = later λ { .force → f .force ⊛ x .force }

-- The number of later constructors in f ⊛ x is bisimilar to the
-- maximum of the number of later constructors in f and the number of
-- later constructors in x.

steps-⊛∼max-steps-steps :
  Conat.[ i ] steps (f ⊛ x) ∼ max (steps f) (steps x)
steps-⊛∼max-steps-steps {f = now _}   {x = now _}   = zero
steps-⊛∼max-steps-steps {f = now _}   {x = later _} = suc λ { .force → steps-⊛∼max-steps-steps }
steps-⊛∼max-steps-steps {f = later _} {x = now _}   = suc λ { .force → steps-⊛∼max-steps-steps }
steps-⊛∼max-steps-steps {f = later _} {x = later _} = suc λ { .force → steps-⊛∼max-steps-steps }

-- Rearrangement lemmas for _⊛_.

later-⊛ :
  later f′ ⊛ x ∼ later (record { force = f′ .force ⊛ drop-later x })
later-⊛ {x = now _}   = later λ { .force → _ ∎ }
later-⊛ {x = later _} = later λ { .force → _ ∎ }

⊛-later :
  f ⊛ later x′ ∼ later (record { force = drop-later f ⊛ x′ .force })
⊛-later {f = now _}   = later λ { .force → _ ∎ }
⊛-later {f = later _} = later λ { .force → _ ∎ }

-- The _⊛_ operator preserves strong and weak bisimilarity and
-- expansion.

infixl 6 _⊛-cong_

_⊛-cong_ :
  [ i ] f₁ ⟨ k ⟩ f₂ →
  [ i ] x₁ ⟨ k ⟩ x₂ →
  [ i ] f₁ ⊛ x₁ ⟨ k ⟩ f₂ ⊛ x₂
now      ⊛-cong now      = now
now      ⊛-cong later  q = later λ { .force → now ⊛-cong q .force }
now      ⊛-cong laterˡ q = laterˡ (now ⊛-cong q)
now      ⊛-cong laterʳ q = laterʳ (now ⊛-cong q)
later  p ⊛-cong now      = later λ { .force → p .force ⊛-cong now }
laterˡ p ⊛-cong now      = laterˡ (p ⊛-cong now)
laterʳ p ⊛-cong now      = laterʳ (p ⊛-cong now)

later  p ⊛-cong later  q = later λ { .force → p .force ⊛-cong q .force }
laterʳ p ⊛-cong laterʳ q = laterʳ (p ⊛-cong q)
laterˡ p ⊛-cong laterˡ q = laterˡ (p ⊛-cong q)

later {x = f₁} {y = f₂} p ⊛-cong laterˡ {x = x₁} {y = x₂} q =
  later f₁ ⊛ later x₁                                   ∼⟨ (later λ { .force → _ ∎ }) ⟩
  later (record { force = f₁ .force ⊛ x₁ .force })      ?⟨ (later λ { .force → p .force ⊛-cong drop-laterʳ q }) ⟩∼
  later (record { force = f₂ .force ⊛ drop-later x₂ })  ∼⟨ symmetric later-⊛ ⟩
  later f₂ ⊛ x₂                                         ∎

later {x = f₁} {y = f₂} p ⊛-cong laterʳ {x = x₁} {y = x₂} q =
  later f₁ ⊛ x₁                                         ∼⟨ later-⊛ ⟩
  later (record { force = f₁ .force ⊛ drop-later x₁ })  ≈⟨ (later λ { .force → p .force ⊛-cong drop-laterˡ q }) ⟩∼
  later (record { force = f₂ .force ⊛ x₂ .force })      ∼⟨ (later λ { .force → _ ∎ }) ⟩
  later f₂ ⊛ later x₂                                   ∎

laterˡ {x = f₁} {y = f₂} p ⊛-cong later {x = x₁} {y = x₂} q =
  later f₁ ⊛ later x₁                                   ∼⟨ (later λ { .force → _ ∎ }) ⟩
  later (record { force = f₁ .force ⊛ x₁ .force })      ?⟨ (later λ { .force → drop-laterʳ p ⊛-cong q .force }) ⟩∼
  later (record { force = drop-later f₂ ⊛ x₂ .force })  ∼⟨ symmetric ⊛-later ⟩
  f₂ ⊛ later x₂                                         ∎

laterʳ {x = f₁} {y = f₂} p ⊛-cong later {x = x₁} {y = x₂} q =
  f₁ ⊛ later x₁                                         ∼⟨ ⊛-later ⟩
  later (record { force = drop-later f₁ ⊛ x₁ .force })  ≈⟨ (later λ { .force → drop-laterˡ p ⊛-cong q .force }) ⟩∼
  later (record { force = f₂ .force ⊛ x₂ .force })      ∼⟨ (later λ { .force → _ ∎ }) ⟩
  later f₂ ⊛ later x₂                                   ∎

laterˡ {x = f₁} {y = f₂} p ⊛-cong laterʳ {x = x₁} {y = x₂} q =
  later f₁ ⊛ x₁                                         ∼⟨ later-⊛ ⟩
  later (record { force = f₁ .force ⊛ drop-later x₁ })  ≈⟨ (later λ { .force → drop-laterʳ p ⊛-cong drop-laterˡ q }) ⟩∼
  later (record { force = drop-later f₂ ⊛ x₂ .force })  ∼⟨ symmetric ⊛-later ⟩
  f₂ ⊛ later x₂                                         ∎

laterʳ {x = f₁} {y = f₂} p ⊛-cong laterˡ {x = x₁} {y = x₂} q =
  f₁ ⊛ later x₁                                         ∼⟨ ⊛-later ⟩
  later (record { force = drop-later f₁ ⊛ x₁ .force })  ≈⟨ (later λ { .force → drop-laterˡ p ⊛-cong drop-laterʳ q }) ⟩∼
  later (record { force = f₂ .force ⊛ drop-later x₂ })  ∼⟨ symmetric later-⊛ ⟩
  later f₂ ⊛ x₂                                         ∎

-- The _⊛_ operator is (kind of) commutative.

⊛-comm : [ i ] f ⊛ x ∼ map′ (flip _$_) x ⊛ f
⊛-comm {f = now f}   {x = now x}   = reflexive _
⊛-comm {f = now f}   {x = later x} = later λ { .force → ⊛-comm }
⊛-comm {f = later f} {x = now x}   = later λ { .force → ⊛-comm }
⊛-comm {f = later f} {x = later x} = later λ { .force → ⊛-comm }

-- The function map′ can be expressed using _⊛_.

map∼now-⊛ : [ i ] map′ h x ∼ now h ⊛ x
map∼now-⊛ {x = now x}   = now
map∼now-⊛ {x = later x} = later λ { .force → map∼now-⊛ }

-- The applicative functor laws hold up to strong bisimilarity.

now-id-⊛ : [ i ] now id ⊛ x ∼ x
now-id-⊛ {x = now x}   = now
now-id-⊛ {x = later x} = later λ { .force → now-id-⊛ }

now-∘-⊛-⊛-⊛ :
  [ i ] now (λ f → f ∘_) ⊛ f ⊛ g ⊛ x ∼ f ⊛ (g ⊛ x)
now-∘-⊛-⊛-⊛ {f = now _}   {g = now _}   {x = now _}   = now
now-∘-⊛-⊛-⊛ {f = now _}   {g = now _}   {x = later _} = later λ { .force → now-∘-⊛-⊛-⊛ }
now-∘-⊛-⊛-⊛ {f = now _}   {g = later _} {x = now _}   = later λ { .force → now-∘-⊛-⊛-⊛ }
now-∘-⊛-⊛-⊛ {f = now _}   {g = later _} {x = later _} = later λ { .force → now-∘-⊛-⊛-⊛ }
now-∘-⊛-⊛-⊛ {f = later _} {g = now _}   {x = now _}   = later λ { .force → now-∘-⊛-⊛-⊛ }
now-∘-⊛-⊛-⊛ {f = later _} {g = now _}   {x = later _} = later λ { .force → now-∘-⊛-⊛-⊛ }
now-∘-⊛-⊛-⊛ {f = later _} {g = later _} {x = now _}   = later λ { .force → now-∘-⊛-⊛-⊛ }
now-∘-⊛-⊛-⊛ {f = later _} {g = later _} {x = later _} = later λ { .force → now-∘-⊛-⊛-⊛ }

now-⊛-now : [ i ] now h ⊛ now z ∼ now (h z)
now-⊛-now = now

⊛-now : [ i ] f ⊛ now z ∼ now (λ f → f z) ⊛ f
⊛-now {f = now f}   = now
⊛-now {f = later f} = later λ { .force → ⊛-now }

-- Sequential composition is an expansion of parallel composition.

⊛≳⊛ : [ i ] f S.⊛ x ≳ f ⊛ x
⊛≳⊛ {f = now f} {x = now x}   = now (f x)  ∎
⊛≳⊛ {f = now f} {x = later x} = later λ { .force →
  now f S.⊛ x .force  ≳⟨ ⊛≳⊛ ⟩∎
  now f ⊛ x .force    ∎ }
⊛≳⊛ {f = later f} {x = now x} = later λ { .force →
  f .force S.⊛ now x  ≳⟨ ⊛≳⊛ ⟩∎
  f .force ⊛ now x    ∎ }
⊛≳⊛ {f = later f} {x = later x} = later λ { .force →
  f .force S.⊛ later x   ≳⟨ ((f .force ∎) >>=-cong λ _ → laterˡ (_ ∎)) ⟩
  f .force S.⊛ x .force  ≳⟨ ⊛≳⊛ ⟩∎
  f .force ⊛ x .force    ∎ }

------------------------------------------------------------------------
-- The _∣_ operator

-- Parallel composition of computations.

infix 10 _∣_

_∣_ : Delay A i → Delay B i → Delay (A × B) i
x ∣ y = map′ _,_ x ⊛ y

-- The number of later constructors in x ∣ y is bisimilar to the
-- maximum of the number of later constructors in x and the number of
-- later constructors in y.

steps-∣∼max-steps-steps :
  Conat.[ i ] steps (x ∣ y) ∼ max (steps x) (steps y)
steps-∣∼max-steps-steps {x = x} {y = y} =
  steps (x ∣ y)                       Conat.∼⟨ Conat.reflexive-∼ _ ⟩
  steps (map′ _,_ x ⊛ y)              Conat.∼⟨ steps-⊛∼max-steps-steps ⟩
  max (steps (map′ _,_ x)) (steps y)  Conat.∼⟨ Conat.max-cong (steps-map′ x) (Conat.reflexive-∼ _) ⟩∎
  max (steps x) (steps y)             ∎∼

-- The _∣_ operator preserves strong and weak bisimilarity and
-- expansion.

infix 10 _∣-cong_

_∣-cong_ :
  [ i ] x₁ ⟨ k ⟩ x₂ →
  [ i ] y₁ ⟨ k ⟩ y₂ →
  [ i ] x₁ ∣ y₁ ⟨ k ⟩ x₂ ∣ y₂
p ∣-cong q = map-cong _,_ p ⊛-cong q

-- The _∣_ operator is commutative (up to swapping of results).

∣-comm : [ i ] x ∣ y ∼ map′ swap (y ∣ x)
∣-comm {x = x} {y = y} =
  x ∣ y                                                          ∼⟨⟩
  map′ _,_ x ⊛ y                                                 ∼⟨ ⊛-comm ⟩
  map′ (flip _$_) y ⊛ map′ _,_ x                                 ∼⟨ map∼now-⊛ ⊛-cong map∼now-⊛ ⟩
  now (flip _$_) ⊛ y ⊛ (now _,_ ⊛ x)                             ∼⟨ symmetric now-∘-⊛-⊛-⊛ ⟩
  now (λ f → f ∘_) ⊛ (now (flip _$_) ⊛ y) ⊛ now _,_ ⊛ x          ∼⟨ symmetric now-∘-⊛-⊛-⊛ ⊛-cong (_ ∎) ⊛-cong (_ ∎) ⟩
  now _∘_ ⊛ now (λ f → f ∘_) ⊛ now (flip _$_) ⊛ y ⊛ now _,_ ⊛ x  ∼⟨⟩
  now (λ x f y → f y x) ⊛ y ⊛ now _,_ ⊛ x                        ∼⟨ ⊛-now ⊛-cong (_ ∎) ⟩
  now (_$ _,_) ⊛ (now (λ x f y → f y x) ⊛ y) ⊛ x                 ∼⟨ symmetric now-∘-⊛-⊛-⊛ ⊛-cong (_ ∎) ⟩
  now _∘_ ⊛ now (_$ _,_) ⊛ now (λ x f y → f y x) ⊛ y ⊛ x         ∼⟨⟩
  now (curry swap) ⊛ y ⊛ x                                       ∼⟨⟩
  now _∘_ ⊛ now (swap ∘_) ⊛ now _,_ ⊛ y ⊛ x                      ∼⟨ now-∘-⊛-⊛-⊛ ⊛-cong (_ ∎) ⟩
  now (swap ∘_) ⊛ (now _,_ ⊛ y) ⊛ x                              ∼⟨ (_ ∎) ⊛-cong symmetric map∼now-⊛ ⊛-cong (_ ∎) ⟩
  now (swap ∘_) ⊛ map′ _,_ y ⊛ x                                 ∼⟨⟩
  now _∘_ ⊛ now swap ⊛ map′ _,_ y ⊛ x                            ∼⟨ now-∘-⊛-⊛-⊛ ⟩
  now swap ⊛ (map′ _,_ y ⊛ x)                                    ∼⟨ symmetric map∼now-⊛ ⟩
  map′ swap (map′ _,_ y ⊛ x)                                     ∼⟨⟩
  map′ swap (y ∣ x)                                              ∎

-- Sequential composition is an expansion of parallel composition.

∣≳∣ : [ i ] x S.∣ y ≳ x ∣ y
∣≳∣ {x = x} {y = y} =
  x S.∣ y           ∼⟨⟩
  map′ _,_ x S.⊛ y  ≳⟨ ⊛≳⊛ ⟩
  map′ _,_ x ⊛ y    ∼⟨⟩
  x ∣ y             ∎


{- 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.Concrete.System.Parameters
open import LibraBFT.Impl.Consensus.BlockStorage.BlockStore
import      LibraBFT.Impl.Consensus.BlockStorage.BlockTree    as BlockTree
open import LibraBFT.Impl.Consensus.ConsensusTypes.Vote       as Vote
import      LibraBFT.Impl.Consensus.PersistentLivenessStorage as PersistentLivenessStorage
open import LibraBFT.Impl.OBM.Rust.RustTypes
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Crypto
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.ByteString
open import Util.Hash
open import Util.KVMap                                        as Map
open import Util.PKCS
open import Util.Prelude
open import Yasm.System ℓ-RoundManager ℓ-VSFP ConcSysParms

open Invariants
open RoundManagerTransProps
open QCProps

module LibraBFT.Impl.Consensus.BlockStorage.Properties.BlockStore where

module new
  (storage              : PersistentLivenessStorage)
  (initialData          : RecoveryData)
  (stateComp            : StateComputer)
  (maxPrunedBlocksInMem : Usize)
  where

  -- TODO-2: May require refinement (additional requirements and/or properties, particularly regarding ECinfo)
  Contract : ECinfo → EitherD-Post ErrLog BlockStore
  Contract _ (Left _)   = ⊤
  Contract eci (Right bs) = BlockStoreInv (bs , eci)

  postulate
    contract : ∀ {eci}
             → Contract eci (new-e-abs storage initialData stateComp maxPrunedBlocksInMem)
module executeBlockESpec (bs : BlockStore) (block : Block) where

  Ok : Set
  Ok = ∃[ eb ] (executeBlockE bs block ≡ Right eb)

  record ContractOk (eb : ExecutedBlock) : Set where
    constructor mkContractOk
    field
      ebBlock≡ : block ≡ eb ^∙ ebBlock

  postulate -- TODO: prove
    contract : (isOk : Ok) → ContractOk (proj₁ isOk)

module executeAndInsertBlockESpec (bs0 : BlockStore) (vblock : ValidBlock) where
  block   = vbBlock vblock
  block-c = vbValid vblock
  open executeAndInsertBlockE bs0 block

  open import LibraBFT.Impl.Consensus.BlockStorage.Properties.BlockTree

  blockId = block ^∙ bId

  ------   These are used only outside this module.
  Ok : Set
  Ok = ∃₂ λ bs' eb → executeAndInsertBlockE bs0 block ≡ Right (bs' , eb)

  open Reqs block (bs0 ^∙ bsInner)

  record ContractOk (bs' : BlockStore) (eb : ExecutedBlock) : Set where
    constructor mkContractOk
    field
      ebBlock≈ : NoHC1 → eb ^∙ ebBlock ≈Block block
      bsInv    : ∀ {eci}
                 → Preserves BlockStoreInv (bs0 , eci) (bs' , eci)
      -- executeAndInsertBlockE does not modify BlockTree fields other than btIDToBlock
      bs≡x : bs0 ≡ (bs' & (bsInner ∙ btIdToBlock) ∙~ (bs0 ^∙ bsInner ∙ btIdToBlock))

  Contract : EitherD-Post ErrLog (BlockStore × ExecutedBlock)
  Contract (Left x) = ⊤
  Contract (Right (bs' , eb)) = ContractOk bs' eb

  -- TUTORIAL: This proof has some additional commentary helping to understand the structure of the
  -- proof, and showing an example of how using abstract variants of functions makes proofs more
  -- resilient to change, as explained in
  -- https://github.com/oracle/bft-consensus-agda/blob/main/docs/PeerHandlerContracts.org
  contract' : EitherD-weakestPre step₀ Contract
  -- step₀ is a maybeSD in context of EitherD.  Therefore, via MonadMaybeD and EitherD-MonadMaybeD,
  -- this translates to EitherD-maybe.  We first deal with the easy case, applying the NoHC1
  -- function provided to ebBlock≈ to evidence eb≡ that eb is in btIdToBlock.
  proj₂ contract' eb eb≡ =
    mkContractOk (λ nohc → nohc eb≡ block-c) id refl
  proj₁ contract' getBlock≡nothing = contract₁
    where
    -- step₁ is again a maybeSD; if bs0 ^∙ bsRoot ≡ nothing, the Contract is trivial
    contract₁ : EitherD-weakestPre step₁ Contract
    proj₁ contract₁ _ = tt
    -- otherwise, bs0 ^∙ bsRoot ≡ just bsr, and we have an ifD; in the true branch, step₁ returns a
    -- Left, so again it is trivial
    proj₁ (proj₂ contract₁ bsr bsr≡) _ = tt
    -- in the else branch, we call step₂ bsr
    proj₂ (proj₂ contract₁ bsr bsr≡) btr<br = contract₂
      where
      contract₃ : ∀ eb → block ≡ (eb ^∙ ebBlock)
                  → EitherD-weakestPre (step₃ eb) Contract

      module EB = executeBlockESpec bs0 block
      open EB.ContractOk

      contract₂ : EitherD-weakestPre (step₂ bsr) Contract
      proj₂ contract₂ eb eb≡ ._             executeBlockE≡Right@refl = let con = (EB.contract (eb , eb≡))
                                                                       in contract₃ eb
                                                                                (EB.ContractOk.ebBlock≡ con)

      proj₁ contract₂ (ErrCBlockNotFound _) executeBlockE≡Left = tt
      proj₁ contract₂ (ErrVerify _)         executeBlockE≡Left = tt
      proj₁ contract₂ (ErrInfo _)           executeBlockE≡Left = tt
      -- if executeBlockE returns Left (ErrECCBlockNotFound parentBlockId), then we have two casesdue to
      -- eitherSD (pathFromRoot parentBlockId bs0) LeftD λ blocksToReexecute →
      -- in the first case, we have a Left, so it's easy
      proj₁        (proj₁ contract₂ (ErrECCBlockNotFound parentBlockId) executeBlockE≡Left) _ _ = tt
      -- in the second case, we have
      -- case⊎D (forM) blocksToReexecute (executeBlockE bs0 ∘ (_^∙ ebBlock)) of λ where
      -- and therefore two more cases; if the case⊎D returns Left, it's easy again
      proj₁ (proj₂ (proj₁ contract₂ (ErrECCBlockNotFound parentBlockId) executeBlockE≡Left) blocksToReexecute btr≡) _ _ = tt
      -- if the case⊎D returns a Right, we call executeBlockE₀ (the EitherD variant).  We use executeBlockE≡ to handle case
      -- analysis on the result of calling the abstract executeBlockE variant, ensuring we must use the contract for
      -- executeBlockE because the proof cannot "look into" the implementation of executeBlockE, which makes the proof
      -- more resilient in case of changes in its implementation.
      -- TODO-2: clean this up by writing a general version of the contract for executeBlockE
      proj₂ (proj₂ (proj₁ contract₂ (ErrECCBlockNotFound parentBlockId) executeBlockE≡Left) blocksToReexecute btr≡) _ _
        with  executeBlockE bs0  block | inspect
             (executeBlockE bs0) block
      ... | Left  x | [ R ] rewrite executeBlockE≡ R = tt
      ... | Right y | [ R ] rewrite executeBlockE≡ R =
        λ where c refl ._ refl →
                  let con = EB.contract (c , R) in
                  contract₃ c
                            (ebBlock≡ con)
                            _ refl

      contract₃ eb refl _ _ = contract₄
        where

        contract₄ : EitherD-weakestPre (step₄ eb) Contract
        contract₄
           with insertBlockESpec.contract eb (bs0 ^∙ bsInner)
        ...| con
           with BlockTree.insertBlockE.E eb (bs0 ^∙ bsInner)
        ...| Left _ = tt
        ...| Right (bt' , eb') =
           λ where ._ refl → mkContractOk IBE.blocks≈ btP bss≡x
           where
           module IBE = insertBlockESpec.ContractOk con

           open BlockStoreInv

           btP : ∀ {eci} → Preserves BlockStoreInv (bs0 , eci) ((bs0 & bsInner ∙~ bt') , eci)
           btP (mkBlockStoreInv bti) = mkBlockStoreInv (IBE.btiPres bti)

           bss≡x : bs0 ≡ (bs0 & bsInner ∙~ bt' & bsInner ∙ btIdToBlock ∙~ (bs0 ^∙ (bsInner ∙ btIdToBlock)))
           bss≡x rewrite sym IBE.bt≡x = refl

  contract : Contract (executeAndInsertBlockE bs0 block)
  contract = EitherD-contract (executeAndInsertBlockE.step₀ bs0 block) Contract contract'

module executeAndInsertBlockMSpec (vb : ValidBlock) where
  b = vbBlock vb

  -- NOTE: This function returns any errors, rather than producing them as output.
  module _ (pre : RoundManager) where
    bs = pre ^∙ lBlockStore

    contract
      : ∀ Post
        → (∀ e → {- At the moment we do not need to know why it failed -} Post (Left e) pre [])
        → ((isOk : executeAndInsertBlockESpec.Ok bs vb) → let (bs' , eb , _) = isOk in
             executeAndInsertBlockESpec.ContractOk bs vb bs' eb
           → Post (Right eb) (pre & rmBlockStore ∙~ bs') [])
        → LBFT-weakestPre (executeAndInsertBlockM b) Post pre
    proj₁ (contract Post pfBail pfOk ._ refl) e ≡left = pfBail e
    proj₂ (contract Post pfBail pfOk ._ refl) (bs' , eb) ≡right ._ refl unit refl
       with executeAndInsertBlockESpec.contract bs vb
    ...| con rewrite ≡right = pfOk (bs' , eb , refl) con

module insertSingleQuorumCertMSpec
  (qc : QuorumCert) where

  module _ (pre : RoundManager) where

    record Contract (r : Either ErrLog Unit) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        -- General invariants / properties
        rmInv         : Preserves RoundManagerInv pre post
        noEpochChange : NoEpochChange pre post
        noMsgOuts     : OutputProps.NoMsgs outs
        -- Voting
        noVote        : VoteNotGenerated pre post true
        -- Signatures
        qcPost : ∈Post⇒∈PreOr (_≡ qc) pre post

    postulate -- TODO-2: prove
      contract' : LBFT-weakestPre (insertSingleQuorumCertM qc) Contract pre

    contract : ∀ Q → RWS-Post-⇒ Contract Q → LBFT-weakestPre (insertSingleQuorumCertM qc) Q pre
    contract Q pf = LBFT-⇒ (insertSingleQuorumCertM qc) pre contract' pf

module syncInfoMSpec where
  syncInfo : RoundManager → SyncInfo
  syncInfo pre =
    SyncInfo∙new (pre ^∙ lBlockStore ∙ bsHighestQuorumCert)
                 (pre ^∙ lBlockStore ∙ bsHighestCommitCert)
                 (pre ^∙ lBlockStore ∙ bsHighestTimeoutCert)

  contract : ∀ pre Post → (Post (syncInfo pre) pre []) → LBFT-weakestPre syncInfoM Post pre
  contract pre Post pf ._ refl ._ refl ._ refl ._ refl ._ refl ._ refl = pf


-- This is mainly a test of the quality of error messages for
-- termination problems.

module TerminationLambda where

postulate Id : Set → Set

F : Set → Set
F = λ A → F (Id A)


-- Andreas, 2013-10-21 reported by Christian Sattler
{-# OPTIONS --allow-unsolved-metas #-}
module Issue922 where

import Common.Level

f : Set → Set → Set
f x _ = x   -- Note: second argument is unused

module _ (_ : f ? ?) where
  g = f
  -- Here an instance search for the unused argument (2nd ?)
  -- is triggered.

-- Problem WAS: instance search was started in wrong context.


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

module cw.examples.Examples where

open import cw.examples.Empty public
open import cw.examples.Sphere public
open import cw.examples.Unit public