------------------------------------------------------------------------
-- Do the parser combinators form a Kleene algebra?
------------------------------------------------------------------------

module TotalParserCombinators.Laws.KleeneAlgebra where

open import Algebra
open import Data.List
open import Data.List.Properties
open import Data.Nat using (ℕ)
open import Data.Product using (_,_; proj₂)
open import Function using (_$_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence
  using (_⇔_; equivalence; module Equivalence)
import Relation.Binary.PropositionalEquality as P
open import Relation.Nullary

open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics
  hiding (_>>=_) renaming (return to return′; _⊛_ to _⊛′_)

------------------------------------------------------------------------
-- A variant of _≲_

infix 4 _≲′_

-- The AdditiveMonoid module shows that _∣_ can be viewed as the join
-- operation of a join-semilattice (if language equivalence is used).
-- This means that the following definition of order is natural.

_≲′_ : ∀ {Tok R xs₁ xs₂} → Parser Tok R xs₁ → Parser Tok R xs₂ → Set₁
p₁ ≲′ p₂ = p₁ ∣ p₂ ≈ p₂

-- This order coincides with _≲_.

≲⇔≲′ : ∀ {Tok R xs₁ xs₂}
       (p₁ : Parser Tok R xs₁) (p₂ : Parser Tok R xs₂) →
       p₁ ≲ p₂ ⇔ p₁ ≲′ p₂
≲⇔≲′ {xs₁ = xs₁} p₁ p₂ = equivalence
  (λ (p₁≲p₂ : p₁ ≲ p₂) {x s} → equivalence (helper p₁≲p₂) (∣-right xs₁))
  (λ (p₁≲′p₂ : p₁ ≲′ p₂) s∈p₁ → Equivalence.to p₁≲′p₂ ⟨$⟩ ∣-left s∈p₁)
  where
  helper : p₁ ≲ p₂ → p₁ ∣ p₂ ≲ p₂
  helper p₁≲p₂ (∣-left       s∈p₁) = p₁≲p₂ s∈p₁
  helper p₁≲p₂ (∣-right .xs₁ s∈p₂) = s∈p₂

------------------------------------------------------------------------
-- A limited notion of *-continuity

-- Least upper bounds.

record _LeastUpperBoundOf_
         {Tok R xs} {f : ℕ → List R}
         (lub : Parser Tok R xs)
         (p : (n : ℕ) → Parser Tok R (f n)) : Set₁ where
  field
    upper-bound : ∀ n → p n ≲ lub
    least       : ∀ {ys} {ub : Parser Tok R ys} →
                  (∀ n → p n ≲ ub) → lub ≲ ub

-- For argument parsers which are not nullable we can prove that the
-- Kleene star operator is *-continuous.

*-continuous :
  ∀ {Tok R₁ R₂ R₃ fs xs}
  (p₁ : Parser Tok (List R₁ → R₂ → R₃) fs)
  (p₂ : Parser Tok R₁ [])
  (p₃ : Parser Tok R₂ xs) →
  (p₁ ⊛ p₂ ⋆ ⊛ p₃) LeastUpperBoundOf (λ n → p₁ ⊛ p₂ ↑ n ⊛ p₃)
*-continuous {Tok} {R₁ = R₁} {R₃ = R₃} {fs} {xs} p₁ p₂ p₃ =
  record { upper-bound = upper-bound; least = least }
  where
  upper-bound : ∀ n → p₁ ⊛ p₂ ↑ n ⊛ p₃ ≲ p₁ ⊛ p₂ ⋆ ⊛ p₃
  upper-bound n (∈p₁ ⊛′ ∈p₂ⁿ ⊛′ ∈p₃) =
    [ ○ - ○ ] [ ○ - ○ ] ∈p₁ ⊛ Exactly.↑≲⋆ n ∈p₂ⁿ ⊛ ∈p₃

  least : ∀ {ys} {p : Parser Tok R₃ ys} →
          (∀ i → p₁ ⊛ p₂ ↑ i ⊛ p₃ ≲ p) → p₁ ⊛ p₂ ⋆ ⊛ p₃ ≲ p
  least ub (∈p₁ ⊛′ ∈p₂⋆ ⊛′ ∈p₃) with Exactly.⋆≲∃↑ ∈p₂⋆
  ... | (n , ∈p₂ⁿ) = ub n ([ ○ - ○ ] [ ○ - ○ ] ∈p₁ ⊛ ∈p₂ⁿ ⊛ ∈p₃)

------------------------------------------------------------------------
-- The parser combinators do not form a Kleene algebra

-- If we allow arbitrary argument parsers, then we cannot prove the
-- following (variant of a) Kleene algebra axiom.

not-Kleene-algebra :
  ∀ {Tok} →
  Tok →
  (f : ∀ {R xs} → Parser Tok R xs → List (List R)) →
  (_⋆′ : ∀ {R xs} (p : Parser Tok R xs) →
         Parser Tok (List R) (f p)) →
  ¬ (∀ {R xs} {p : Parser Tok R xs} →
     return [] ∣ (p >>= λ x → (p ⋆′) >>= λ xs → return (x ∷ xs))
       ≲ (p ⋆′))
not-Kleene-algebra {Tok} t f _⋆′ fold =
  KleeneStar.unrestricted-incomplete t f _⋆′ ⋆′-complete
  where
  ⋆′-complete : ∀ {xs ys s} {p : Parser Tok Tok ys} →
                xs ∈[ p ]⋆· s → xs ∈ p ⋆′ · s
  ⋆′-complete []         = fold (∣-left return′)
  ⋆′-complete (∈p ∷ ∈p⋆) =
    fold (∣-right [ [] ]
            ([ ○ - ○ ] ∈p >>=
                       fix ([ ○ - ○ ] ⋆′-complete ∈p⋆ >>= return′)))
    where
    fix = cast∈ P.refl P.refl $ ++-identityʳ _

-- This shows that the parser combinators do not form a Kleene
-- algebra (interpreted liberally) using _⊛_ for composition, return
-- for unit, etc. However, it should be straightforward to build a
-- recogniser library, based on the parser combinators, which does
-- satisfy the Kleene algebra axioms (see
-- TotalRecognisers.LeftRecursion.KleeneAlgebra).


-- Andreas, 2015-10-05, issue reported by mechvel, test case by Jesper Cockx

-- {-# OPTIONS -v tc.term.exlam:20 #-}

abstract
  foo : Set₁
  foo = Set
    where
      AbstractSet₁ : Set₂
      AbstractSet₁ = Set₁
      f : Set → AbstractSet₁
      f = λ { _ → Set }

{-# NON_TERMINATING #-}
loop : Set → Set
loop = λ { A → loop A }


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

open import Oscar.Class
open import Oscar.Class.Reflexivity
open import Oscar.Class.Symmetry
open import Oscar.Class.Transitivity
open import Oscar.Class.Transleftidentity
open import Oscar.Prelude

module Test.ProblemWithDerivation-5 where

module Map
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  {𝔯₁₂} {𝔯₁₂'}
  (ℜ₁₂ : 𝔛₁ → 𝔛₂ → Ø 𝔯₁₂)
  (ℜ₁₂' : 𝔛₁ → 𝔛₂ → Ø 𝔯₁₂')
  = ℭLASS (ℜ₁₂ , ℜ₁₂')
          (∀ P₁ P₂
           → ℜ₁₂ P₁ P₂ → ℜ₁₂' P₁ P₂)

module _
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  {𝔯₁₂} {ℜ₁₂ : 𝔛₁ → 𝔛₂ → Ø 𝔯₁₂}
  {𝔯₁₂'} {ℜ₁₂' : 𝔛₁ → 𝔛₂ → Ø 𝔯₁₂'}
  where
  map = Map.method ℜ₁₂ ℜ₁₂'

module _
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔯₁₂} {ℜ₁₂ : 𝔛₁ → 𝔛₁ → Ø 𝔯₁₂}
  {𝔯₁₂'} {ℜ₁₂' : 𝔛₁ → 𝔛₁ → Ø 𝔯₁₂'}
  where
  smap = Map.method ℜ₁₂ ℜ₁₂' -- FIXME this looks like a viable solution; but what if `-MapFromTransleftidentity` builds something addressable by smap (i.e., where 𝔛₁ ≡ 𝔛₂)?

module _
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  {𝔯₁₂} {ℜ₁₂ : 𝔛₁ → 𝔛₂ → Ø 𝔯₁₂}
  where
  hmap = Map.method ℜ₁₂ ℜ₁₂

postulate
  A : Set
  B : Set
  _~A~_ : A → A → Set
  _~B~_ : B → B → Set
  s1 : A → B
  f1 : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y

instance
  𝓢urjectivity1 : Map.class
                    {𝔛₁ = A}
                    {𝔛₂ = A}
                    _~A~_ (λ x y → s1 x ~B~ s1 y)
  𝓢urjectivity1 .⋆ _ _ = f1

-- Oscar.Class.Hmap.Transleftidentity
instance
  postulate
    -MapFromTransleftidentity : ∀
      {𝔵} {𝔛 : Ø 𝔵}
      {𝔞} {𝔄 : 𝔛 → Ø 𝔞}
      {𝔟} {𝔅 : 𝔛 → Ø 𝔟}
      (let _∼_ = Arrow 𝔄 𝔅)
      {ℓ̇} {_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ̇}
      {transitivity : Transitivity.type _∼_}
      {reflexivity : Reflexivity.type _∼_}
      {ℓ}
      ⦃ _ : Transleftidentity.class _∼_ _∼̇_ reflexivity transitivity ⦄
      → ∀ {m n}
      → Map.class {𝔛₁ = Arrow 𝔄 𝔅 m n}
                  {𝔛₂ = LeftExtensionṖroperty ℓ (Arrow 𝔄 𝔅) _∼̇_ m}
                  (λ f P → π₀ (π₀ P) f)
                  (λ f P → π₀ (π₀ P) (transitivity f reflexivity))

test-before : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y
test-before = map _ _

postulate
  XX : Set
  BB : XX → Set
  EQ : ∀ {x y} → Arrow BB BB x y → Arrow BB BB x y → Set

instance
  postulate
    -transleftidentity : Transleftidentity.class (Arrow BB BB) EQ (λ x₁ → magic) (λ x₁ x₂ x₃ → magic)

test-after : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y
test-after {x} {y} = map _ _ -- FIXME yellow

test-after-s : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y
test-after-s {x} {y} = smap _ _

testr : ∀ {m n ℓ}
          (P₁ : Arrow BB BB m n)
          (P₂ : LeftExtensionṖroperty ℓ (Arrow BB BB) EQ m)
          → π₀ (π₀ P₂) P₁ → π₀ (π₀ P₂) (flip {∅̂} {∅̂} {∅̂}
                                         {Arrow (λ z → BB z) (λ z → BB z) m n}
                                         {Arrow (λ z → BB z) (λ z → BB z) n n}
                                         {λ _ _ → Arrow BB BB m n}
                                         (λ _ _ _ → magic) (λ _ → magic) P₁)
testr = map


module CoInf where

open import Codata.Musical.Notation

-- Check that ∞ can be used as an "expression".
test : Set → Set
test = ∞


open import Data.String using ( _++_ )
open import System.IO using ( _>>_ ; _>>=_ ; getStr ; putStr ; commit )

module System.IO.Examples.HelloUser where

main =
  putStr "What is your name?\n" >>
  commit >>
  getStr >>= λ name →
  putStr ("Hello, " ++ name ++ "\n") >>
  commit


module HOAny where

open import Agda.Builtin.Nat
open import Agda.Builtin.Bool

data Wrapper (M : Set → Set) : Set where
  mnat  : M Nat → Wrapper M
  mbool : M Bool → Wrapper M

{-# FOREIGN GHC data AgdaWrapper m = Mnat (m Integer) | Mbool (m Bool) #-}
{-# COMPILE GHC Wrapper = data AgdaWrapper (Mnat | Mbool) #-}

map : ∀ {M N} → (∀ {n} → M n → N n) → Wrapper M → Wrapper N
map f (mnat mn)  = mnat (f mn)
map f (mbool mb) = mbool (f mb)

-- Higher-order use of Any in the compiled code:

-- data AgdaWrapper m = Mnat (m Integer) | Mbool (m Bool)

-- map ::
--  (() -> ()) ->
--  (() -> ()) ->
--  (() -> AgdaAny -> AgdaAny) -> AgdaWrapper AgdaAny -> AgdaWrapper AgdaAny

-- WAS:
-- The expected kind to AgdaWrapper's argument is * -> *
-- but AgdaAny's kind is *

-- WANT: SUCCESS
-- made possible by making AgdaAny poly-kinded

open import Common.Prelude

main : IO Unit
main = putStrLn ""


{-# OPTIONS --cubical --safe #-}
module Cubical.ZCohomology.Everything where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties

open import Cubical.ZCohomology.S1.S1


{- 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 Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Base.Types
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Handle sha256 sha256-cr
open        EpochConfig
open import LibraBFT.Yasm.Base (ℓ+1 0ℓ) EpochConfig epochId authorsN

-- In this module, we instantiate the system model with parameters to
-- model a system using the simple implementation model we have so
-- far, which aims to obey the VotesOnceRule, but not LockedRoundRule
-- yet.  This will evolve as we build out a model of a real
-- implementation.

module LibraBFT.Concrete.System.Parameters where
 ConcSysParms : SystemParameters
 ConcSysParms = mkSysParms
                 NodeId
                 _≟NodeId_
                 EventProcessor
                 fakeEP
                 NetworkMsg
                 Vote
                 sig-Vote
                 _⊂Msg_
                 (_^∙ vEpoch)
                 initialEventProcessorAndMessages
                 peerStepWrapper


-- Algorithmic equality.

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

module Definition.Conversion where

open import Definition.Untyped
open import Definition.Typed

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

infix 10 _⊢_~_↑_
infix 10 _⊢_~_↓_
infix 10 _⊢_[conv↑]_
infix 10 _⊢_[conv↓]_
infix 10 _⊢_[conv↑]_∷_
infix 10 _⊢_[conv↓]_∷_

mutual
  -- Neutral equality.
  data _⊢_~_↑_ (Γ : Con Term) : (k l A : Term) → Set where
    var-refl      : ∀ {x y A}
                  → Γ ⊢ var x ∷ A
                  → x PE.≡ y
                  → Γ ⊢ var x ~ var y ↑ A
    app-cong      : ∀ {k l t v F G}
                  → Γ ⊢ k ~ l ↓ Π F ▹ G
                  → Γ ⊢ t [conv↑] v ∷ F
                  → Γ ⊢ k ∘ t ~ l ∘ v ↑ G [ t ]
    fst-cong      : ∀ {p r F G}
                  → Γ ⊢ p ~ r ↓ Σ F ▹ G
                  → Γ ⊢ fst p ~ fst r ↑ F
    snd-cong      : ∀ {p r F G}
                  → Γ ⊢ p ~ r ↓ Σ F ▹ G
                  → Γ ⊢ snd p ~ snd r ↑ G [ fst p ]
    natrec-cong   : ∀ {k l h g a₀ b₀ F G}
                  → Γ ∙ ℕ ⊢ F [conv↑] G
                  → Γ ⊢ a₀ [conv↑] b₀ ∷ F [ zero ]
                  → Γ ⊢ h [conv↑] g ∷ Π ℕ ▹ (F ▹▹ F [ suc (var 0) ]↑)
                  → Γ ⊢ k ~ l ↓ ℕ
                  → Γ ⊢ natrec F a₀ h k ~ natrec G b₀ g l ↑ F [ k ]
    Emptyrec-cong : ∀ {k l F G}
                  → Γ ⊢ F [conv↑] G
                  → Γ ⊢ k ~ l ↓ Empty
                  → Γ ⊢ Emptyrec F k ~ Emptyrec G l ↑ F

  -- Neutral equality with types in WHNF.
  record _⊢_~_↓_ (Γ : Con Term) (k l B : Term) : Set where
    inductive
    constructor [~]
    field
      A     : Term
      D     : Γ ⊢ A ⇒* B
      whnfB : Whnf B
      k~l   : Γ ⊢ k ~ l ↑ A

  -- Type equality.
  record _⊢_[conv↑]_ (Γ : Con Term) (A B : Term) : Set where
    inductive
    constructor [↑]
    field
      A′ B′  : Term
      D      : Γ ⊢ A ⇒* A′
      D′     : Γ ⊢ B ⇒* B′
      whnfA′ : Whnf A′
      whnfB′ : Whnf B′
      A′<>B′ : Γ ⊢ A′ [conv↓] B′

  -- Type equality with types in WHNF.
  data _⊢_[conv↓]_ (Γ : Con Term) : (A B : Term) → Set where
    U-refl     : ⊢ Γ → Γ ⊢ U [conv↓] U
    ℕ-refl     : ⊢ Γ → Γ ⊢ ℕ [conv↓] ℕ
    Empty-refl : ⊢ Γ → Γ ⊢ Empty [conv↓] Empty
    Unit-refl  : ⊢ Γ → Γ ⊢ Unit [conv↓] Unit
    ne         : ∀ {K L}
               → Γ ⊢ K ~ L ↓ U
               → Γ ⊢ K [conv↓] L
    Π-cong     : ∀ {F G H E}
               → Γ ⊢ F
               → Γ ⊢ F [conv↑] H
               → Γ ∙ F ⊢ G [conv↑] E
               → Γ ⊢ Π F ▹ G [conv↓] Π H ▹ E
    Σ-cong     : ∀ {F G H E}
               → Γ ⊢ F
               → Γ ⊢ F [conv↑] H
               → Γ ∙ F ⊢ G [conv↑] E
               → Γ ⊢ Σ F ▹ G [conv↓] Σ H ▹ E

  -- Term equality.
  record _⊢_[conv↑]_∷_ (Γ : Con Term) (t u A : Term) : Set where
    inductive
    constructor [↑]ₜ
    field
      B t′ u′ : Term
      D       : Γ ⊢ A ⇒* B
      d       : Γ ⊢ t ⇒* t′ ∷ B
      d′      : Γ ⊢ u ⇒* u′ ∷ B
      whnfB   : Whnf B
      whnft′  : Whnf t′
      whnfu′  : Whnf u′
      t<>u    : Γ ⊢ t′ [conv↓] u′ ∷ B

  -- Term equality with types and terms in WHNF.
  data _⊢_[conv↓]_∷_ (Γ : Con Term) : (t u A : Term) → Set where
    ℕ-ins     : ∀ {k l}
              → Γ ⊢ k ~ l ↓ ℕ
              → Γ ⊢ k [conv↓] l ∷ ℕ
    Empty-ins : ∀ {k l}
              → Γ ⊢ k ~ l ↓ Empty
              → Γ ⊢ k [conv↓] l ∷ Empty
    Unit-ins  : ∀ {k l}
              → Γ ⊢ k ~ l ↓ Unit
              → Γ ⊢ k [conv↓] l ∷ Unit
    ne-ins    : ∀ {k l M N}
              → Γ ⊢ k ∷ N
              → Γ ⊢ l ∷ N
              → Neutral N
              → Γ ⊢ k ~ l ↓ M
              → Γ ⊢ k [conv↓] l ∷ N
    univ      : ∀ {A B}
              → Γ ⊢ A ∷ U
              → Γ ⊢ B ∷ U
              → Γ ⊢ A [conv↓] B
              → Γ ⊢ A [conv↓] B ∷ U
    zero-refl : ⊢ Γ → Γ ⊢ zero [conv↓] zero ∷ ℕ
    suc-cong  : ∀ {m n}
              → Γ ⊢ m [conv↑] n ∷ ℕ
              → Γ ⊢ suc m [conv↓] suc n ∷ ℕ
    η-eq      : ∀ {f g F G}
              → Γ ⊢ f ∷ Π F ▹ G
              → Γ ⊢ g ∷ Π F ▹ G
              → Function f
              → Function g
              → Γ ∙ F ⊢ wk1 f ∘ var 0 [conv↑] wk1 g ∘ var 0 ∷ G
              → Γ ⊢ f [conv↓] g ∷ Π F ▹ G
    Σ-η       : ∀ {p r F G}
              → Γ ⊢ p ∷ Σ F ▹ G
              → Γ ⊢ r ∷ Σ F ▹ G
              → Product p
              → Product r
              → Γ ⊢ fst p [conv↑] fst r ∷ F
              → Γ ⊢ snd p [conv↑] snd r ∷ G [ fst p ]
              → Γ ⊢ p [conv↓] r ∷ Σ F ▹ G
    η-unit    : ∀ {k l}
              → Γ ⊢ k ∷ Unit
              → Γ ⊢ l ∷ Unit
              → Whnf k
              → Whnf l
              → Γ ⊢ k [conv↓] l ∷ Unit

star-refl : ∀ {Γ} → ⊢ Γ → Γ ⊢ star [conv↓] star ∷ Unit
star-refl ⊢Γ = η-unit (starⱼ ⊢Γ) (starⱼ ⊢Γ) starₙ starₙ


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn(x : X) where
  open X (x) public
  open import OutsideIn.Prelude public
  open import Data.Vec public hiding ([_])
  import OutsideIn.Constraints as C
  import OutsideIn.TypeSchema as TS
  import OutsideIn.Expressions as E
  import OutsideIn.Environments as V
  import OutsideIn.TopLevel as TL
  import OutsideIn.Inference as I
  open E (x) public
  open TL(x) public
  open TS(x) public
  open I (x) public
  open V (x) public
  open C (x)


module _ where

postulate
  A B : Set

{-# DISPLAY A = B #-}
{-# DISPLAY B = A #-}

loop : A
loop = {!!}


-- Check that unquoted functions are termination checked.
module _ where

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

`⊥ : Type
`⊥ = def (quote ⊥) []

{-
Generate
  aux : ⊥
  aux = aux

  loop : ⊥
  loop = aux
-}
makeLoop : QName → TC ⊤
makeLoop loop =
  freshName "aux" >>= λ aux →
  declareDef (vArg aux) `⊥ >>= λ _ →
  defineFun aux (clause [] (def aux []) ∷ []) >>= λ _ →
  declareDef (vArg loop) `⊥ >>= λ _ →
  defineFun loop (clause [] (def aux []) ∷ [])

unquoteDecl loop = makeLoop loop


module Category.Fibration where

open import Data.Product

open import Category.Category
open import Category.Subcategory
open import Category.Funct


------------------------------------------------------------------------
-- A variant of Coherently with an erased field
------------------------------------------------------------------------

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

import Equality.Path as P

module Lens.Non-dependent.Higher.Coherently.Coinductive.Erased
  {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 Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J as B using (_↔_)
import Bijection P.equality-with-J as PB
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 Equivalence.Erased equality-with-J as EEq using (_≃ᴱ_)
open import Function-universe equality-with-J hiding (_∘_)
import Function-universe P.equality-with-J as PF
open import H-level.Truncation.Propositional.One-step eq as O
  using (∥_∥¹; ∥∥¹ᴱ→∥∥¹)
open import H-level.Truncation.Propositional.One-step.Erased eq as OE
  using (∥_∥¹ᴱ)
open import Univalence-axiom equality-with-J
import Univalence-axiom P.equality-with-J as PU

open import Lens.Non-dependent.Higher.Coherently.Coinductive eq as C
  using (Coherently)

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

-- A variant of
-- Lens.Non-dependent.Higher.Coherently.Coinductive.Coherently with an
-- erased "coherent" field.

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

open Coherentlyᴱ public

-- A preservation lemma for Coherentlyᴱ. (See also Coherentlyᴱ-cong
-- below.)

@0 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₂

-- Coherently can be converted to Coherentlyᴱ in a certain way
-- (assuming univalence).

Coherently→Coherentlyᴱ :
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B} →
  @0 Univalence a →
  Coherently P step f → Coherentlyᴱ P (λ f p → step f p ∘ ∥∥¹ᴱ→∥∥¹) f
Coherently→Coherentlyᴱ _    c .property = c .C.property
Coherently→Coherentlyᴱ univ c .coherent =
  Coherently→Coherentlyᴱ univ
    (_≃_.from (C.Coherently-cong′ univ O.∥∥¹ᴱ≃∥∥¹)
       (c .C.coherent))

-- In erased contexts Coherently and Coherentlyᴱ are, in a certain
-- sense, logically equivalent (assuming univalence).

@0 Coherentlyᴱ⇔Coherently :
  {P : {A : Type a} → (A → B) → Type p}
  {step : {A : Type a} (f : A → B) → P f → ∥ A ∥¹ → B} →
  Univalence a →
  Coherentlyᴱ P (λ f p → step f p ∘ ∥∥¹ᴱ→∥∥¹) f ⇔ Coherently P step f
Coherentlyᴱ⇔Coherently univ ._⇔_.from = Coherently→Coherentlyᴱ univ

Coherentlyᴱ⇔Coherently univ ._⇔_.to c .C.property = c .property
Coherentlyᴱ⇔Coherently univ ._⇔_.to c .C.coherent =
  Coherentlyᴱ⇔Coherently univ ._⇔_.to
    (_≃_.to (Coherentlyᴱ-cong′ univ O.∥∥¹ᴱ≃∥∥¹)
       (c .coherent))

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.⟨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)

    Σ-≡,≡→≡′ :
      {P : A → Type b} {p₁ p₂ : Σ A P} →
      (p : proj₁ p₁ P.≡ proj₁ p₂) →
      P.subst P p (proj₂ p₁) P.≡ proj₂ p₂ →
      p₁ P.≡ p₂
    Σ-≡,≡→≡′ {P = P} {p₁ = _ , y₁} {p₂ = _ , y₂} p q i =
      p i , lemma i
      where
      lemma : P.[ (λ i → P (p i)) ] y₁ ≡ y₂
      lemma = PB._↔_.from (P.heterogeneous↔homogeneous _) q

  -- 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}
    {@0 step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ᴱ → B}
    {@0 step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ᴱ → B}
    {f : A → B} →
    @0 Univalence p →
    (P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ᴱ P₂ f) →
    @0 ({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 →
    EEq.[≃]→≃ᴱ
      (EEq.[proofs]
         (Eq.with-other-inverse
            (Eq.with-other-function
               (equiv bl)
               (to bl)
               (_↔_.from ≡↔≡ ∘ ≡to bl))
            (from bl)
            (_↔_.from ≡↔≡ ∘ ≡from bl)))

    where

    @0 equiv :
      Block "Coherentlyᴱ-cong-≡" →
      Coherentlyᴱ P₁ step₁ f ≃ Coherentlyᴱ P₂ step₂ f
    equiv bl =
      _↔_.from ≃↔≃ $ PU.≡⇒≃ $
      Coherentlyᴱ-cong-≡ bl univ (EEq.≃ᴱ→≃ ∘ 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 (EEq.≃ᴱ→≃ ∘ P₁≃P₂) step₁≡step₂ c) $
      _≃_.to (equiv bl) c .coherent

    @0 ≡to : ∀ bl c → _≃_.to (equiv bl) c P.≡ to bl c
    ≡to bl c i .property = to-Coherentlyᴱ-cong-≡-property
                             bl univ (EEq.≃ᴱ→≃ ∘ 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 (EEq.≃ᴱ→≃ ∘ 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 (EEq.≃ᴱ→≃ ∘ 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 (EEq.≃ᴱ→≃ ∘ P₁≃P₂) step₁≡step₂ c) $
      _≃_.from (equiv bl) c .coherent

    @0 ≡from : ∀ bl c → _≃_.from (equiv bl) c P.≡ from bl c
    ≡from bl c i .property = from-Coherentlyᴱ-cong-≡-property
                               bl univ (EEq.≃ᴱ→≃ ∘ 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 (EEq.≃ᴱ→≃ ∘ 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 (EEq.≃ᴱ→≃ ∘ 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}
    {@0 step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ᴱ → B}
    {@0 step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ᴱ → B}
    {f : A → B}
    {@0 univ : Univalence p}
    {P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ᴱ P₂ f}
    {@0 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}
    {@0 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₂}
  {@0 step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ᴱ → B}
  {@0 step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ᴱ → B}
  {f : A → B} →
  @0 Univalence (p₁ ⊔ p₂) →
  (P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ᴱ P₂ f) →
  @0 ({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₂}
  {@0 step₁ : {A : Type a} (f : A → B) → P₁ f → ∥ A ∥¹ᴱ → B}
  {@0 step₂ : {A : Type a} (f : A → B) → P₂ f → ∥ A ∥¹ᴱ → B}
  {f : A → B}
  {@0 univ : Univalence (p₁ ⊔ p₂)}
  {P₁≃P₂ : {A : Type a} (f : A → B) → P₁ f ≃ᴱ P₂ f}
  {@0 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 "computation rule".

subst-Coherentlyᴱ-property :
  ∀ {B : Type b} {P : C → {A : Type a} → (A → B) → Type p}
    {@0 step : (c : C) {A : Type a} (f : A → B) → P c f → ∥ A ∥¹ᴱ → B}
    {f : C → A → 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


------------------------------------------------------------------------
-- IO
------------------------------------------------------------------------

{-# OPTIONS --no-termination-check #-}

module IO where

open import Coinduction
open import Data.Unit
open import Data.String
open import Data.Colist
import Foreign.Haskell as Haskell
import IO.Primitive as Prim

------------------------------------------------------------------------
-- The IO monad

-- One cannot write "infinitely large" computations with the
-- postulated IO monad in IO.Primitive without turning off the
-- termination checker (or going via the FFI, or perhaps abusing
-- something else). The following coinductive deep embedding is
-- introduced to avoid this problem. Possible non-termination is
-- isolated to the run function below.

infixl 1 _>>=_ _>>_

data IO : Set → Set₁ where
  lift   : ∀ {A} (m : Prim.IO A) → IO A
  return : ∀ {A} (x : A) → IO A
  _>>=_  : ∀ {A B} (m : ∞₁ (IO A)) (f : (x : A) → ∞₁ (IO B)) → IO B
  _>>_   : ∀ {A B} (m₁ : ∞₁ (IO A)) (m₂ : ∞₁ (IO B)) → IO B

-- The use of abstract ensures that the run function will not be
-- unfolded infinitely by the type checker.

abstract

  run : ∀ {A} → IO A → Prim.IO A
  run (lift m)   = m
  run (return x) = Prim.return x
  run (m  >>= f) = Prim._>>=_ (run (♭₁ m )) λ x → run (♭₁ (f x))
  run (m₁ >> m₂) = Prim._>>=_ (run (♭₁ m₁)) λ _ → run (♭₁ m₂)

------------------------------------------------------------------------
-- Utilities

-- Because IO A lives in Set₁ I hesitate to define sequence, which
-- would require defining a Set₁ variant of Colist.

mapM : ∀ {A B} → (A → IO B) → Colist A → IO (Colist B)
mapM f []       = return []
mapM f (x ∷ xs) = ♯₁ f x               >>= λ y  →
                  ♯₁ (♯₁ mapM f (♭ xs) >>= λ ys →
                  ♯₁ return (y ∷ ♯ ys))

-- The reason for not defining mapM′ in terms of mapM is efficiency
-- (the unused results could cause unnecessary memory use).

mapM′ : ∀ {A B} → (A → IO B) → Colist A → IO ⊤
mapM′ f []       = return _
mapM′ f (x ∷ xs) = ♯₁ f x >> ♯₁ mapM′ f (♭ xs)

------------------------------------------------------------------------
-- Simple lazy IO (UTF8-based)

getContents : IO Costring
getContents =
  ♯₁ lift Prim.getContents >>= λ s →
  ♯₁ return (Haskell.toColist s)

readFile : String → IO Costring
readFile f =
  ♯₁ lift (Prim.readFile f) >>= λ s →
  ♯₁ return (Haskell.toColist s)

writeFile∞ : String → Costring → IO ⊤
writeFile∞ f s =
  ♯₁ lift (Prim.writeFile f (Haskell.fromColist s)) >>
  ♯₁ return _

writeFile : String → String → IO ⊤
writeFile f s = writeFile∞ f (toCostring s)

putStr∞ : Costring → IO ⊤
putStr∞ s =
  ♯₁ lift (Prim.putStr (Haskell.fromColist s)) >>
  ♯₁ return _

putStr : String → IO ⊤
putStr s = putStr∞ (toCostring s)

putStrLn∞ : Costring → IO ⊤
putStrLn∞ s =
  ♯₁ lift (Prim.putStrLn (Haskell.fromColist s)) >>
  ♯₁ return _

putStrLn : String → IO ⊤
putStrLn s = putStrLn∞ (toCostring s)


{- 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
-}

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

open import LibraBFT.Base.Types
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Util.Crypto
open import Optics.All
open import Util.Encode
open import Util.KVMap                            as Map
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId

-- This module defines types for connecting abstract and concrete
-- votes by defining what constitutes enough "evidence" that a
-- vote was cast, which is passed around in the abstract model as
-- the variable (𝓥 : VoteEvidence); here we instantiate it to
-- 'ConcreteVoteEvidence'.
--
-- Some of the types in this module depend on an EpochConfig, but
-- never inspect it. Consequently, we define everything over an
-- abstract 𝓔 passed around as module parameter to an inner module
-- WithEC.  Before that, we define some definitions relevant to
-- constructing EpochConfigs from RoundManager.

module LibraBFT.ImplShared.Consensus.Types.EpochDep where

-- Note that the definitions below are relevant only to the verification, not the implementation.
-- They should probably move somewhere else.

-- ValidatorVerifier-correct imposes requirements on a ValidatorVerifier that are sufficient to
-- ensure that we can construct an abstract EpochConfig based on it (see α-EC-VV below).
ValidatorVerifier-correct : ValidatorVerifier → Set
ValidatorVerifier-correct vv =
  let authorsInfo    = List-map proj₂ (kvm-toList (vv ^∙ vvAddressToValidatorInfo))
      totalVotPower  = f-sum (_^∙ vciVotingPower) authorsInfo
      quorumVotPower = vv ^∙ vvQuorumVotingPower
      bizF           = totalVotPower ∸ quorumVotPower
      pksAll≢        = ∀ v₁ v₂ nId₁ nId₂ → nId₁ ≢ nId₂
                       → lookup nId₁ (vv ^∙ vvAddressToValidatorInfo) ≡ just v₁
                       → lookup nId₂ (vv ^∙ vvAddressToValidatorInfo) ≡ just v₂
                       → v₁ ^∙ vciPublicKey ≢ v₂ ^∙ vciPublicKey
   in   3 * bizF       < totalVotPower
      × quorumVotPower ≤ totalVotPower
      × pksAll≢
      × f-sum (_^∙ vciVotingPower) (List-filter (Meta-DishonestPK? ∘ (_^∙ vciPublicKey)) authorsInfo) ≤ bizF

open DecLemmas {A = NodeId} _≟_
import LibraBFT.Abstract.BFT

-- α-EC-VV computes an abstract EpochConfig given a ValidatorVerifier
-- that satisfies the conditions stipulated by ValidVerifier-correct
α-EC-VV : Σ ValidatorVerifier ValidatorVerifier-correct → Epoch → EpochConfig
α-EC-VV (vv , ok) epoch =
      EpochConfig∙new bsId
                      epoch
                      numAuthors
                      toNodeId
                      (list-index (_≟_ ∘ proj₁) authors)
                      (index∘lookup-id authors proj₁ authorsIDs≢)
                      (λ lkp≡α → lookup∘index-id authors proj₁ authorsIDs≢ lkp≡α)
                      getPubKey
                      getPKey-Inj
                      (λ quorum → qsize ≤ VotPowerMembers quorum
                                   × allDistinct quorum)
                      λ q₁ q₂ → LibraBFT.Abstract.BFT.bft-lemma
                                  numAuthors
                                  (_^∙ vciVotingPower ∘ getAuthorInfo)
                                  (f-sum (_^∙ vciVotingPower) authorsInfo ∸ qsize)
                                  (≤-trans (proj₁ ok) (≡⇒≤ totalVotPower≡))
                                  getPubKey
                                  (let disMembers  = List-filter (Meta-DishonestPK? ∘ getPubKey) members
                                       sumDisM≡    = sum-f∘g disMembers (_^∙ vciVotingPower) getAuthorInfo
                                       disM≡disNId = map∘filter members authorsInfo getAuthorInfo
                                                                (Meta-DishonestPK? ∘ (_^∙ vciPublicKey)) getAuthInfo≡VCI
                                       sumDis≤bizF = (proj₂ ∘ proj₂ ∘ proj₂) ok
                                   in ≤-trans (≡⇒≤ (trans sumDisM≡ (cong (f-sum _vciVotingPower) disM≡disNId))) sumDis≤bizF)
                                  (proj₂ q₁) (proj₂ q₂)
                                  (≤-trans (≡⇒≤ N∸bizF≡Qsize) (proj₁ q₁))
                                  (≤-trans (≡⇒≤ N∸bizF≡Qsize) (proj₁ q₂))
                              -- TODO-2: this takes the per-epoch genesisUID from the GenesisInfo
                              -- for the *first* epoch (soon to be renamed to BootStrapInfo avoid
                              -- this confusion).  This is temporary until we do epoch change; then
                              -- it will need to be provided by the caller.
      where bsId            = fakeBootstrapInfo ^∙ bsiLIWS ∙ liwsLedgerInfo ∙ liConsensusDataHash
            authorsMap      = vv ^∙ vvAddressToValidatorInfo
            authors         = kvm-toList authorsMap
            authorsIDs≢     = kvm-keys-All≢ authorsMap
            authorsInfo     = List-map proj₂ authors
            numAuthors      = length authors
            members         = allFin numAuthors
            qsize           = vv ^∙ vvQuorumVotingPower
            toNodeId        = proj₁ ∘ List-lookup authors
            getAuthorInfo   = proj₂ ∘ List-lookup authors
            getPubKey       = _^∙ vciPublicKey ∘ getAuthorInfo
            VotPowerMembers = f-sum (_^∙ vciVotingPower ∘ getAuthorInfo)
            VotPowerAuthors = f-sum (_^∙ vciVotingPower)
            bizF            = VotPowerAuthors authorsInfo ∸ qsize
            getAuthInfo≡VCI : List-map getAuthorInfo members ≡ authorsInfo
            getAuthInfo≡VCI = trans (List-map-compose members) (cong (List-map proj₂) (map-lookup-allFin authors))
            totalVotPower≡  : VotPowerAuthors authorsInfo ≡ VotPowerMembers members
            totalVotPower≡  = let sumf∘g = sum-f∘g members (_^∙ vciVotingPower) getAuthorInfo
                              in sym (trans sumf∘g (cong (f-sum (_^∙ vciVotingPower)) getAuthInfo≡VCI))
            N∸bizF≡Qsize    = subst ((_≡ qsize) ∘ (_∸ bizF)) totalVotPower≡ (m∸[m∸n]≡n ((proj₁ ∘ proj₂) ok))
            getPKey-Inj   : ∀ {m₁ m₂} → getPubKey m₁ ≡ getPubKey m₂ → m₁ ≡ m₂
            getPKey-Inj {m₁} {m₂} pk≡
              with m₁ ≟Fin m₂
            ...| yes m₁≡m₂ = m₁≡m₂
            ...| no  m₁≢m₂ = let nIdm₁≢nIdm₂ = allDistinct-Map {xs = authors} proj₁ authorsIDs≢ m₁≢m₂
                                 pksAll≢ = (proj₁ ∘ proj₂ ∘ proj₂) ok
                             in ⊥-elim (pksAll≢ (getAuthorInfo m₁) (getAuthorInfo m₂)
                                                (toNodeId m₁) (toNodeId m₂) nIdm₁≢nIdm₂
                                                (kvm-toList-lookup authorsMap) (kvm-toList-lookup authorsMap)
                                         pk≡)

postulate -- TODO-2: define BootstrapInfo to match implementation and write these functions
  init-EC : BootstrapInfo → EpochConfig

module WithEC (𝓔 : EpochConfig) where
  open EpochConfig 𝓔
  open WithAbsVote 𝓔

  -- A 'ConcreteVoteEvidence' is a piece of information that
  -- captures that the 'vd : AbsVoteData' in question was not /invented/
  -- but instead, comes from a concrete vote that is /valid/ (that is,
  -- signature has been checked and author belongs to this epoch).
  --
  -- Moreover, we will also store the RecordChain that leads to the vote;
  -- this requires some mutually-recursive shenanigans, so we first declare
  -- ConcreteVoteEvidence, then import the necessary modules, and then define it.
  record ConcreteVoteEvidence (vd : AbsVoteData) : Set

  open import LibraBFT.Abstract.Abstract UID _≟UID_ NodeId 𝓔 ConcreteVoteEvidence as Abs hiding (qcVotes; Vote)

  data VoteCoherence (v : Vote) (b : Abs.Block) : Set where
    initial  : v ^∙ vParentId    ≡ genesisUID
             → v ^∙ vParentRound ≡ 0
             → Abs.bPrevQC b     ≡ nothing
             → VoteCoherence v b

    ¬initial : ∀{b' q}
             → v ^∙ vParentId    ≢ genesisUID
             → v ^∙ vParentRound ≢ 0
             → v ^∙ vParentId    ≡ Abs.bId b'
             → v ^∙ vParentRound ≡ Abs.bRound b'
             → (Abs.B b') ← (Abs.Q q)
             → (Abs.Q q)  ← (Abs.B b)
             → VoteCoherence v b

  -- Estabilishing validity of a concrete vote involves checking:
  --
  --   i) Vote author belongs to the current epoch
  --  ii) Vote signature is correctly verified
  -- iii) Existence of a RecordChain up to the voted-for block.
  --  iv) Coherence of 'vdParent' field with the above record chain.
  --
  record IsValidVote (v : Vote) : Set where
    constructor IsValidVote∙new
    inductive
    field
      _ivvMember   : Member
      _ivvAuthor   : isMember? (_vAuthor v) ≡ just _ivvMember
      _ivvSigned   : WithVerSig (getPubKey _ivvMember) v

      _ivvVDhash   : v ^∙ vLedgerInfo ∙ liConsensusDataHash ≡ hashVD (v ^∙ vVoteData)

      -- A valid vote must vote for a block that exists and is
      -- inserted in a RecordChain.
      _ivvBlock    : Abs.Block
      _ivvBlockId  : v ^∙ vProposedId ≡ Abs.bId _ivvBlock

      -- Moreover; we must check that the 'parent' field of the vote is coherent.
      _ivvCoherent : VoteCoherence v _ivvBlock

      -- Finally, the vote is for the correct epoch
      _ivvEpoch    : v ^∙ vEpoch ≡ epoch
      _ivvEpoch2   : v ^∙ vParent ∙ biEpoch ≡ epoch  -- Not needed?
  open IsValidVote public

  -- A valid vote can be directly mapped to an AbsVoteData. Abstraction of QCs
  -- and blocks will be given in LibraBFT.Concrete.Records, since those are
  -- more involved functions.
  α-ValidVote : (v : Vote) → Member → AbsVoteData
  α-ValidVote v mbr = AbsVoteData∙new (v ^∙ vProposed ∙ biRound)
                                      mbr
                                      (v ^∙ vProposed ∙ biId)

  -- α-ValidVote is the same for two votes that have the same vAuthor, vdProposed and vOrder
  α-ValidVote-≡ : ∀ {cv v'} {m : Member}
                → _vdProposed (_vVoteData cv) ≡ _vdProposed (_vVoteData v')
                → α-ValidVote cv m ≡ α-ValidVote v' m
  α-ValidVote-≡ {cv} {v'} prop≡ =
    AbsVoteData-η (cong _biRound prop≡) refl (cong _biId prop≡)

  -- Finally; evidence for some abstract vote consists of a concrete valid vote
  -- that is coherent with the abstract vote data.
  record ConcreteVoteEvidence vd where
    constructor CVE∙new
    inductive
    field
      _cveVote        : Vote
      _cveIsValidVote : IsValidVote _cveVote
      _cveIsAbs       : α-ValidVote _cveVote (_ivvMember _cveIsValidVote) ≡ vd
  open ConcreteVoteEvidence public

  -- Gets the signature of a concrete vote evidence
  _cveSignature : ∀{vd} → ConcreteVoteEvidence vd → Signature
  _cveSignature = _vSignature ∘ _cveVote

  -- A valid quorum certificate contains a collection of valid votes, such that
  -- the members represented by those votes (which exist because the votes are valid)
  -- constitutes a quorum.
  record MetaIsValidQC (qc : QuorumCert) : Set where
    field
      _ivqcMetaVotesValid      : All (IsValidVote ∘ rebuildVote qc) (qcVotes qc)
      _ivqcMetaIsQuorum        : IsQuorum (All-reduce _ivvMember _ivqcMetaVotesValid)
  open MetaIsValidQC public

  -- A valid TimeoutCertificate has a quorum of signatures that are valid for the current
  -- EpochConfig.  There will be a lot of overlap with MetaIsValidQc and IsValidVote.
  -- TODO-2: flesh out the details.
  postulate -- TODO-1: defined if needed (see draft below)
    MetaIsValidTimeoutCert : TimeoutCertificate → Set

  {-
  record MetaIsValidTimeoutCert (tc : TimeoutCertificate) : Set where
    field
      _ivtcMetaSigsValid :
      _ivtcMetaIsQuorum  :
  -}

  vqcMember : (qc : QuorumCert) → MetaIsValidQC qc
             → ∀ {as} → as ∈ qcVotes qc → Member
  vqcMember qc v {α , _ , _} as∈qc with All-lookup (_ivqcMetaVotesValid v) as∈qc
  ...| prf = _ivvMember prf


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

postulate
  A B : Set
  @0 a : A

tac : Term → TC ⊤
tac = unify (def (quote a) [])

postulate
  f : {@0 @(tactic tac) x : A} → B

test : B
test = f


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

open import HoTT

module groups.HomSequence where

infix 15 _⊣|ᴳ
infixr 10 _→⟨_⟩ᴳ_

data HomSequence {i} : (G : Group i) (H : Group i) → Type (lsucc i) where
  _⊣|ᴳ : (G : Group i) → HomSequence G G
  _→⟨_⟩ᴳ_ : (G : Group i) {H K : Group i}
    → (G →ᴳ H) → HomSequence H K
    → HomSequence G K

HomSeq-++ : ∀ {i} {G H K : Group i}
  → HomSequence G H → HomSequence H K → HomSequence G K
HomSeq-++ (_ ⊣|ᴳ) seq = seq
HomSeq-++ (_ →⟨ φ ⟩ᴳ seq₁) seq₂ = _ →⟨ φ ⟩ᴳ HomSeq-++ seq₁ seq₂

HomSeq-snoc : ∀ {i} {G H K : Group i}
  → HomSequence G H → (H →ᴳ K) → HomSequence G K
HomSeq-snoc seq φ = HomSeq-++ seq (_ →⟨ φ ⟩ᴳ _ ⊣|ᴳ)

{- maps between two hom sequences -}

infix 15 _↓|ᴳ
infixr 10 _↓⟨_⟩ᴳ_

data HomSeqMap {i₀ i₁} : {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
  → HomSequence G₀ H₀ → HomSequence G₁ H₁
  → (G₀ →ᴳ G₁) → (H₀ →ᴳ H₁) → Type (lsucc (lmax i₀ i₁)) where
  _↓|ᴳ : {G₀ : Group i₀} {G₁ : Group i₁} (ξ : G₀ →ᴳ G₁) → HomSeqMap (G₀ ⊣|ᴳ) (G₁ ⊣|ᴳ) ξ ξ
  _↓⟨_⟩ᴳ_ : {G₀ H₀ K₀ : Group i₀} {G₁ H₁ K₁ : Group i₁}
    → {φ : G₀ →ᴳ H₀} {seq₀ : HomSequence H₀ K₀}
    → {ψ : G₁ →ᴳ H₁} {seq₁ : HomSequence H₁ K₁}
    → (ξG : G₀ →ᴳ G₁) {ξH : H₀ →ᴳ H₁} {ξK : K₀ →ᴳ K₁}
    → CommSquareᴳ φ ψ ξG ξH
    → HomSeqMap seq₀ seq₁ ξH ξK
    → HomSeqMap (G₀ →⟨ φ ⟩ᴳ seq₀) (G₁ →⟨ ψ ⟩ᴳ seq₁) ξG ξK

HomSeqMap-snoc : ∀ {i₀ i₁} {G₀ H₀ K₀ : Group i₀} {G₁ H₁ K₁ : Group i₁}
  {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
  {φ₀ : H₀ →ᴳ K₀} {φ₁ : H₁ →ᴳ K₁}
  {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁} {ξK : K₀ →ᴳ K₁}
  → HomSeqMap seq₀ seq₁ ξG ξH
  → CommSquareᴳ φ₀ φ₁ ξH ξK
  → HomSeqMap (HomSeq-snoc seq₀ φ₀) (HomSeq-snoc seq₁ φ₁) ξG ξK
HomSeqMap-snoc (ξG ↓|ᴳ) □ = ξG ↓⟨ □ ⟩ᴳ _ ↓|ᴳ
HomSeqMap-snoc (ξG ↓⟨ □₁ ⟩ᴳ seq) □₂ = ξG ↓⟨ □₁ ⟩ᴳ HomSeqMap-snoc seq □₂

{- equivalences between two hom sequences -}

is-seqᴳ-equiv : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
  {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
  {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
  → HomSeqMap seq₀ seq₁ ξG ξH
  → Type (lmax i₀ i₁)
is-seqᴳ-equiv (ξ ↓|ᴳ) = is-equiv (GroupHom.f ξ)
is-seqᴳ-equiv (ξ ↓⟨ _ ⟩ᴳ seq) = is-equiv (GroupHom.f ξ) × is-seqᴳ-equiv seq

is-seqᴳ-equiv-snoc : ∀ {i₀ i₁} {G₀ H₀ K₀ : Group i₀} {G₁ H₁ K₁ : Group i₁}
  {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
  {φ₀ : H₀ →ᴳ K₀} {φ₁ : H₁ →ᴳ K₁}
  {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁} {ξK : K₀ →ᴳ K₁}
  {seq-map : HomSeqMap seq₀ seq₁ ξG ξH}
  {cs : CommSquareᴳ φ₀ φ₁ ξH ξK}
  → is-seqᴳ-equiv seq-map → is-equiv (GroupHom.f ξK)
  → is-seqᴳ-equiv (HomSeqMap-snoc seq-map cs)
is-seqᴳ-equiv-snoc {seq-map = ξG ↓|ᴳ} ξG-is-equiv ξH-is-equiv = ξG-is-equiv , ξH-is-equiv
is-seqᴳ-equiv-snoc {seq-map = ξG ↓⟨ _ ⟩ᴳ seq} (ξG-is-equiv , seq-is-equiv) ξH-is-equiv =
  ξG-is-equiv , is-seqᴳ-equiv-snoc seq-is-equiv ξH-is-equiv

private
  is-seqᴳ-equiv-head : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    {seq-map : HomSeqMap seq₀ seq₁ ξG ξH}
    → is-seqᴳ-equiv seq-map → is-equiv (GroupHom.f ξG)
  is-seqᴳ-equiv-head {seq-map = ξ ↓|ᴳ} ise = ise
  is-seqᴳ-equiv-head {seq-map = ξ ↓⟨ _ ⟩ᴳ _} ise = fst ise

  is-seqᴳ-equiv-last : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    {seq-map : HomSeqMap seq₀ seq₁ ξG ξH}
    → is-seqᴳ-equiv seq-map → is-equiv (GroupHom.f ξH)
  is-seqᴳ-equiv-last {seq-map = ξ ↓|ᴳ} ise = ise
  is-seqᴳ-equiv-last {seq-map = _ ↓⟨ _ ⟩ᴳ rest} (_ , rest-ise) = is-seqᴳ-equiv-last rest-ise

module is-seqᴳ-equiv {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
  {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
  {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
  {seq-map : HomSeqMap seq₀ seq₁ ξG ξH}
  (seq-map-is-equiv : is-seqᴳ-equiv seq-map) where

  head = is-seqᴳ-equiv-head seq-map-is-equiv
  last = is-seqᴳ-equiv-last seq-map-is-equiv

HomSeqEquiv : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
  (seq₀ : HomSequence G₀ H₀) (seq₁ : HomSequence G₁ H₁)
  (ξG : G₀ →ᴳ G₁) (ξH : H₀ →ᴳ H₁) → Type (lsucc (lmax i₀ i₁))
HomSeqEquiv seq₀ seq₁ ξG ξH = Σ (HomSeqMap seq₀ seq₁ ξG ξH) is-seqᴳ-equiv

HomSeqEquiv-inverse : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
  {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
  {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
  (equiv : HomSeqEquiv seq₀ seq₁ ξG ξH)
  → HomSeqEquiv seq₁ seq₀
      (GroupIso.g-hom (ξG , is-seqᴳ-equiv-head (snd equiv)))
      (GroupIso.g-hom (ξH , is-seqᴳ-equiv-last (snd equiv)))
HomSeqEquiv-inverse ((ξ ↓|ᴳ) , ξ-ise) =
  (GroupIso.g-hom (ξ , ξ-ise) ↓|ᴳ) , is-equiv-inverse ξ-ise
HomSeqEquiv-inverse ((ξ ↓⟨ □ ⟩ᴳ rest) , (ξ-ise , rest-ise)) =
  (GroupIso.g-hom (ξ , ξ-ise)
    ↓⟨ CommSquareᴳ-inverse-v □ ξ-ise (is-seqᴳ-equiv-head rest-ise) ⟩ᴳ
  fst rest-inverse-equiv) ,
  is-equiv-inverse ξ-ise , snd rest-inverse-equiv
  where
    rest-inverse-equiv = HomSeqEquiv-inverse (rest , rest-ise)

{- Doesn't seem useful.

infix 15 _↕|ᴳ
infixr 10 _↕⟨_⟩ᴳ_

_↕|ᴳ : ∀ {i} {G₀ G₁ : Group i} (iso : G₀ ≃ᴳ G₁)
  → HomSeqEquiv (G₀ ⊣|ᴳ) (G₁ ⊣|ᴳ) (fst iso) (fst iso)
iso ↕|ᴳ = (fst iso ↓|ᴳ) , snd iso

_↕⟨_⟩ᴳ_ : ∀ {i} {G₀ G₁ H₀ H₁ K₀ K₁ : Group i}
  → {φ : G₀ →ᴳ H₀} {seq₀ : HomSequence H₀ K₀}
  → {ψ : G₁ →ᴳ H₁} {seq₁ : HomSequence H₁ K₁}
  → (isoG : G₀ ≃ᴳ G₁) {isoH : H₀ ≃ᴳ H₁} {isoK : K₀ ≃ᴳ K₁}
  → HomCommSquare φ ψ (fst isoG) (fst isoH)
  → HomSeqEquiv seq₀ seq₁ (fst isoH) (fst isoK)
  → HomSeqEquiv (G₀ →⟨ φ ⟩ᴳ seq₀) (G₁ →⟨ ψ ⟩ᴳ seq₁) (fst isoG) (fst isoK)
(ξG , hG-is-equiv) ↕⟨ sqr ⟩ᴳ (seq-map , seq-map-is-equiv) =
  (ξG ↓⟨ sqr ⟩ᴳ seq-map) , hG-is-equiv , seq-map-is-equiv
-}

private
  hom-seq-map-index-type : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    → ℕ → HomSeqMap seq₀ seq₁ ξG ξH → Type (lmax i₀ i₁)
  hom-seq-map-index-type _     (_ ↓|ᴳ) = Lift ⊤
  hom-seq-map-index-type O     (_↓⟨_⟩ᴳ_ {φ = φ} {ψ = ψ} ξG {ξH} _ _)
    = CommSquareᴳ φ ψ ξG ξH
  hom-seq-map-index-type (S n) (_ ↓⟨ _ ⟩ᴳ seq-map)
    = hom-seq-map-index-type n seq-map

abstract
  hom-seq-map-index : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    (n : ℕ) (seq-map : HomSeqMap seq₀ seq₁ ξG ξH)
    → hom-seq-map-index-type n seq-map
  hom-seq-map-index _     (_ ↓|ᴳ) = lift tt
  hom-seq-map-index O     (_ ↓⟨ □ ⟩ᴳ _) = □
  hom-seq-map-index (S n) (_ ↓⟨ _ ⟩ᴳ seq-map)
    = hom-seq-map-index n seq-map

private
  hom-seq-equiv-index-type : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    → ℕ → HomSeqMap seq₀ seq₁ ξG ξH → Type (lmax i₀ i₁)
  hom-seq-equiv-index-type {ξG = ξG} O _ = is-equiv (GroupHom.f ξG)
  hom-seq-equiv-index-type (S _) (_ ↓|ᴳ) = Lift ⊤
  hom-seq-equiv-index-type (S n) (_ ↓⟨ _ ⟩ᴳ seq-map)
    = hom-seq-equiv-index-type n seq-map

abstract
  hom-seq-equiv-index : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    (n : ℕ) (seq-equiv : HomSeqEquiv seq₀ seq₁ ξG ξH)
    → hom-seq-equiv-index-type n (fst seq-equiv)
  hom-seq-equiv-index O     (seq-map , ise) = is-seqᴳ-equiv-head ise
  hom-seq-equiv-index (S _) ((_ ↓|ᴳ) , _) = lift tt
  hom-seq-equiv-index (S n) ((_ ↓⟨ _ ⟩ᴳ seq-map) , ise)
    = hom-seq-equiv-index n (seq-map , snd ise)


-- Andreas, 2013-03-15 issue reported by Nisse
-- {-# OPTIONS -v tc.proj:40 -v tc.conv.elim:40 #-}
module Issue821 where

import Common.Level

data D (A : Set) : Set where
  c : D A → D A

f : (A : Set) → D A → D A
f A (c x) = x

postulate
  A : Set
  P : D A → Set
  x : D A
  p : P x
  Q : P (f A x) → Set

Foo : Set₁
Foo = Q p

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:466

-- Reason was that f is projection-like so the test x =?= f A x
-- actually becomes x =?= x .f with unequal spine shapes (empty vs. non-empty).
-- Agda thought this was impossible.


-- Andreas, 2011-04-26
{-# OPTIONS --universe-polymorphism #-}
module Issue411 where
import Common.Irrelevance

record A : Set₁ where
  field
    .foo : Set
-- this yielded a panic "-1 not a valid deBruijn index" due to old code for assignS


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists
------------------------------------------------------------------------

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

module Data.List where

------------------------------------------------------------------------
-- Types and basic operations

open import Data.List.Base public


record C (A : Set) : Set where
  field f : A → A

open C {{...}}

module M (A : Set) where
  data D : Set where
    d : A → D

  instance
    CD : C D
    CD = record { f = λ x → x }

data Bool : Set where
  false true : Bool

open M Bool

-- Bug: M.CD is not considered in instance search
x : D
x = f (M.d false)


module CompilingCoinduction where

open import Common.Coinduction

data List (A : Set) : Set where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  []   #-}
{-# BUILTIN CONS _∷_  #-}

{-# COMPILED_DATA List [] [] (:) #-}

postulate
  Char : Set

{-# BUILTIN CHAR Char #-}
{-# COMPILED_TYPE Char Char #-}

-- Strings --

postulate
  String : Set

{-# BUILTIN STRING String #-}
{-# COMPILED_TYPE String String #-}

data Unit : Set where
  unit : Unit

{-# COMPILED_DATA Unit () () #-}

postulate
  IO : Set → Set

{-# COMPILED_TYPE IO IO #-}
{-# BUILTIN IO IO #-}

postulate
  putStrLn : ∞ String → IO Unit

{-# COMPILED putStrLn putStrLn #-}

main = putStrLn (♯ "a")


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

open import Agda.Primitive

infixr 5 _,_
record Pair
  {a} (A : Set a) {b} (B : Set b)
  : Set (a ⊔ b) where
  constructor _,_
  field
    fst : A
    snd : B

data Constraint
  {a} {A : Set a} (x : A)
  : Set where
  instance _ : Constraint x

record Outer
  l {a} {A : Set a} (x : A)
  : Set (lsuc l) where
  constructor #
  field type : Set l

record Inner
  {l} {a} {A : Set a} (x : A) {{_ : Constraint x}} (outer : Outer l x)
  : Set l where
  field value : Outer.type outer

module Class
  {l} {a} {A : Set a} (x : A) (C : Set l)
  where
  class = Inner x (# C)
  method : {{_ : class}} → C
  method {{INSTANCE}} = Inner.value INSTANCE

module Beekeeper
  {i} {I : Set i}
  (A : I -> Set)
  (B : I -> Set)
  (x : I)
  = Class (x , A , B)
          (A x -> B x)

module Indexed
  {a b b?} {I : Set}
  {A : I -> Set a}
  (mkA : ∀ {x} -> A x)
  (B : I -> Set b)
  (toB : ∀ {x} -> A x -> B x)
  (B? : ∀ {x} -> B x -> Set b?)
  = Class ((λ {x} -> toB {x}) , (λ {x} -> B? {x}))
          (∀ {x} -> B? (toB (mkA {x})))

module Unindexed
  {a b}
  {A : Set a}
  (mkA : A)
  {B : Set b}
  (toB : A -> B)
  (B? : B -> Set)
  = Class (mkA , toB , B?)
          (B? (toB mkA))

module _
  {a b} {I : Set}
  {A : I -> Set a}
  {mkA : ∀ {x} -> A x}
  {B : I -> Set b}
  {toB : ∀ {x} -> A x -> B x}
  {B? : ∀ {x} -> B x -> Set}
  {{_ : Indexed.class mkA B toB B?}}
  where
  postulate
    instance iToUnindexed : ∀ {x} -> Unindexed.class (mkA {x}) toB B?

postulate
  I : Set

data A
  a (x : I)
  : Set a where
  mkA : A a x

record B
  b (x : I)
  : Set (lsuc b) where
  field ?? : Set b
open B public

postulate
  toB : ∀ {a b x} -> A a x -> B b x
  instance
    iIndexedAB : ∀ {a b} -> Indexed.class (mkA {a}) (B b) toB (B.??)
  b : Level
  x : I
  myB : B b x

error : myB .??
error = {!Beekeeper.method _ _ _ _ _!}
-- Location of the error: src/full/Agda/TypeChecking/Substitute.hs:98


------------------------------------------------------------------------
-- The derivative operator does not introduce any unneeded ambiguity
------------------------------------------------------------------------

module TotalParserCombinators.Derivative.LeftInverse where

open import Codata.Musical.Notation
open import Data.Maybe hiding (_>>=_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.HeterogeneousEquality using (refl)

open import TotalParserCombinators.Derivative.Definition
open import TotalParserCombinators.Derivative.SoundComplete
import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics

complete∘sound : ∀ {Tok R xs x s t}
                 (p : Parser Tok R xs) (x∈ : x ∈ D t p · s) →
                 complete (sound p x∈) ≡ x∈
complete∘sound token     return            = refl
complete∘sound (p₁ ∣ p₂) (∣-left     x∈p₁) rewrite complete∘sound p₁ x∈p₁ = refl
complete∘sound (p₁ ∣ p₂) (∣-right ._ x∈p₂) rewrite complete∘sound p₂ x∈p₂ = refl
complete∘sound (f <$> p) (<$> x∈p)         rewrite complete∘sound p  x∈p  = refl

complete∘sound (_⊛_ {fs = nothing} {xs = just _}  p₁ p₂)             (f∈p₁′  ⊛ x∈p₂)  rewrite complete∘sound p₁ f∈p₁′ = refl
complete∘sound (_⊛_ {fs = just _}  {xs = just _}  p₁ p₂) (∣-left     (f∈p₁′  ⊛ x∈p₂)) rewrite complete∘sound p₁ f∈p₁′ = refl
complete∘sound (_⊛_ {fs = just fs} {xs = just xs} p₁ p₂) (∣-right ._ (f∈ret⋆ ⊛ x∈p₂′))
  with (refl , f∈fs) ←          Return⋆.sound fs f∈ret⋆
     | refl          ← Return⋆.complete∘sound fs f∈ret⋆
  rewrite I.complete∘sound p₁ f∈fs | complete∘sound p₂ x∈p₂′ = refl
complete∘sound (_⊛_ {fs = nothing} {xs = nothing} p₁ p₂)             (f∈p₁′  ⊛ x∈p₂)  rewrite complete∘sound (♭ p₁) f∈p₁′ = refl
complete∘sound (_⊛_ {fs = just fs} {xs = nothing} p₁ p₂) (∣-left     (f∈p₁′  ⊛ x∈p₂)) rewrite complete∘sound (♭ p₁) f∈p₁′ = refl
complete∘sound (_⊛_ {fs = just fs} {xs = nothing} p₁ p₂) (∣-right ._ (f∈ret⋆ ⊛ x∈p₂′))
  with (refl , f∈fs) ←          Return⋆.sound fs f∈ret⋆
     | refl          ← Return⋆.complete∘sound fs f∈ret⋆
  rewrite I.complete∘sound (♭ p₁) f∈fs | complete∘sound p₂ x∈p₂′ = refl

complete∘sound (_>>=_ {xs = nothing} {f = just _} p₁ p₂)             (x∈p₁′  >>= y∈p₂x)  rewrite complete∘sound p₁ x∈p₁′ = refl
complete∘sound (_>>=_ {xs = just _}  {f = just _} p₁ p₂) (∣-left     (x∈p₁′  >>= y∈p₂x)) rewrite complete∘sound p₁ x∈p₁′ = refl
complete∘sound (_>>=_ {xs = just xs} {f = just _} p₁ p₂) (∣-right ._ (y∈ret⋆ >>= z∈p₂′y))
  with (refl , y∈xs) ←          Return⋆.sound xs y∈ret⋆
     | refl          ← Return⋆.complete∘sound xs y∈ret⋆
  rewrite I.complete∘sound p₁ y∈xs | complete∘sound (p₂ _) z∈p₂′y = refl
complete∘sound (_>>=_ {xs = nothing} {f = nothing} p₁ p₂)             (x∈p₁′  >>= y∈p₂x)  rewrite complete∘sound (♭ p₁) x∈p₁′ = refl
complete∘sound (_>>=_ {xs = just _}  {f = nothing} p₁ p₂) (∣-left     (x∈p₁′  >>= y∈p₂x)) rewrite complete∘sound (♭ p₁) x∈p₁′ = refl
complete∘sound (_>>=_ {xs = just xs} {f = nothing} p₁ p₂) (∣-right ._ (y∈ret⋆ >>= z∈p₂′y))
  with (refl , y∈xs) ←          Return⋆.sound xs y∈ret⋆
     | refl          ← Return⋆.complete∘sound xs y∈ret⋆
  rewrite I.complete∘sound (♭ p₁) y∈xs | complete∘sound (p₂ _) z∈p₂′y = refl

complete∘sound (nonempty p) x∈p = complete∘sound p x∈p
complete∘sound (cast _ p)   x∈p = complete∘sound p x∈p

complete∘sound (return _) ()
complete∘sound fail       ()


-- Andreas, 2014-09-23

module _ where

syntax c x   = ⟦ x ⟧
syntax c x y = x + y

-- Should complain about multiple notations.


postulate
  P : {A : Set} → A → A → Set
  p : {A : Set} {x : A} → P x x
  q : {A : Set} (x : A) {y : A} → P x y → P x y
  A : Set

record R (F : Set → Set) : Set₁ where
  field
    f₁ : (A → A) → F A → F A
    f₂ : P (f₁ (λ x → x)) (λ (x : F A) → x)

open R ⦃ … ⦄ public

instance

  r : R (λ O → O → O)
  r = record
    { f₁ = λ f g x → f (g x)
    ; f₂ = p
    }

postulate
  F : Set → Set

  instance
    rF : R F

Foo : P (f₁ (λ x → x)) (λ (x : F A) → x)
Foo = q (f₁ (λ x → x)) f₂

-- An internal error has occurred. Please report this as a bug.
-- Location of the error:
-- src/full/Agda/TypeChecking/InstanceArguments.hs:224


------------------------------------------------------------------------
-- An alternative but equivalent definition of the partiality monad
-- (but only for sets), based on the lifting construction in Lifting
------------------------------------------------------------------------

-- The code in this module is based on a suggestion from Paolo
-- Capriotti.

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

open import Prelude hiding (T; ⊥)

module Lifting.Partiality-monad {a : Level} where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)

open import Bijection equality-with-J using (_↔_)
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J hiding (⊥↔⊥)
open import H-level equality-with-J

import Lifting
open import Omega-cpo
import Partiality-monad.Inductive as I
import Partiality-monad.Inductive.Eliminators as IE

private
  module L {A : Set a} = Lifting (Set→ω-cpo A)

-- The partiality monad as an ω-cppo.

partiality-monad : Set a → ω-cppo a a
partiality-monad A = L.cppo {A = A}

-- The partiality monad.

infix 10 _⊥
infix  4 _⊑_

_⊥ : Set a → Type a
A ⊥ = ω-cppo.Carrier (partiality-monad A)

_⊑_ : ∀ {A} → A ⊥ → A ⊥ → Type a
_⊑_ {A = A} = ω-cppo._⊑_ (partiality-monad A)

-- This definition of the partiality monad is isomorphic to the
-- definition in Partiality-monad.Inductive.

private

  argsL :
    ∀ {A} →
    L.Rec-args (λ (_ : A ⊥) → ⌞ A ⌟ I.⊥) (λ x y _ → x I.⊑ y)
  argsL = record
    { pe = I.never
    ; po = I.now
    ; pl = λ _ → I.⨆
    ; pa = λ x⊑y y⊑x p-x p-y p-x⊑p-y p-y⊑p-x →
             subst (const _) (L.antisymmetry x⊑y y⊑x) p-x  ≡⟨ subst-const (L.antisymmetry x⊑y y⊑x) ⟩
             p-x                                           ≡⟨ I.antisymmetry p-x⊑p-y p-y⊑p-x ⟩∎
             p-y                                           ∎
    ; pp = I.⊥-is-set
    ; qr = λ _ → I.⊑-refl
    ; qt = λ _ _ _ _ _ → I.⊑-trans
    ; qe = λ _ → I.never⊑
    ; qu = λ _ → I.upper-bound
    ; ql = λ _ _ _ → I.least-upper-bound
    ; qm = λ { refl → I.⊑-refl _ }
    ; q⨆ = λ s →
             I.now (proj₁ s 0)                    I.⊑⟨ I.upper-bound _ 0 ⟩■
             I.⨆ ((λ n → I.now (proj₁ s n)) , _)  ■
    ; qp = λ _ _ _ → I.⊑-propositional
    }

  argsI : ∀ {A} → IE.Arguments-nd a a ⌞ A ⌟
  argsI {A} = record
    { P  = A ⊥
    ; Q  = _⊑_
    ; pe = L.never
    ; po = L.now
    ; pl = λ _ → L.⨆
    ; pa = λ _ _ → L.antisymmetry
    ; ps = L.Carrier-is-set
    ; qr = λ _ → L.⊑-refl
    ; qt = λ _ _ → L.⊑-trans
    ; qe = λ _ → L.never⊑
    ; qu = λ _ → L.upper-bound
    ; ql = λ _ _ _ → L.least-upper-bound
    ; qp = λ _ _ → L.⊑-propositional
    }

⊥↔⊥ : ∀ {A} → A ⊥ ↔ ⌞ A ⌟ I.⊥
⊥↔⊥ = record
  { surjection = record
    { logical-equivalence = record
      { to   = L.⊥-rec argsL
      ; from = IE.⊥-rec-nd argsI
      }
    ; right-inverse-of = IE.⊥-rec-⊥ (record
        { pe = L.⊥-rec argsL (IE.⊥-rec-nd argsI I.never)  ≡⟨ cong (L.⊥-rec argsL) (IE.⊥-rec-nd-never argsI) ⟩
               L.⊥-rec argsL L.never                      ≡⟨ L.⊥-rec-never _ ⟩∎
               I.never                                    ∎
        ; po = λ x →
                 L.⊥-rec argsL (IE.⊥-rec-nd argsI (I.now x))  ≡⟨ cong (L.⊥-rec argsL) (IE.⊥-rec-nd-now argsI _) ⟩
                 L.⊥-rec argsL (L.now x)                      ≡⟨ L.⊥-rec-now _ _ ⟩∎
                 I.now x ∎
        ; pl = λ s ih →
                 L.⊥-rec argsL (IE.⊥-rec-nd argsI (I.⨆ s))      ≡⟨ cong (L.⊥-rec argsL) (IE.⊥-rec-nd-⨆ argsI _) ⟩
                 L.⊥-rec argsL (L.⨆ (IE.inc-rec-nd argsI s))    ≡⟨ L.⊥-rec-⨆ _ _ ⟩
                 I.⨆ (L.inc-rec argsL (IE.inc-rec-nd argsI s))  ≡⟨ cong I.⨆ $ _↔_.to I.equality-characterisation-increasing ih ⟩∎
                 I.⨆ s                                          ∎
        ; pp = λ _ → I.⊥-is-set
        })
    }
  ; left-inverse-of = L.⊥-rec {Q = λ _ _ _ → ⊤} (record
      { pe = IE.⊥-rec-nd argsI (L.⊥-rec argsL L.never)  ≡⟨ cong (IE.⊥-rec-nd argsI) (L.⊥-rec-never _) ⟩
             IE.⊥-rec-nd argsI I.never                  ≡⟨ IE.⊥-rec-nd-never argsI ⟩∎
             L.never                                    ∎
      ; po = λ x →
               IE.⊥-rec-nd argsI (L.⊥-rec argsL (L.now x))  ≡⟨ cong (IE.⊥-rec-nd argsI) (L.⊥-rec-now _ _) ⟩
               IE.⊥-rec-nd argsI (I.now x)                  ≡⟨ IE.⊥-rec-nd-now argsI _ ⟩∎
               L.now x                                      ∎
      ; pl = λ s ih →
                 IE.⊥-rec-nd argsI (L.⊥-rec argsL (L.⨆ s))      ≡⟨ cong (IE.⊥-rec-nd argsI) (L.⊥-rec-⨆ _ _) ⟩
                 IE.⊥-rec-nd argsI (I.⨆ (L.inc-rec argsL s))    ≡⟨ IE.⊥-rec-nd-⨆ argsI _ ⟩
                 L.⨆ (IE.inc-rec-nd argsI (L.inc-rec argsL s))  ≡⟨ cong L.⨆ $ _↔_.to L.equality-characterisation-increasing (proj₁ ih) ⟩∎
                 L.⨆ s                                          ∎
      ; pa = λ _ _ _ _ _ _ → L.Carrier-is-set _ _
      ; pp = mono₁ 1 L.Carrier-is-set
      ; qp = λ _ _ _ _ _ → refl
      })
  }

⊑≃⊑ : ∀ {A} {x y : A ⊥} →
      (x ⊑ y) ≃ (_↔_.to ⊥↔⊥ x I.⊑ _↔_.to ⊥↔⊥ y)
⊑≃⊑ {x = x} {y} =
  _↔_.to (Eq.⇔↔≃ ext L.⊑-propositional I.⊑-propositional)
    (record
       { to   = L.⊑-rec argsL
       ; from =
                _↔_.to ⊥↔⊥ x I.⊑ _↔_.to ⊥↔⊥ y  ↝⟨ IE.⊑-rec-nd argsI ⟩

                _↔_.from ⊥↔⊥ (_↔_.to ⊥↔⊥ x) ⊑
                _↔_.from ⊥↔⊥ (_↔_.to ⊥↔⊥ y)    ↝⟨ ≡⇒↝ _ (cong₂ _⊑_ (_↔_.left-inverse-of ⊥↔⊥ _)
                                                                   (_↔_.left-inverse-of ⊥↔⊥ _)) ⟩□
                x ⊑ y                          □
       })


module MultipleFixityDecl where

infixl 40 _+_
infixr 60 _+_

_+_ : Set -> Set -> Set
A + B = A


import Agda.Builtin.Nat as Nat public

f : let open Nat public in Nat → Nat
f x = x


module TemporalOps.StrongMonad where

open import CategoryTheory.Instances.Reactive
open import CategoryTheory.Functor
open import CategoryTheory.Monad
open import CategoryTheory.Comonad
open import CategoryTheory.NatTrans
open import CategoryTheory.BCCCs
open import CategoryTheory.CartesianStrength

open import TemporalOps.Next
open import TemporalOps.Delay
open import TemporalOps.Diamond
open import TemporalOps.Diamond.Join
open import TemporalOps.Box
open import TemporalOps.Common.Other
open import TemporalOps.Common.Compare
open import TemporalOps.Common.Rewriting
open import TemporalOps.OtherOps

open import Relation.Binary.PropositionalEquality as ≡ hiding (inspect)
open import Data.Product
open import Data.Sum
open import Data.Nat hiding (_*_)
open import Data.Nat.Properties
            using (+-identityʳ ; +-comm ; +-suc ; +-assoc)

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

open Monad M-◇
open Comonad W-□
private module F-◇ = Functor F-◇
private module F-□ = Functor F-□
open ≡.≡-Reasoning

◇-□-Strong : WStrongMonad ℝeactive-cart M-◇ W-cart-□
◇-□-Strong = record
    { st = st-◇
    ; st-nat₁ = st-nat₁-◇
    ; st-nat₂ = st-nat₂-◇
    ; st-λ = st-λ-◇
    ; st-α = st-α-◇
    ; st-η = refl
    ; st-μ = λ{A}{B}{n}{a} -> st-μ-◇ {A}{B}{n}{a}
    }
    where
    open Functor F-◇ renaming (fmap to ◇-f ; omap to ◇-o)
    open Functor F-□ renaming (fmap to □-f ; omap to □-o)
    private module ▹ᵏ-C k = CartesianFunctor (F-cart-delay k)
    private module ▹ᵏ-F k = Functor (F-delay k)
    private module ▹-F = Functor F-▹
    private module ▹-C = CartesianFunctor (F-cart-▹)
    private module □-C = CartesianFunctor (F-cart-□)
    private module □-CW = CartesianComonad (W-cart-□)
    private module □-▹ᵏ k = _⟹_ (□-to-▹ᵏ k)

    st-◇ : ∀(A B : τ) -> □ A ⊗ ◇ B ⇴ ◇ (□ A ⊗ B)
    st-◇ A B n (□A , (k , a)) = k , ▹ᵏ-C.m k (□ A) B n (□-▹ᵏ.at k (□ A) n (δ.at A k □A) , a)

    st-nat₁-◇ : ∀{A B C : τ} (f : A ⇴ B)
             -> ◇-f (□-f f * id) ∘ st-◇ A C ≈ st-◇ B C ∘ □-f f * id
    st-nat₁-◇ {A} {B} {C} f {n} {□A , k , a}
        rewrite ▹ᵏ-C.m-nat₁ k (□-f f)
                {n} {(□-▹ᵏ.at k (□ A) n (δ.at A k □A)) , a}
              | (□-▹ᵏ.nat-cond k {□ A} {□ B} {□-f f} {n} {δ.at A k □A})
        = refl

    st-nat₂-◇ : ∀{A B C : τ} (f : A ⇴ B)
             -> ◇-f (id * f) ∘ st-◇ C A ≈ st-◇ C B ∘ id * ◇-f f
    st-nat₂-◇ {A} {B} {C} f {n} {□C , k , a}
        rewrite ▹ᵏ-C.m-nat₂ k f {n} {□-▹ᵏ.at k (□ C) n (δ.at C k □C) , a} = refl

    st-λ-◇ : ∀{A} -> ◇-f π₂ ∘ st-◇ ⊤ A ≈ π₂
    st-λ-◇ {A} {n} {□⊤ , (k , a)} =
        begin
            ◇-f π₂ n (st-◇ ⊤ A n (□⊤ , (k , a)))
        ≡⟨⟩
            ◇-f π₂ n (k , ▹ᵏ-C.m k (□ ⊤) A n (□-▹ᵏ.at k (□ ⊤) n (δ.at ⊤ n □⊤) , a))
        ≡⟨⟩
            k , ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k (□ ⊤) A n (□-▹ᵏ.at k (□ ⊤) n (δ.at ⊤ n □⊤) , a))
        ≡⟨ cong (λ x -> k , x) lemma ⟩
            k , a
        ∎
        where
        lemma : ▹ᵏ-F.fmap k π₂ ∘ ▹ᵏ-C.m k (□ ⊤) A ≈ π₂
        lemma {n} {t , b} =
            begin
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k (□ ⊤) A n (t , b))
            ≡⟨⟩
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k (□ ⊤) A n (⌞ t ⌟ , b))
            ≡⟨ cong! (▹ᵏ-F.fmap-id k {□ ⊤}{n}{t}) ⟩
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k (□ ⊤) A n (▹ᵏ-F.fmap k ⌞ id ⌟ n t , b))
            ≡⟨⟩
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k (□ ⊤) A n (⌞ ▹ᵏ-F.fmap k (u ∘ ε.at ⊤) n t ⌟ , b))
            ≡⟨ cong! (▹ᵏ-F.fmap-∘ k) ⟩
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k (□ ⊤) A n (▹ᵏ-F.fmap k u n (▹ᵏ-F.fmap k (ε.at ⊤) n t) , b))
            ≡⟨ cong (▹ᵏ-F.fmap k π₂ n) (sym (▹ᵏ-C.m-nat₁ k u)) ⟩
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-F.fmap k (u * id) n (▹ᵏ-C.m k ⊤ A n (▹ᵏ-F.fmap k (ε.at ⊤) n t , b)))
            ≡⟨ sym (▹ᵏ-F.fmap-∘ k) ⟩
                ▹ᵏ-F.fmap k (π₂ ∘ u * id) n (▹ᵏ-C.m k ⊤ A n (▹ᵏ-F.fmap k (ε.at ⊤) n t , b))
            ≡⟨⟩
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k ⊤ A n (⌞ ▹ᵏ-F.fmap k (ε.at ⊤) n t ⌟ , b))
            ≡⟨ cong! (⊤-eq k n t) ⟩
                ▹ᵏ-F.fmap k π₂ n (▹ᵏ-C.m k ⊤ A n (▹ᵏ-C.u k n top.tt , b))
            ≡⟨ ▹ᵏ-C.unital-left k ⟩
                b
            ∎
            where
            ⊤-eq : ∀ k n t -> ▹ᵏ-F.fmap k (ε.at ⊤) n t ≡ ▹ᵏ-C.u k n top.tt
            ⊤-eq zero n t = refl
            ⊤-eq (suc k) zero t = refl
            ⊤-eq (suc k) (suc n) t = ⊤-eq k n t

    st-α-◇ : ∀{A B C : τ}
          -> st-◇ A (□ B ⊗ C) ∘ id * st-◇ B C ∘ assoc-right ∘ m⁻¹ A B * id
           ≈ ◇-f (assoc-right ∘ m⁻¹ A B * id) ∘ st-◇ (A ⊗ B) C
    st-α-◇ {A} {B} {C} {n} {□A⊗B , (k , a)} =
        begin
            st-◇ A (□ B ⊗ C) n
                (□-f π₁ n □A⊗B , st-◇ B C n (□-f π₂ n □A⊗B , (k , a)))
        ≡⟨ cong (λ x → k , x) (
            begin
                ▹ᵏ-C.m k (□ A) (□ B ⊗ C) n
                    ( □-▹ᵏ.at k (□ A) n (δ.at A k (□-f π₁ n □A⊗B))
                    , ▹ᵏ-C.m k (□ B) C n (□-▹ᵏ.at k (□ B) n (δ.at B n (□-f π₂ n □A⊗B)) , a))
            ≡⟨⟩ -- Naturality and definitional equality
                ▹ᵏ-C.m k (□ A) (□ B ⊗ C) n
                    ((id {delay □ A by k} * ▹ᵏ-C.m k (□ B) C) n (assoc-right {delay □ A by k} {delay □ B by k} {delay C by k} n
                        (((□-▹ᵏ.at k (□ A) * □-▹ᵏ.at k (□ B)) n
                            ((δ.at A * δ.at B) n (m⁻¹ A B n □A⊗B)))
                        , a)))
            ≡⟨ ▹ᵏ-C.associative k  ⟩
                ▹ᵏ-F.fmap k assoc-right n
                    (▹ᵏ-C.m k (□ A ⊗ □ B) C n
                        ( ⌞ ▹ᵏ-C.m k (□ A) (□ B) n
                            ((□-▹ᵏ.at k (□ A) * □-▹ᵏ.at k (□ B)) n
                                ((δ.at A * δ.at B) n (m⁻¹ A B n □A⊗B))) ⌟
                        , a))
            ≡⟨ cong! (lemma k) ⟩
                ▹ᵏ-F.fmap k assoc-right n
                    (▹ᵏ-C.m k (□ A ⊗ □ B) C n
                        ( □-▹ᵏ.at k (□ A ⊗ □ B) n
                            (□-C.m (□ A) (□ B) n ((δ.at A * δ.at B) n (m⁻¹ A B n □A⊗B)))
                        , a))
            ≡⟨⟩
                ▹ᵏ-F.fmap k assoc-right n
                    (▹ᵏ-C.m k (□ A ⊗ □ B) C n
                        ( ⌞ □-▹ᵏ.at k (□ A ⊗ □ B) n
                            (□-f (m⁻¹ A B) n (δ.at (A ⊗ B) k □A⊗B)) ⌟
                        , a))
            ≡⟨ cong! (□-▹ᵏ.nat-cond k {f = m⁻¹ A B} {n} {δ.at (A ⊗ B) k □A⊗B}) ⟩
                ▹ᵏ-F.fmap k assoc-right n
                    ⌞ (▹ᵏ-C.m k (□ A ⊗ □ B) C n
                        (▹ᵏ-F.fmap k (m⁻¹ A B) n
                            (□-▹ᵏ.at k (□ (A ⊗ B)) n (δ.at (A ⊗ B) k □A⊗B))
                        , a)) ⌟
            ≡⟨ cong! (▹ᵏ-C.m-nat₁ k (m⁻¹ A B) {n}
                        {(□-▹ᵏ.at k (□ (A ⊗ B)) n (δ.at (A ⊗ B) k □A⊗B)) , a}) ⟩
                ▹ᵏ-F.fmap k assoc-right n
                    (▹ᵏ-F.fmap k (m⁻¹ A B * id) n (▹ᵏ-C.m k (□ (A ⊗ B)) C n
                        (□-▹ᵏ.at k (□ (A ⊗ B)) n (δ.at (A ⊗ B) k □A⊗B) , a)))
            ≡⟨ sym (▹ᵏ-F.fmap-∘ k) ⟩
                ▹ᵏ-F.fmap k (assoc-right ∘ m⁻¹ A B * id) n
                    (▹ᵏ-C.m k (□ (A ⊗ B)) C n (□-▹ᵏ.at k (□ (A ⊗ B)) n (δ.at (A ⊗ B) k □A⊗B) , a))
            ≡⟨⟩

                ▹ᵏ-F.fmap k (assoc-right ∘ m⁻¹ A B * id) n
                    (▹ᵏ-C.m k (□ (A ⊗ B)) C n (□-▹ᵏ.at k (□ (A ⊗ B)) n (δ.at (A ⊗ B) k □A⊗B) , a))
            ∎
        ) ⟩
            ◇-f (assoc-right ∘ m⁻¹ A B * id) n (st-◇ (A ⊗ B) C n (□A⊗B , (k , a)))
        ∎
        where
        lemma : ∀ k -> ▹ᵏ-C.m k (□ A) (□ B) ∘ □-▹ᵏ.at k (□ A) * □-▹ᵏ.at k (□ B)
                     ≈ □-▹ᵏ.at k (□ A ⊗ □ B) ∘ □-C.m (□ A) (□ B)
        lemma zero = refl
        lemma (suc k) {zero} {□□A , □□B} = refl
        lemma (suc k) {suc n} {□□A , □□B} = lemma k

    st-μ-◇ : ∀{A B : τ}
          -> μ.at (□ A ⊗ B) ∘ ◇-f (st-◇ A B) ∘ st-◇ A (◇ B)
           ≈ st-◇ A B ∘ (id * μ.at B)
    st-μ-◇ {A} {B} {n} {□A , (k , a)} with inspect (compareLeq k n)
    st-μ-◇ {A} {B} {.(k + l)} {□A , k , a} | snd==[ .k + l ] with≡ pf =
        begin
            μ.at (□ A ⊗ B) (k + l) (◇-f (st-◇ A B) (k + l) (st-◇ A (◇ B) (k + l) (□A , (k , a))))
        ≡⟨⟩
            μ-compare (□ A ⊗ B) (k + l) k
                (▹ᵏ-F.fmap k (st-◇ A B) (k + l)
                    (▹ᵏ-C.m k (□ A) (◇ B) (k + l)
                        (□-▹ᵏ.at k (□ A) (k + l) (δ.at A (k + l) □A) , a)))
                            (⌞ compareLeq k (k + l) ⌟)
        ≡⟨ cong! pf ⟩
            μ-compare (□ A ⊗ B) (k + l) k
                (▹ᵏ-F.fmap k (st-◇ A B) (k + l)
                    (▹ᵏ-C.m k (□ A) (◇ B) (k + l)
                        (□-▹ᵏ.at k (□ A) (k + l) (δ.at A (k + l) □A) , a)))
                            (snd==[ k + l ])
        ≡⟨⟩
            μ-shift k l
                (rew (delay-+-left0 k l)
                    (▹ᵏ-F.fmap k (st-◇ A B) (k + l)
                        (▹ᵏ-C.m k (□ A) (◇ B) (k + l)
                            ( □-▹ᵏ.at k (□ A) (k + l) (δ.at A (k + l) □A)
                            , a))))
        ≡⟨ cong (μ-shift k l) (fmap-delay-+-n+0 k l) ⟩
            μ-shift k l
                (st-◇ A B l
                    (rew (delay-+-left0 k l)
                        (▹ᵏ-C.m k (□ A) (◇ B) (k + l)
                            ( □-▹ᵏ.at k (□ A) (k + l) (δ.at A (k + l) □A)
                            , a))))
        ≡⟨ cong (λ x → μ-shift k l (st-◇ A B l x)) (m-delay-+-n+0 k l) ⟩
            μ-shift k l
                (st-◇ A B l
                    ( rew (delay-+-left0 k l) (□-▹ᵏ.at k (□ A) (k + l) (δ.at A (k + l) □A))
                    , rew (delay-+-left0 k l) a))
        ≡⟨ cong (λ x → μ-shift k l (st-◇ A B l (x , _))) (rew-□-left0 k l) ⟩
            μ-shift k l (st-◇ A B l (□A , rew (delay-+-left0 k l) a))
         ≡⟨ lemma k l (rew (delay-+-left0 k l) a) ⟩
            st-◇ A B (k + l) (□A , μ-shift k l (rew (delay-+-left0 k l) a))
        ≡⟨⟩
            st-◇ A B (k + l) (□A , μ-compare B (k + l) k a (⌞ snd==[ k + l ] ⌟))
        ≡⟨ cong! pf ⟩
            st-◇ A B (k + l) (□A , μ.at B (k + l) (k , a))
        ∎
        where
        rew-□-left0 : ∀ k l
             -> rew (delay-+-left0 k l) (□-▹ᵏ.at k (□ A) (k + l) (δ.at A (k + l) □A))
              ≡ □A
        rew-□-left0 zero l = refl
        rew-□-left0 (suc k) l = rew-□-left0 k l

        rew-□ : ∀ k l m
             -> rew (sym (delay-+ k m l)) (□-▹ᵏ.at m (□ A) l (δ.at A m □A))
              ≡ □-▹ᵏ.at (k + m) (□ A) (k + l) (δ.at A (k + m) □A)
        rew-□ zero l m = refl
        rew-□ (suc k) l m = rew-□ k l m

        lemma : ∀ k l a
             -> μ-shift k l (st-◇ A B l (□A , a))
              ≡ st-◇ A B (k + l) (□A , μ-shift k l a)
        lemma k l (m , a) =
            begin
                μ-shift k l (st-◇ A B l (□A , (m , a)))
            ≡⟨⟩
                k + m , rew (sym (delay-+ k m l)) (▹ᵏ-C.m m (□ A) B l (□-▹ᵏ.at m (□ A) l (δ.at A m □A) , a))
            ≡⟨ cong (λ x -> _ , x) (m-delay-+-sym k l m) ⟩
                k + m , ▹ᵏ-C.m (k + m) (□ A) B (k + l)
                            ( rew (sym (delay-+ k m l)) (□-▹ᵏ.at m (□ A) l (δ.at A m □A))
                            , rew (sym (delay-+ k m l)) a)
            ≡⟨ cong (λ x → _ , ▹ᵏ-C.m (k + m) (□ A) B (k + l) (x , _)) (rew-□ k l m) ⟩
                k + m , ▹ᵏ-C.m (k + m) (□ A) B (k + l)
                            ( □-▹ᵏ.at (k + m) (□ A) (k + l) (δ.at A (k + m) □A)
                            , rew (sym (delay-+ k m l)) a)
            ≡⟨⟩
                st-◇ A B (k + l) (□A , (k + m , rew (sym (delay-+ k m l)) a))
            ∎

    st-μ-◇ {A} {B} {.n} {□A , .(n + suc l) , a} | fst==suc[ n + l ] with≡ pf =
        begin
            μ.at (□ A ⊗ B) n (◇-f (st-◇ A B) n (st-◇ A (◇ B) n (□A , (n + suc l , a))))
        ≡⟨⟩
            μ-compare (□ A ⊗ B) n (n + suc l)
                (▹ᵏ-F.fmap (n + suc l) (st-◇ A B) n
                    (▹ᵏ-C.m (n + suc l) (□ A) (◇ B) n
                    (□-▹ᵏ.at (n + suc l) (□ A) n
                    (δ.at A (n + suc l) □A) , a)))
                    (⌞ compareLeq (n + suc l) n ⌟)
        ≡⟨ cong! pf ⟩
            μ-compare (□ A ⊗ B) n (n + suc l)
                (▹ᵏ-F.fmap (n + suc l) (st-◇ A B) n
                    (▹ᵏ-C.m (n + suc l) (□ A) (◇ B) n
                    (□-▹ᵏ.at (n + suc l) (□ A) n
                    (δ.at A (n + suc l) □A) , a)))
                    (fst==suc[ n + l ])
        ≡⟨⟩
            n + suc l , rew (delay-⊤ n l) top.tt
        ≡⟨ cong (λ x -> _ , x) (lemma n l) ⟩
            n + suc l , ▹ᵏ-C.m (n + suc l) (□ A) B n (□-▹ᵏ.at (n + suc l) (□ A) n (δ.at A (n + suc l) □A) , rew (delay-⊤ n l) top.tt)
        ≡⟨⟩
            st-◇ A B n (□A , μ-compare B n (n + suc l) a (⌞ fst==suc[ n + l ] ⌟))
        ≡⟨ cong! pf ⟩
            st-◇ A B n (□A , μ.at B n ((n + suc l) , a))
        ∎
        where
        lemma : ∀ n l
             -> rew (delay-⊤ n l) top.tt
              ≡ ▹ᵏ-C.m (n + suc l) (□ A) B n (□-▹ᵏ.at (n + suc l) (□ A) n (δ.at A (n + suc l) □A)
                                            , rew (delay-⊤ n l) top.tt)
        lemma zero l = refl
        lemma (suc n) l = lemma n l

open WStrongMonad ◇-□-Strong public


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Tarski-style semantics with contexts as concrete worlds, and glueing for α, ▻, and □.
-- Gentzen-style syntax.

module BasicIS4.Semantics.TarskiOvergluedGentzen where

open import BasicIS4.Syntax.Common public
open import Common.Semantics public

-- Intuitionistic Tarski models.

record Model : Set₁ where
  infix 3 _⊩ᵅ_ _[⊢]_ _[⊢⋆]_
  field
    -- Forcing for atomic propositions; monotonic.
    _⊩ᵅ_   : Cx Ty → Atom → Set
    mono⊩ᵅ : ∀ {P Γ Γ′} → Γ ⊆ Γ′ → Γ ⊩ᵅ P → Γ′ ⊩ᵅ P

    -- Gentzen-style syntax representation; monotonic.
    _[⊢]_     : Cx Ty → Ty → Set
    _[⊢⋆]_    : Cx Ty → Cx Ty → Set
    mono[⊢]   : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ [⊢] A → Γ′ [⊢] A
    [var]      : ∀ {A Γ}    → A ∈ Γ → Γ [⊢] A
    [lam]      : ∀ {A B Γ}  → Γ , A [⊢] B → Γ [⊢] A ▻ B
    [app]      : ∀ {A B Γ}  → Γ [⊢] A ▻ B → Γ [⊢] A → Γ [⊢] B
    [multibox] : ∀ {A Δ Γ}  → Γ [⊢⋆] □⋆ Δ → □⋆ Δ [⊢] A → Γ [⊢] □ A
    [down]     : ∀ {A Γ}    → Γ [⊢] □ A → Γ [⊢] A
    [pair]     : ∀ {A B Γ}  → Γ [⊢] A → Γ [⊢] B → Γ [⊢] A ∧ B
    [fst]      : ∀ {A B Γ}  → Γ [⊢] A ∧ B → Γ [⊢] A
    [snd]      : ∀ {A B Γ}  → Γ [⊢] A ∧ B → Γ [⊢] B
    [unit]     : ∀ {Γ}      → Γ [⊢] ⊤

    -- TODO: Workarounds for Agda bug #2143.
    top[⊢⋆] : ∀ {Γ}     → (Γ [⊢⋆] ∅) ≡ 𝟙
    pop[⊢⋆] : ∀ {Ξ A Γ} → (Γ [⊢⋆] Ξ , A) ≡ (Γ [⊢⋆] Ξ × Γ [⊢] A)

  infix 3 _[⊢]⋆_
  _[⊢]⋆_ : Cx Ty → Cx Ty → Set
  Γ [⊢]⋆ ∅     = 𝟙
  Γ [⊢]⋆ Ξ , A = Γ [⊢]⋆ Ξ × Γ [⊢] A

  [⊢⋆]→[⊢]⋆ : ∀ {Ξ Γ} → Γ [⊢⋆] Ξ → Γ [⊢]⋆ Ξ
  [⊢⋆]→[⊢]⋆ {∅}     {Γ} ts = ∙
  [⊢⋆]→[⊢]⋆ {Ξ , A} {Γ} ts rewrite pop[⊢⋆] {Ξ} {A} {Γ} = [⊢⋆]→[⊢]⋆ (π₁ ts) , π₂ ts

  [⊢]⋆→[⊢⋆] : ∀ {Ξ Γ} → Γ [⊢]⋆ Ξ → Γ [⊢⋆] Ξ
  [⊢]⋆→[⊢⋆] {∅}     {Γ} ∙        rewrite top[⊢⋆] {Γ}         = ∙
  [⊢]⋆→[⊢⋆] {Ξ , A} {Γ} (ts , t) rewrite pop[⊢⋆] {Ξ} {A} {Γ} = [⊢]⋆→[⊢⋆] ts , t

open Model {{…}} public

-- Forcing in a particular model.

module _ {{_ : Model}} where
  infix 3 _⊩_
  _⊩_ : Cx Ty → Ty → Set
  Γ ⊩ α P   = Glue (Γ [⊢] α P) (Γ ⊩ᵅ P)
  Γ ⊩ A ▻ B = ∀ {Γ′} → Γ ⊆ Γ′ → Glue (Γ′ [⊢] A ▻ B) (Γ′ ⊩ A → Γ′ ⊩ B)
  Γ ⊩ □ A   = ∀ {Γ′} → Γ ⊆ Γ′ → Glue (Γ′ [⊢] □ A) (Γ′ ⊩ A)
  Γ ⊩ A ∧ B = Γ ⊩ A × Γ ⊩ B
  Γ ⊩ ⊤    = 𝟙

  infix 3 _⊩⋆_
  _⊩⋆_ : Cx Ty → Cx Ty → Set
  Γ ⊩⋆ ∅     = 𝟙
  Γ ⊩⋆ Ξ , A = Γ ⊩⋆ Ξ × Γ ⊩ A

-- Monotonicity with respect to context inclusion.

module _ {{_ : Model}} where
  mono⊩ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊩ A → Γ′ ⊩ A
  mono⊩ {α P}   η s = mono[⊢] η (syn s) ⅋ mono⊩ᵅ η (sem s)
  mono⊩ {A ▻ B} η s = λ η′ → s (trans⊆ η η′)
  mono⊩ {□ A}   η s = λ η′ → s (trans⊆ η η′)
  mono⊩ {A ∧ B} η s = mono⊩ {A} η (π₁ s) , mono⊩ {B} η (π₂ s)
  mono⊩ {⊤}    η s = ∙

  mono⊩⋆ : ∀ {Ξ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊩⋆ Ξ → Γ′ ⊩⋆ Ξ
  mono⊩⋆ {∅}     η ∙        = ∙
  mono⊩⋆ {Ξ , A} η (ts , t) = mono⊩⋆ {Ξ} η ts , mono⊩ {A} η t

-- Extraction of syntax representation in a particular model.

module _ {{_ : Model}} where
  reifyʳ : ∀ {A Γ} → Γ ⊩ A → Γ [⊢] A
  reifyʳ {α P}   s = syn s
  reifyʳ {A ▻ B} s = syn (s refl⊆)
  reifyʳ {□ A}   s = syn (s refl⊆)
  reifyʳ {A ∧ B} s = [pair] (reifyʳ {A} (π₁ s)) (reifyʳ {B} (π₂ s))
  reifyʳ {⊤}    s = [unit]

  reifyʳ⋆ : ∀ {Ξ Γ} → Γ ⊩⋆ Ξ → Γ [⊢]⋆ Ξ
  reifyʳ⋆ {∅}     ∙        = ∙
  reifyʳ⋆ {Ξ , A} (ts , t) = reifyʳ⋆ ts , reifyʳ t

-- Shorthand for variables.

module _ {{_ : Model}} where
  [v₀] : ∀ {A Γ} → Γ , A [⊢] A
  [v₀] = [var] i₀

  [v₁] : ∀ {A B Γ} → Γ , A , B [⊢] A
  [v₁] = [var] i₁

  [v₂] : ∀ {A B C Γ} → Γ , A , B , C [⊢] A
  [v₂] = [var] i₂

-- Useful theorems in functional form.

module _ {{_ : Model}} where
  [multicut] : ∀ {Ξ A Γ} → Γ [⊢]⋆ Ξ → Ξ [⊢] A → Γ [⊢] A
  [multicut] {∅}     ∙        u = mono[⊢] bot⊆ u
  [multicut] {Ξ , B} (ts , t) u = [app] ([multicut] ts ([lam] u)) t

  [dist] : ∀ {A B Γ} → Γ [⊢] □ (A ▻ B) → Γ [⊢] □ A → Γ [⊢] □ B
  [dist] t u = [multibox] ([⊢]⋆→[⊢⋆] ((∙ , t) , u)) ([app] ([down] [v₁]) ([down] [v₀]))

  [up] : ∀ {A Γ} → Γ [⊢] □ A → Γ [⊢] □ □ A
  [up] t = [multibox] ([⊢]⋆→[⊢⋆] ((∙ , t))) [v₀]

-- Useful theorems in combinatory form.

module _ {{_ : Model}} where
  [ci] : ∀ {A Γ} → Γ [⊢] A ▻ A
  [ci] = [lam] [v₀]

  [ck] : ∀ {A B Γ} → Γ [⊢] A ▻ B ▻ A
  [ck] = [lam] ([lam] [v₁])

  [cs] : ∀ {A B C Γ} → Γ [⊢] (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
  [cs] = [lam] ([lam] ([lam] ([app] ([app] [v₂] [v₀]) ([app] [v₁] [v₀]))))

  [cdist] : ∀ {A B Γ} → Γ [⊢] □ (A ▻ B) ▻ □ A ▻ □ B
  [cdist] = [lam] ([lam] ([dist] [v₁] [v₀]))

  [cup] : ∀ {A Γ} → Γ [⊢] □ A ▻ □ □ A
  [cup] = [lam] ([up] [v₀])

  [cdown] : ∀ {A Γ} → Γ [⊢] □ A ▻ A
  [cdown] = [lam] ([down] [v₀])

  [box] : ∀ {A Γ} → ∅ [⊢] A → Γ [⊢] □ A
  [box] t = [multibox] ([⊢]⋆→[⊢⋆] ∙) t

  [cpair] : ∀ {A B Γ} → Γ [⊢] A ▻ B ▻ A ∧ B
  [cpair] = [lam] ([lam] ([pair] [v₁] [v₀]))

  [cfst] : ∀ {A B Γ} → Γ [⊢] A ∧ B ▻ A
  [cfst] = [lam] ([fst] [v₀])

  [csnd] : ∀ {A B Γ} → Γ [⊢] A ∧ B ▻ B
  [csnd] = [lam] ([snd] [v₀])

-- Additional useful equipment.

module _ {{_ : Model}} where
  _⟪$⟫_ : ∀ {A B Γ} → Γ ⊩ A ▻ B → Γ ⊩ A → Γ ⊩ B
  s ⟪$⟫ a = sem (s refl⊆) a

  ⟪K⟫ : ∀ {A B Γ} → Γ ⊩ A → Γ ⊩ B ▻ A
  ⟪K⟫ {A} a η = let a′ = mono⊩ {A} η a
                in  [app] [ck] (reifyʳ a′) ⅋ K a′

  ⟪S⟫ : ∀ {A B C Γ} → Γ ⊩ A ▻ B ▻ C → Γ ⊩ A ▻ B → Γ ⊩ A → Γ ⊩ C
  ⟪S⟫ s₁ s₂ a = (s₁ ⟪$⟫ a) ⟪$⟫ (s₂ ⟪$⟫ a)

  ⟪S⟫′ : ∀ {A B C Γ} → Γ ⊩ A ▻ B ▻ C → Γ ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ {A} {B} {C} s₁ η = let s₁′ = mono⊩ {A ▻ B ▻ C} η s₁
                              t   = syn (s₁′ refl⊆)
                          in  [app] [cs] t ⅋ λ s₂ η′ →
                                let s₁″ = mono⊩ {A ▻ B ▻ C} (trans⊆ η η′) s₁
                                    s₂′ = mono⊩ {A ▻ B} η′ s₂
                                    t′  = syn (s₁″ refl⊆)
                                    u   = syn (s₂′ refl⊆)
                                in  [app] ([app] [cs] t′) u ⅋ ⟪S⟫ s₁″ s₂′

  _⟪D⟫_ : ∀ {A B Γ} → Γ ⊩ □ (A ▻ B) → Γ ⊩ □ A → Γ ⊩ □ B
  (s₁ ⟪D⟫ s₂) η = let t ⅋ s₁′ = s₁ η
                      u ⅋ a   = s₂ η
                  in  [app] ([app] [cdist] t) u ⅋ s₁′ ⟪$⟫ a

  _⟪D⟫′_ : ∀ {A B Γ} → Γ ⊩ □ (A ▻ B) → Γ ⊩ □ A ▻ □ B
  _⟪D⟫′_ {A} {B} s₁ η = let s₁′ = mono⊩ {□ (A ▻ B)} η s₁
                        in  [app] [cdist] (reifyʳ (λ {_} η′ → s₁′ η′ )) ⅋ _⟪D⟫_ s₁′

  ⟪↑⟫ : ∀ {A Γ} → Γ ⊩ □ A → Γ ⊩ □ □ A
  ⟪↑⟫ s η = [app] [cup] (syn (s η)) ⅋ λ η′ → s (trans⊆ η η′)

  ⟪↓⟫ : ∀ {A Γ} → Γ ⊩ □ A → Γ ⊩ A
  ⟪↓⟫ s = sem (s refl⊆)

  _⟪,⟫′_ : ∀ {A B Γ} → Γ ⊩ A → Γ ⊩ B ▻ A ∧ B
  _⟪,⟫′_ {A} a η = let a′ = mono⊩ {A} η a
                   in  [app] [cpair] (reifyʳ a′) ⅋ _,_ a′

-- Forcing in a particular world of a particular model, for sequents.

module _ {{_ : Model}} where
  infix 3 _⊩_⇒_
  _⊩_⇒_ : Cx Ty → Cx Ty → Ty → Set
  w ⊩ Γ ⇒ A = w ⊩⋆ Γ → w ⊩ A

  infix 3 _⊩_⇒⋆_
  _⊩_⇒⋆_ : Cx Ty → Cx Ty → Cx Ty → Set
  w ⊩ Γ ⇒⋆ Ξ = w ⊩⋆ Γ → w ⊩⋆ Ξ

-- Entailment, or forcing in all worlds of all models, for sequents.

infix 3 _⊨_
_⊨_ : Cx Ty → Ty → Set₁
Γ ⊨ A = ∀ {{_ : Model}} {w : Cx Ty} → w ⊩ Γ ⇒ A

infix 3 _⊨⋆_
_⊨⋆_ : Cx Ty → Cx Ty → Set₁
Γ ⊨⋆ Ξ = ∀ {{_ : Model}} {w : Cx Ty} → w ⊩ Γ ⇒⋆ Ξ

-- Additional useful equipment, for sequents.

module _ {{_ : Model}} where
  lookup : ∀ {A Γ w} → A ∈ Γ → w ⊩ Γ ⇒ A
  lookup top     (γ , a) = a
  lookup (pop i) (γ , b) = lookup i γ

  _⟦$⟧_ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A ▻ B → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ B
  (s₁ ⟦$⟧ s₂) γ = s₁ γ ⟪$⟫ s₂ γ

  ⟦K⟧ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ B ▻ A
  ⟦K⟧ {A} {B} a γ = ⟪K⟫ {A} {B} (a γ)

  ⟦S⟧ : ∀ {A B C Γ w} → w ⊩ Γ ⇒ A ▻ B ▻ C → w ⊩ Γ ⇒ A ▻ B → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ C
  ⟦S⟧ s₁ s₂ a γ = ⟪S⟫ (s₁ γ) (s₂ γ) (a γ)

  _⟦D⟧_ : ∀ {A B Γ w} → w ⊩ Γ ⇒ □ (A ▻ B) → w ⊩ Γ ⇒ □ A → w ⊩ Γ ⇒ □ B
  (s₁ ⟦D⟧ s₂) γ = (s₁ γ) ⟪D⟫ (s₂ γ)

  ⟦↑⟧ : ∀ {A Γ w} → w ⊩ Γ ⇒ □ A → w ⊩ Γ ⇒ □ □ A
  ⟦↑⟧ s γ = ⟪↑⟫ (s γ)

  ⟦↓⟧ : ∀ {A Γ w} → w ⊩ Γ ⇒ □ A → w ⊩ Γ ⇒ A
  ⟦↓⟧ s γ = ⟪↓⟫ (s γ)

  _⟦,⟧_ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A → w ⊩ Γ ⇒ B → w ⊩ Γ ⇒ A ∧ B
  (a ⟦,⟧ b) γ = a γ , b γ

  ⟦π₁⟧ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A ∧ B → w ⊩ Γ ⇒ A
  ⟦π₁⟧ s γ = π₁ (s γ)

  ⟦π₂⟧ : ∀ {A B Γ w} → w ⊩ Γ ⇒ A ∧ B → w ⊩ Γ ⇒ B
  ⟦π₂⟧ s γ = π₂ (s γ)


-- Overlapping instances are only allowed if all valid candidates are
-- overappable.

module _ where

postulate
  A : Set

record B : Set where
  field overlap {{a}} : A

record C : Set where
  field overlap {{a}} : A

record D : Set where
  field {{a}} : A

it : ∀ {a} {A : Set a} {{_ : A}} → A
it {{x}} = x

work : {{b : B}} {{c : C}} → A
work = it

-- One variable candidate
fail₁ : {{a : A}} {{b : B}} → A
fail₁ = it

-- One non-overlappable field candidate
fail₂ : {{c : C}} {{d : D}} → A
fail₂ = it

instance postulate a : A

-- One top-level candidate
fail₃ : {{b : B}} → A
fail₃ = it


------------------------------------------------------------------------
-- A type soundness result
------------------------------------------------------------------------

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

module Lambda.Partiality-monad.Inductive.Type-soundness where

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

open import Bijection equality-with-J using (_↔_)
open import Equality.Decision-procedures equality-with-J
open import Equivalence equality-with-J using (_≃_)
open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
  as Trunc
open import Maybe equality-with-J
open import Monad equality-with-J
open import Univalence-axiom equality-with-J
open import Vec.Function equality-with-J

open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Alternative-order
open import Partiality-monad.Inductive.Monad

open import Lambda.Partiality-monad.Inductive.Interpreter
open import Lambda.Syntax

open Closure Tm

-- A propositionally truncated variant of WF-MV.

∥WF-MV∥ : Ty ∞ → Maybe Value → Type
∥WF-MV∥ σ x = ∥ WF-MV σ x ∥

-- If we can prove □ (∥WF-MV∥ σ) (run x), then x does not "go wrong".

does-not-go-wrong : ∀ {σ} {x : M Value} →
                    □ (∥WF-MV∥ σ) (run x) → ¬ x ≡ fail
does-not-go-wrong {σ} {x} always =
  x ≡ fail             ↝⟨ cong MaybeT.run ⟩
  run x ≡ now nothing  ↝⟨ always _ ⟩
  ∥WF-MV∥ σ nothing    ↝⟨ id ⟩
  ∥ ⊥₀ ∥               ↝⟨ _↔_.to (not-inhabited⇒∥∥↔⊥ id) ⟩□
  ⊥₀                   □

-- Some "constructors" for □ ∘ ∥WF-MV∥.

return-wf :
  ∀ {σ v} →
  WF-Value σ v →
  □ (∥WF-MV∥ σ) (MaybeT.run (return v))
return-wf v-wf = □-now truncation-is-proposition ∣ v-wf ∣

_>>=-wf_ :
  ∀ {σ τ} {x : M Value} {f : Value → M Value} →
  □ (∥WF-MV∥ σ) (run x) →
  (∀ {v} → WF-Value σ v → □ (∥WF-MV∥ τ) (run (f v))) →
  □ (∥WF-MV∥ τ) (MaybeT.run (x >>= f))
_>>=-wf_ {σ} {τ} {f = f} x-wf f-wf =
  □->>= (λ _ → truncation-is-proposition) x-wf
    λ { {nothing} → Trunc.rec prop ⊥-elim
      ; {just v}  → Trunc.rec prop f-wf
      }
  where
  prop : ∀ {x} → Is-proposition (□ (∥WF-MV∥ τ) x)
  prop = □-closure 1 (λ _ → truncation-is-proposition)

-- Type soundness.

mutual

  ⟦⟧′-wf : ∀ {n Γ} (t : Tm n) {σ} → Γ ⊢ t ∈ σ →
           ∀ {ρ} → WF-Env Γ ρ →
           ∀ n → □ (∥WF-MV∥ σ) (run (⟦ t ⟧′ ρ n))
  ⟦⟧′-wf (con i)   con             ρ-wf n = return-wf con
  ⟦⟧′-wf (var x)   var             ρ-wf n = return-wf (ρ-wf x)
  ⟦⟧′-wf (ƛ t)     (ƛ t∈)          ρ-wf n = return-wf (ƛ t∈ ρ-wf)
  ⟦⟧′-wf (t₁ · t₂) (t₁∈ · t₂∈) {ρ} ρ-wf n =
     ⟦⟧′-wf t₁ t₁∈ ρ-wf n >>=-wf λ f-wf →
     ⟦⟧′-wf t₂ t₂∈ ρ-wf n >>=-wf λ v-wf →
     ∙-wf f-wf v-wf n

  ∙-wf : ∀ {σ τ f v} →
         WF-Value (σ ⇾ τ) f → WF-Value (force σ) v →
         ∀ n → □ (∥WF-MV∥ (force τ)) (run ((f ∙ v) n))
  ∙-wf (ƛ t₁∈ ρ₁-wf) v₂-wf (suc n) = ⟦⟧′-wf _ t₁∈ (cons-wf v₂-wf ρ₁-wf) n
  ∙-wf (ƛ t₁∈ ρ₁-wf) v₂-wf zero    =         $⟨ □-never ⟩
    □ (∥WF-MV∥ _) never                      ↝⟨ ≡⇒↝ bijection $ cong (□ (∥WF-MV∥ _)) (sym never->>=) ⟩□
    □ (∥WF-MV∥ _) (never >>= return ∘ just)  □

type-soundness : ∀ {t : Tm 0} {σ} →
                 nil ⊢ t ∈ σ → ¬ ⟦ t ⟧ nil ≡ fail
type-soundness {t} {σ} =
  nil ⊢ t ∈ σ                                 ↝⟨ (λ t∈ → ⟦⟧′-wf _ t∈ nil-wf) ⟩
  (∀ n → □ (∥WF-MV∥ σ) (run (⟦ t ⟧′ nil n)))  ↝⟨ □-⨆ (λ _ → truncation-is-proposition) ⟩
  □ (∥WF-MV∥ σ) (run (⟦ t ⟧ nil))             ↝⟨ does-not-go-wrong ⟩□
  ¬ ⟦ t ⟧ nil ≡ fail                          □


------------------------------------------------------------------------
-- Code related to the paper draft "Structurally Recursive Descent
-- Parsing"
--
-- Nils Anders Danielsson and Ulf Norell
------------------------------------------------------------------------

module StructurallyRecursiveDescentParsing where

-- The code presented here is not identical to that in the paper; it
-- has evolved.

-- Parser type indices.

import StructurallyRecursiveDescentParsing.Index

-- Parsers containing non-terminals, and grammars using such parsers.

import StructurallyRecursiveDescentParsing.Grammar

-- A library of derived parser combinators.

import StructurallyRecursiveDescentParsing.Lib

-- Some small examples.

import StructurallyRecursiveDescentParsing.Examples

-- An example: parsing PBM image files.

import StructurallyRecursiveDescentParsing.PBM

-- A depth-first backend.

import StructurallyRecursiveDescentParsing.DepthFirst

-- The backend does not work directly on the parsers in
-- StructurallyRecursiveDescentParsing.Grammar. The following
-- simplified parsers are used instead. The function
-- StructurallyRecursiveDescentParsing.Grammar.⟦_⟧ turns parsers
-- containing non-terminals into simplified parsers.

import StructurallyRecursiveDescentParsing.Simplified
import StructurallyRecursiveDescentParsing.Simplified.Semantics