module examplesPaperJFP.BasicIO where

open import Data.Maybe hiding ( _>>=_ )
open import Data.Sum renaming (inj₁ to left; inj₂ to right; [_,_]′ to either)
open import Function

open import examplesPaperJFP.NativeIOSafe
open import examplesPaperJFP.triangleRightOperator

module _ where  -- for indentation
  record IOInterface : Set₁ where
    field  Command   :  Set
           Response  :  (c : Command) → Set

open IOInterface public

module _ {C : Set} {R : C → Set} (let
  I = record { Command = C; Response = R }
    ) where
module Postulated {I : IOInterface} (let C = Command I) (let R = Response I) where

  postulate
    IO                :  (I : IOInterface) (A : Set) → Set
    exec               :  ∀{A}    (c  :  C)       (f  :  R c → IO I A)  → IO I A
    return            :  ∀{A}    (a  :  A)                             → IO I A
    _>>=_             :  ∀{A B}  (m  :  IO I A)  (k  :  A → IO I B)    → IO I B

mutual
  record IO I A : Set where
    coinductive
    constructor delay
    field force : IO′ I A

  data IO′ I A : Set where
    exec′      :  (c : Command I) (f : Response I c → IO I A)  → IO′ I A
    return′  :  (a : A)                                      → IO′ I A

open IO public

delay′ : ∀{I A} → IO′ I A → IO I A
force (delay′ x) = x

module _ {I : IOInterface} (let C = Command I) (let R = Response I) where
-- module _ {I : IOInterface} (let record { Command = C; Response = R } = I) where
-- module _ {I : IOInterface} (let ioInterface C R = I) where
  exec                :  ∀{A} (c : C) (f : R c → IO I A) → IO I A
  force (exec c f)    =  exec′ c f

  return            :  ∀{A} (a : A) → IO I A
  force (return a)  =  return′ a

  infixl 2 _>>=_
  _>>=_             :  ∀{A B} (m : IO I A) (k : A → IO I B) → IO I B
  force (m >>= k) with force m
  ... | exec′ c f     =  exec′ c λ x → f x >>= k
  ... | return′ a   =  force (k a)

module _ {I : IOInterface} (let C = Command I) (let R = Response I)
      where

  {-# NON_TERMINATING #-}
  translateIO : ∀ {A} (tr : (c : C) → NativeIO (R c)) → IO I A → NativeIO A
  translateIO tr m = force m ▹ λ
     {  (exec′ c f)    →  (tr c) native>>= λ r → translateIO tr (f r)
     ;  (return′ a)  →  nativeReturn a
     }

-- Recursion

-- trampoline provides a generic form of loop (generalizing while/repeat).
-- Starting at state s : S, step function f is iterated until it returns
-- a result in A.

module _ (I : IOInterface)(let C = Command I) (let R = Response I)
      where
  data IO+ (A : Set) : Set where
      exec′ : (c : C) (f : R c → IO I A) → IO+ A

module _ {I : IOInterface}(let C = Command I) (let R = Response I)
      where
  fromIO+′ : ∀{A} → IO+ I A → IO′ I A
  fromIO+′ (exec′ c f) = exec′ c f

  fromIO+ : ∀{A} → IO+ I A → IO I A
  force (fromIO+ (exec′ c f)) = exec′ c f

  _>>=+′_ : ∀{A B} (m : IO+ I A) (k : A → IO I B) → IO′ I B
  exec′ c f >>=+′ k = exec′ c λ x → f x >>= k

  _>>=+_ : ∀{A B} (m : IO+ I A) (k : A → IO I B) → IO I B
  force (m >>=+ k) = m >>=+′ k

  mutual

    _>>+_ : ∀{A B} (m : IO I (A ⊎ B)) (k : A → IO I B) → IO I B
    force (m >>+ k) = force m >>+′ k

    _>>+′_ : ∀{A B} (m : IO′ I (A ⊎ B)) (k : A → IO I B) → IO′ I B
    exec′ c f            >>+′ k = exec′ c λ x → f x >>+ k
    return′ (left  a)  >>+′ k = force (k a)
    return′ (right b)  >>+′ k = return′ b

   -- loop

  {-# TERMINATING #-}

  trampoline : ∀{A S} (f : S → IO+ I (S ⊎ A)) (s : S) → IO I A
  force (trampoline f s) = case (f s) of
    \ { (exec′ c k) → exec′ c λ r → k r >>+ trampoline f }

  -- simple infinite loop

  {-# TERMINATING #-}
  forever : ∀{A B} → IO+ I A → IO I B
  force (forever (exec′ c f)) = exec′ c λ r → f r >>= λ _ → forever (exec′ c f)

  whenJust : {A : Set} → Maybe A → (A → IO I Unit) → IO I Unit
  whenJust nothing  k = return _
  whenJust (just a) k = k a

main : NativeIO Unit
main = nativePutStrLn "Hello, world!"


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

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Concrete.Obligations
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Impl.Consensus.Types
open        EpochConfig
open import LibraBFT.Yasm.Yasm (ℓ+1 0ℓ) EpochConfig epochId authorsN ConcSysParms NodeId-PK-OK

-- In this module, we assume that the implementation meets its
-- obligations, and use this assumption to prove that, in any reachable
-- state, the implementatioon enjoys one of the per-epoch correctness
-- conditions proved in Abstract.Properties.  It can be extended to other
-- properties later.
module LibraBFT.Concrete.Properties
         (impl-correct : ImplObligations)
         {e}(st : SystemState e)
         (r : ReachableSystemState st)
         (eid : Fin e)
         where
    open        ImplObligations impl-correct
    open import LibraBFT.Concrete.System sps-cor
    open        PerState st r
    open        PerEpoch eid

    open import LibraBFT.Abstract.Abstract     UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Abs
    open import LibraBFT.Concrete.Intermediate                   𝓔 (ConcreteVoteEvidence 𝓔)
    import      LibraBFT.Concrete.Obligations.VotesOnce          𝓔 (ConcreteVoteEvidence 𝓔) as VO-obl
    import      LibraBFT.Concrete.Obligations.LockedRound        𝓔 (ConcreteVoteEvidence 𝓔) as LR-obl
    open import LibraBFT.Concrete.Properties.VotesOnce                                       as VO
    open import LibraBFT.Concrete.Properties.LockedRound                                     as LR

    --------------------------------------------------------------------------------------------
    -- * A /ValidSysState/ is one in which both peer obligations are obeyed by honest peers * --
    --------------------------------------------------------------------------------------------

    record ValidSysState {ℓ}(𝓢 : IntermediateSystemState ℓ) : Set (ℓ+1 ℓ0 ℓ⊔ ℓ) where
      field
        vss-votes-once   : VO-obl.Type 𝓢
        vss-locked-round : LR-obl.Type 𝓢
    open ValidSysState public

    -- TODO-2 : This should be provided as a module parameter here, and the
    -- proofs provided to instantiate it should be refactored into LibraBFT.Impl.
    -- However, see the TODO-3 in LibraBFT.Concrete.Intermediate, which suggests
    -- that those proofs may change, perhaps some parts of them will remain in
    -- Concrete and others should be in Impl, depending on how that TODO-3 is
    -- addressed.  There is not much point in doing said refactoring until we
    -- make progress on that question.

    validState : ValidSysState IntSystemState
    validState = record
      { vss-votes-once   = VO.Proof.voo sps-cor vo₁ vo₂ st r eid
      ; vss-locked-round = LR.Proof.lrr sps-cor lr₁ st r eid
      }

    open IntermediateSystemState IntSystemState

    open All-InSys-props InSys
    open WithAssumptions InSys

    -- We can now invoke the various abstract correctness properties, using
    --
    ConcCommitsDoNotConflict :
       ∀{q q'}
       → {rc  : RecordChain (Abs.Q q)}  → All-InSys rc
       → {rc' : RecordChain (Abs.Q q')} → All-InSys rc'
       → {b b' : Abs.Block}
       → CommitRule rc  b
       → CommitRule rc' b'
       → NonInjective-≡ Abs.bId ⊎ ((Abs.B b) ∈RC rc' ⊎ (Abs.B b') ∈RC rc)
    ConcCommitsDoNotConflict = CommitsDoNotConflict
           (VO-obl.proof IntSystemState (vss-votes-once validState))
           (LR-obl.proof IntSystemState (vss-locked-round validState))

    module _ (∈QC⇒AllSent : Complete InSys) where

      ConcCommitsDoNotConflict' :
        ∀{q q'}{rc  : RecordChain (Abs.Q q)}{rc' : RecordChain (Abs.Q q')}{b b' : Abs.Block}
        → InSys (Abs.Q q) → InSys (Abs.Q q')
        → CommitRule rc  b
        → CommitRule rc' b'
        → NonInjective-≡ Abs.bId ⊎ ((Abs.B b) ∈RC rc' ⊎ (Abs.B b') ∈RC rc)
      ConcCommitsDoNotConflict' = CommitsDoNotConflict'
           (VO-obl.proof IntSystemState (vss-votes-once validState))
           (LR-obl.proof IntSystemState (vss-locked-round validState))
           ∈QC⇒AllSent

      ConcCommitsDoNotConflict''
        : ∀{o o' q q'}
        → {rcf  : RecordChainFrom o  (Abs.Q q)}
        → {rcf' : RecordChainFrom o' (Abs.Q q')}
        → {b b' : Abs.Block}
        → InSys (Abs.Q q)
        → InSys (Abs.Q q')
        → CommitRuleFrom rcf  b
        → CommitRuleFrom rcf' b'
        → NonInjective-≡ Abs.bId ⊎ Σ (RecordChain (Abs.Q q')) ((Abs.B b)  ∈RC_)
                                 ⊎ Σ (RecordChain (Abs.Q q))  ((Abs.B b') ∈RC_)
      ConcCommitsDoNotConflict'' = CommitsDoNotConflict''
           (VO-obl.proof IntSystemState (vss-votes-once validState))
           (LR-obl.proof IntSystemState (vss-locked-round validState))
           ∈QC⇒AllSent


module Issue395 where

foo : Set → Set₁
foo foo with Set
... | _ = Set


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

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

module Data.Vec.All where

open import Data.Vec.Relation.Unary.All public

{-# WARNING_ON_IMPORT
"Data.Vec.All was deprecated in v1.0.
Use Data.Vec.Relation.Unary.All instead."
#-}


------------------------------------------------------------------------
-- Parallel substitutions (defined using an inductive family)
------------------------------------------------------------------------

open import Data.Universe.Indexed

module deBruijn.Substitution.Data
  {i u e} {Uni : IndexedUniverse i u e} where

import deBruijn.Context; open deBruijn.Context Uni
open import Function as F using (_$_)
open import Level using (_⊔_)
import Relation.Binary.PropositionalEquality as P

open P.≡-Reasoning

-- This module reexports some other modules.

open import deBruijn.Substitution.Data.Application public
open import deBruijn.Substitution.Data.Basics      public
open import deBruijn.Substitution.Data.Map         public
open import deBruijn.Substitution.Data.Simple      public

------------------------------------------------------------------------
-- Instantiations and code for facilitating instantiations

-- Renamings (variable substitutions).

module Renaming where

  -- Variables support all of the operations above.

  simple : Simple Var
  simple = record
    { weaken     = weaken∋
    ; var        = [id]
    ; weaken-var = λ _ → P.refl
    }

  application : Application Var Var
  application = record { app = app∋ }

  application₁ : Application₁ Var
  application₁ = record
    { simple        = simple
    ; application₂₂ = record
      { application₂₁ = record
        { application  = application
        ; trans-weaken = λ _ → P.refl
        ; trans-var    = λ _ → P.refl
        ; var-/⊢       = λ _ _ → P.refl
        }
      ; var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ = λ _ _ hyp → hyp
      ; /⊢-wk                 = Simple./∋-wk simple
      }
    }

  open Application₁ application₁ public hiding (simple; application)

  ≅-∋-⇒-≅-⊢ : ∀ {Γ₁ σ₁} {x₁ : Γ₁ ∋ σ₁}
                {Γ₂ σ₂} {x₂ : Γ₂ ∋ σ₂} →
              x₁ ≅-∋ x₂ → Term-like._≅-⊢_ Var x₁ x₂
  ≅-∋-⇒-≅-⊢ P.refl = P.refl

  ≅-⊢-⇒-≅-∋ : ∀ {Γ₁ σ₁} {x₁ : Γ₁ ∋ σ₁}
                {Γ₂ σ₂} {x₂ : Γ₂ ∋ σ₂} →
              Term-like._≅-⊢_ Var x₁ x₂ → x₁ ≅-∋ x₂
  ≅-⊢-⇒-≅-∋ P.refl = P.refl

-- A translation of T₁'s to T₂'s, plus a bit more.

record _↦_ {t₁} (T₁ : Term-like t₁)
           {t₂} (T₂ : Term-like t₂) : Set (i ⊔ u ⊔ e ⊔ t₁ ⊔ t₂) where
  field
    -- Translates T₁'s to T₂'s.
    trans : [ T₁ ⟶⁼ T₂ ]

    -- Simple substitutions for T₁'s.
    simple : Simple T₁

  open Simple simple public

  open Term-like T₁ renaming (⟦_⟧ to ⟦_⟧₁)
  open Term-like T₂ renaming (⟦_⟧ to ⟦_⟧₂)

  /̂∋-⟦⟧⇨ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ σ) (ρ : Sub T₁ ρ̂) →
           x /̂∋ ⟦ ρ ⟧⇨ ≅-Value ⟦ trans · (x /∋ ρ) ⟧₂
  /̂∋-⟦⟧⇨ x ρ = begin
    [ x /̂∋ ⟦ ρ ⟧⇨           ]  ≡⟨ corresponds (app∋ ρ) x ⟩
    [ ⟦ x /∋ ρ ⟧₁           ]  ≡⟨ corresponds trans (x /∋ ρ) ⟩
    [ ⟦ trans · (x /∋ ρ) ⟧₂ ]  ∎

-- "Term" substitutions.

-- For simplicity I have chosen to use the universe level (i ⊔ u ⊔ e)
-- here; this is the level of Var. The code could perhaps be made more
-- general.

record Substitution₁ (T : Term-like (i ⊔ u ⊔ e))
                     : Set (Level.suc (i ⊔ u ⊔ e)) where

  open Term-like T

  field
    -- Takes variables to terms.
    var : [ Var ⟶⁼ T ]

    -- Applies substitutions, which contain things which can be
    -- translated to terms, to terms.
    app′ : {T′ : Term-like (i ⊔ u ⊔ e)} → T′ ↦ T →
           ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T′ ρ̂ → [ T ⟶ T ] ρ̂

    -- A property relating app′ and var.
    app′-var :
      ∀ {T′ : Term-like (i ⊔ u ⊔ e)} {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ}
      (T′↦T : T′ ↦ T) (x : Γ ∋ σ) (ρ : Sub T′ ρ̂) →
      app′ T′↦T ρ · (var · x) ≅-⊢ _↦_.trans T′↦T · (x /∋ ρ)

  -- Variables can be translated into terms.

  private

    Var-↦′ : Var ↦ T
    Var-↦′ = record
      { trans  = var
      ; simple = Renaming.simple
      }

  -- Renamings can be applied to terms.

  app-renaming : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub Var ρ̂ → [ T ⟶ T ] ρ̂
  app-renaming = app′ Var-↦′

  -- This gives us a way to define the weakening operation.

  simple : Simple T
  simple = record
    { weaken     = app-renaming Renaming.wk
    ; var        = var
    ; weaken-var = weaken-var
    }
    where
    abstract
      weaken-var : ∀ {Γ σ τ} (x : Γ ∋ τ) →
                   app-renaming (Renaming.wk[_] σ) · (var · x) ≅-⊢
                   var · suc[ σ ] x
      weaken-var x = begin
        [ app-renaming Renaming.wk · (var · x) ]  ≡⟨ app′-var Var-↦′ x Renaming.wk ⟩
        [ var · (x /∋ Renaming.wk)             ]  ≡⟨ ·-cong (var ∎-⟶) (Renaming./∋-wk x) ⟩
        [ var · suc x                          ]  ∎

  -- A translation of T′'s to T's, plus a bit more.

  record Translation-from (T′ : Term-like (i ⊔ u ⊔ e))
                          : Set (i ⊔ u ⊔ e) where

    field
      translation : T′ ↦ T

    open _↦_ translation
      using (trans)
      renaming (simple to simple′; var to var′; weaken[_] to weaken′[_])

    field
      trans-weaken : ∀ {Γ σ τ} (t : Term-like._⊢_ T′ Γ τ) →
                     trans · (weaken′[ σ ] · t) ≅-⊢
                     Simple.weaken[_] simple σ · (trans · t)
      trans-var    : ∀ {Γ σ} (x : Γ ∋ σ) →
                     trans · (var′ · x) ≅-⊢ var · x

    -- An Application₂₁ record.

    application₂₁ : Application₂₁ simple′ simple trans
    application₂₁ = record
      { application  = record { app = app′ translation }
      ; trans-weaken = trans-weaken
      ; trans-var    = trans-var
      ; var-/⊢       = app′-var translation
      }

    open _↦_ translation public
    open Application₂₁ application₂₁ public
      hiding (trans-weaken; trans-var)

  -- Variables can be translated into terms.

  Var-↦ : Translation-from Var
  Var-↦ = record
    { translation  = Var-↦′
    ; trans-weaken = trans-weaken
    ; trans-var    = λ _ → P.refl
    }
    where
    abstract
      trans-weaken :
        ∀ {Γ σ τ} (x : Γ ∋ τ) →
        var · suc[ σ ] x ≅-⊢
        Simple.weaken[_] simple σ · (var · x)
      trans-weaken x = P.sym $ Simple.weaken-var simple x

  -- Terms can be translated into terms.

  no-translation : Translation-from T
  no-translation = record
    { translation  = record { trans = [id]; simple = simple }
    ; trans-weaken = λ _ → P.refl
    ; trans-var    = λ _ → P.refl
    }

record Substitution₂ (T : Term-like (i ⊔ u ⊔ e))
                     : Set (Level.suc (i ⊔ u ⊔ e)) where

  open Term-like T

  field
    substitution₁ : Substitution₁ T

  open Substitution₁ substitution₁

  field
    -- Lifts equalities valid for all variables and liftings to
    -- arbitrary terms.
    var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆′ :
      {T₁ T₂ : Term-like (i ⊔ u ⊔ e)}
      (T₁↦T : Translation-from T₁) (T₂↦T : Translation-from T₂) →

      let open Translation-from T₁↦T
            using () renaming (_↑⁺⋆_ to _↑⁺⋆₁_; _/⊢⋆_ to _/⊢⋆₁_)
          open Translation-from T₂↦T
            using () renaming (_↑⁺⋆_ to _↑⁺⋆₂_; _/⊢⋆_ to _/⊢⋆₂_) in

      ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρs₁ : Subs T₁ ρ̂) (ρs₂ : Subs T₂ ρ̂) →
      (∀ Γ⁺ {σ} (x : Γ ++⁺ Γ⁺ ∋ σ) →
         var · x /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢ var · x /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺) →
      ∀ Γ⁺ {σ} (t : Γ ++⁺ Γ⁺ ⊢ σ) →
      t /⊢⋆₁ ρs₁ ↑⁺⋆₁ Γ⁺ ≅-⊢ t /⊢⋆₂ ρs₂ ↑⁺⋆₂ Γ⁺

  -- Given a well-behaved translation from something with simple
  -- substitutions one can define an Application₂₂ record.

  application₂₂ :
    {T′ : Term-like (i ⊔ u ⊔ e)} (T′↦T : Translation-from T′) →
    let open Translation-from T′↦T
          using (trans) renaming (simple to simple′) in
    Application₂₂ simple′ simple trans
  application₂₂ T′↦T = record
    { application₂₁         = Translation-from.application₂₁ T′↦T
    ; var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆ = var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆′ T′↦T T′↦T
    ; /⊢-wk                 = /⊢-wk
    }
    where
    open Translation-from T′↦T
      using ()
      renaming ( _↑⁺_ to _↑⁺′_; _↑⁺⋆_ to _↑⁺⋆′_
               ; wk to wk′; wk[_] to wk′[_]
               ; _/⊢_ to _/⊢′_; _/⊢⋆_ to _/⊢⋆′_
               )
    open Translation-from Var-↦
      using ()
      renaming ( _↑⁺_ to _↑⁺-renaming_; _↑⁺⋆_ to _↑⁺⋆-renaming_
               ; _/⊢_ to _/⊢-renaming_; _/⊢⋆_ to _/⊢⋆-renaming_
               )

    abstract
      /⊢-wk : ∀ {Γ σ τ} (t : Γ ⊢ τ) →
              t /⊢′ wk′[ σ ] ≅-⊢ t /⊢-renaming Renaming.wk[_] σ
      /⊢-wk =
        var-/⊢⋆-↑⁺⋆-⇒-/⊢⋆-↑⁺⋆′ T′↦T Var-↦ (ε ▻ wk′) (ε ▻ Renaming.wk)
          (λ Γ⁺ x → begin
             [ var · x /⊢⋆′ (ε ▻ wk′) ↑⁺⋆′ Γ⁺                         ]  ≡⟨ Translation-from./⊢⋆-ε-▻-↑⁺⋆ T′↦T Γ⁺ (var · x) wk′ ⟩
             [ var · x /⊢′ wk′ ↑⁺′ Γ⁺                                 ]  ≡⟨ Translation-from.var-/⊢-wk-↑⁺ T′↦T Γ⁺ x ⟩
             [ var · (lift weaken∋ Γ⁺ · x)                            ]  ≡⟨ P.sym $ Translation-from.var-/⊢-wk-↑⁺ Var-↦ Γ⁺ x ⟩
             [ var · x /⊢-renaming Renaming.wk ↑⁺-renaming Γ⁺         ]  ≡⟨ P.sym $ Translation-from./⊢⋆-ε-▻-↑⁺⋆
                                                                                Var-↦ Γ⁺ (var · x) Renaming.wk ⟩
             [ var · x /⊢⋆-renaming (ε ▻ Renaming.wk) ↑⁺⋆-renaming Γ⁺ ]  ∎)
          ε

  -- An Application₂₂ record for renamings.

  application₂₂-renaming : Application₂₂ Renaming.simple simple var
  application₂₂-renaming = application₂₂ Var-↦

  -- We can apply substitutions to terms.

  application₁ : Application₁ T
  application₁ = record
    { simple        = simple
    ; application₂₂ = application₂₂ no-translation
    }

  open Application₁ application₁ public
    hiding (var; simple; application₂₂)
  open Substitution₁ substitution₁ public


-- Andreas, 2020-02-15, issue #4447, reported by zraffer

record Wrap : Set₁ where
  constructor ↑
  field ↓ : Set
open Wrap public

data Unit : Set

-- The type checker sees through this definition,
-- thus, the positivity checker should as well:
𝕌nit = ↑ Unit

data Unit where
  unit : ↓ 𝕌nit

-- WAS: internal error in the positivity checker.


------------------------------------------------------------------------
-- The coinductive type family Coherently
------------------------------------------------------------------------

-- This type family is used to define the lenses in
-- Lens.Non-dependent.Higher.Coinductive and
-- Lens.Non-dependent.Higher.Coinductive.Small.

{-# OPTIONS --cubical --guardedness #-}

import Equality.Path as P

module Lens.Non-dependent.Higher.Coherently.Coinductive
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

import Equality.Path.Univalence as EPU
open import Prelude

open import Bijection equality-with-J as B using (_↔_)
import Bijection P.equality-with-J as PB
open import Container.Indexed equality-with-J
open import Container.Indexed.M.Codata eq
import Container.Indexed.M.Function equality-with-J as F
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
import Equivalence P.equality-with-J as PEq
open import Function-universe equality-with-J hiding (id; _∘_)
import Function-universe P.equality-with-J as PF
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional.One-step eq as O
  using (∥_∥¹; ∣_∣)
open import Univalence-axiom equality-with-J
import Univalence-axiom P.equality-with-J as PU

import Lens.Non-dependent.Higher.Coherently.Not-coinductive eq as NC

private
  variable
    a b ℓ p p₁ p₂ : Level
    A A₁ A₂ B C   : Type a
    f q x y       : A
    n             : ℕ

------------------------------------------------------------------------
-- The type family

-- Coherently P step f means that f and all variants of f built using
-- step (in a certain way) satisfy the property P.
--
-- Paolo Capriotti came up with a coinductive definition of lenses.
-- Andrea Vezzosi suggested that one could use a kind of indexed
-- M-type to make it easier to prove that two variants of coinductive
-- lenses are equivalent: the lemma Coherently-cong-≡ below is based
-- on his idea, and Coherently is a less general variant of the M-type
-- that he suggested. See also Coherently-with-restriction′ below,
-- which is defined as an indexed M-type.

record Coherently
         {A : Type a} {B : Type b}
         (P : {A : Type a} → (A → B) → Type p)
         (step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B)
         (f : A → B) : Type p where
  coinductive
  field
    property : P f
    coherent : Coherently P step (step f property)

open Coherently public

------------------------------------------------------------------------
-- An equivalence

-- Coherently is pointwise equivalent to NC.Coherently (assuming
-- univalence).

Coherently≃Not-coinductive-coherently :
  {B : Type b}
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B}
  {f : A → B} →
  Univalence (lsuc a ⊔ b ⊔ p) →
  Univalence (lsuc a ⊔ b) →
  Coherently P step f ≃ NC.Coherently P step f
Coherently≃Not-coinductive-coherently
  {a = a} {B = B} {P = P} {step = step} {f = f} univ₁ univ₂ =
  block λ b →

  Coherently P step f     ↝⟨ Eq.↔→≃ to from
                               (_↔_.from ≡↔≡ ∘ to-from)
                               (_↔_.from ≡↔≡ ∘ from-to) ⟩
  M (CC step) (_ , f)     ↝⟨ carriers-of-final-coalgebras-equivalent
                               (M-coalgebra (CC step) , M-final univ₁ univ₂)
                               (F.M-coalgebra b ext (CC step) , F.M-final b ext ext)
                               _ ⟩
  F.M (CC step) (_ , f)   ↔⟨⟩
  NC.Coherently P step f  □
  where
  CC = NC.Coherently-container P

  to :
    {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B} {f : A → B} →
    Coherently P step f → M (CC step) (_ , f)
  to c .out-M .proj₁   = c .property
  to c .out-M .proj₂ _ = to (c .coherent)

  from :
    {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B} {f : A → B} →
    M (CC step) (_ , f) → Coherently P step f
  from c .property = c .out-M .proj₁
  from c .coherent = from (c .out-M .proj₂ _)

  to-from :
    {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B} {f : A → B} →
    (c : M (CC step) (_ , f)) →
    to (from c) P.≡ c
  to-from c i .out-M .proj₁   = c .out-M .proj₁
  to-from c i .out-M .proj₂ _ = to-from (c .out-M .proj₂ _) i

  from-to :
    {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B} {f : A → B} →
    (c : Coherently P step f) →
    from (to c) P.≡ c
  from-to c i .property = c .property
  from-to c i .coherent = from-to (c .coherent) i

------------------------------------------------------------------------
-- Preservation lemmas

private

  -- A preservation lemma for Coherently.
  --
  -- The lemma does not use the univalence argument, instead it uses
  -- EPU.univ (and EPU.≃⇒≡) directly.

  Coherently-cong-≡ :
    Block "Coherently-cong-≡" →
    {A : Type a}
    {P₁ P₂ : {A : Type a} → (A → B) → Type p}
    {step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ → B}
    {step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ → B}
    {f : A → B} →
    Univalence p →
    (P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ P₂ f) →
    ({A : Type a} (f : A → B) (x : P₂ f) →
     step₁ f (_≃_.from (P₁≃P₂ f) x) ≡ step₂ f x) →
    Coherently P₁ step₁ f P.≡ Coherently P₂ step₂ f
  Coherently-cong-≡
    {a = a} {B = B} {p = p} ⊠ {P₁ = P₁} {P₂ = P₂}
    {step₁ = step₁} {step₂ = step₂} {f = f} _ P₁≃P₂′ step₁≡step₂ =

    P.cong (λ ((P , step) :
              ∃ λ (P : (A : Type a) → (A → B) → Type p) →
                  {A : Type a} (f : A → B) → P A f → ∥ A ∥¹ → B) →
             Coherently (P _) step f) $

    P.Σ-≡,≡→≡′

      (P.⟨ext⟩ λ A → P.⟨ext⟩ λ (f : A → B) →
       EPU.≃⇒≡ (P₁≃P₂ f))

      (P.implicit-extensionality P.ext λ A → P.⟨ext⟩ λ f →
         P.subst (λ P → {A : Type a} (f : A → B) → P A f → ∥ A ∥¹ → B)
           (P.⟨ext⟩ λ A → P.⟨ext⟩ λ (f : A → B) →
            EPU.≃⇒≡ (P₁≃P₂ f))
           step₁ f                                                      P.≡⟨ P.trans (P.cong (_$ f) $ P.sym $
                                                                                P.push-subst-implicit-application
                                                                                (P.⟨ext⟩ λ A → P.⟨ext⟩ λ (f : A → B) → EPU.≃⇒≡ (P₁≃P₂ f))
                                                                                (λ P A → (f : A → B) → P A f → ∥ A ∥¹ → B)
                                                                                {f = const _} {g = step₁}) $
                                                                             P.sym $ P.push-subst-application
                                                                                (P.⟨ext⟩ λ A → P.⟨ext⟩ λ (f : A → B) → EPU.≃⇒≡ (P₁≃P₂ f))
                                                                                (λ P f → P A f → ∥ A ∥¹ → B)
                                                                                {f = const f} {g = step₁} ⟩
         P.subst (λ P → P A f → ∥ A ∥¹ → B)
           (P.⟨ext⟩ λ A → P.⟨ext⟩ λ (f : A → B) →
            EPU.≃⇒≡ (P₁≃P₂ f))
           (step₁ f)                                                    P.≡⟨⟩

         P.subst (λ P → P → ∥ A ∥¹ → B)
           (EPU.≃⇒≡ (P₁≃P₂ f))
           (step₁ f)                                                    P.≡⟨ P.sym $
                                                                             PU.transport-theorem
                                                                               (λ P → P → ∥ A ∥¹ → B)
                                                                               (PF.→-cong₁ _)
                                                                               (λ _ → P.refl)
                                                                               EPU.univ
                                                                               (P₁≃P₂ f)
                                                                               (step₁ f) ⟩
         PF.→-cong₁ _ (P₁≃P₂ f) (step₁ f)                               P.≡⟨⟩

         step₁ f ∘ PEq._≃_.from (P₁≃P₂ f)                               P.≡⟨ P.⟨ext⟩ (_↔_.to ≡↔≡ ∘ step₁≡step₂ f) ⟩∎

         step₂ f                                                        ∎)
    where
    P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f PEq.≃ P₂ f
    P₁≃P₂ f = _↔_.to ≃↔≃ (P₁≃P₂′ f)

  -- A "computation rule".

  to-Coherently-cong-≡-property :
    (bl : Block "Coherently-cong-≡")
    {A : Type a} {B : Type b}
    {P₁ P₂ : {A : Type a} → (A → B) → Type p}
    {step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ → B}
    {step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ → B}
    {f : A → B}
    (univ : Univalence p)
    (P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ P₂ f)
    (step₁≡step₂ :
       {A : Type a} (f : A → B) (x : P₂ f) →
       step₁ f (_≃_.from (P₁≃P₂ f) x) ≡ step₂ f x)
    (c : Coherently P₁ step₁ f) →
    PU.≡⇒→ (Coherently-cong-≡ bl univ P₁≃P₂ step₁≡step₂) c .property P.≡
    _≃_.to (P₁≃P₂ f) (c .property)
  to-Coherently-cong-≡-property
    ⊠ {P₁ = P₁} {P₂ = P₂} {f = f} _ P₁≃P₂ step₁≡step₂ c =

    P.transport (λ _ → P₂ f) P.0̲
      (_≃_.to (P₁≃P₂ f) (P.transport (λ _ → P₁ f) P.0̲ (c .property)))  P.≡⟨ P.cong (_$ _≃_.to (P₁≃P₂ f)
                                                                                (P.transport (λ _ → P₁ f) P.0̲ (c .property))) $
                                                                                P.transport-refl P.0̲ ⟩

    _≃_.to (P₁≃P₂ f) (P.transport (λ _ → P₁ f) P.0̲ (c .property))      P.≡⟨ P.cong (λ g → _≃_.to (P₁≃P₂ f) (g (c .property))) $
                                                                                P.transport-refl P.0̲ ⟩∎
    _≃_.to (P₁≃P₂ f) (c .property)                                     ∎

  -- Another "computation rule".

  from-Coherently-cong-≡-property :
    (bl : Block "Coherently-cong-≡")
    {A : Type a} {B : Type b}
    {P₁ P₂ : {A : Type a} → (A → B) → Type p}
    {step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ → B}
    {step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ → B}
    {f : A → B}
    (univ : Univalence p)
    (P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ P₂ f)
    (step₁≡step₂ :
       {A : Type a} (f : A → B) (x : P₂ f) →
       step₁ f (_≃_.from (P₁≃P₂ f) x) ≡ step₂ f x)
    (c : Coherently P₂ step₂ f) →
    PEq._≃_.from
      (PU.≡⇒≃ (Coherently-cong-≡ bl {step₁ = step₁} univ
                 P₁≃P₂ step₁≡step₂))
      c .property P.≡
    _≃_.from (P₁≃P₂ f) (c .property)
  from-Coherently-cong-≡-property
    ⊠ {P₁ = P₁} {P₂ = P₂} {f = f} _ P₁≃P₂ step₁≡step₂ c =

    P.transport (λ _ → P₁ f) P.0̲
      (_≃_.from (P₁≃P₂ f) (P.transport (λ _ → P₂ f) P.0̲ (c .property)))  P.≡⟨ P.cong (_$ _≃_.from (P₁≃P₂ f)
                                                                                (P.transport (λ _ → P₂ f) P.0̲ (c .property))) $
                                                                              P.transport-refl P.0̲ ⟩

    _≃_.from (P₁≃P₂ f) (P.transport (λ _ → P₂ f) P.0̲ (c .property))      P.≡⟨ P.cong (λ g → _≃_.from (P₁≃P₂ f) (g (c .property))) $
                                                                              P.transport-refl P.0̲ ⟩∎
    _≃_.from (P₁≃P₂ f) (c .property)                                     ∎

  -- A preservation lemma for Coherently.
  --
  -- The two directions of this equivalence compute the property
  -- fields in certain ways, see the "unit tests" below.
  --
  -- Note that P₁ and P₂ have to target the same universe. A more
  -- general result is given below (Coherently-cong).

  Coherently-cong-≃ :
    {A : Type a}
    {P₁ P₂ : {A : Type a} → (A → B) → Type p}
    {step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ → B}
    {step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ → B}
    {f : A → B} →
    Univalence p →
    (P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ P₂ f) →
    ({A : Type a} (f : A → B) (x : P₂ f) →
     step₁ f (_≃_.from (P₁≃P₂ f) x) ≡ step₂ f x) →
    Coherently P₁ step₁ f ≃ Coherently P₂ step₂ f
  Coherently-cong-≃
    {P₁ = P₁} {P₂ = P₂} {step₁ = step₁} {step₂ = step₂} {f = f}
    univ P₁≃P₂ step₁≡step₂ =

    block λ bl →
    Eq.with-other-inverse
      (Eq.with-other-function
         (equiv bl)
         (to bl)
         (_↔_.from ≡↔≡ ∘ ≡to bl))
      (from bl)
      (_↔_.from ≡↔≡ ∘ ≡from bl)

    where

    equiv :
      Block "Coherently-cong-≡" →
      Coherently P₁ step₁ f ≃ Coherently P₂ step₂ f
    equiv bl =
      _↔_.from ≃↔≃ $ PU.≡⇒≃ $
      Coherently-cong-≡ bl univ P₁≃P₂ step₁≡step₂

    to :
      Block "Coherently-cong-≡" →
      Coherently P₁ step₁ f → Coherently P₂ step₂ f
    to _  c .property = _≃_.to (P₁≃P₂ f) (c .property)
    to bl c .coherent =
      P.subst
        (Coherently P₂ step₂)
        (P.cong (step₂ f) $
         to-Coherently-cong-≡-property bl univ P₁≃P₂ step₁≡step₂ c) $
      _≃_.to (equiv bl) c .coherent

    ≡to : ∀ bl c → _≃_.to (equiv bl) c P.≡ to bl c
    ≡to bl c i .property = to-Coherently-cong-≡-property
                             bl univ P₁≃P₂ step₁≡step₂ c i
    ≡to bl c i .coherent = lemma i
      where
      lemma :
        P.[ (λ i → Coherently P₂ step₂
                     (step₂ f
                        (to-Coherently-cong-≡-property
                           bl univ P₁≃P₂ step₁≡step₂ c i))) ]
          _≃_.to (equiv bl) c .coherent ≡
          P.subst
            (Coherently P₂ step₂)
            (P.cong (step₂ f) $
             to-Coherently-cong-≡-property bl univ P₁≃P₂ step₁≡step₂ c)
            (_≃_.to (equiv bl) c .coherent)
      lemma =
        PB._↔_.from (P.heterogeneous↔homogeneous _) P.refl

    from :
      Block "Coherently-cong-≡" →
      Coherently P₂ step₂ f → Coherently P₁ step₁ f
    from _  c .property = _≃_.from (P₁≃P₂ f) (c .property)
    from bl c .coherent =
      P.subst
        (Coherently P₁ step₁)
        (P.cong (step₁ f) $
         from-Coherently-cong-≡-property bl univ P₁≃P₂ step₁≡step₂ c) $
      _≃_.from (equiv bl) c .coherent

    ≡from : ∀ bl c → _≃_.from (equiv bl) c P.≡ from bl c
    ≡from bl c i .property = from-Coherently-cong-≡-property
                               bl univ P₁≃P₂ step₁≡step₂ c i
    ≡from bl c i .coherent = lemma i
      where
      lemma :
        P.[ (λ i → Coherently P₁ step₁
                     (step₁ f
                        (from-Coherently-cong-≡-property
                           bl univ P₁≃P₂ step₁≡step₂ c i))) ]
          _≃_.from (equiv bl) c .coherent ≡
          P.subst
            (Coherently P₁ step₁)
            (P.cong (step₁ f) $
             from-Coherently-cong-≡-property
               bl univ P₁≃P₂ step₁≡step₂ c)
            (_≃_.from (equiv bl) c .coherent)
      lemma =
        PB._↔_.from (P.heterogeneous↔homogeneous _) P.refl

  -- Unit tests that ensure that Coherently-cong-≃ computes the
  -- property fields in certain ways.

  module _
    {A : Type a}
    {P₁ P₂ : {A : Type a} → (A → B) → Type p}
    {step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ → B}
    {step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ → B}
    {f : A → B}
    {univ : Univalence p}
    {P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ P₂ f}
    {step₁≡step₂ :
       {A : Type a} (f : A → B) (x : P₂ f) →
       step₁ f (_≃_.from (P₁≃P₂ f) x) ≡ step₂ f x}
    where

    _ :
      {c : Coherently P₁ step₁ f} →
      _≃_.to (Coherently-cong-≃ univ P₁≃P₂ step₁≡step₂) c .property ≡
      _≃_.to (P₁≃P₂ f) (c .property)
    _ = refl _

    _ :
      {c : Coherently P₂ step₂ f} →
      _≃_.from (Coherently-cong-≃ {step₁ = step₁} univ
                  P₁≃P₂ step₁≡step₂)
        c .property ≡
      _≃_.from (P₁≃P₂ f) (c .property)
    _ = refl _

  -- A lemma involving Coherently and ↑.

  Coherently-↑ :
    {A : Type a}
    {P : {A : Type a} → (A → B) → Type p}
    {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B}
    {f : A → B} →
    Coherently (↑ ℓ ∘ P) ((_∘ lower) ∘ step) f ≃
    Coherently P step f
  Coherently-↑ {ℓ = ℓ} {P = P} {step = step} =
    Eq.↔→≃
      to
      from
      (_↔_.from ≡↔≡ ∘ to-from)
      (_↔_.from ≡↔≡ ∘ from-to)
    where
    to :
      Coherently (↑ ℓ ∘ P) ((_∘ lower) ∘ step) f →
      Coherently P step f
    to c .property = lower (c .property)
    to c .coherent = to (c .coherent)

    from :
      Coherently P step f →
      Coherently (↑ ℓ ∘ P) ((_∘ lower) ∘ step) f
    from c .property = lift (c .property)
    from c .coherent = from (c .coherent)

    to-from :
      (c : Coherently P step f) →
      to (from c) P.≡ c
    to-from c i .property = c .property
    to-from c i .coherent = to-from (c .coherent) i

    from-to :
      (c : Coherently (↑ ℓ ∘ P) ((_∘ lower) ∘ step) f) →
      from (to c) P.≡ c
    from-to c i .property = c .property
    from-to c i .coherent = from-to (c .coherent) i

-- A preservation lemma for Coherently.
--
-- The two directions of this equivalence compute the property
-- fields in certain ways, see the "unit tests" below.

Coherently-cong :
  {A : Type a}
  {P₁ : {A : Type a} → (A → B) → Type p₁}
  {P₂ : {A : Type a} → (A → B) → Type p₂}
  {step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ → B}
  {step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ → B}
  {f : A → B} →
  Univalence (p₁ ⊔ p₂) →
  (P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ P₂ f) →
  ({A : Type a} (f : A → B) (x : P₂ f) →
   step₁ f (_≃_.from (P₁≃P₂ f) x) ≡ step₂ f x) →
  Coherently P₁ step₁ f ≃ Coherently P₂ step₂ f
Coherently-cong
  {p₁ = p₁} {p₂ = p₂}
  {P₁ = P₁} {P₂ = P₂} {step₁ = step₁} {step₂ = step₂} {f = f}
  univ P₁≃P₂ step₁≡step₂ =

  Coherently P₁ step₁ f                          ↝⟨ inverse Coherently-↑ ⟩

  Coherently (↑ p₂ ∘ P₁) ((_∘ lower) ∘ step₁) f  ↝⟨ Coherently-cong-≃
                                                      univ
                                                      (λ f →
    ↑ p₂ (P₁ f)                                          ↔⟨ B.↑↔ ⟩
    P₁ f                                                 ↝⟨ P₁≃P₂ f ⟩
    P₂ f                                                 ↔⟨ inverse B.↑↔ ⟩□
    ↑ p₁ (P₂ f)                                          □)
                                                      ((_∘ lower) ∘ step₁≡step₂) ⟩

  Coherently (↑ p₁ ∘ P₂) ((_∘ lower) ∘ step₂) f  ↝⟨ Coherently-↑ ⟩□

  Coherently P₂ step₂ f                          □

-- Unit tests that ensure that Coherently-cong computes the
-- property fields in certain ways.

module _
  {A : Type a}
  {P₁ : {A : Type a} → (A → B) → Type p₁}
  {P₂ : {A : Type a} → (A → B) → Type p₂}
  {step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ → B}
  {step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ → B}
  {f : A → B}
  {univ : Univalence (p₁ ⊔ p₂)}
  {P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ P₂ f}
  {step₁≡step₂ :
     {A : Type a} (f : A → B) (x : P₂ f) →
     step₁ f (_≃_.from (P₁≃P₂ f) x) ≡ step₂ f x}
  where

  _ :
    {c : Coherently P₁ step₁ f} →
    _≃_.to (Coherently-cong univ P₁≃P₂ step₁≡step₂) c .property ≡
    _≃_.to (P₁≃P₂ f) (c .property)
  _ = refl _

  _ :
    {c : Coherently P₂ step₂ f} →
    _≃_.from (Coherently-cong {step₁ = step₁} univ P₁≃P₂ step₁≡step₂)
      c .property ≡
    _≃_.from (P₁≃P₂ f) (c .property)
  _ = refl _

-- Another preservation lemma for Coherently.

Coherently-cong′ :
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B} →
  Univalence a →
  (A₁≃A₂ : A₁ ≃ A₂) →
  Coherently P step (f ∘ _≃_.to A₁≃A₂) ≃ Coherently P step f
Coherently-cong′ {f = f} {P = P} {step = step} univ A₁≃A₂ =
  ≃-elim₁ univ
    (λ A₁≃A₂ →
       Coherently P step (f ∘ _≃_.to A₁≃A₂) ≃
       Coherently P step f)
    Eq.id
    A₁≃A₂

------------------------------------------------------------------------
-- Another lemma

-- A "computation rule".

subst-Coherently-property :
  ∀ {A : C → Type a} {B : Type b}
    {P : C → {A : Type a} → (A → B) → Type p}
    {step : (c : C) {A : Type a} (f : A → B) → P c f → ∥ A ∥¹ → B}
    {f : (c : C) → A c → B} {eq : x ≡ y} {c} →
  subst (λ x → Coherently (P x) (step x) (f x)) eq c .property ≡
  subst (λ x → P x (f x)) eq (c .property)
subst-Coherently-property
  {P = P} {step = step} {f = f} {eq = eq} {c = c} =
  elim¹
    (λ eq →
       subst (λ x → Coherently (P x) (step x) (f x)) eq c .property ≡
       subst (λ x → P x (f x)) eq (c .property))
    (subst (λ x → Coherently (P x) (step x) (f x)) (refl _) c .property  ≡⟨ cong property $ subst-refl _ _ ⟩
     c .property                                                         ≡⟨ sym $ subst-refl _ _ ⟩∎
     subst (λ x → P x (f x)) (refl _) (c .property)                      ∎)
    eq

------------------------------------------------------------------------
-- Coherently-with-restriction

-- A variant of Coherently. An extra predicate Q is included, so that
-- one can restrict the "f" functions (and their domains).

record Coherently-with-restriction
         {A : Type a} {B : Type b}
         (P : {A : Type a} → (A → B) → Type p)
         (step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B)
         (f : A → B)
         (Q : {A : Type a} → (A → B) → Type q)
         (pres : {A : Type a} {f : A → B} {p : P f} →
                 Q f → Q (step f p))
         (q : Q f) : Type p where
  coinductive
  field
    property : P f
    coherent :
      Coherently-with-restriction
        P step (step f property)
        Q pres (pres q)

open Coherently-with-restriction public

-- Coherently P step f is equivalent to
-- Coherently-with-restriction P step f Q pres q.

Coherently≃Coherently-with-restriction :
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B}
  {f : A → B}
  {Q : {A : Type a} → (A → B) → Type q}
  {pres : {A : Type a} {f : A → B} {p : P f} → Q f → Q (step f p)}
  {q : Q f} →
  Coherently P step f ≃ Coherently-with-restriction P step f Q pres q
Coherently≃Coherently-with-restriction
  {P = P} {step = step} {Q = Q} {pres = pres} =
  Eq.↔→≃ to (from _)
    (λ c → _↔_.from ≡↔≡ (to-from c))
    (λ c → _↔_.from ≡↔≡ (from-to _ c))
  where
  to :
    Coherently P step f →
    Coherently-with-restriction P step f Q pres q
  to c .property = c .property
  to c .coherent = to (c .coherent)

  from :
    ∀ q →
    Coherently-with-restriction P step f Q pres q →
    Coherently P step f
  from _ c .property = c .property
  from _ c .coherent = from _ (c .coherent)

  to-from :
    (c : Coherently-with-restriction P step f Q pres q) →
    to (from q c) P.≡ c
  to-from c i .property = c .property
  to-from c i .coherent = to-from (c .coherent) i

  from-to : ∀ q (c : Coherently P step f) → from q (to c) P.≡ c
  from-to _ c i .property = c .property
  from-to q c i .coherent = from-to (pres q) (c .coherent) i

-- A container that is used to define Coherently-with-restriction′.

Coherently-with-restriction-container :
  {B : Type b}
  (P : {A : Type a} → (A → B) → Type p)
  (step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B) →
  (Q : {A : Type a} → (A → B) → Type q) →
  ({A : Type a} {f : A → B} {p : P f} → Q f → Q (step f p)) →
  Container (∃ λ (A : Type a) → ∃ λ (f : A → B) → Q f) p lzero
Coherently-with-restriction-container P step _ pres = λ where
  .Shape (_ , f , _)               → P f
  .Position _                      → ⊤
  .index {o = A , f , q} {s = p} _ → ∥ A ∥¹ , step f p , pres q

-- A variant of Coherently-with-restriction, defined using an indexed
-- container.

Coherently-with-restriction′ :
  {A : Type a} {B : Type b}
  (P : {A : Type a} → (A → B) → Type p)
  (step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B) →
  (f : A → B) →
  (Q : {A : Type a} → (A → B) → Type q) →
  ({A : Type a} {f : A → B} {p : P f} → Q f → Q (step f p)) →
  Q f →
  Type (lsuc a ⊔ b ⊔ p ⊔ q)
Coherently-with-restriction′ P step f Q pres q =
  M (Coherently-with-restriction-container P step Q pres) (_ , f , q)

-- Coherently-with-restriction P step f Q pres q is equivalent to
-- Coherently-with-restriction′ P step f Q pres q.

Coherently-with-restriction≃Coherently-with-restriction′ :
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B}
  {f : A → B}
  {Q : {A : Type a} → (A → B) → Type q}
  {pres : {A : Type a} {f : A → B} {p : P f} → Q f → Q (step f p)}
  {q : Q f} →
  Coherently-with-restriction P step f Q pres q ≃
  Coherently-with-restriction′ P step f Q pres q
Coherently-with-restriction≃Coherently-with-restriction′
  {P = P} {step = step} {Q = Q} {pres = pres} =
  Eq.↔→≃ to (from _)
    (λ c → _↔_.from ≡↔≡ (to-from _ c))
    (λ c → _↔_.from ≡↔≡ (from-to c))
  where
  to :
    Coherently-with-restriction P step f Q pres q →
    Coherently-with-restriction′ P step f Q pres q
  to c .out-M .proj₁   = c .property
  to c .out-M .proj₂ _ = to (c .coherent)

  from :
    ∀ q →
    Coherently-with-restriction′ P step f Q pres q →
    Coherently-with-restriction P step f Q pres q
  from _ c .property = c .out-M .proj₁
  from _ c .coherent = from _ (c .out-M .proj₂ _)

  to-from :
    ∀ q (c : Coherently-with-restriction′ P step f Q pres q) →
    to (from q c) P.≡ c
  to-from _ c i .out-M .proj₁   = c .out-M .proj₁
  to-from q c i .out-M .proj₂ _ = to-from (pres q) (c .out-M .proj₂ _) i

  from-to :
    (c : Coherently-with-restriction P step f Q pres q) →
    from q (to c) P.≡ c
  from-to c i .property = c .property
  from-to c i .coherent = from-to (c .coherent) i

------------------------------------------------------------------------
-- H-levels

-- I think that Paolo Capriotti suggested that one could prove that
-- certain instances of Coherently have certain h-levels by using the
-- result (due to Ahrens, Capriotti and Spadotti, see "Non-wellfounded
-- trees in Homotopy Type Theory") that M-types for indexed containers
-- have h-level n if all shapes have h-level n. The use of containers
-- with "restrictions" is my idea.

-- If P f has h-level n for every function f for which Q holds, then
-- Coherently-with-restriction P step f Q pres q has h-level n
-- (assuming univalence).

H-level-Coherently-with-restriction :
  Univalence (lsuc a ⊔ b ⊔ p ⊔ q) →
  Univalence (lsuc a ⊔ b ⊔ q) →
  {B : Type b}
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B}
  {f : A → B}
  {Q : {A : Type a} → (A → B) → Type q}
  {pres : {A : Type a} {f : A → B} {p : P f} → Q f → Q (step f p)}
  {q : Q f} →
  ({A : Type a} {f : A → B} → Q f → H-level n (P f)) →
  H-level n (Coherently-with-restriction P step f Q pres q)
H-level-Coherently-with-restriction
  {n = n} univ₁ univ₂ {B = B} {P = P} {step = step} {f = f} {Q = Q}
  {pres = pres} {q = q} =

  (∀ {A} {f : A → B} → Q f → H-level n (P f))                        ↝⟨ (λ h (_ , _ , q) → h q) ⟩
  (((_ , f , _) : ∃ λ A → ∃ λ (f : A → B) → Q f) → H-level n (P f))  ↝⟨ (λ h → H-level-M univ₁ univ₂ h) ⟩
  H-level n (Coherently-with-restriction′ P step f Q pres q)         ↝⟨ H-level-cong _ n
                                                                          (inverse Coherently-with-restriction≃Coherently-with-restriction′) ⟩□
  H-level n (Coherently-with-restriction P step f Q pres q)          □

-- If P f has h-level n, and (for any f and p) P (step f p) has
-- h-level n when P f has h-level n, then Coherently P step f has
-- h-level n (assuming univalence).

H-level-Coherently :
  {B : Type b}
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B}
  {f : A → B} →
  Univalence (lsuc a ⊔ b ⊔ p) →
  H-level n (P f) →
  ({A : Type a} {f : A → B} {p : P f} →
   H-level n (P f) → H-level n (P (step f p))) →
  H-level n (Coherently P step f)
H-level-Coherently {n = n} {P = P} {step = step} {f = f} univ h₁ h₂ =
                                            $⟨ H-level-Coherently-with-restriction univ univ id ⟩
  H-level n
    (Coherently-with-restriction P step f
       (λ f → H-level n (P f)) h₂ h₁)       ↝⟨ H-level-cong _ n (inverse Coherently≃Coherently-with-restriction) ⦂ (_ → _) ⟩□

  H-level n (Coherently P step f)           □

-- A variant of H-level-Coherently for type-valued functions.

H-level-Coherently-→Type :
  {P : {A : Type a} → (A → Type f) → Type p}
  {step : {A : Type a} (F : A → Type f) → P F → ∥ A ∥¹ → Type f}
  {F : A → Type f} →
  Univalence (lsuc a ⊔ p ⊔ lsuc f) →
  Univalence (lsuc (a ⊔ f)) →
  ((a : A) → H-level n (F a)) →
  ({A : Type a} {F : A → Type f} →
   ((a : A) → H-level n (F a)) → H-level n (P F)) →
  ({A : Type a} {F : A → Type f} {p : P F} →
   ((a : A) → H-level n (F a)) →
   (a : A) → H-level n (step F p ∣ a ∣)) →
  H-level n (Coherently P step F)
H-level-Coherently-→Type
  {a = a} {f = f} {n = n} {P = P} {step = step} {F = F}
  univ₁ univ₂ h₁ h₂ h₃ =
                                              $⟨ H-level-Coherently-with-restriction univ₁ univ₂ h₂ ⟩
  H-level n
    (Coherently-with-restriction P step F
       (λ F → ∀ a → H-level n (F a)) h₃′ h₁)  ↝⟨ H-level-cong _ n (inverse Coherently≃Coherently-with-restriction) ⦂ (_ → _) ⟩□

  H-level n (Coherently P step F)             □
  where
  h₃′ :
    {A : Type a} {F : A → Type f} {p : P F} →
    ((a : A) → H-level n (F a)) →
    (a : ∥ A ∥¹) → H-level n (step F p a)
  h₃′ h = O.elim λ where
    .O.∣∣ʳ              → h₃ h
    .O.∣∣-constantʳ _ _ → H-level-propositional ext n _ _


------------------------------------------------------------------------
-- Strict ω-continuous functions
------------------------------------------------------------------------

{-# OPTIONS --cubical --safe #-}

module Partiality-monad.Inductive.Strict-omega-continuous where

open import Equality.Propositional.Cubical
open import Prelude hiding (⊥)

open import Bijection equality-with-J using (_↔_)
open import Function-universe equality-with-J hiding (_∘_)
open import Monad equality-with-J

import Partiality-algebra.Strict-omega-continuous as S
open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Eliminators
open import Partiality-monad.Inductive.Monad
open import Partiality-monad.Inductive.Monotone
open import Partiality-monad.Inductive.Omega-continuous

-- Definition of strict ω-continuous functions.

[_⊥→_⊥]-strict : ∀ {a b} → Type a → Type b → Type (a ⊔ b)
[ A ⊥→ B ⊥]-strict = S.[ partiality-algebra A ⟶ partiality-algebra B ]⊥

module [_⊥→_⊥]-strict
         {a b} {A : Type a} {B : Type b}
         (f : [ A ⊥→ B ⊥]-strict) =
         S.[_⟶_]⊥ f

open [_⊥→_⊥]-strict

-- Identity.

id-strict : ∀ {a} {A : Type a} → [ A ⊥→ A ⊥]-strict
id-strict = S.id⊥

-- Composition.

infixr 40 _∘-strict_

_∘-strict_ :
  ∀ {a b c} {A : Type a} {B : Type b} {C : Type c} →
  [ B ⊥→ C ⊥]-strict → [ A ⊥→ B ⊥]-strict → [ A ⊥→ C ⊥]-strict
_∘-strict_ = S._∘⊥_

-- Equality characterisation lemma for strict ω-continuous functions.

equality-characterisation-strict :
  ∀ {a b} {A : Type a} {B : Type b} {f g : [ A ⊥→ B ⊥]-strict} →
  (∀ x → function f x ≡ function g x) ↔ f ≡ g
equality-characterisation-strict =
  S.equality-characterisation-strict

-- Composition is associative.

∘-strict-assoc :
  ∀ {a b c d} {A : Type a} {B : Type b} {C : Type c} {D : Type d}
  (f : [ C ⊥→ D ⊥]-strict) (g : [ B ⊥→ C ⊥]-strict)
  (h : [ A ⊥→ B ⊥]-strict) →
  f ∘-strict (g ∘-strict h) ≡ (f ∘-strict g) ∘-strict h
∘-strict-assoc = S.∘⊥-assoc

-- Strict ω-continuous functions satisfy an extra monad law.

>>=-∘-return :
  ∀ {a b} {A : Type a} {B : Type b} →
  (f : [ A ⊥→ B ⊥]-strict) →
  ∀ x → x >>=′ (function f ∘ return) ≡ function f x
>>=-∘-return fs = ⊥-rec-⊥
  (record
     { P  = λ x → x >>=′ (f ∘ return) ≡ f x
     ; pe = never >>=′ f ∘ return  ≡⟨ never->>= ⟩
            never                  ≡⟨ sym (strict fs) ⟩∎
            f never                ∎
     ; po = λ x →
              now x >>=′ f ∘ return  ≡⟨ now->>= ⟩∎
              f (now x)              ∎
     ; pl = λ s p →
              ⨆ s >>=′ (f ∘ return)     ≡⟨ ⨆->>= ⟩
              ⨆ ((f ∘ return) ∗-inc s)  ≡⟨ cong ⨆ (_↔_.to equality-characterisation-increasing λ n →

                (f ∘ return) ∗-inc s [ n ]   ≡⟨ p n ⟩∎
                [ f⊑ $ s ]-inc [ n ]         ∎) ⟩

              ⨆ [ f⊑ $ s ]-inc          ≡⟨ sym $ ω-continuous fs s ⟩∎
              f (⨆ s)                   ∎
     ; pp = λ _ → ⊥-is-set
     })
  where
  f⊑ = monotone-function fs
  f  = function fs

-- Strict ω-continuous functions from A ⊥ to B ⊥ are isomorphic to
-- functions from A to B ⊥.

partial↔strict :
  ∀ {a b} {A : Type a} {B : Type b} →
  (A → B ⊥) ↔ [ A ⊥→ B ⊥]-strict
partial↔strict {a} = record
  { surjection = record
    { logical-equivalence = record
      { to   = λ f → record
                 { ω-continuous-function = f ∗
                 ; strict                =
                     never >>=′ f  ≡⟨ never->>= ⟩∎
                     never         ∎
                 }
      ; from = λ f x → function f (return x)
      }
    ; right-inverse-of = λ f →
        _↔_.to equality-characterisation-strict λ x →
          x >>=′ (function f ∘ return)  ≡⟨ >>=-∘-return f x ⟩∎
          function f x                  ∎
    }
  ; left-inverse-of = λ f → ⟨ext⟩ λ x →
      return x >>=′ f  ≡⟨ Monad-laws.left-identity x f ⟩∎
      f x              ∎
  }


{-# OPTIONS --rewriting #-}

module Correctness where

open import Convertibility public
open import Semantics public

{-# BUILTIN REWRITE _≡_ #-}
{-# REWRITE idmono⊩⋆ #-}

-- TODO: Naming things.

module _ {{_ : Model}} where
  ⟦_≔_⟧∈ : ∀ {C Γ w} → (i : C ∈ Γ) → w ⟪ Γ ∖ i ⊫ C ⟫ →
           ∀ {A} → A ∈ Γ → w ⟪ Γ ∖ i ⊫ A ⟫
  ⟦ i ≔ ⟪c⟫ ⟧∈ j  with i ≟∈ j
  ⟦ i ≔ ⟪c⟫ ⟧∈ .i | same   = ⟪c⟫
  ⟦ i ≔ ⟪c⟫ ⟧∈ ._ | diff j = ⟪var⟫ j

  lem≔∈ : ∀ {A C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (j : A ∈ Γ) →
          ⟦ i ≔ eval c ⟧∈ j ≡ eval ([ i ≔ c ]∈ j) {w}
  lem≔∈ i c j  with i ≟∈ j
  lem≔∈ i c .i | same   = refl
  lem≔∈ i c ._ | diff j = refl

-- TODO: Naming things.

module _ {{_ : Model}} where
  plug : ∀ {C Γ w} → (i : C ∈ Γ) → w ⊩⋆ Γ ∖ i → w ⊩ C → w ⊩⋆ Γ
  plug top     γ       s = γ , s
  plug (pop i) (γ , r) s = plug i γ s , r

  ⟦_≔_⟧ : ∀ {C Γ w} → (i : C ∈ Γ) → w ⟪ Γ ∖ i ⊫ C ⟫ →
          ∀ {A} → (∀ {w′} → w′ ⟪ Γ ⊫ A ⟫) → w ⟪ Γ ∖ i ⊫ A ⟫
  ⟦ i ≔ ⟪c⟫ ⟧ ⟪d⟫ = λ γ → ⟪d⟫ (plug i γ (⟪c⟫ γ))

  -- TODO: The var case in lem≔.

  postulate
    oops≔var₁ : ∀ {C Γ w} → (i : C ∈ Γ) (⟪c⟫ : w ⟪ Γ ∖ i ⊫ C ⟫) (γ : w ⊩⋆ Γ ∖ i) →
                ⟪var⟫ {C} i (plug i γ (⟪c⟫ γ)) ≡ ⟪c⟫ γ
  -- oops≔var₁ top     ⟪c⟫ γ       = refl
  -- oops≔var₁ (pop i) ⟪c⟫ (γ , s) = {!!}

  postulate
    oops≔var₂ : ∀ {A C Γ w} → (i : C ∈ Γ) (⟪c⟫ : w ⟪ Γ ∖ i ⊫ C ⟫) (j : A ∈ Γ ∖ i) (γ : w ⊩⋆ Γ ∖ i) →
                ⟪var⟫ {A} (mono∈ (thin⊆ i) j) (plug i γ (⟪c⟫ γ)) ≡ ⟪var⟫ {A} j γ
  -- oops≔var₂ top     ⟪c⟫ j γ       = cong² ⟪var⟫ (idmono∈ j) refl
  -- oops≔var₂ (pop i) ⟪c⟫ j (γ , s) = {!!}

  oops≔var : ∀ {A C Γ w} → (i : C ∈ Γ) (⟪c⟫ : w ⟪ Γ ∖ i ⊫ C ⟫) (j : A ∈ Γ) →
             ⟦ i ≔ ⟪c⟫ ⟧ {A} (⟪var⟫ {A} j) ≡ ⟦ i ≔ ⟪c⟫ ⟧∈ {A} j
  oops≔var i ⟪c⟫ j  with i ≟∈ j
  oops≔var i ⟪c⟫ .i | same   = funext (λ γ → oops≔var₁ i ⟪c⟫ γ)
  oops≔var i ⟪c⟫ ._ | diff j = funext (λ γ → oops≔var₂ i ⟪c⟫ j γ)

  -- TODO: The lam case in lem≔.

  lem₁ : ∀ {C Γ w w′} → (i : C ∈ Γ) (γ : w ⊩⋆ Γ ∖ i) (s : w ⊩ C) (p : w ≤ w′) →
         mono⊩⋆ p (plug i γ s) ≡ plug i (mono⊩⋆ p γ) (mono⊩ {C} p s)
  lem₁ top     γ       s p = refl
  lem₁ (pop i) (γ , r) s p = cong² _,_ (lem₁ i γ s p) refl

  mutual
    postulate
      lem₂ : ∀ {A Γ w w′} → (p : w ≤ w′) (d : Γ ⊢ A) (γ : w ⊩⋆ Γ) →
             mono⊩ {A} p (eval d γ) ≡ eval d (mono⊩⋆ p γ)
    -- lem₂ p (var {A} j)        γ = {!!}
    -- lem₂ p (lam {A} {B} d)    γ = {!!}
    -- lem₂ p (app {A} {B} d e)  γ = {!!}
    -- lem₂ p (pair {A} {B} d e) γ = lem₂pair p d e γ
    -- lem₂ p (fst {A} {B} d)    γ = lem₂fst p d γ
    -- lem₂ p (snd {A} {B} d)    γ = lem₂snd p d γ
    -- lem₂ p unit               γ = refl

    lem₂pair : ∀ {A B Γ w w′} → (p : w ≤ w′) (d : Γ ⊢ A) (e : Γ ⊢ B) (γ : w ⊩⋆ Γ) →
               mono⊩ {A ⩕ B} p (⟪pair⟫ {A} {B} (eval d) (eval e) γ) ≡ ⟪pair⟫ {A} {B} (eval d) (eval e) (mono⊩⋆ p γ)
    lem₂pair {A} {B} p d e γ =
      begin
        mono⊩ {A ⩕ B} p (⟪pair⟫ {A} {B} (eval d) (eval e) γ)
      ≡⟨⟩
        ⟪pair⟫ {A} {B} (λ γ′ → mono⊩ {A} p (eval d γ)) (λ γ′ → mono⊩ {B} p (eval e γ)) (mono⊩⋆ p γ)
      ≡⟨ cong² (λ ⟪d⟫ ⟪e⟫ → ⟪pair⟫ {A} {B} ⟪d⟫ ⟪e⟫ (mono⊩⋆ p γ)) (funext (λ γ′ → lem₂ p d γ)) (funext (λ γ′ → lem₂ p e γ)) ⟩
        ⟪pair⟫ {A} {B} (λ γ′ → eval d (mono⊩⋆ p γ)) (λ γ′ → eval e (mono⊩⋆ p γ)) (mono⊩⋆ p γ)
      ≡⟨⟩
        ⟪pair⟫ {A} {B} (eval d) (eval e) (mono⊩⋆ p γ)
      ∎

    lem₂fst : ∀ {A B Γ w w′} → (p : w ≤ w′) (d : Γ ⊢ A ⩕ B) (γ : w ⊩⋆ Γ) →
              mono⊩ {A} p (⟪fst⟫ {A} {B} (eval d) γ) ≡ ⟪fst⟫ {A} {B} (eval d) (mono⊩⋆ p γ)
    lem₂fst {A} {B} p d γ =
      begin
        mono⊩ {A} p (⟪fst⟫ {A} {B} (eval d) γ)
      ≡⟨⟩
        ⟪fst⟫ {A} {B} (λ γ′ → mono⊩ {A ⩕ B} p (eval d γ)) (mono⊩⋆ p γ)
      ≡⟨ cong (λ ⟪d⟫ → ⟪fst⟫ {A} {B} ⟪d⟫ (mono⊩⋆ p γ)) (funext (λ γ′ → lem₂ p d γ)) ⟩
        ⟪fst⟫ {A} {B} (λ γ′ → eval d (mono⊩⋆ p γ)) (mono⊩⋆ p γ)
      ≡⟨⟩
        ⟪fst⟫ {A} {B} (eval d) (mono⊩⋆ p γ)
      ∎

    lem₂snd : ∀ {A B Γ w w′} → (p : w ≤ w′) (d : Γ ⊢ A ⩕ B) (γ : w ⊩⋆ Γ) →
              mono⊩ {B} p (⟪snd⟫ {A} {B} (eval d) γ) ≡ ⟪snd⟫ {A} {B} (eval d) (mono⊩⋆ p γ)
    lem₂snd {A} {B} p d γ =
      begin
        mono⊩ {B} p (⟪snd⟫ {A} {B} (eval d) γ)
      ≡⟨⟩
        ⟪snd⟫ {A} {B} (λ γ′ → mono⊩ {A ⩕ B} p (eval d γ)) (mono⊩⋆ p γ)
      ≡⟨ cong (λ ⟪d⟫ → ⟪snd⟫ {A} {B} ⟪d⟫ (mono⊩⋆ p γ)) (funext (λ γ′ → lem₂ p d γ)) ⟩
        ⟪snd⟫ {A} {B} (λ γ′ → eval d (mono⊩⋆ p γ)) (mono⊩⋆ p γ)
      ≡⟨⟩
        ⟪snd⟫ {A} {B} (eval d) (mono⊩⋆ p γ)
      ∎

  postulate
    oops≔lam₂ : ∀ {A C Γ w w′} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (γ : w ⊩⋆ Γ ∖ i) (p : w ≤ w′) (s : w′ ⊩ A) →
                mono⊩ {C} p (eval c γ) ≡ eval (mono⊢ (weak⊆ {A = A}) c) (mono⊩⋆ p γ , s)
  -- oops≔lam₂ i c γ p s = {!!}

  oops≔lam₁ : ∀ {A B C Γ w w′} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ , A ⊢ B) (γ : w ⊩⋆ Γ ∖ i) (p : w ≤ w′) (s : w′ ⊩ A) →
              eval d (mono⊩⋆ p (plug i γ (eval c γ)) , s) ≡ eval d (plug i (mono⊩⋆ p γ) (eval (mono⊢ (weak⊆ {A = A}) c) (mono⊩⋆ p γ , s)) , s)
  oops≔lam₁ {A} {B} {C} i c d γ p s =
    begin
      eval d (mono⊩⋆ p (plug i γ (eval c γ)) , s)
    ≡⟨ cong (eval d) (cong² _,_ (lem₁ i γ (eval c γ) p) refl) ⟩
      eval d (plug i (mono⊩⋆ p γ) (mono⊩ {C} p (eval c γ)) , s)
    ≡⟨ cong (eval d) (cong² _,_ (cong² (plug i) refl (oops≔lam₂ i c γ p s)) refl) ⟩
      eval d (plug i (mono⊩⋆ p γ) (eval (mono⊢ weak⊆ c) (mono⊩⋆ p γ , s)) , s)
    ∎

  oops≔lam : ∀ {A B C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ , A ⊢ B) →
             ⟦ i ≔ eval c {w} ⟧ {A ⇒ B} (⟪lam⟫ {A} {B} (eval d)) ≡
               ⟪lam⟫ {A} {B} (⟦ pop {A = C} {B = A} i ≔ eval (mono⊢ (weak⊆ {A = A}) c) ⟧ {B} (eval d))
  oops≔lam i c d = funext (λ γ → ⟨funext⟩ (funext (λ p → funext (λ s → oops≔lam₁ i c d γ p s))))

  mutual
    lem≔ : ∀ {A C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ ⊢ A) →
           ⟦ i ≔ eval c ⟧ {A} (eval d) ≡ eval ([ i ≔ c ] d) {w}
    lem≔ i c (var j)    = lem≔var i c j
    lem≔ i c (lam d)    = lem≔lam i c d
    lem≔ i c (app d e)  = lem≔app i c d e
    lem≔ i c (pair d e) = lem≔pair i c d e
    lem≔ i c (fst d)    = lem≔fst i c d
    lem≔ i c (snd d)    = lem≔snd i c d
    lem≔ i c unit       = lem≔unit i c

    lem≔var : ∀ {A C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (j : A ∈ Γ) →
              ⟦ i ≔ eval c ⟧ {A} (⟪var⟫ {A} j) ≡ eval ([ i ≔ c ] (var j)) {w}
    lem≔var {A} i c j =
      begin
        ⟦ i ≔ eval c ⟧ {A} (⟪var⟫ {A} j)
      ≡⟨ oops≔var i (eval c) j ⟩
        ⟦ i ≔ eval c ⟧∈ {A} j
      ≡⟨ lem≔∈ i c j ⟩
        eval ([ i ≔ c ]∈ j)
      ≡⟨⟩
        eval ([ i ≔ c ] (var j))
      ∎

    lem≔lam : ∀ {A B C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ , A ⊢ B) →
              ⟦ i ≔ eval c ⟧ {A ⇒ B} (⟪lam⟫ {A} {B} (eval d)) ≡ eval ([ i ≔ c ] (lam d)) {w}
    lem≔lam {A} {B} {C} i c d =
      begin
        ⟦ i ≔ eval c ⟧ {A ⇒ B} (⟪lam⟫ {A} {B} (eval d))
      ≡⟨ oops≔lam i c d ⟩
        ⟪lam⟫ {A} {B} (⟦ pop {A = C} {B = A} i ≔ eval (mono⊢ (weak⊆ {A = A}) c) ⟧ {B} (eval d))
      ≡⟨ cong (⟪lam⟫ {A} {B}) (⟨funext⟩ (lem≔ (pop i) (mono⊢ (weak⊆ {A = A}) c) d)) ⟩
        ⟪lam⟫ {A} {B} (eval ([ pop {A = C} {B = A} i ≔ mono⊢ (weak⊆ {A = A}) c ] d))
      ≡⟨⟩
        eval (lam ([ pop i ≔ mono⊢ weak⊆ c ] d))
      ≡⟨⟩
        eval ([ i ≔ c ] (lam d))
      ∎

    lem≔app : ∀ {A B C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ ⊢ A ⇒ B) (e : Γ ⊢ A) →
              ⟦ i ≔ eval c ⟧ {B} (⟪app⟫ {A} {B} (eval d) (eval e)) ≡ eval ([ i ≔ c ] (app d e)) {w}
    lem≔app {A} {B} i c d e =
      begin
        ⟦ i ≔ eval c ⟧ {B} (⟪app⟫ {A} {B} (eval d) (eval e))
      ≡⟨⟩
        ⟪app⟫ {A} {B} (⟦ i ≔ eval c ⟧ {A ⇒ B} (eval d)) (⟦ i ≔ eval c ⟧ {A} (eval e))
      ≡⟨ cong² (⟪app⟫ {A} {B}) (lem≔ i c d) (funext (λ γ → extfun (lem≔ i c e) γ)) ⟩
        ⟪app⟫ {A} {B} (eval ([ i ≔ c ] d)) (eval ([ i ≔ c ] e))
      ≡⟨⟩
        eval (app ([ i ≔ c ] d) ([ i ≔ c ] e))
      ≡⟨⟩
        eval ([ i ≔ c ] (app d e))
      ∎

    lem≔pair : ∀ {A B C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ ⊢ A) (e : Γ ⊢ B) →
               ⟦ i ≔ eval c ⟧ {A ⩕ B} (⟪pair⟫ {A} {B} (eval d) (eval e)) ≡ eval ([ i ≔ c ] (pair d e)) {w}
    lem≔pair {A} {B} i c d e =
      begin
        ⟦ i ≔ eval c ⟧ {A ⩕ B} (⟪pair⟫ {A} {B} (eval d) (eval e))
      ≡⟨⟩
        ⟪pair⟫ {A} {B} (⟦ i ≔ eval c ⟧ {A} (eval d)) (⟦ i ≔ eval c ⟧ {B} (eval e))
      ≡⟨ cong² (⟪pair⟫ {A} {B}) (lem≔ i c d) (lem≔ i c e) ⟩
        ⟪pair⟫ {A} {B} (eval ([ i ≔ c ] d)) (eval ([ i ≔ c ] e))
      ≡⟨⟩
        eval (pair ([ i ≔ c ] d) ([ i ≔ c ] e))
      ≡⟨⟩
        eval ([ i ≔ c ] (pair d e))
      ∎

    lem≔fst : ∀ {A B C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ ⊢ A ⩕ B) →
              ⟦ i ≔ eval c ⟧ {A} (⟪fst⟫ {A} {B} (eval d)) ≡ eval ([ i ≔ c ] (fst d)) {w}
    lem≔fst {A} {B} i c d =
      begin
        ⟦ i ≔ eval c ⟧ {A} (⟪fst⟫ {A} {B} (eval d))
      ≡⟨⟩
        ⟪fst⟫ {A} {B} (⟦ i ≔ eval c ⟧ {A ⩕ B} (eval d))
      ≡⟨ cong (⟪fst⟫ {A} {B}) (lem≔ i c d) ⟩
        ⟪fst⟫ {A} {B} (eval ([ i ≔ c ] d))
      ≡⟨⟩
        eval (fst ([ i ≔ c ] d))
      ≡⟨⟩
        eval ([ i ≔ c ] (fst d))
      ∎

    lem≔snd : ∀ {A B C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) (d : Γ ⊢ A ⩕ B) →
              ⟦ i ≔ eval c ⟧ {B} (⟪snd⟫ {A} {B} (eval d)) ≡ eval ([ i ≔ c ] (snd d)) {w}
    lem≔snd {A} {B} i c d =
      begin
        ⟦ i ≔ eval c ⟧ {B} (⟪snd⟫ {A} {B} (eval d))
      ≡⟨⟩
        ⟪snd⟫ {A} {B} (⟦ i ≔ eval c ⟧ {A ⩕ B} (eval d))
      ≡⟨ cong (⟪snd⟫ {A} {B}) (lem≔ i c d) ⟩
        ⟪snd⟫ {A} {B} (eval ([ i ≔ c ] d))
      ≡⟨⟩
        eval (snd ([ i ≔ c ] d))
      ≡⟨⟩
        eval ([ i ≔ c ] (snd d))
      ∎

    lem≔unit : ∀ {C Γ w} → (i : C ∈ Γ) (c : Γ ∖ i ⊢ C) →
               ⟦ i ≔ eval c ⟧ {⫪} ⟪unit⟫ ≡ eval ([ i ≔ c ] unit) {w}
    lem≔unit i c = refl

-- TODO: Naming things.

-- NOTE: This is using {-# REWRITE idmono⊩⋆ #-}.

module _ {{_ : Model}} where
  lemreduce⇒ : ∀ {A B Γ w} → (d : Γ , A ⊢ B) (e : Γ ⊢ A) →
                ⟪app⟫ {A} {B} (⟪lam⟫ {A} {B} (eval d)) (eval e {w}) ≡ eval ([ top ≔ e ] d) {w}
  lemreduce⇒ d e = lem≔ top e d

-- TODO: The expand⇒ case in eval✓.

module _ {{_ : Model}} where
  postulate
    lemexpand⇒ : ∀ {A B Γ w} → (d : Γ ⊢ A ⇒ B) →
                  eval d {w} ≡ ⟪lam⟫ {A} {B} (⟪app⟫ {A} {B} {Γ , A} (eval (mono⊢ {A ⇒ B} (weak⊆ {A = A}) d)) (⟪v₀⟫ {A}))
  -- lemexpand⇒ d = {!!}

-- Correctness of evaluation with respect to β-η-equivalence.

module _ {{_ : Model}} where
  eval✓ : ∀ {A Γ} {d d′ : Γ ⊢ A} {w} → d ≡ᵝᵑ d′ → eval d {w} ≡ eval d′ {w}
  eval✓ refl≡ᵝᵑ                   = refl
  eval✓ (trans≡ᵝᵑ p q)            = trans (eval✓ p) (eval✓ q)
  eval✓ (sym≡ᵝᵑ p)                = sym (eval✓ p)
  eval✓ (cong≡ᵝᵑlam {A} {B} p)    = cong (⟪lam⟫ {A} {B}) (⟨funext⟩ (eval✓ p))
  eval✓ (cong≡ᵝᵑapp {A} {B} p q)  = cong² (⟪app⟫ {A} {B}) (eval✓ p) (eval✓ q)
  eval✓ (cong≡ᵝᵑpair {A} {B} p q) = cong² (⟪pair⟫ {A} {B}) (eval✓ p) (eval✓ q)
  eval✓ (cong≡ᵝᵑfst {A} {B} p)    = cong (⟪fst⟫ {A} {B}) (eval✓ p)
  eval✓ (cong≡ᵝᵑsnd {A} {B} p)    = cong (⟪snd⟫ {A} {B}) (eval✓ p)
  eval✓ (reduce⇒ d e)            = lemreduce⇒ d e
  eval✓ (reduce⩕₁ d e)            = refl
  eval✓ (reduce⩕₂ d e)            = refl
  eval✓ (expand⇒ d)              = lemexpand⇒ d
  eval✓ (expand⩕ d)               = refl
  eval✓ (expand⫪ d)              = refl


open import Data.Nat hiding (_^_)
open import Data.List as List hiding (null)
open import Data.List.Membership.Propositional
open import Data.List.Relation.Unary.Any
open import Data.List.Relation.Unary.All
open import Data.List.Prefix
open import Data.Product hiding (map)
open import Data.Unit
open import Relation.Binary.PropositionalEquality hiding ([_])
open ≡-Reasoning

-- This file contains the definition of monads used for computation in
-- the definitional interpreter for MJ using scopes and frames,
-- described in Section 5 of the paper.

module MJSF.Monad (k : ℕ) where

open import MJSF.Syntax k
open import MJSF.Values k
open import ScopesFrames.ScopesFrames k Ty

module MonadG (g : Graph) where

  open SyntaxG g
  open ValuesG g
  open UsesVal Valᵗ valᵗ-weaken renaming (getFrame to getFrame')
  open import Common.Weakening

  -- Computations may either time out, raise a null-pointer exception,
  -- or successfully terminate to produce a result:

  data Res (a : Set) : Set where
    timeout : Res a
    nullpointer : Res a
    ok : (x : a) → Res a

  -- The monad is similar to the monad used for STLCSF, except it uses
  -- `Res` instead of `Maybe`:

  M : (s : Scope) → (List Scope → Set) → List Scope → Set
  M s p Σ = Frame s Σ → Heap Σ → Res (∃ λ Σ' → (Heap Σ' × p Σ' × Σ ⊑ Σ'))

  -- We define some usual monad operations:

  return     :  ∀ {s Σ}{p : List Scope → Set} → p Σ → M s p Σ
  return v f h = ok (_ , h , v , ⊑-refl)

  fmap : ∀ {A B : List Scope → Set}{Γ Σ} → (∀ {Σ} → A Σ → B Σ) → M Γ A Σ → M Γ B Σ
  fmap g m f h
    with (m f h)
  ...  | timeout = timeout
  ...  | nullpointer = nullpointer
  ...  | ok (Σ' , h' , v' , ext') = ok (Σ' , h' , g v' , ext')

  join : ∀ {A : List Scope → Set}{Γ Σ} → M Γ (M Γ A) Σ → M Γ A Σ
  join m f h
    with (m f h)
  ...  | timeout = timeout
  ...  | nullpointer = nullpointer
  ...  | ok (Σ' , h' , m' , ext')
       with (m' (wk ext' f) h')
  ...     | timeout = timeout
  ...     | nullpointer = nullpointer
  ...     | ok (Σ'' , h'' , v'' , ext'') = ok ((Σ'' , h'' , v'' , ext' ⊚ ext''))

  _>>=_     :  ∀ {s Σ}{p q : List Scope → Set} →
               M s p Σ → (∀ {Σ'} → p Σ' → M s q Σ') → M s q Σ
  (a >>= b) = join (fmap b a)

  -- To program in dependent-passing style, we use the variant of
  -- monadic strength also used for STLCSF.

  _^_  :  ∀ {Σ Γ}{p q : List Scope → Set} ⦃ w : Weakenable q ⦄ →
          M Γ p Σ → q Σ → M Γ (p ⊗ q) Σ
  (a ^ x) f h
    with (a f h)
  ...  | timeout = timeout
  ...  | nullpointer = nullpointer
  ...  | ok (Σ , h' , v , ext) = ok (Σ , h' , (v , wk ext x) , ext)

  -- The remaining definitions in this file are straightforward
  -- monadic liftings of the coercion function from `MJSF.Values` and
  -- of the frame operations.

  getFrame   :  ∀ {s Σ} → M s (Frame s) Σ
  getFrame f = return f f

  usingFrame  :  ∀ {s s' Σ}{p : List Scope → Set} → Frame s Σ → M s p Σ → M s' p Σ
  usingFrame f a _ = a f

  timeoutᴹ    :  ∀ {s Σ}{p : List Scope → Set} → M s p Σ
  timeoutᴹ _ _ = timeout

  raise : ∀ {s Σ}{p : List Scope → Set} → M s p Σ
  raise _ _ = nullpointer

  init : ∀ {Σ s' ds es} → (s : Scope) → ⦃ shape : g s ≡ (ds , es) ⦄ →
               Slots ds Σ → Links es Σ → M s' (Frame s) Σ
  init {Σ} s slots links _ h
    with (initFrame s slots links h)
  ...  | (f' , h') = ok (_ , h' , f' , ∷ʳ-⊒ s Σ)

  initι : ∀ {Σ s' ds es} → (s : Scope) → ⦃ shape : g s ≡ (ds , es) ⦄ →
               (Frame s (Σ ∷ʳ s) → Slots ds (Σ ∷ʳ s)) → Links es Σ → M s' (Frame s) Σ
  initι {Σ} s slots links _ h
    with (initFrameι s slots links h)
  ...  | (f' , h') = ok (_ , h' , f' , ∷ʳ-⊒ s Σ)

  getv : ∀ {s t Σ} → (s ↦ t) → M s (Valᵗ t) Σ
  getv p f h = return (getVal p f h) f h

  getf : ∀ {s s' Σ} → (s ⟶ s')  → M s (Frame s') Σ
  getf p f h = return (getFrame' p f h) f h

  getd : ∀ {s t Σ} → t ∈ declsOf s → M s (Valᵗ t) Σ
  getd d f h = return (getSlot d f h) f h

  getl : ∀ {s s' Σ} → s' ∈ edgesOf s → M s (Frame s') Σ
  getl e f h = return (getLink e f h) f h

  setd  :  ∀ {s t Σ} → t ∈ declsOf s → Valᵗ t Σ → M s (λ _ → ⊤) Σ
  setd d v f h with (setSlot d v f h)
  ...             | h' = return tt f h'

  setv  :  ∀ {s t Σ} → (s ↦ t) → Valᵗ t Σ → M s (λ _ → ⊤) Σ
  setv p v f h with (setVal p v f h)
  ...             | h' = return tt f h'


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

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening as T hiding (wk; wkTerm; wkEqTerm)
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Weakening
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Introductions.Pi

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Valid lambda term construction.
lamᵛ : ∀ {F G t Γ l}
       ([Γ] : ⊩ᵛ Γ)
       ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
       ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
       ([t] : Γ ∙ F ⊩ᵛ⟨ l ⟩ t ∷ G / [Γ] ∙″ [F] / [G])
     → Γ ⊩ᵛ⟨ l ⟩ lam t ∷ Π F ▹ G / [Γ] / Πᵛ {F} {G} [Γ] [F] [G]
lamᵛ {F} {G} {t} {Γ} {l} [Γ] [F] [G] [t] {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let ⊢F = escape (proj₁ ([F] ⊢Δ [σ]))
      [liftσ] = liftSubstS {F = F} [Γ] ⊢Δ [F] [σ]
      [ΠFG] = Πᵛ {F} {G} [Γ] [F] [G]
      Πᵣ F′ G′ D′ ⊢F′ ⊢G′ A≡A′ [F]′ [G]′ G-ext =
        extractMaybeEmbΠ (Π-elim (proj₁ ([ΠFG] ⊢Δ [σ])))
      lamt : ∀ {Δ σ} (⊢Δ : ⊢ Δ) ([σ] : Δ ⊩ˢ σ ∷ Γ / [Γ] / ⊢Δ)
           → Δ ⊩⟨ l ⟩ subst σ (lam t) ∷ subst σ (Π F ▹ G) / proj₁ ([ΠFG] ⊢Δ [σ])
      lamt {Δ} {σ} ⊢Δ [σ] =
        let [liftσ] = liftSubstS {F = F} [Γ] ⊢Δ [F] [σ]
            [σF] = proj₁ ([F] ⊢Δ [σ])
            ⊢F = escape [σF]
            ⊢wk1F = T.wk (step id) (⊢Δ ∙ ⊢F) ⊢F
            [σG] = proj₁ ([G] (⊢Δ ∙ ⊢F) [liftσ])
            ⊢G = escape [σG]
            [σt] = proj₁ ([t] (⊢Δ ∙ ⊢F) [liftσ])
            ⊢t = escapeTerm [σG] [σt]
            wk1t[0] = irrelevanceTerm″
                        PE.refl
                        (PE.sym (wkSingleSubstId (subst (liftSubst σ) t)))
                        [σG] [σG] [σt]
            β-red′ = PE.subst (λ x → _ ⊢ _ ⇒ _ ∷ x)
                              (wkSingleSubstId (subst (liftSubst σ) G))
                              (β-red ⊢wk1F (T.wkTerm (lift (step id))
                                                     (⊢Δ ∙ ⊢F ∙ ⊢wk1F) ⊢t)
                                                     (var (⊢Δ ∙ ⊢F) here))
            Πᵣ F′ G′ D′ ⊢F′ ⊢G′ A≡A′ [F]′ [G]′ G-ext =
              extractMaybeEmbΠ (Π-elim (proj₁ ([ΠFG] ⊢Δ [σ])))
        in  Πₜ (lam (subst (liftSubst σ) t)) (idRedTerm:*: (lamⱼ ⊢F ⊢t)) lamₙ
               (≅-η-eq ⊢F (lamⱼ ⊢F ⊢t) (lamⱼ ⊢F ⊢t) lamₙ lamₙ
                       (escapeTermEq [σG]
                         (reflEqTerm [σG]
                           (proj₁ (redSubstTerm β-red′ [σG] wk1t[0])))))
               (λ {_} {Δ₁} {a} {b} ρ ⊢Δ₁ [a] [b] [a≡b] →
                  let [ρσ] = wkSubstS [Γ] ⊢Δ ⊢Δ₁ ρ [σ]
                      [a]′ = irrelevanceTerm′ (wk-subst F) ([F]′ ρ ⊢Δ₁)
                                              (proj₁ ([F] ⊢Δ₁ [ρσ])) [a]
                      [b]′ = irrelevanceTerm′ (wk-subst F) ([F]′ ρ ⊢Δ₁)
                                              (proj₁ ([F] ⊢Δ₁ [ρσ])) [b]
                      [a≡b]′ = irrelevanceEqTerm′ (wk-subst F) ([F]′ ρ ⊢Δ₁)
                                                  (proj₁ ([F] ⊢Δ₁ [ρσ])) [a≡b]
                      ⊢F₁′ = escape (proj₁ ([F] ⊢Δ₁ [ρσ]))
                      ⊢F₁ = escape ([F]′ ρ ⊢Δ₁)
                      [G]₁ = proj₁ ([G] (⊢Δ₁ ∙ ⊢F₁′)
                                        (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ]))
                      [G]₁′ = irrelevanceΓ′
                                (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                                (PE.sym (wk-subst-lift G)) [G]₁
                      [t]′ = irrelevanceTermΓ″
                               (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                               (PE.sym (wk-subst-lift G))
                               (PE.sym (wk-subst-lift t))
                               [G]₁ [G]₁′
                               (proj₁ ([t] (⊢Δ₁ ∙ ⊢F₁′)
                                           (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ])))
                      ⊢a = escapeTerm ([F]′ ρ ⊢Δ₁) [a]
                      ⊢b = escapeTerm ([F]′ ρ ⊢Δ₁) [b]
                      ⊢t = escapeTerm [G]₁′ [t]′
                      G[a]′ = proj₁ ([G] ⊢Δ₁ ([ρσ] , [a]′))
                      G[a] = [G]′ ρ ⊢Δ₁ [a]
                      t[a] = irrelevanceTerm″
                               (PE.sym (singleSubstWkComp a σ G))
                               (PE.sym (singleSubstWkComp a σ t))
                               G[a]′ G[a]
                               (proj₁ ([t] ⊢Δ₁ ([ρσ] , [a]′)))
                      G[b]′ = proj₁ ([G] ⊢Δ₁ ([ρσ] , [b]′))
                      G[b] = [G]′ ρ ⊢Δ₁ [b]
                      t[b] = irrelevanceTerm″
                               (PE.sym (singleSubstWkComp b σ G))
                               (PE.sym (singleSubstWkComp b σ t))
                               G[b]′ G[b]
                               (proj₁ ([t] ⊢Δ₁ ([ρσ] , [b]′)))
                      lamt∘a≡t[a] = proj₂ (redSubstTerm (β-red ⊢F₁ ⊢t ⊢a) G[a] t[a])
                      G[a]≡G[b] = G-ext ρ ⊢Δ₁ [a] [b] [a≡b]
                      t[a]≡t[b] = irrelevanceEqTerm″
                                    (PE.sym (singleSubstWkComp a σ t))
                                    (PE.sym (singleSubstWkComp b σ t))
                                    (PE.sym (singleSubstWkComp a σ G))
                                    G[a]′ G[a]
                                    (proj₂ ([t] ⊢Δ₁ ([ρσ] , [a]′)) ([ρσ] , [b]′)
                                                (reflSubst [Γ] ⊢Δ₁ [ρσ] , [a≡b]′))
                      t[b]≡lamt∘b =
                        convEqTerm₂ G[a] G[b] G[a]≡G[b]
                          (symEqTerm G[b] (proj₂ (redSubstTerm (β-red ⊢F₁ ⊢t ⊢b)
                                                               G[b] t[b])))
                  in  transEqTerm G[a] lamt∘a≡t[a]
                             (transEqTerm G[a] t[a]≡t[b] t[b]≡lamt∘b))
               (λ {_} {Δ₁} {a} ρ ⊢Δ₁ [a] →
                  let [ρσ] = wkSubstS [Γ] ⊢Δ ⊢Δ₁ ρ [σ]
                      [a]′ = irrelevanceTerm′ (wk-subst F) ([F]′ ρ ⊢Δ₁)
                                              (proj₁ ([F] ⊢Δ₁ [ρσ])) [a]
                      ⊢F₁′ = escape (proj₁ ([F] ⊢Δ₁ [ρσ]))
                      ⊢F₁ = escape ([F]′ ρ ⊢Δ₁)
                      [G]₁ = proj₁ ([G] (⊢Δ₁ ∙ ⊢F₁′)
                                        (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ]))
                      [G]₁′ = irrelevanceΓ′
                                (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                                (PE.sym (wk-subst-lift G)) [G]₁
                      [t]′ = irrelevanceTermΓ″
                               (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                               (PE.sym (wk-subst-lift G))
                               (PE.sym (wk-subst-lift t))
                               [G]₁ [G]₁′
                               (proj₁ ([t] (⊢Δ₁ ∙ ⊢F₁′)
                                           (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ])))
                      ⊢a = escapeTerm ([F]′ ρ ⊢Δ₁) [a]
                      ⊢t = escapeTerm [G]₁′ [t]′
                      G[a]′ = proj₁ ([G] ⊢Δ₁ ([ρσ] , [a]′))
                      G[a] = [G]′ ρ ⊢Δ₁ [a]
                      t[a] = irrelevanceTerm″ (PE.sym (singleSubstWkComp a σ G))
                                               (PE.sym (singleSubstWkComp a σ t))
                                               G[a]′ G[a]
                                               (proj₁ ([t] ⊢Δ₁ ([ρσ] , [a]′)))
                  in  proj₁ (redSubstTerm (β-red ⊢F₁ ⊢t ⊢a) G[a] t[a]))
  in  lamt ⊢Δ [σ]
  ,   (λ {σ′} [σ′] [σ≡σ′] →
         let [liftσ′] = liftSubstS {F = F} [Γ] ⊢Δ [F] [σ′]
             Πᵣ F″ G″ D″ ⊢F″ ⊢G″ A≡A″ [F]″ [G]″ G-ext′ =
               extractMaybeEmbΠ (Π-elim (proj₁ ([ΠFG] ⊢Δ [σ′])))
             ⊢F′ = escape (proj₁ ([F] ⊢Δ [σ′]))
             [G]₁ = proj₁ ([G] (⊢Δ ∙ ⊢F) [liftσ])
             [G]₁′ = proj₁ ([G] (⊢Δ ∙ ⊢F′) [liftσ′])
             [σΠFG≡σ′ΠFG] = proj₂ ([ΠFG] ⊢Δ [σ]) [σ′] [σ≡σ′]
             ⊢t = escapeTerm [G]₁ (proj₁ ([t] (⊢Δ ∙ ⊢F) [liftσ]))
             ⊢t′ = escapeTerm [G]₁′ (proj₁ ([t] (⊢Δ ∙ ⊢F′) [liftσ′]))
             neuVar = neuTerm ([F]′ (step id) (⊢Δ ∙ ⊢F))
                              (var 0) (var (⊢Δ ∙ ⊢F) here)
                              (~-var (var (⊢Δ ∙ ⊢F) here))
             σlamt∘a≡σ′lamt∘a : ∀ {ρ Δ₁ a} → ([ρ] : ρ ∷ Δ₁ ⊆ Δ) (⊢Δ₁ : ⊢ Δ₁)
                 → ([a] : Δ₁ ⊩⟨ l ⟩ a ∷ U.wk ρ (subst σ F) / [F]′ [ρ] ⊢Δ₁)
                 → Δ₁ ⊩⟨ l ⟩ U.wk ρ (subst σ (lam t)) ∘ a
                           ≡ U.wk ρ (subst σ′ (lam t)) ∘ a
                           ∷ U.wk (lift ρ) (subst (liftSubst σ) G) [ a ]
                           / [G]′ [ρ] ⊢Δ₁ [a]
             σlamt∘a≡σ′lamt∘a {_} {Δ₁} {a} ρ ⊢Δ₁ [a] =
                let [ρσ] = wkSubstS [Γ] ⊢Δ ⊢Δ₁ ρ [σ]
                    [ρσ′] = wkSubstS [Γ] ⊢Δ ⊢Δ₁ ρ [σ′]
                    [ρσ≡ρσ′] = wkSubstSEq [Γ] ⊢Δ ⊢Δ₁ ρ [σ] [σ≡σ′]
                    ⊢F₁′ = escape (proj₁ ([F] ⊢Δ₁ [ρσ]))
                    ⊢F₁ = escape ([F]′ ρ ⊢Δ₁)
                    ⊢F₂′ = escape (proj₁ ([F] ⊢Δ₁ [ρσ′]))
                    ⊢F₂ = escape ([F]″ ρ ⊢Δ₁)
                    [σF≡σ′F] = proj₂ ([F] ⊢Δ₁ [ρσ]) [ρσ′] [ρσ≡ρσ′]
                    [a]′ = irrelevanceTerm′ (wk-subst F) ([F]′ ρ ⊢Δ₁)
                                            (proj₁ ([F] ⊢Δ₁ [ρσ])) [a]
                    [a]″ = convTerm₁ (proj₁ ([F] ⊢Δ₁ [ρσ]))
                                      (proj₁ ([F] ⊢Δ₁ [ρσ′]))
                                      [σF≡σ′F] [a]′
                    ⊢a = escapeTerm ([F]′ ρ ⊢Δ₁) [a]
                    ⊢a′ = escapeTerm ([F]″ ρ ⊢Δ₁)
                            (irrelevanceTerm′ (PE.sym (wk-subst F))
                                              (proj₁ ([F] ⊢Δ₁ [ρσ′]))
                                              ([F]″ ρ ⊢Δ₁)
                                              [a]″)
                    G[a]′ = proj₁ ([G] ⊢Δ₁ ([ρσ] , [a]′))
                    G[a]₁′ = proj₁ ([G] ⊢Δ₁ ([ρσ′] , [a]″))
                    G[a] = [G]′ ρ ⊢Δ₁ [a]
                    G[a]″ = [G]″ ρ ⊢Δ₁
                                   (irrelevanceTerm′ (PE.sym (wk-subst F))
                                                     (proj₁ ([F] ⊢Δ₁ [ρσ′]))
                                                     ([F]″ ρ ⊢Δ₁)
                                                     [a]″)
                    [σG[a]≡σ′G[a]] = irrelevanceEq″
                                       (PE.sym (singleSubstWkComp a σ G))
                                       (PE.sym (singleSubstWkComp a σ′ G))
                                       G[a]′ G[a]
                                       (proj₂ ([G] ⊢Δ₁ ([ρσ] , [a]′))
                                              ([ρσ′] , [a]″)
                                              (consSubstSEq {t = a} {A = F}
                                                [Γ] ⊢Δ₁ [ρσ] [ρσ≡ρσ′] [F] [a]′))
                    [G]₁ = proj₁ ([G] (⊢Δ₁ ∙ ⊢F₁′)
                                      (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ]))
                    [G]₁′ = irrelevanceΓ′
                              (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                              (PE.sym (wk-subst-lift G)) [G]₁
                    [G]₂ = proj₁ ([G] (⊢Δ₁ ∙ ⊢F₂′)
                                      (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ′]))
                    [G]₂′ = irrelevanceΓ′
                              (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                              (PE.sym (wk-subst-lift G)) [G]₂
                    [t]′ = irrelevanceTermΓ″
                             (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                             (PE.sym (wk-subst-lift G)) (PE.sym (wk-subst-lift t))
                             [G]₁ [G]₁′
                             (proj₁ ([t] (⊢Δ₁ ∙ ⊢F₁′)
                                         (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ])))
                    [t]″ = irrelevanceTermΓ″
                              (PE.cong (λ x → _ ∙ x) (PE.sym (wk-subst F)))
                              (PE.sym (wk-subst-lift G)) (PE.sym (wk-subst-lift t))
                              [G]₂ [G]₂′
                              (proj₁ ([t] (⊢Δ₁ ∙ ⊢F₂′)
                                          (liftSubstS {F = F} [Γ] ⊢Δ₁ [F] [ρσ′])))
                    ⊢t = escapeTerm [G]₁′ [t]′
                    ⊢t′ = escapeTerm [G]₂′ [t]″
                    t[a] = irrelevanceTerm″
                             (PE.sym (singleSubstWkComp a σ G))
                             (PE.sym (singleSubstWkComp a σ t)) G[a]′ G[a]
                             (proj₁ ([t] ⊢Δ₁ ([ρσ] , [a]′)))
                    t[a]′ = irrelevanceTerm″
                              (PE.sym (singleSubstWkComp a σ′ G))
                              (PE.sym (singleSubstWkComp a σ′ t))
                              G[a]₁′ G[a]″
                              (proj₁ ([t] ⊢Δ₁ ([ρσ′] , [a]″)))
                    [σlamt∘a≡σt[a]] = proj₂ (redSubstTerm (β-red ⊢F₁ ⊢t ⊢a)
                                                          G[a] t[a])
                    [σ′t[a]≡σ′lamt∘a] =
                      convEqTerm₂ G[a] G[a]″ [σG[a]≡σ′G[a]]
                        (symEqTerm G[a]″
                           (proj₂ (redSubstTerm (β-red ⊢F₂ ⊢t′ ⊢a′)
                                                G[a]″ t[a]′)))
                    [σt[a]≡σ′t[a]] = irrelevanceEqTerm″
                                       (PE.sym (singleSubstWkComp a σ t))
                                       (PE.sym (singleSubstWkComp a σ′ t))
                                       (PE.sym (singleSubstWkComp a σ G))
                                       G[a]′ G[a]
                                       (proj₂ ([t] ⊢Δ₁ ([ρσ] , [a]′))
                                              ([ρσ′] , [a]″)
                                              (consSubstSEq {t = a} {A = F}
                                                [Γ] ⊢Δ₁ [ρσ] [ρσ≡ρσ′] [F] [a]′))
                in  transEqTerm G[a] [σlamt∘a≡σt[a]]
                                (transEqTerm G[a] [σt[a]≡σ′t[a]]
                                             [σ′t[a]≡σ′lamt∘a])
         in  Πₜ₌ (lam (subst (liftSubst σ) t)) (lam (subst (liftSubst σ′) t))
                 (idRedTerm:*: (lamⱼ ⊢F ⊢t))
                 (idRedTerm:*: (conv (lamⱼ ⊢F′ ⊢t′)
                                     (sym (≅-eq (escapeEq (proj₁ ([ΠFG] ⊢Δ [σ]))
                                                              [σΠFG≡σ′ΠFG])))))
                 lamₙ lamₙ
                 (≅-η-eq ⊢F (lamⱼ ⊢F ⊢t)
                      (conv (lamⱼ ⊢F′ ⊢t′)
                            (sym (≅-eq (escapeEq (proj₁ ([ΠFG] ⊢Δ [σ]))
                                              [σΠFG≡σ′ΠFG]))))
                      lamₙ lamₙ
                      (escapeTermEq
                        (proj₁ ([G] (⊢Δ ∙ ⊢F) [liftσ]))
                        (irrelevanceEqTerm′
                          (idWkLiftSubstLemma σ G)
                          ([G]′ (step id) (⊢Δ ∙ ⊢F) neuVar)
                          (proj₁ ([G] (⊢Δ ∙ ⊢F) [liftσ]))
                          (σlamt∘a≡σ′lamt∘a (step id) (⊢Δ ∙ ⊢F) neuVar))))
                  (lamt ⊢Δ [σ])
                  (convTerm₂ (proj₁ ([ΠFG] ⊢Δ [σ]))
                             (proj₁ ([ΠFG] ⊢Δ [σ′]))
                             [σΠFG≡σ′ΠFG]
                             (lamt ⊢Δ [σ′]))
                  σlamt∘a≡σ′lamt∘a)

-- Reducibility of η-equality under a valid substitution.
η-eqEqTerm : ∀ {f g F G Γ Δ σ l}
             ([Γ] : ⊩ᵛ Γ)
             ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
             ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
           → let [ΠFG] = Πᵛ {F} {G} [Γ] [F] [G] in
             Γ ∙ F ⊩ᵛ⟨ l ⟩ wk1 f ∘ var 0 ≡ wk1 g ∘ var 0 ∷ G
                          / [Γ] ∙″ [F] / [G]
           → (⊢Δ   : ⊢ Δ)
             ([σ]  : Δ ⊩ˢ σ ∷ Γ / [Γ] / ⊢Δ)
           → Δ ⊩⟨ l ⟩ subst σ f ∷ Π subst σ F ▹ subst (liftSubst σ) G
               / proj₁ ([ΠFG] ⊢Δ [σ])
           → Δ ⊩⟨ l ⟩ subst σ g ∷ Π subst σ F ▹ subst (liftSubst σ) G
               / proj₁ ([ΠFG] ⊢Δ [σ])
           → Δ ⊩⟨ l ⟩ subst σ f ≡ subst σ g ∷ Π subst σ F ▹ subst (liftSubst σ) G
               / proj₁ ([ΠFG] ⊢Δ [σ])
η-eqEqTerm {f} {g} {F} {G} {Γ} {Δ} {σ} [Γ] [F] [G] [f0≡g0] ⊢Δ [σ]
           (Πₜ f₁ [ ⊢t , ⊢u , d ] funcF f≡f [f] [f]₁)
           (Πₜ g₁ [ ⊢t₁ , ⊢u₁ , d₁ ] funcG g≡g [g] [g]₁) =
  let [d]  = [ ⊢t , ⊢u , d ]
      [d′] = [ ⊢t₁ , ⊢u₁ , d₁ ]
      [ΠFG] = Πᵛ {F} {G} [Γ] [F] [G]
      [σΠFG] = proj₁ ([ΠFG] ⊢Δ [σ])
      Πᵣ F′ G′ D′ ⊢F ⊢G A≡A [F]′ [G]′ G-ext = extractMaybeEmbΠ (Π-elim [σΠFG])
      [σF] = proj₁ ([F] ⊢Δ [σ])
      [wk1F] = wk (step id) (⊢Δ ∙ ⊢F) [σF]
      var0′ = var (⊢Δ ∙ ⊢F) here
      var0 = neuTerm [wk1F] (var 0) var0′ (~-var var0′)
      var0≡0 = neuEqTerm [wk1F] (var 0) (var 0) var0′ var0′ (~-var var0′)
      [σG]′ = [G]′ (step id) (⊢Δ ∙ ⊢F) var0
      [σG] = proj₁ ([G] (⊢Δ ∙ ⊢F) (liftSubstS {F = F} [Γ] ⊢Δ [F] [σ]))
      σf0≡σg0 = escapeTermEq [σG]
                                 ([f0≡g0] (⊢Δ ∙ ⊢F)
                                          (liftSubstS {F = F} [Γ] ⊢Δ [F] [σ]))
      σf0≡σg0′ =
        PE.subst₂
          (λ x y → Δ ∙ subst σ F ⊢ x ≅ y ∷ subst (liftSubst σ) G)
          (PE.cong₂ _∘_ (PE.trans (subst-wk f) (PE.sym (wk-subst f))) PE.refl)
          (PE.cong₂ _∘_ (PE.trans (subst-wk g) (PE.sym (wk-subst g))) PE.refl)
          σf0≡σg0
      ⊢ΠFG = escape [σΠFG]
      f≡f₁′ = proj₂ (redSubst*Term d [σΠFG] (Πₜ f₁ (idRedTerm:*: ⊢u) funcF f≡f [f] [f]₁))
      g≡g₁′ = proj₂ (redSubst*Term d₁ [σΠFG] (Πₜ g₁ (idRedTerm:*: ⊢u₁) funcG g≡g [g] [g]₁))
      eq′  = irrelevanceEqTerm′ (cons0wkLift1-id σ G) [σG]′ [σG]
                                (app-congTerm [wk1F] [σG]′ (wk (step id) (⊢Δ ∙ ⊢F) [σΠFG])
                                              (wkEqTerm (step id) (⊢Δ ∙ ⊢F) [σΠFG] f≡f₁′) var0 var0 var0≡0)
      eq₁′ = irrelevanceEqTerm′ (cons0wkLift1-id σ G) [σG]′ [σG]
                                (app-congTerm [wk1F] [σG]′ (wk (step id) (⊢Δ ∙ ⊢F) [σΠFG])
                                              (wkEqTerm (step id) (⊢Δ ∙ ⊢F) [σΠFG] g≡g₁′) var0 var0 var0≡0)
      eq   = escapeTermEq [σG] eq′
      eq₁  = escapeTermEq [σG] eq₁′
  in  Πₜ₌ f₁ g₁ [d] [d′] funcF funcG
          (≅-η-eq ⊢F ⊢u ⊢u₁ funcF funcG
                  (≅ₜ-trans (≅ₜ-sym eq) (≅ₜ-trans σf0≡σg0′ eq₁)))
          (Πₜ f₁ [d] funcF f≡f [f] [f]₁)
          (Πₜ g₁ [d′] funcG g≡g [g] [g]₁)
          (λ {ρ} {Δ₁} {a} [ρ] ⊢Δ₁ [a] →
             let [F]″ = proj₁ ([F] ⊢Δ₁ (wkSubstS [Γ] ⊢Δ ⊢Δ₁ [ρ] [σ]))
                 [a]′ = irrelevanceTerm′
                          (wk-subst F) ([F]′ [ρ] ⊢Δ₁)
                          [F]″ [a]
                 fEq = PE.cong₂ _∘_ (PE.trans (subst-wk f) (PE.sym (wk-subst f))) PE.refl
                 gEq = PE.cong₂ _∘_ (PE.trans (subst-wk g) (PE.sym (wk-subst g))) PE.refl
                 GEq = PE.sym (PE.trans (subst-wk (subst (liftSubst σ) G))
                                        (PE.trans (substCompEq G)
                                                  (cons-wk-subst ρ σ a G)))
                 f≡g = irrelevanceEqTerm″ fEq gEq GEq
                         (proj₁ ([G] ⊢Δ₁ (wkSubstS [Γ] ⊢Δ ⊢Δ₁ [ρ] [σ] , [a]′)))
                         ([G]′ [ρ] ⊢Δ₁ [a])
                         ([f0≡g0] ⊢Δ₁ (wkSubstS [Γ] ⊢Δ ⊢Δ₁ [ρ] [σ] , [a]′))
                 [ρσΠFG] = wk [ρ] ⊢Δ₁ [σΠFG]
                 [f]′ : Δ ⊩⟨ _ ⟩ f₁ ∷ Π F′ ▹ G′ / [σΠFG]
                 [f]′ = Πₜ f₁ (idRedTerm:*: ⊢u) funcF f≡f [f] [f]₁
                 [ρf]′ = wkTerm [ρ] ⊢Δ₁ [σΠFG] [f]′
                 [g]′ : Δ ⊩⟨ _ ⟩ g₁ ∷ Π F′ ▹ G′ / [σΠFG]
                 [g]′ = Πₜ g₁ (idRedTerm:*: ⊢u₁) funcG g≡g [g] [g]₁
                 [ρg]′ = wkTerm [ρ] ⊢Δ₁ [σΠFG] [g]′
                 [f∘u] = appTerm ([F]′ [ρ] ⊢Δ₁) ([G]′ [ρ] ⊢Δ₁ [a]) [ρσΠFG] [ρf]′ [a]
                 [g∘u] = appTerm ([F]′ [ρ] ⊢Δ₁) ([G]′ [ρ] ⊢Δ₁ [a]) [ρσΠFG] [ρg]′ [a]
                 [tu≡fu] = proj₂ (redSubst*Term (app-subst* (wkRed*Term [ρ] ⊢Δ₁ d)
                                                            (escapeTerm ([F]′ [ρ] ⊢Δ₁) [a]))
                                                ([G]′ [ρ] ⊢Δ₁ [a]) [f∘u])
                 [gu≡t′u] = proj₂ (redSubst*Term (app-subst* (wkRed*Term [ρ] ⊢Δ₁ d₁)
                                                             (escapeTerm ([F]′ [ρ] ⊢Δ₁) [a]))
                                                 ([G]′ [ρ] ⊢Δ₁ [a]) [g∘u])
             in  transEqTerm ([G]′ [ρ] ⊢Δ₁ [a]) (symEqTerm ([G]′ [ρ] ⊢Δ₁ [a]) [tu≡fu])
                             (transEqTerm ([G]′ [ρ] ⊢Δ₁ [a]) f≡g [gu≡t′u]))

-- Validity of η-equality.
η-eqᵛ : ∀ {f g F G Γ l}
        ([Γ] : ⊩ᵛ Γ)
        ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
        ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
      → let [ΠFG] = Πᵛ {F} {G} [Γ] [F] [G] in
        Γ ⊩ᵛ⟨ l ⟩ f ∷ Π F ▹ G / [Γ] / [ΠFG]
      → Γ ⊩ᵛ⟨ l ⟩ g ∷ Π F ▹ G / [Γ] / [ΠFG]
      → Γ ∙ F ⊩ᵛ⟨ l ⟩ wk1 f ∘ var 0 ≡ wk1 g ∘ var 0 ∷ G
                     / [Γ] ∙″ [F] / [G]
      → Γ ⊩ᵛ⟨ l ⟩ f ≡ g ∷ Π F ▹ G / [Γ] / [ΠFG]
η-eqᵛ {f} {g} {F} {G} [Γ] [F] [G] [f] [g] [f0≡g0] {Δ} {σ} ⊢Δ [σ] =
  η-eqEqTerm {f} {g} {F} {G} [Γ] [F] [G] [f0≡g0] ⊢Δ [σ]
                (proj₁ ([f] ⊢Δ [σ])) (proj₁ ([g] ⊢Δ [σ]))


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Empty.Base where

open import Cubical.Core.Everything

data ⊥ : Type₀ where

⊥-elim : ∀ {ℓ} {A : Type ℓ} → ⊥ → A
⊥-elim ()


{-# OPTIONS --cubical --safe #-}

module Chord where

open import Cubical.Core.Everything using (_≡_; Level; Type; Σ; _,_; fst; snd; _≃_; ~_)

open import Data.Fin        using (Fin; toℕ) renaming (zero to fz; suc to fs)
open import Data.List       using (List; map; []; _∷_; _++_; zip)
open import Data.Nat        using (ℕ)
open import Data.Product    using (_×_)
open import Data.String     using (String) renaming (_++_ to _++s_)

open import Function        using (_∘_)

open import AssocList
open import BitVec
open import Pitch
open import Util            using (_+N_)

data Root : Type where
  root : Fin s12 → Root

showRoot : Root → String
showRoot (root fz)                                                        = "I"
showRoot (root (fs fz))                                                   = "♭II"
showRoot (root (fs (fs fz)))                                              = "II"
showRoot (root (fs (fs (fs fz))))                                         = "♭III"
showRoot (root (fs (fs (fs (fs fz)))))                                    = "III"
showRoot (root (fs (fs (fs (fs (fs fz))))))                               = "IV"
showRoot (root (fs (fs (fs (fs (fs (fs fz)))))))                          = "♭V"
showRoot (root (fs (fs (fs (fs (fs (fs (fs fz))))))))                     = "V"
showRoot (root (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))                = "♭VI"
showRoot (root (fs (fs (fs (fs (fs (fs (fs (fs (fs fz))))))))))           = "VI"
showRoot (root (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))      = "♭VII"
showRoot (root (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))) = "VII"

data Quality : Type where
  maj  : Quality
  min  : Quality
  dom7 : Quality
  maj7 : Quality

showQuality : Quality → String
showQuality maj  = "maj"
showQuality min  = "min"
showQuality dom7 = "⁷"
showQuality maj7 = "maj⁷"

RootQuality : Type
RootQuality = Root × Quality

showRootQuality : RootQuality → String
showRootQuality (r , q) = showRoot r ++s showQuality q

Notes : Type
Notes = BitVec s12

ChordList : Type
ChordList = AList Notes RootQuality

-- The list should not include the root.
makeChord : Root → List ℕ → Notes
makeChord (root n) []       = BitVec.insert n empty
makeChord (root n) (x ∷ xs) = BitVec.insert (n +N x) (makeChord (root n) xs)

-- The list should not include the root.
qualityNotes : Quality → List ℕ
qualityNotes maj  = 4 ∷ 7 ∷ []
qualityNotes min  = 3 ∷ 7 ∷ []
qualityNotes dom7 = 4 ∷ 7 ∷ 10 ∷ []
qualityNotes maj7 = 4 ∷ 7 ∷ 11 ∷ []

makeChordQuality : RootQuality → Notes
makeChordQuality (r , q) = makeChord r (qualityNotes q)

---------

--addMajor

aa = show (makeChordQuality (root fz , maj))

{-
allPairs : {A : Type} → List A → List (A × A)
allPairs []       = []
allPairs (x ∷ xs) = map (x ,_) xs ++ allPairs xs

aa = allPairs (c 5 ∷ e 5 ∷ g 5 ∷ [])
bb = zip aa (map (toℕ ∘ unIntervalClass ∘ pitchPairToIntervalClass) aa)
-}


module RandomAccessList.Redundant.Core.Properties where

open import BuildingBlock
open import BuildingBlock.BinaryLeafTree using (BinaryLeafTree; Node; Leaf)
open import RandomAccessList.Redundant.Core

open import Data.Num.Redundant
open import Data.Num.Redundant.Properties

open import Data.Nat using (ℕ; zero; suc)
open import Data.Nat.Etc
open import Data.Nat.Properties.Simple
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; cong₂; trans; sym; inspect)
open PropEq.≡-Reasoning

⟦[]⟧≈zero∷[] : ∀ {n A} → (xs : 0-2-RAL A n) → {xs≣[] : xs ≡ []} → ⟦ xs ⟧ ≈ zero ∷ []
⟦[]⟧≈zero∷[] {n} {A} [] = <<<-zero n [] {eq refl}
⟦[]⟧≈zero∷[] (      0∷ xs) {()}
⟦[]⟧≈zero∷[] (x     1∷ xs) {()}
⟦[]⟧≈zero∷[] (x , y 2∷ xs) {()}

--------------------------------------------------------------------------------
-- On ⟦_⟧ and ⟦_⟧ₙ

{-
⟦[]⟧ₙ≡0 : ∀ {A n} → (xs : 0-2-RAL A n) → {xs≣[] : xs ≡ []} → ⟦ xs ⟧ₙ ≡ zero ∷ []
⟦[]⟧ₙ≡0 []                 = refl
⟦[]⟧ₙ≡0 (      0∷ xs) {()}
⟦[]⟧ₙ≡0 (x     1∷ xs) {()}
⟦[]⟧ₙ≡0 (x , y 2∷ xs) {()}

⟦[]⟧≡0 : ∀ {n A} → (xs : 0-2-RAL A n) → {xs≣[] : xs ≡ []} → ⟦ xs ⟧ ≡ zero ∷ []
⟦[]⟧≡0 {n}    []     {p}  =
    begin
        n <<< (zero ∷ [])
    ≡⟨ {!   !} ⟩
        zero ∷ []
    ∎
⟦[]⟧≡0 (      0∷ xs) {()}
⟦[]⟧≡0 (x     1∷ xs) {()}
⟦[]⟧≡0 (x , y 2∷ xs) {()}
-- identity
⟦[]⟧ₙ≡0 : ∀ {A n} → (xs : 0-2-RAL A n) → xs ≡ [] → ⟦ xs ⟧ₙ ≡ zero
⟦[]⟧ₙ≡0 []            p  = refl
⟦[]⟧ₙ≡0 (      0∷ xs) ()
⟦[]⟧ₙ≡0 (x     1∷ xs) ()
⟦[]⟧ₙ≡0 (x , y 2∷ xs) ()

⟦[]⟧≡0 : ∀ {n A} → (xs : 0-2-RAL A n) → xs ≡ [] → ⟦ xs ⟧ ≡ 0
⟦[]⟧≡0 {zero }    [] p  = refl
⟦[]⟧≡0 {suc n}    [] p  = *-right-zero (2 * 2 ^ n)
⟦[]⟧≡0 (      0∷ xs) ()
⟦[]⟧≡0 (x     1∷ xs) ()
⟦[]⟧≡0 (x , y 2∷ xs) ()

⟦0∷xs⟧≡⟦xs⟧ : ∀ {n A} → (xs : 0-2-RAL A (suc n)) → ⟦ 0∷ xs ⟧ ≡ ⟦ xs ⟧
⟦0∷xs⟧≡⟦xs⟧ {zero} xs = +-right-identity (2 * ⟦ xs ⟧ₙ)
⟦0∷xs⟧≡⟦xs⟧ {suc n} xs =
    begin
        2 * 2 ^ n * (2 * ⟦ xs ⟧ₙ)
    ≡⟨ sym (*-assoc (2 * 2 ^ n) 2 ⟦ xs ⟧ₙ) ⟩
        ((2 * 2 ^ n) * 2) * ⟦ xs ⟧ₙ
    ≡⟨ cong (λ x → x * ⟦ xs ⟧ₙ) (*-comm (2 * 2 ^ n) 2) ⟩
        (2 * (2 * 2 ^ n)) * ⟦ xs ⟧ₙ
    ∎

⟦[]⟧≡⟦[]⟧ : ∀ {m n A} → ⟦ [] {A} {m} ⟧ ≡ ⟦ [] {A} {n} ⟧
⟦[]⟧≡⟦[]⟧ {m} {n} =
    begin
        2 ^ m * 0
    ≡⟨ *-right-zero (2 ^ m) ⟩
        0
    ≡⟨ sym (*-right-zero (2 ^ n)) ⟩
        2 ^ n * 0
    ∎

splitIndex : ∀ {n A} → (x : BinaryLeafTree A n) → (xs : 0-2-RAL A (suc n)) → ⟦ x 1∷ xs ⟧ ≡ 1 * (2 ^ n) + ⟦ xs ⟧
splitIndex {n} x xs =
    begin
        2 ^ n * suc (2 * ⟦ xs ⟧ₙ)
    ≡⟨ +-*-suc (2 ^ n) (2 * ⟦ xs ⟧ₙ) ⟩
        2 ^ n + 2 ^ n * (2 * ⟦ xs ⟧ₙ)
    ≡⟨ cong (λ w → 2 ^ n + w) (sym (*-assoc (2 ^ n) 2 ⟦ xs ⟧ₙ)) ⟩
        2 ^ n + (2 ^ n * 2) * ⟦ xs ⟧ₙ
    ≡⟨ cong (λ w → 2 ^ n + w * ⟦ xs ⟧ₙ) (*-comm (2 ^ n) 2) ⟩
        2 ^ n + (2 * 2 ^ n) * ⟦ xs ⟧ₙ
    ≡⟨ cong (λ w → w + (2 * 2 ^ n) * ⟦ xs ⟧ₙ) (sym (+-right-identity (2 ^ n))) ⟩
        2 ^ n + 0 + (2 * 2 ^ n) * ⟦ xs ⟧ₙ
    ∎

splitIndex2 : ∀ {n A} → (x : BinaryLeafTree A n) → (y : BinaryLeafTree A n) → (xs : 0-2-RAL A (suc n)) → ⟦ x , y 2∷ xs ⟧ ≡ 2 * (2 ^ n) + ⟦ xs ⟧
splitIndex2 {n} x y xs =
    begin
        2 ^ n * (1 + (1 + (2 * ⟦ xs ⟧ₙ)))
    ≡⟨ +-*-suc (2 ^ n) ((1 + (2 * ⟦ xs ⟧ₙ))) ⟩
        2 ^ n + 2 ^ n * (1 + (2 * ⟦ xs ⟧ₙ))
    ≡⟨ cong (λ w → 2 ^ n + w) (+-*-suc (2 ^ n) (2 * ⟦ xs ⟧ₙ)) ⟩
        2 ^ n + (2 ^ n + 2 ^ n * (2 * ⟦ xs ⟧ₙ))
    ≡⟨ sym (+-assoc (2 ^ n) (2 ^ n) (2 ^ n * (2 * ⟦ xs ⟧ₙ))) ⟩
        2 ^ n + 2 ^ n + 2 ^ n * (2 * ⟦ xs ⟧ₙ)
    ≡⟨ cong (λ w → 2 ^ n + 2 ^ n + w) (sym (*-assoc (2 ^ n) 2 ⟦ xs ⟧ₙ)) ⟩
        2 ^ n + 2 ^ n + (2 ^ n * 2) * ⟦ xs ⟧ₙ
    ≡⟨ cong (λ w → 2 ^ n + 2 ^ n + w * ⟦ xs ⟧ₙ) (*-comm (2 ^ n) 2) ⟩
        2 ^ n + 2 ^ n + (2 * 2 ^ n) * ⟦ xs ⟧ₙ
    ≡⟨ cong (λ w → 2 ^ n + w + (2 * 2 ^ n) * ⟦ xs ⟧ₙ) (sym (+-right-identity (2 ^ n))) ⟩
        2 ^ n + (2 ^ n + 0) + (2 * 2 ^ n) * ⟦ xs ⟧ₙ
    ≡⟨ refl ⟩
        2 * 2 ^ n + (2 * 2 ^ n) * ⟦ xs ⟧ₙ
    ∎

    begin
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ∎
-}

{-
⟦[]⟧≡⟦[]⟧ : ∀ {n A} → ⟦ [] {A} {suc n} ⟧ ≡ ⟦ [] {A} {n} ⟧
⟦[]⟧≡⟦[]⟧ {n} =
    begin
        (2 * 2 ^ n) * 0
    ≡⟨ *-right-zero (2 * 2 ^ n) ⟩
        0
    ≡⟨ sym (*-right-zero (2 ^ n)) ⟩
        2 ^ n * 0
    ∎

⟦0∷xs⟧≡⟦xs⟧ {zero} xs = +-right-identity (2 * ⟦ xs ⟧ₙ)
⟦0∷xs⟧≡⟦xs⟧ {suc n} xs =
    begin
        2 * 2 ^ n * (2 * ⟦ xs ⟧ₙ)
    ≡⟨ sym (*-assoc (2 * 2 ^ n) 2 ⟦ xs ⟧ₙ) ⟩
        2 * 2 ^ n * 2 * ⟦ xs ⟧ₙ
    ≡⟨ cong (λ x → x * ⟦ xs ⟧ₙ) (*-assoc 2 (2 ^ n) 2) ⟩
        2 * (2 ^ n * 2) * ⟦ xs ⟧ₙ
    ≡⟨ cong (λ x → 2 * x * ⟦ xs ⟧ₙ) (*-comm (2 ^ n) 2) ⟩
        (2 * (2 * 2 ^ n)) * ⟦ xs ⟧ₙ
    ∎

⟦0∷xs⟧≢0⇒⟦xs⟧≢0  : ∀ {n A}
                → (xs : 0-1-RAL A (suc n))
                → ⟦ 0∷ xs ⟧ ≢ 0
                → ⟦ xs ⟧ ≢ 0
⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p = contraposition (trans (⟦0∷xs⟧≡⟦xs⟧ xs)) p
-}


module DuplicateConstructors where

data D : Set where
  c : D
  c : D

f : D -> D
f c = c


module HelloWorldPrim where

open import IO.Primitive.Infinite
open import Codata.Musical.Costring

main = putStrLn (toCostring "Hello World!")