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

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Abstract.Types
open import LibraBFT.Abstract.Types.EpochConfig
open        WithAbsVote

-- This module contains properties about RecordChains, culminating in
-- theorem S5, which is the main per-epoch correctness condition.  The
-- properties are based on the original version of the LibraBFT paper,
-- which was current when they were developed:
-- https://developers.diem.com/docs/assets/papers/diem-consensus-state-machine-replication-in-the-diem-blockchain/2019-06-28.pdf
-- Even though the implementation has changed since that version of the
-- paper, we do not need to redo these proofs because that affects only
-- the concrete implementation.  This demonstrates one advantage of
-- separating these proofs into abstract and concrete pieces.

module LibraBFT.Abstract.RecordChain.Properties
  (UID    : Set)
  (_≟UID_ : (u₀ u₁ : UID) → Dec (u₀ ≡ u₁))
  (NodeId : Set)
  (𝓔      : EpochConfig UID NodeId)
  (𝓥      : VoteEvidence UID NodeId 𝓔)
  where
 open import LibraBFT.Abstract.Types                   UID        NodeId 𝓔
 open import LibraBFT.Abstract.System                  UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.Records                 UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.Records.Extends         UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.RecordChain             UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.RecordChain.Assumptions UID _≟UID_ NodeId 𝓔 𝓥
 open        EpochConfig 𝓔

 module WithInvariants {ℓ}
   (InSys                 : Record → Set ℓ)
   (votes-only-once       : VotesOnlyOnceRule InSys)
   (preferred-round-rule  : PreferredRoundRule InSys)
   where
   open All-InSys-props InSys

   ----------------------
   -- Lemma 2

   -- Lemma 2 states that there can be at most one certified block per
   -- round.  If two blocks have a quorum certificate for the same round,
   -- then they are equal or their unique identifier is not
   -- injective. This is required because, on the concrete side, this bId
   -- will be a hash function which might yield collisions.
   lemmaS2 : {b₀ b₁ : Block}{q₀ q₁ : QC}
           → InSys (Q q₀) → InSys (Q q₁)
           → (p₀ : B b₀ ← Q q₀)
           → (p₁ : B b₁ ← Q q₁)
           → getRound b₀ ≡ getRound b₁
           → NonInjective-≡ bId ⊎ b₀ ≡ b₁
   lemmaS2 {b₀} {b₁} {q₀} {q₁} ex₀ ex₁ (B←Q refl h₀) (B←Q refl h₁) refl
     with b₀ ≟Block b₁
   ...| yes done = inj₂ done
   ...| no  imp
     with bft-assumption (qVotes-C1 q₀) (qVotes-C1 q₁)
   ...|  (a , (a∈q₀mem , a∈q₁mem , honest))
     with Any-sym (Any-map⁻ a∈q₀mem) | Any-sym (Any-map⁻ a∈q₁mem)
   ...| a∈q₀ | a∈q₁
      with All-lookup (qVotes-C3 q₀) (∈QC-Vote-correct q₀ a∈q₀) |
      All-lookup (qVotes-C3 q₁) (∈QC-Vote-correct q₁ a∈q₁)
   ...| a∈q₀rnd≡ | a∈q₁rnd≡
     with <-cmp (abs-vRound (∈QC-Vote q₀ a∈q₀)) (abs-vRound (∈QC-Vote q₁ a∈q₁))
   ...| tri< va<va' _ _ = ⊥-elim (<⇒≢ (subst₂ _<_ a∈q₀rnd≡ a∈q₁rnd≡ va<va') refl)
   ...| tri> _ _ va'<va = ⊥-elim (<⇒≢ (subst₂ _≤_ (cong suc a∈q₁rnd≡) a∈q₀rnd≡ va'<va) refl)
   ...| tri≈ _ v₀≡v₁ _ =
     let v₀∈q₀ = ∈QC-Vote-correct q₀ a∈q₀
         v₁∈q₁ = ∈QC-Vote-correct q₁ a∈q₁
         ppp   = trans h₀ (trans (vote≡⇒QPrevId≡ {q₀} {q₁} v₀∈q₀ v₁∈q₁ (votes-only-once a honest ex₀ ex₁ a∈q₀ a∈q₁ v₀≡v₁))
                                 (sym h₁))
     in inj₁ ((b₀ , b₁) , (imp , ppp))

   ----------------
   -- Lemma S3

   lemmaS3 : ∀{r₂ q'}
             {rc : RecordChain r₂}      → InSys r₂
           → (rc' : RecordChain (Q q')) → InSys (Q q')  -- Immediately before a (Q q), we have the certified block (B b), which is the 'B' in S3
           → (c3 : 𝕂-chain Contig 3 rc)                 -- This is B₀ ← C₀ ← B₁ ← C₁ ← B₂ ← C₂ in S3
           → round r₂ < getRound q'
           → NonInjective-≡ bId ⊎ (getRound (kchainBlock (suc (suc zero)) c3) ≤ prevRound rc')
   lemmaS3 {r₂} {q'} ex₀ (step rc' b←q') ex₁ (s-chain {rc = rc} {b = b₂} {q₂} r←b₂ _ b₂←q₂ c2) hyp
     with bft-assumption (qVotes-C1 q₂) (qVotes-C1 q')
   ...| (a , (a∈q₂mem , a∈q'mem , honest))
        with Any-sym (Any-map⁻ a∈q₂mem) | Any-sym (Any-map⁻ a∈q'mem)
   ...| a∈q₂ | a∈q'

     -- TODO-1: We have done similar reasoning on the order of votes for
     -- lemmaS2. We should factor out a predicate that analyzes the rounds
     -- of QC's and returns us a judgement about the order of the votes.
     with All-lookup (qVotes-C3 q') (∈QC-Vote-correct q' a∈q') |
          All-lookup (qVotes-C3 q₂) (∈QC-Vote-correct q₂ a∈q₂)
   ...| a∈q'rnd≡ | a∈q₂rnd≡
     with <-cmp (round r₂) (abs-vRound (∈QC-Vote q' a∈q'))
   ...| tri> _ _ va'<va₂
     with subst₂ _<_ a∈q'rnd≡ a∈q₂rnd≡   (≤-trans va'<va₂ (≤-reflexive (sym a∈q₂rnd≡)))
   ...| res = ⊥-elim (n≮n (getRound q') (≤-trans res (≤-unstep hyp)))
   lemmaS3 {q' = q'} ex₀ (step rc' b←q') ex₁ (s-chain {rc = rc} {b = b₂} {q₂} r←b₂ P b₂←q₂ c2) hyp
      | (a , (a∈q₂mem , a∈q'mem , honest))
      | a∈q₂ | a∈q'
      | a∈q'rnd≡ | a∈q₂rnd≡
      | tri≈ _ v₂≡v' _ =
     let v₂∈q₂ = ∈QC-Vote-correct q₂ a∈q₂
         v'∈q' = ∈QC-Vote-correct q' a∈q'
      in ⊥-elim (<⇒≢ hyp (vote≡⇒QRound≡ {q₂} {q'} v₂∈q₂ v'∈q'
                                        (votes-only-once a honest {q₂} {q'} ex₀ ex₁ a∈q₂ a∈q'
                                                         (trans a∈q₂rnd≡ v₂≡v'))))
   lemmaS3 {r} {q'} ex₀ (step rc' b←q') ex₁  (s-chain {rc = rc} {b = b₂} {q₂} r←b₂ P b₂←q₂ c2) hyp
      | (a , (a∈q₂mem , a∈q'mem , honest))
      | a∈q₂ | a∈q'
      | a∈q'rnd≡ | a∈q₂rnd≡
      | tri< va₂<va' _ _
     with b←q'
   ...| B←Q rrr xxx
      = preferred-round-rule a honest {q₂} {q'} ex₀ ex₁ (s-chain r←b₂ P b₂←q₂ c2) a∈q₂
                    (step rc' (B←Q rrr xxx)) a∈q'
                          (≤-trans (≤-reflexive (cong suc a∈q₂rnd≡))
                                   va₂<va')

  ------------------
  -- Proposition S4

   -- The base case for lemma S4 resorts to a pretty simple
   -- arithmetic statement.
   propS4-base-arith
     : ∀ n r
     → n ≤ r → r ≤ (suc (suc n))
     → r ∈ (suc (suc n) ∷ suc n ∷ n ∷ [])
   propS4-base-arith .0 .0 z≤n z≤n = there (there (here refl))
   propS4-base-arith .0 .1 z≤n (s≤s z≤n) = there (here refl)
   propS4-base-arith .0 .2 z≤n (s≤s (s≤s z≤n)) = here refl
   propS4-base-arith (suc r) (suc n) (s≤s h0) (s≤s h1)
     = ∈-cong suc (propS4-base-arith r n h0 h1)

   -- Which is then translated to LibraBFT lingo
   propS4-base-lemma-1
     : ∀{q}{rc : RecordChain (Q q)}
     → (c3 : 𝕂-chain Contig 3 rc) -- This is B₀ ← C₀ ← B₁ ← C₁ ← B₂ ← C₂ in S4
     → (r : ℕ)
     → getRound (c3 b⟦ suc (suc zero) ⟧) ≤ r
     → r ≤ getRound (c3 b⟦ zero ⟧)
     → r ∈ ( getRound (c3 b⟦ zero ⟧)
           ∷ getRound (c3 b⟦ (suc zero) ⟧)
           ∷ getRound (c3 b⟦ (suc (suc zero)) ⟧)
           ∷ [])
   propS4-base-lemma-1 (s-chain {b = b0} _ p0 (B←Q refl b←q0)
                       (s-chain {b = b1} r←b1 p1 (B←Q refl b←q1)
                       (s-chain {r = R} {b = b2} r←b2 p2 (B←Q refl b←q2)
                          0-chain))) r hyp0 hyp1
     rewrite p0 | p1 = propS4-base-arith (bRound b2) r hyp0 hyp1

   propS4-base-lemma-2
     : ∀{k r}
       {rc : RecordChain r} → All-InSys rc
     → (q' : QC) → InSys (Q q')
     → {b' : Block}
     → (rc' : RecordChain (B b')) → (ext : (B b') ← (Q q'))
     → (c  : 𝕂-chain Contig k rc)
     → (ix : Fin k)
     → getRound (kchainBlock ix c) ≡ getRound b'
     → NonInjective-≡ bId ⊎ (kchainBlock ix c ≡ b')
   propS4-base-lemma-2 {rc = rc} prev∈sys q' q'∈sys rc' ext (s-chain r←b prf b←q c) zero hyp
     = lemmaS2 (All-InSys⇒last-InSys prev∈sys) q'∈sys b←q ext hyp
   propS4-base-lemma-2 prev∈sys q' q'∈sys rc' ext (s-chain r←b prf b←q c) (suc ix)
     = propS4-base-lemma-2 (All-InSys-unstep (All-InSys-unstep prev∈sys)) q' q'∈sys rc' ext c ix

   propS4-base : ∀{q q'}
               → {rc : RecordChain (Q q)}   → All-InSys rc
               → (rc' : RecordChain (Q q')) → InSys (Q q')
               → (c3 : 𝕂-chain Contig 3 rc) -- This is B₀ ← C₀ ← B₁ ← C₁ ← B₂ ← C₂ in S4
               → getRound (c3 b⟦ suc (suc zero) ⟧) ≤ getRound q'
               → getRound q' ≤ getRound (c3 b⟦ zero ⟧)
               → NonInjective-≡ bId ⊎ B (c3 b⟦ suc (suc zero) ⟧) ∈RC rc'
   propS4-base {q' = q'} prev∈sys (step {B b} rc'@(step rc'' q←b) b←q@(B←Q refl _)) q'∈sys c3 hyp0 hyp1
     with propS4-base-lemma-1 c3 (getRound b) hyp0 hyp1
   ...| here r
     with propS4-base-lemma-2 prev∈sys q' q'∈sys rc' b←q c3 zero (sym r)
   ...| inj₁ hb = inj₁ hb
   ...| inj₂ res
     with 𝕂-chain-∈RC c3 zero (suc (suc zero)) z≤n res rc'
   ...| inj₁ hb   = inj₁ hb
   ...| inj₂ res' = inj₂ (there b←q res')
   propS4-base {q} {q'} prev∈sys (step rc' (B←Q refl x₀)) q'∈sys c3 hyp0 hyp1
      | there (here r)
     with propS4-base-lemma-2 prev∈sys q' q'∈sys rc' (B←Q refl x₀) c3 (suc zero) (sym r)
   ...| inj₁ hb = inj₁ hb
   ...| inj₂ res
     with 𝕂-chain-∈RC c3 (suc zero) (suc (suc zero)) (s≤s z≤n) res rc'
   ...| inj₁ hb   = inj₁ hb
   ...| inj₂ res' = inj₂ (there (B←Q refl x₀) res')
   propS4-base {q' = q'} prev∈sys (step rc' (B←Q refl x₀)) q'∈sys c3 hyp0 hyp1
      | there (there (here r))
     with propS4-base-lemma-2 prev∈sys q' q'∈sys rc' (B←Q refl x₀) c3 (suc (suc zero)) (sym r)
   ...| inj₁ hb = inj₁ hb
   ...| inj₂ res
     with 𝕂-chain-∈RC c3 (suc (suc zero)) (suc (suc zero)) (s≤s (s≤s z≤n)) res rc'
   ...| inj₁ hb   = inj₁ hb
   ...| inj₂ res' = inj₂ (there (B←Q refl x₀) res')

   propS4 : ∀{q q'}
          → {rc : RecordChain (Q q)}   → All-InSys rc
          → (rc' : RecordChain (Q q')) → All-InSys rc'
          → (c3 : 𝕂-chain Contig 3 rc) -- This is B₀ ← C₀ ← B₁ ← C₁ ← B₂ ← C₂ in S4
          → getRound (c3 b⟦ suc (suc zero) ⟧) ≤ getRound q'
          -- In the paper, the proposition states that B₀ ←⋆ B, yet, B is the block preceding
          -- C, which in our case is 'prevBlock rc''. Hence, to say that B₀ ←⋆ B is
          -- to say that B₀ is a block in the RecordChain that goes all the way to C.
          → NonInjective-≡ bId ⊎ B (c3 b⟦ suc (suc zero) ⟧) ∈RC rc'
   propS4 {q' = q'} {rc} prev∈sys (step rc' b←q') prev∈sys' c3 hyp
     with getRound q' ≤?ℕ getRound (c3 b⟦ zero ⟧)
   ...| yes rq≤rb₂ = propS4-base {q' = q'} prev∈sys (step rc' b←q') (All-InSys⇒last-InSys prev∈sys') c3 hyp rq≤rb₂
   propS4 {q' = q'} prev∈sys (step rc' b←q') all∈sys c3 hyp
      | no  rb₂<rq
     with lemmaS3 (All-InSys⇒last-InSys prev∈sys) (step rc' b←q')
                  (All-InSys⇒last-InSys all∈sys) c3
                  (subst (_< getRound q') (kchainBlockRoundZero-lemma c3) (≰⇒> rb₂<rq))
   ...| inj₁ hb = inj₁ hb
   ...| inj₂ ls3
     with rc' | b←q'
   ...| step rc'' q←b | (B←Q {b} rx x)
     with rc'' | q←b
   ...| empty | (I←B _ _)
      = contradiction (n≤0⇒n≡0 ls3)
                      (¬bRound≡0 (kchain-to-RecordChain-at-b⟦⟧ c3 (suc (suc zero))))
   ...| step {r = r} rc''' (B←Q {q = q''} refl bid≡) | (Q←B ry y)
     with propS4 {q' = q''} prev∈sys (step rc''' (B←Q refl bid≡)) (All-InSys-unstep (All-InSys-unstep all∈sys)) c3 ls3
   ...| inj₁ hb'   = inj₁ hb'
   ...| inj₂ final = inj₂ (there (B←Q rx x) (there (Q←B ry y) final))

   -------------------
   -- Theorem S5
   thmS5 : ∀{q q'}
         → {rc  : RecordChain (Q q )} → All-InSys rc
         → {rc' : RecordChain (Q q')} → All-InSys rc'
         → {b b' : Block}
         → CommitRule rc  b
         → CommitRule rc' b'
         → NonInjective-≡ bId ⊎ ((B b) ∈RC rc' ⊎ (B b') ∈RC rc) -- Not conflicting means one extends the other.
   thmS5 {rc = rc} prev∈sys {rc'} prev∈sys' (commit-rule c3 refl) (commit-rule c3' refl)
     with <-cmp (getRound (c3 b⟦ suc (suc zero) ⟧)) (getRound (c3' b⟦ suc (suc zero) ⟧))
   ...| tri≈ _ r≡r' _ = inj₁ <⊎$> (propS4 prev∈sys  rc' prev∈sys' c3  (≤-trans (≡⇒≤ r≡r')      (kchain-round-≤-lemma' c3' (suc (suc zero)))))
   ...| tri< r<r' _ _ = inj₁ <⊎$> (propS4 prev∈sys  rc' prev∈sys' c3  (≤-trans (≤-unstep r<r') (kchain-round-≤-lemma' c3' (suc (suc zero)))))
   ...| tri> _ _ r'<r = inj₂ <⊎$> (propS4 prev∈sys' rc  prev∈sys  c3' (≤-trans (≤-unstep r'<r) (kchain-round-≤-lemma' c3  (suc (suc zero)))))


  open import Data.Proofs
  open import Function.Proofs
  open import Logic.Propositional.Theorems
  open import Structure.Container.SetLike
  open import Structure.Relator
  open import Structure.Relator.Properties
  open import Syntax.Transitivity

  instance
    ImageSet-setLike : SetLike(_∈_ {ℓᵢ})
    SetLike._⊆_ ImageSet-setLike A B = ∀{x} → (x ∈ A) → (x ∈ B)
    SetLike._≡_ ImageSet-setLike A B = ∀{x} → (x ∈ A) ↔ (x ∈ B)
    SetLike.[⊆]-membership ImageSet-setLike = [↔]-reflexivity
    SetLike.[≡]-membership ImageSet-setLike = [↔]-reflexivity
  private open module ImageSet-SetLike {ℓᵢ} = SetLike(ImageSet-setLike{ℓᵢ}) public
  open import Structure.Container.SetLike.Proofs using ([⊇]-membership) public
  module _ {ℓᵢ} where
    instance [⊆]-binaryRelator  = Structure.Container.SetLike.Proofs.[⊆]-binaryRelator  ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [⊇]-binaryRelator  = Structure.Container.SetLike.Proofs.[⊇]-binaryRelator  ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [≡]-to-[⊆]         = Structure.Container.SetLike.Proofs.[≡]-to-[⊆]         ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [≡]-to-[⊇]         = Structure.Container.SetLike.Proofs.[≡]-to-[⊇]         ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [⊆]-reflexivity    = Structure.Container.SetLike.Proofs.[⊆]-reflexivity    ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [⊆]-antisymmetry   = Structure.Container.SetLike.Proofs.[⊆]-antisymmetry   ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [⊆]-transitivity   = Structure.Container.SetLike.Proofs.[⊆]-transitivity   ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [⊆]-partialOrder   = Structure.Container.SetLike.Proofs.[⊆]-partialOrder   ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [≡]-reflexivity    = Structure.Container.SetLike.Proofs.[≡]-reflexivity    ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [≡]-symmetry       = Structure.Container.SetLike.Proofs.[≡]-symmetry       ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [≡]-transitivity   = Structure.Container.SetLike.Proofs.[≡]-transitivity   ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [≡]-equivalence    = Structure.Container.SetLike.Proofs.[≡]-equivalence    ⦃ ImageSet-setLike{ℓᵢ} ⦄
    instance [∈]-unaryOperatorᵣ = Structure.Container.SetLike.Proofs.[∈]-unaryOperatorᵣ ⦃ ImageSet-setLike{ℓᵢ} ⦄


{-# OPTIONS --two-level --cubical-compatible #-}

open import Agda.Primitive

data D₁ : SSet → SSet (lsuc lzero) where
  c : (@0 A : SSet) → A → D₁ A

data D₂ : Set → SSet (lsuc lzero) where
  c : (@0 A : Set) → A → D₂ A


module Extensionality where

open import Relation.Binary.PropositionalEquality hiding (Extensionality)

postulate
  f-ext : {A : Set}{B : A → Set}{f : (x : A) → B x} {g : (x : A) → B x} →
    (∀ x → f x ≡ g x) → f ≡ g


open import Level hiding ( suc ; zero )
open import Algebra
module sym2 where

open import Symmetric
open import Data.Unit
open import Function.Inverse as Inverse using (_↔_; Inverse; _InverseOf_)
open import Function
open import Data.Nat hiding (_⊔_) -- using (ℕ; suc; zero)
open import Relation.Nullary
open import Data.Empty
open import Data.Product

open import Gutil
open import Putil
open import FLutil
open import Solvable using (solvable)
open import  Relation.Binary.PropositionalEquality hiding ( [_] )

open import Data.Fin
open import Data.Fin.Permutation

sym2solvable : solvable (Symmetric 2)
solvable.dervied-length sym2solvable = 1
solvable.end sym2solvable x d = solved x d where

   open import Data.List using ( List ; [] ; _∷_ )

   open Solvable (Symmetric 2)
   -- open Group (Symmetric 2) using (_⁻¹)

   p0 :  FL→perm ((# 0) :: ((# 0 ) :: f0)) =p= pid
   p0 = pleq _ _ refl

   p0r :  perm→FL pid ≡  ((# 0) :: ((# 0 ) :: f0))
   p0r = refl

   p1 :  FL→perm ((# 1) :: ((# 0 ) :: f0)) =p= pswap pid
   p1 = pleq _ _ refl

   p1r :  perm→FL (pswap pid) ≡  ((# 1) :: ((# 0 ) :: f0))
   p1r = refl

   -- FL→iso : (fl : FL 2 )  → perm→FL ( FL→perm fl ) ≡ fl
   -- FL→iso  (zero :: (zero :: f0)) = refl
   -- FL→iso ((suc zero) :: (zero :: f0)) = refl

   open _=p=_
   open ≡-Reasoning

   sym2lem0 :  ( g h : Permutation 2 2 ) → (q : Fin 2)  → ([ g , h ]  ⟨$⟩ʳ q) ≡ (pid ⟨$⟩ʳ q)
   sym2lem0 g h q with perm→FL g | perm→FL h | inspect perm→FL g | inspect perm→FL h
   sym2lem0 g h q | zero :: (zero :: f0) | _ | record { eq = g=00} | record { eq = h=00}  = begin
             [ g , h ]  ⟨$⟩ʳ q
           ≡⟨⟩
              h ⟨$⟩ʳ  (g ⟨$⟩ʳ ( h ⟨$⟩ˡ ( g ⟨$⟩ˡ q )))
           ≡⟨ cong (λ k → h ⟨$⟩ʳ  (g ⟨$⟩ʳ ( h ⟨$⟩ˡ  k))) ((peqˡ sym2lem1 _ )) ⟩
              h ⟨$⟩ʳ  (g ⟨$⟩ʳ ( h ⟨$⟩ˡ ( pid ⟨$⟩ˡ q )))
           ≡⟨ cong (λ k →  h ⟨$⟩ʳ k ) (peq sym2lem1 _ )  ⟩
              h ⟨$⟩ʳ  (pid ⟨$⟩ʳ ( h ⟨$⟩ˡ ( pid ⟨$⟩ˡ q )))
           ≡⟨⟩
             [ pid , h ]  ⟨$⟩ʳ q
           ≡⟨ peq (idcomtl h) q ⟩
             q
           ∎ where
             sym2lem1 :  g =p= pid
             sym2lem1 = FL-inject  g=00
   sym2lem0 g h q | _ | zero :: (zero :: f0) | record { eq = g=00} | record { eq = h=00} = begin
             [ g , h ]  ⟨$⟩ʳ q
           ≡⟨⟩
              h ⟨$⟩ʳ  (g ⟨$⟩ʳ ( h ⟨$⟩ˡ ( g ⟨$⟩ˡ q )))
           ≡⟨ peq sym2lem2 _   ⟩
              pid ⟨$⟩ʳ  (g ⟨$⟩ʳ ( h ⟨$⟩ˡ ( g ⟨$⟩ˡ q )))
           ≡⟨ cong (λ k → pid ⟨$⟩ʳ  (g ⟨$⟩ʳ k)) (peqˡ sym2lem2 _ ) ⟩
              pid ⟨$⟩ʳ  (g ⟨$⟩ʳ ( pid ⟨$⟩ˡ ( g ⟨$⟩ˡ q )))
           ≡⟨⟩
             [ g , pid ]  ⟨$⟩ʳ q
           ≡⟨ peq (idcomtr g) q ⟩
             q
          ∎ where
             sym2lem2 :  h =p= pid
             sym2lem2 = FL-inject h=00
   sym2lem0 g h q | suc zero :: (zero :: f0) | suc zero :: (zero :: f0) | record { eq = g=00} | record { eq = h=00}= begin
             [ g , h ]  ⟨$⟩ʳ q
           ≡⟨⟩
              h ⟨$⟩ʳ  (g ⟨$⟩ʳ ( h ⟨$⟩ˡ ( g ⟨$⟩ˡ q )))
           ≡⟨ peq (psym g=h ) _  ⟩
              g ⟨$⟩ʳ  (g ⟨$⟩ʳ ( h ⟨$⟩ˡ ( g ⟨$⟩ˡ q )))
           ≡⟨ cong (λ k →   g ⟨$⟩ʳ  (g ⟨$⟩ʳ  k) ) (peqˡ (psym g=h) _)  ⟩
              g ⟨$⟩ʳ  (g ⟨$⟩ʳ ( g ⟨$⟩ˡ ( g ⟨$⟩ˡ q )))
           ≡⟨ cong (λ k → g  ⟨$⟩ʳ k) ( inverseʳ g )  ⟩
              g ⟨$⟩ʳ  ( g ⟨$⟩ˡ q )
           ≡⟨ inverseʳ g   ⟩
             q
          ∎ where
              g=h :  g =p= h
              g=h =  FL-inject (trans g=00 (sym h=00))
   solved :  (x : Permutation 2 2) → Commutator  (λ x₁ → Lift (Level.suc Level.zero) ⊤) x → x =p= pid
   solved x (comm {g} {h} _ _) = record { peq = sym2lem0 g h  }
   solved x (ccong {f} {g} (record {peq = f=g}) d) with solved f d
   ... | record { peq = f=e }  =  record  { peq = λ q → cc q } where
      cc : ( q : Fin 2 ) → x ⟨$⟩ʳ q ≡ q
      cc q = begin
             x ⟨$⟩ʳ q
          ≡⟨ sym (f=g q) ⟩
             f ⟨$⟩ʳ q
          ≡⟨ f=e q ⟩
             q
          ∎ where open ≡-Reasoning


open import Prelude
open import Algebra
open import Algebra.Monus

module Codata.Segments
  {ℓ}
  (mon : CTMAPOM ℓ)
  where

open CTMAPOM mon

private variable i j : 𝑆

-- This is a type which contains some finite and some infinite lists.
-- The idea is that each entry contains a parameter (w) which says
-- how much coinductive "fuel" it uses.
-- The Colist′ A i type represents a colist which is defined down to depth
-- i; the Colist A type represents a "true" colist, i.e. a colist defined for
-- any given depth.
infixr 5 _◃_
data Colist′ {a} (A : Type a) (i : 𝑆) : Type (a ℓ⊔ ℓ) where
  _◃_ : ∀ w → -- Segment size
          (  (w<i : w < i) → -- If there is enough fuel left (i is the fuel)
                             -- (also the _<_ type is a proposition)
             A × Colist′ A (i ∸ w) -- Produce an element followed by the rest of
                                   -- the list, with w taken out of the fuel.
             ) →
          Colist′ A i

Colist : Type a → Type (a ℓ⊔ ℓ)
Colist A = ∀ {i} → Colist′ A i

-- The main interesting things tyhis type can do are the following:
-- * Infinite lists.
-- * The "fuel" parameter can be an arbitrary monoid, not just ℕ
-- * Finite lists can also be specified, and the way we say something is
--   finite is by taking no fuel.
-- * Everything seems to correspond correctly to the monus axioms.

--------------------------------------------------------------------------------
-- Finite colists
--------------------------------------------------------------------------------

-- By adding a finite prefix you don't have to use any of the fuel.

_∹_ : A → Colist A → Colist A
x ∹ xs = ε ◃ λ _ → x , xs

--------------------------------------------------------------------------------
-- Empty colists
--------------------------------------------------------------------------------

-- To terminate computation you use all the fuel, making an empty list.
-- (I'm not sure how principled this is: semantically I don't know if I like
-- that the size of a segment can depend on the supplied size parameter).
empty : Colist A
empty {i = i} = i ◃ λ i<i → ⊥-elim (irrefl i<i)

--------------------------------------------------------------------------------
-- Finite derived colists
--------------------------------------------------------------------------------

-- singleton
pure : A → Colist A
pure x = x ∹ empty

replicate : ℕ → A → Colist A
replicate zero    x = empty
replicate (suc n) x = x ∹ replicate n x

--------------------------------------------------------------------------------
-- Infinite colists
--------------------------------------------------------------------------------

-- This unfold function produces an infinite list; it needs every size segment
-- be non empty so that each step uses some fuel. This is what provides the
-- termination argument.

module _
    (B : 𝑆 → Type b) -- The seed type
    (ϕ : ∀ {i} → -- At depth i
           B i → -- With this seed
           ∃ w × -- Produce a segment of size w
           (w ≢ ε) × -- w can't be ε, so that we use some of the fuel to prove
                     -- termination
           ((w<i : w < i) → A × B (i ∸ w)) -- And produce the cons constructor.
           )
    -- ^ The step function
    where
    unfold′ : Acc _<_ i → B i → Colist′ A i
    unfold′ a = uncurry _◃_
              ∘ map₂
                (λ { (w≢ε , xs′) w<i →
                       map₂ (case a of
                              λ { (acc wf) →
                                    unfold′ (wf _ (∸‿<-< _ _ w<i w≢ε)) })
                            (xs′ w<i) })
              ∘ ϕ

unfold : (fdc : WellFounded _<_)
         (B : 𝑆 → Type b)
         (ϕ : ∀ {i} → B i → ∃ w × (w ≢ ε) × ((w<i : w < i) → A × B (i ∸ w))) →
         (∀ {i} → B i) → Colist A
unfold fdc B ϕ xs {i} = unfold′ B ϕ (fdc i) xs

-- Here's a simple example using the unfold function: this produces infinitely
-- repeated values, with segment size s.
repeat : (fdc : WellFounded _<_) (s : 𝑆) (s≢ε : s ≢ ε) (x : A) → Colist A
repeat fdc s s≢ε x = unfold fdc (const ⊤) (λ _ → s , s≢ε , const (x , tt)) tt

--------------------------------------------------------------------------------
-- Manipulating colists
--------------------------------------------------------------------------------

-- One important thing to note about the Colist type: it is inductive!
-- Although it does technically represent "coinduction", the constructors and
-- type itself are inductive as far as Agda can see. For that reason functions
-- like map pass the termination checker with no extra ceremony.
map : (A → B) → Colist′ A i → Colist′ B i
map f (w ◃ xs) = w ◃ λ w<i → case xs w<i of λ { (y , ys) → f y , map f ys }

-- You can extract a finite prefix of the colist.
open import Data.List using (List; _∷_; [])

take′ : ∀ i → Colist′ A i → List A
take′ i (w ◃ xs) with w <? i
... | no _ = []
... | yes w<i with xs w<i
... | y , ys = y ∷ take′ _ ys

take : 𝑆 → Colist A → List A
take x xs = take′ x xs


{-# OPTIONS --cubical #-}

open import Agda.Builtin.Cubical.Path using (_≡_)
open import Agda.Builtin.Sigma using (Σ; fst; _,_)

postulate
  Is-proposition : Set → Set
  subst          : ∀ {A : Set} (P : A → Set) {x y} → x ≡ y → P x → P y

Proposition : Set₁
Proposition = Σ _ Is-proposition

data _/_ (A : Set) (R : A → A → Proposition) : Set where
  [_]  : A → A / R
  resp : ∀ {x y} → fst (R x y) → [ x ] ≡ [ y ]

variable
  A : Set
  R : A → A → Proposition

postulate
  F : (P : A / R → Set)
      (p-[] : ∀ x → P [ x ]) →
      (∀ {x y} (r : fst (R x y)) → subst P (resp r) (p-[] x) ≡ p-[] y) →
      Set

F' : (A : Set)
     (R : A → A → Proposition)
     (P : A / R → Set)
     (p-[] : ∀ x → P [ x ]) →
     (∀ {x y} (r : fst (R x y)) → subst P (resp r) (p-[] x) ≡ p-[] y) →
     Set
F' A R = F {A = A} {R = R}


module Structure.Function.Names where

open import Function.Names
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.Predicate
import      Lvl
open import Structure.Setoid.Uniqueness
open import Structure.Setoid
open import Type

private variable ℓₒ ℓₒ₁ ℓₒ₂ ℓₒ₃ ℓₒ₄ ℓₗ ℓₗ₁ ℓₗ₂ ℓₗ₃ ℓₗ₄ : Lvl.Level

module _ {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₗ₂}(B) ⦄ where
  Injective : (A → B) → Stmt
  Injective(f) = (∀{x y : A} → (f(x) ≡ f(y)) → (x ≡ y))

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₗ₂}(B) ⦄ where
  Surjective : (A → B) → Stmt
  Surjective(f) = (∀{y : B} → ∃(x ↦ f(x) ≡ y))

module _ {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₗ₂}(B) ⦄ where
  Bijective : (A → B) → Stmt
  Bijective(f) = (∀{y : B} → ∃!(x ↦ f(x) ≡ y))

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₗ₂}(B) ⦄ where
  InversesOn : (A → B) → (B → A) → B → Stmt
  InversesOn f g x = ((f ∘ g)(x) ≡ x)

  Inverses : (A → B) → (B → A) → Stmt
  Inverses f g = ∀¹(InversesOn f g)

  Constant : (A → B) → Stmt
  Constant(f) = (∀{x y : A} → (f(x) ≡ f(y)))

module _ {A : Type{ℓₒ}} ⦃ equiv : Equiv{ℓₗ}(A) ⦄ where
  Fixpoint : (A → A) → A → Stmt
  Fixpoint f(x) = (f(x) ≡ x)

  InvolutionOn : (A → A) → A → Stmt
  InvolutionOn f(x) = InversesOn f f x
  -- (f ∘ f)(x) ≡ x
  -- f(f(x)) ≡ x

  Involution : (A → A) → Stmt
  Involution(f) = Inverses f f

  IdempotentOn : (A → A) → A → Stmt
  IdempotentOn f(x) = Fixpoint f(f(x))
  -- (f ∘ f)(x) ≡ f(x)
  -- f(f(x)) ≡ f(x)

  Idempotent : (A → A) → Stmt
  Idempotent(f) = ∀ₗ(IdempotentOn f)

module _ {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₗ₂}(B) ⦄ where
  Congruence₁ : (A → B) → Stmt
  Congruence₁(f) = (∀{x y : A} → (x ≡ y) → (f(x) ≡ f(y)))

  module _ {C : Type{ℓₒ₃}} ⦃ _ : Equiv{ℓₗ₃}(C) ⦄ where
    Congruence₂ : (A → B → C) → Stmt
    Congruence₂(f) = (∀{x₁ y₁ : A}{x₂ y₂ : B} → (x₁ ≡ y₁) → (x₂ ≡ y₂) → (f x₁ x₂ ≡ f y₁ y₂))

    module _ {D : Type{ℓₒ₄}} ⦃ _ : Equiv{ℓₗ₄}(D) ⦄ where
      Congruence₃ : (A → B → C → D) → Stmt
      Congruence₃(f) = (∀{x₁ y₁ : A}{x₂ y₂ : B}{x₃ y₃ : C} → (x₁ ≡ y₁) → (x₂ ≡ y₂) → (x₃ ≡ y₃) → (f x₁ x₂ x₃ ≡ f y₁ y₂ y₃))

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ ⦃ _ : Equiv{ℓₗ₃}(A → B) ⦄ where
  FunctionExtensionalityOn : (A → B) → (A → B) → Stmt
  FunctionExtensionalityOn(f)(g) = ((f ⊜ g) → (f ≡ g))

  FunctionApplicationOn : (A → B) → (A → B) → Stmt
  FunctionApplicationOn(f)(g) = ((f ≡ g) → (f ⊜ g))

module _ (A : Type{ℓₒ₁}) (B : Type{ℓₒ₂}) ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ ⦃ _ : Equiv{ℓₗ₃}(A → B) ⦄ where
  FunctionExtensionality : Stmt
  FunctionExtensionality = ∀²(FunctionExtensionalityOn{ℓₒ₁}{ℓₒ₂}{ℓₗ₂}{ℓₗ₃}{A}{B})

  FunctionApplication : Stmt
  FunctionApplication = ∀²(FunctionApplicationOn{ℓₒ₁}{ℓₒ₂}{ℓₗ₂}{ℓₗ₃}{A}{B})

module _ {A : Type{ℓₒ₁}} {B : A → Type{ℓₒ₂}} ⦃ _ : ∀{a} → Equiv{ℓₗ₂}(B(a)) ⦄ ⦃ _ : Equiv{ℓₗ₃}((a : A) → B(a)) ⦄ where
  DependentFunctionExtensionalityOn : ((a : A) → B(a)) → ((a : A) → B(a)) → Stmt
  DependentFunctionExtensionalityOn(f)(g) = ((f ⊜ g) → (f ≡ g))

module _ (A : Type{ℓₒ₁}) (B : A → Type{ℓₒ₂}) ⦃ _ : ∀{a} → Equiv{ℓₗ₂}(B(a)) ⦄ ⦃ _ : Equiv{ℓₗ₃}((a : A) → B(a)) ⦄ where
  DependentFunctionExtensionality : Stmt
  DependentFunctionExtensionality = ∀²(DependentFunctionExtensionalityOn{ℓₒ₁}{ℓₒ₂}{ℓₗ₂}{ℓₗ₃}{A}{B})

module _ {A : Type{ℓₒ₁}} {B : A → Type{ℓₒ₂}} ⦃ _ : ∀{a} → Equiv{ℓₗ₂}(B(a)) ⦄ ⦃ _ : Equiv{ℓₗ₃}({a : A} → B(a)) ⦄ where
  DependentImplicitFunctionExtensionalityOn : ({a : A} → B(a)) → ({a : A} → B(a)) → Stmt
  DependentImplicitFunctionExtensionalityOn(f)(g) = (((\{a} → f{a}) ⊜ᵢ (\{a} → g{a})) → ((\{a} → f{a}) ≡ (\{a} → g{a})))

module _ (A : Type{ℓₒ₁}) (B : A → Type{ℓₒ₂}) ⦃ _ : ∀{a} → Equiv{ℓₗ₂}(B(a)) ⦄ ⦃ _ : Equiv{ℓₗ₃}({a : A} → B(a)) ⦄ where
  DependentImplicitFunctionExtensionality : Stmt
  DependentImplicitFunctionExtensionality = ∀²(DependentImplicitFunctionExtensionalityOn{ℓₒ₁}{ℓₒ₂}{ℓₗ₂}{ℓₗ₃}{A}{B})

module _ {A : Type{ℓₒ₁}} {B : A → Type{ℓₒ₂}} ⦃ _ : ∀{a} → Equiv{ℓₗ₂}(B(a)) ⦄ ⦃ _ : Equiv{ℓₗ₃}(⦃ a : A ⦄ → B(a)) ⦄ where
  DependentInstanceFunctionExtensionalityOn : (⦃ a : A ⦄ → B(a)) → (⦃ a : A ⦄ → B(a)) → Stmt
  DependentInstanceFunctionExtensionalityOn(f)(g) = (((\ ⦃ a ⦄ → f ⦃ a ⦄) ⦃⊜⦄ (\ ⦃ a ⦄ → g ⦃ a ⦄)) → ((\ ⦃ a ⦄ → f ⦃ a ⦄) ≡ (\ ⦃ a ⦄ → g ⦃ a ⦄)))

module _ (A : Type{ℓₒ₁}) (B : A → Type{ℓₒ₂}) ⦃ _ : ∀{a} → Equiv{ℓₗ₂}(B(a)) ⦄ ⦃ _ : Equiv{ℓₗ₃}(⦃ a : A ⦄ → B(a)) ⦄ where
  DependentInstanceFunctionExtensionality : Stmt
  DependentInstanceFunctionExtensionality = ∀²(DependentInstanceFunctionExtensionalityOn{ℓₒ₁}{ℓₒ₂}{ℓₗ₂}{ℓₗ₃}{A}{B})


module Data.Vec.Any.Properties where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_; inspect; refl)
open import Relation.Unary renaming (_⊆_ to _⋐_) using ()
open import Data.Product as Prod hiding (map; swap)
open import Data.Vec as Vec
open import Data.Vec.Any as Any
open import Data.Vec.Any.Membership.Propositional
--open import Data.Vec.Membership
open import Data.Bool.Base using (Bool; false; true; T)
open import Data.Bool.Properties
open import Data.Fin using (Fin) renaming (zero to fzero; suc to fsuc)
open import Data.Nat
open import Data.Nat.Properties
open import Data.Empty
open import Data.Sum as Sum hiding (map)
open import Function using (_∘_; _$_; id; flip; const)
open import Function.Inverse as Inv using (_↔_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Eq using (_⇔_ ; module Equivalence)
open import Function.Related as Related using (Related)
open Related.EquationalReasoning
open import Relation.Binary.Sum

map-id : ∀ {a p n}  {A : Set a} {P : A → Set p} (f : P ⋐ P) {xs : Vec A n} →
         (∀ {x} (p : P x) → f p ≡ p) →
         (p : Any P xs) → Any.map f p ≡ p
map-id f hyp (here px) = P.cong here $ hyp px
map-id f hyp (there p) = P.cong there $ map-id f hyp p

map-∘  : ∀ {a p q r n}{A : Set a}{P : A → Set p}{Q : A → Set q}{R : A → Set r}
         (f : Q ⋐ R)(g : P ⋐ Q) {xs : Vec A n}(p : Any P xs) →
         Any.map (f ∘ g) p ≡ Any.map f (Any.map g p)

map-∘ f g (here px) = P.refl
map-∘ f g (there p) = P.cong there $ map-∘ f g p

map∘find′ : ∀ {a n p}{A : Set a} {P : A → Set p}{xs : Vec A n} (p : Any P xs) →
         let (x , x∈xs , px) = find′ p in
           {f : (x ≡_) ⋐ P } →
           f P.refl ≡ px     →
           Any.map f x∈xs ≡ p
map∘find′ (here px) hyp = P.cong here hyp
map∘find′ (there pxs) hyp = P.cong there $ map∘find′ pxs hyp

find′∘map : ∀ {a n p q}{A : Set a}{P : A → Set p}{Q : A → Set q}{xs : Vec A n}(p : Any P xs)(f : P ⋐ Q) →
           find′ (Any.map f p) ≡ Prod.map id (Prod.map id f) (find′ p)
find′∘map (here px) f = P.refl
find′∘map (there pxs) f rewrite find′∘map pxs f = P.refl

find′-∈′ : ∀ {a n}{A : Set a}{x}{xs : Vec A n}(x∈xs : x ∈′ xs) →
  find′ x∈xs ≡ (x , x∈xs , P.refl)
find′-∈′ (here P.refl) = P.refl
find′-∈′ (there x∈xs) rewrite find′-∈′ x∈xs = P.refl

lose′∘find′ : ∀ {a n p}{A : Set a} {P : A → Set p}{xs : Vec A n} (p : Any P xs) →
  uncurry′ lose′ (proj₂ (find′ p)) ≡ p
lose′∘find′ (here px) = P.refl
lose′∘find′ (there p) = P.cong there $ lose′∘find′ p

find′∘lose′ : ∀ {a n p}{A : Set a} (P : A → Set p){x}{xs : Vec A n} (x∈xs : x ∈′ xs)(px : P x) →
  find′ {P = P} (lose′ x∈xs px) ≡ (x , x∈xs , px)
find′∘lose′ P x∈xs px rewrite find′∘map x∈xs (flip (P.subst P) px) | find′-∈′ x∈xs = P.refl

∃∈-Any : ∀ {a p n}{A : Set a} {P : A → Set p}{xs : Vec A n} →
         (∃ λ x → x ∈′ xs × P x) → Any P xs
∃∈-Any = uncurry′ lose′ ∘ proj₂

Any↔  : ∀ {a p n}{A : Set a} {P : A → Set p}{xs : Vec A n} →
  (∃ λ x → x ∈′ xs × P x) ↔ Any P xs

Any↔ {P = P}{xs} = record {
     to = P.→-to-⟶ ∃∈-Any
   ; from = P.→-to-⟶ (find′ {P = P})
   ; inverse-of = record {
         left-inverse-of = λ { (x , x∈xs , px) → find′∘lose′ P x∈xs px}
       ; right-inverse-of = lose′∘find′
     }
  }

Any-cong : ∀ {k a p m n} {A : Set a} {P₁ P₂ : A → Set p} {xs₁ : Vec A m} {xs₂ : Vec A n} →
           (∀ x → Related k (P₁ x) (P₂ x)) → xs₁ ∼[ k ] xs₂ → Related k (Any P₁ xs₁) (Any P₂ xs₂)
Any-cong {P₁ = P₁}{P₂}{xs₁}{xs₂} P₁∼P₂ xs₁∼xs₂ =
  Any P₁ xs₁ ↔⟨ sym $ Any↔ {P = P₁} ⟩ (∃ λ x → x ∈′ xs₁ × P₁ x)
               ∼⟨ Σ.cong Inv.id (xs₁∼xs₂ ×-cong P₁∼P₂ _) ⟩(∃ λ x → x ∈′ xs₂ × P₂ x)
             ↔⟨ Any↔ {P = P₂} ⟩  Any P₂ xs₂ ∎
  where
    open import Relation.Binary.Product.Pointwise
    import Relation.Binary.Sigma.Pointwise as Σ

swap : ∀ {a b p}{A : Set a}{B : Set b}{P : A → B → Set p}
  {m n}{xs : Vec A m}{ys : Vec B n} → Any (λ x → Any (P x) ys) xs → Any (λ y → (Any (flip P y) xs)) ys
swap (here pys) = Any.map here pys
swap (there pxys) = Any.map there $ swap pxys

swap-there : ∀ {a b p}{A : Set a}{B : Set b}{P : A → B → Set p}
    {m n x}{xs : Vec A m}{ys : Vec B n}(any : Any (λ x → Any (P x) ys) xs) →
    swap (Any.map (there {x = x}) any) ≡ there (swap any)
swap-there (here pys) = P.refl
swap-there (there pxys) = P.cong (Any.map there) $ swap-there pxys

swap-invol : ∀ {a b p}{A : Set a}{B : Set b}{P : A → B → Set p}
    {m n}{xs : Vec A m}{ys : Vec B n}(any : Any (λ x → Any (P x) ys) xs) →
      swap (swap any) ≡ any
swap-invol (here (here px)) = P.refl
swap-invol (here (there pys)) = P.cong (Any.map there) $ swap-invol (here pys)
swap-invol (there pxys) = P.trans (swap-there (swap pxys)) $ P.cong there $ swap-invol pxys

swap↔ : ∀ {a b p}{A : Set a}{B : Set b}{P : A → B → Set p}
    {m n}{xs : Vec A m}{ys : Vec B n} →
    Any (λ x → Any (P x) ys) xs ↔  Any (λ y → (Any (flip P y) xs)) ys
swap↔ = record {
    to = P.→-to-⟶ swap
  ; from = P.→-to-⟶ swap
  ; inverse-of = record {
     left-inverse-of = swap-invol
   ; right-inverse-of = swap-invol
  }
  }

⊥↔Any⊥ : ∀ {a n}{A : Set a}{xs : Vec A n} → ⊥ ↔ Any (const ⊥) xs
⊥↔Any⊥ {A = A} = record {
    to = P.→-to-⟶ λ()
  ; from = P.→-to-⟶ (λ p → from p)
  ; inverse-of = record {
      left-inverse-of = λ()
    ; right-inverse-of = λ p → from p
  }
  }
  where
    from : ∀ {n}{xs : Vec A n} → Any (const ⊥) xs → ∀ {b} {B : Set b} → B
    from (here ())
    from (there p) = from p

⊥↔Any[] : ∀ {a}{A : Set a}{P : A → Set}  → ⊥ ↔ Any P []
⊥↔Any[] = record {
    to = P.→-to-⟶ λ()
  ; from = P.→-to-⟶ λ()
  ; inverse-of = record {
      left-inverse-of = λ()
    ; right-inverse-of = λ()
  }
  }

-- any⇔

module _ {a p q}{A : Set a}{P : A → Set p}{Q : A → Set q} where
  Any-⊎⁺ : ∀{n}{xs : Vec A n} → Any P xs ⊎ Any Q xs → Any (λ x → P x ⊎ Q x) xs
  Any-⊎⁺ = [ Any.map inj₁  , Any.map inj₂ ]′

  Any-⊎⁻ : ∀{n}{xs : Vec A n} → Any (λ x → P x ⊎ Q x) xs → Any P xs ⊎ Any Q xs
  Any-⊎⁻ (here (inj₁ px)) = inj₁ (here px)
  Any-⊎⁻ (here (inj₂ qx)) = inj₂ (here qx)
  Any-⊎⁻ (there p) = Sum.map there there (Any-⊎⁻ p)

  ⊎↔ : ∀ {n}{xs : Vec A n} → (Any P xs ⊎ Any Q xs) ↔ Any (λ x → P x ⊎ Q x) xs
  ⊎↔ = record
    { to         = P.→-to-⟶ Any-⊎⁺
    ; from       = P.→-to-⟶ Any-⊎⁻
    ; inverse-of = record
      { left-inverse-of  = from∘to
      ; right-inverse-of = to∘from
      }
    }
    where

    from∘to : ∀ {n}{xs : Vec A n} (p : Any P xs ⊎ Any Q xs) → Any-⊎⁻ (Any-⊎⁺ p) ≡ p
    from∘to (inj₁ (here  p)) = P.refl
    from∘to (inj₁ (there p)) rewrite from∘to (inj₁ p) = P.refl
    from∘to (inj₂ (here  q)) = P.refl
    from∘to (inj₂ (there q)) rewrite from∘to (inj₂ q) = P.refl

    to∘from : ∀ {n}{xs : Vec A n} (p : Any (λ x → P x ⊎ Q x) xs) →
              Any-⊎⁺ (Any-⊎⁻ p) ≡ p
    to∘from (here (inj₁ p)) = P.refl
    to∘from (here (inj₂ q)) = P.refl
    to∘from (there p) with Any-⊎⁻ p | to∘from p
    to∘from (there .(Any.map inj₁ p)) | inj₁ p | P.refl = P.refl
    to∘from (there .(Any.map inj₂ q)) | inj₂ q | P.refl = P.refl

module _ {a b p q} {A : Set a} {B : Set b}
         {P : A → Set p} {Q : B → Set q} where

  Any-×⁺ : ∀ {m n}{xs : Vec A m} {ys : Vec B n} → Any P xs × Any Q ys →
           Any (λ x → Any (λ y → P x × Q y) ys) xs
  Any-×⁺ (p , q) = Any.map (λ p → Any.map (λ q → (p , q)) q) p

  Any-×⁻ : ∀ {m n} {xs : Vec A m}{ys : Vec B n} → Any (λ x → Any (λ y → P x × Q y) ys) xs →
           Any P xs × Any Q ys
  Any-×⁻ pq with Prod.map id (Prod.map id find′) (find′ pq)
  ... | (x , x∈xs , y , y∈ys , p , q) = (lose′ x∈xs p , lose′ y∈ys q)

  ×↔ : ∀ {m n} {xs : Vec A m}{ys : Vec B n} →
       (Any P xs × Any Q ys) ↔ Any (λ x → Any (λ y → P x × Q y) ys) xs
  ×↔ {m}{n}{xs} {ys} = record
    { to         = P.→-to-⟶ Any-×⁺
    ; from       = P.→-to-⟶ Any-×⁻
    ; inverse-of = record
      { left-inverse-of  = from∘to
      ; right-inverse-of = to∘from
      }
    }
    where
      from∘to : ∀ (pq : Any P xs × Any Q ys)
        → Any-×⁻ (Any-×⁺ pq) ≡ pq
      from∘to (p , q)
        rewrite find′∘map {Q = λ x → Any (λ y → P x × Q y) ys}
                       p (λ px → Any.map (λ q → (px , q)) q)
              | find′∘map {Q = λ y → P (proj₁ (find′ p)) × Q y}
                         q (λ q → proj₂ (proj₂ (find′ p)) , q)
              | lose′∘find′ p
              | lose′∘find′ q
              = P.refl

      to∘from : ∀ (pq :  Any (λ x → Any (λ y → P x × Q y) ys) xs) → Any-×⁺ (Any-×⁻ pq) ≡ pq
      to∘from pq  with find′ pq
              | (λ (f : (proj₁ (find′ pq) ≡_) ⋐ _) → map∘find′ pq {f})
      ... | (x , x∈xs , pq′) | lem₁
        with find′ pq′
          | (λ (f : (proj₁ (find′ pq′) ≡_) ⋐ _) → map∘find′ pq′ {f})
      ... | (y , y∈ys , p , q) | lem₂
        rewrite P.sym $ map-∘ {R = λ x → Any (λ y → P x × Q y) ys}
                              (λ p → Any.map (λ q → p , q) (lose′ y∈ys q))
                              (λ y → P.subst P y p)
                              x∈xs
                = lem₁ _ helper
        where
          helper : Any.map (λ q → p , q) (lose′ y∈ys q) ≡ pq′
          helper rewrite P.sym $ map-∘ {R = λ y → P x × Q y}
                                     (λ q → p , q)
                                     (λ y → P.subst Q y q)
                                     y∈ys
                 = lem₂ _ P.refl

module _ {a b} {A : Set a} {B : Set b} where
  map⁺ : ∀ {p} {P : B → Set p} {f : A → B}{n}{xs : Vec A n} →
         Any (P ∘ f) xs → Any P (Vec.map f xs)
  map⁺ (here pfx) = here pfx
  map⁺ (there p) = there (map⁺ p)

  map⁻ : ∀ {p} {P : B → Set p} {f : A → B} {n}{xs : Vec A n} →
         Any P (Vec.map f xs) → Any (P ∘ f) xs
  map⁻ {xs = []}     ()
  map⁻ {xs = x ∷ xs} (here p)  = here p
  map⁻ {xs = x ∷ xs} (there p) = there $ map⁻ p

  map⁺∘map⁻ : ∀ {p} {P : B → Set p} {f : A → B}{n}{xs : Vec A n} →
              (p : Any P (Vec.map f xs)) → map⁺ (map⁻ p) ≡ p
  map⁺∘map⁻ {xs = []}     ()
  map⁺∘map⁻ {xs = x ∷ xs} (here  p) = P.refl
  map⁺∘map⁻ {xs = x ∷ xs} (there p) = P.cong there (map⁺∘map⁻ p)

  map⁻∘map⁺ : ∀ {p} (P : B → Set p) {f : A → B}{n} {xs : Vec A n} →
              (p : Any (P ∘ f) xs) → map⁻ {P = P} (map⁺ p) ≡ p
  map⁻∘map⁺ P (here  p) = P.refl
  map⁻∘map⁺ P (there p) = P.cong there (map⁻∘map⁺ P p)

  map↔ : ∀ {p} {P : B → Set p} {f : A → B} {n}{xs : Vec A n} →
         Any (P ∘ f) xs ↔ Any P (Vec.map f xs)
  map↔ {P = P} {f = f} = record
    { to         = P.→-to-⟶ $ map⁺ {P = P} {f = f}
    ; from       = P.→-to-⟶ $ map⁻ {P = P} {f = f}
    ; inverse-of = record
      { left-inverse-of  = map⁻∘map⁺ P
      ; right-inverse-of = map⁺∘map⁻
      }
    }
------------------------------------------------------------------------

-- _++_

module _ {a p} {A : Set a} {P : A → Set p} where

  ++⁺ˡ : ∀ {m n}{xs : Vec A m} {ys : Vec A n} → Any P xs → Any P (xs ++ ys)
  ++⁺ˡ (here p)  = here p
  ++⁺ˡ (there p) = there (++⁺ˡ p)

  ++⁺ʳ : ∀ {m n} (xs : Vec A m) {ys : Vec A n} → Any P ys → Any P (xs ++ ys)
  ++⁺ʳ []       p = p
  ++⁺ʳ (x ∷ xs) p = there (++⁺ʳ xs p)

  ++⁻ : ∀ {m n} (xs : Vec A m) {ys : Vec A n} → Any P (xs ++ ys) → Any P xs ⊎ Any P ys
  ++⁻ []       p         = inj₂ p
  ++⁻ (x ∷ xs) (here p)  = inj₁ (here p)
  ++⁻ (x ∷ xs) (there p) = Sum.map there id (++⁻ xs p)

  ++⁺∘++⁻ : ∀{m n} (xs : Vec A m) {ys : Vec A n} (p : Any P (xs ++ ys)) →
            [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs p) ≡ p
  ++⁺∘++⁻ []       p         = refl
  ++⁺∘++⁻ (x ∷ xs) (here  p) = refl
  ++⁺∘++⁻ (x ∷ xs) (there p) with ++⁻ xs p | ++⁺∘++⁻ xs p
  ++⁺∘++⁻ (x ∷ xs) (there p) | inj₁ p′ | ih = P.cong there ih
  ++⁺∘++⁻ (x ∷ xs) (there p) | inj₂ p′ | ih = P.cong there ih

  ++⁻∘++⁺ : ∀{m n} (xs : Vec A m) {ys : Vec A n} (p : Any P xs ⊎ Any P ys) →
            ++⁻ xs ([ ++⁺ˡ , ++⁺ʳ xs ]′ p) ≡ p
  ++⁻∘++⁺ []            (inj₁ ())
  ++⁻∘++⁺ []            (inj₂ p)         = refl
  ++⁻∘++⁺ (x ∷ xs)      (inj₁ (here  p)) = refl
  ++⁻∘++⁺ (x ∷ xs) {ys} (inj₁ (there p)) rewrite ++⁻∘++⁺ xs {ys} (inj₁ p) = refl
  ++⁻∘++⁺ (x ∷ xs)      (inj₂ p)         rewrite ++⁻∘++⁺ xs      (inj₂ p) = refl

  ++↔ : ∀{m n} {xs : Vec A m}{ys : Vec A n} → (Any P xs ⊎ Any P ys) ↔ Any P (xs ++ ys)
  ++↔ {xs = xs} = record
    { to         = P.→-to-⟶ [ ++⁺ˡ , ++⁺ʳ xs ]′
    ; from       = P.→-to-⟶ $ ++⁻ xs
    ; inverse-of = record
      { left-inverse-of  = ++⁻∘++⁺ xs
      ; right-inverse-of = ++⁺∘++⁻ xs
      }
    }

  ++-comm : ∀ {m n} (xs : Vec A m) (ys : Vec A n) → Any P (xs ++ ys) → Any P (ys ++ xs)
  ++-comm xs ys = [ ++⁺ʳ ys , ++⁺ˡ ]′ ∘ ++⁻ xs

  ++-comm∘++-comm : ∀{m n} (xs : Vec A m) {ys : Vec A n} (p : Any P (xs ++ ys)) →
                    ++-comm ys xs (++-comm xs ys p) ≡ p
  ++-comm∘++-comm [] {ys} p
    rewrite ++⁻∘++⁺ ys {ys = []} (inj₁ p) = P.refl
  ++-comm∘++-comm (x ∷ xs) {ys} (here p)
    rewrite ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₂ (here p)) = P.refl
  ++-comm∘++-comm (x ∷ xs)      (there p) with ++⁻ xs p | ++-comm∘++-comm xs p
  ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ʳ ys p))))
    | inj₁ p | P.refl
    rewrite ++⁻∘++⁺ ys (inj₂                 p)
            | ++⁻∘++⁺ ys (inj₂ $ there {x = x} p) = P.refl
  ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ˡ p))))
    | inj₂ p | P.refl
    rewrite ++⁻∘++⁺ ys {ys =     xs} (inj₁ p)
            | ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₁ p) = P.refl

  ++↔++ : ∀{m n} (xs : Vec A m) (ys : Vec A n) → Any P (xs ++ ys) ↔ Any P (ys ++ xs)
  ++↔++ xs ys = record
    { to         = P.→-to-⟶ $ ++-comm xs ys
    ; from       = P.→-to-⟶ $ ++-comm ys xs
    ; inverse-of = record
      { left-inverse-of  = ++-comm∘++-comm xs
      ; right-inverse-of = ++-comm∘++-comm ys
      }
    }

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

-- tabulate

module _ {a p} {A : Set a} {P : A → Set p} where
  tabulate⁺ : ∀ {n} {f : Fin n → A} i → P (f i) → Any P (tabulate f)
  tabulate⁺ fzero    p = here p
  tabulate⁺ (fsuc i) p = there (tabulate⁺ i p)

  tabulate⁻ : ∀ {n} {f : Fin n → A} →
              Any P (tabulate f) → ∃ λ i → P (f i)
  tabulate⁻ {zero}  ()
  tabulate⁻ {suc n} (here p)   = fzero , p
  tabulate⁻ {suc n} (there p) = Prod.map fsuc id (tabulate⁻ p)

------------------------------------------------------------------------
-- map-with-∈.

module _ {a b p} {A : Set a} {B : Set b} {P : B → Set p} where

  map-with-∈′⁺ : ∀ {n}{xs : Vec A n} (f : ∀ {x} → x ∈′ xs → B) →
                (∃₂ λ x (x∈xs : x ∈′ xs) → P (f x∈xs)) →
                Any P (map-with-∈′ xs f)
  map-with-∈′⁺ f (_ , here refl  , p) = here p
  map-with-∈′⁺ f (_ , there x∈xs , p) =
    there $ map-with-∈′⁺ (f ∘ there) (_ , x∈xs , p)

  map-with-∈′⁻ : ∀ {n} (xs : Vec A n) (f : ∀ {x} → x ∈′ xs → B) →
                Any P (map-with-∈′ xs f) →
                ∃₂ λ x (x∈xs : x ∈′ xs) → P (f x∈xs)
  map-with-∈′⁻ []       f ()
  map-with-∈′⁻ (y ∷ xs) f (here  p) = (y , here refl , p)
  map-with-∈′⁻ (y ∷ xs) f (there p) =
    Prod.map id (Prod.map there id) $ map-with-∈′⁻ xs (f ∘ there) p

  map-with-∈′↔ : ∀{n}{xs : Vec A n} {f : ∀ {x} → x ∈′ xs → B} →
    (∃₂ λ x (x∈xs : x ∈′ xs) → P (f x∈xs)) ↔ Any P (map-with-∈′ xs f)
  map-with-∈′↔ = record
    { to         = P.→-to-⟶ (map-with-∈′⁺ _)
    ; from       = P.→-to-⟶ (map-with-∈′⁻ _ _)
    ; inverse-of = record
      { left-inverse-of  = from∘to _
      ; right-inverse-of = to∘from _ _
      }
    }
    where

    from∘to : ∀ {n} {xs : Vec A n} (f : ∀ {x} → x ∈′ xs → B)
              (p : ∃₂ λ x (x∈xs : x ∈′ xs) → P (f x∈xs)) →
              map-with-∈′⁻ xs f (map-with-∈′⁺ f p) ≡ p
    from∘to f (_ , here refl  , p) = refl
    from∘to f (_ , there x∈xs , p)
      rewrite from∘to (f ∘ there) (_ , x∈xs , p) = refl

    to∘from : ∀ {n}(xs : Vec A n) (f : ∀ {x} → x ∈′ xs → B)
              (p : Any P (map-with-∈′ xs f)) →
              map-with-∈′⁺ f (map-with-∈′⁻ xs f p) ≡ p
    to∘from []       f ()
    to∘from (y ∷ xs) f (here  p) = refl
    to∘from (y ∷ xs) f (there p) =
      P.cong there $ to∘from xs (f ∘ there) p

------------------------------------------------------------------------
module _ {a p} {A : Set a} {P : A → Set p} where
  return⁺ : ∀ {x} → P x → Any P ([ x ])
  return⁺ = here

  return⁻ : ∀ {x} → Any P ([ x ]) → P x
  return⁻ (here p)   = p
  return⁻ (there ())

  return⁺∘return⁻ : ∀ {x} (p : Any P [ x ]) →
                    return⁺ (return⁻ p) ≡ p
  return⁺∘return⁻ (here p)   = refl
  return⁺∘return⁻ (there ())

  return⁻∘return⁺ : ∀ {x} (p : P x) → return⁻ (return⁺ p) ≡ p
  return⁻∘return⁺ p = refl

  return↔ : ∀ {x} → P x ↔ Any P ([ x ])
  return↔ = record
    { to         = P.→-to-⟶ $ return⁺
    ; from       = P.→-to-⟶ $ return⁻
    ; inverse-of = record
      { left-inverse-of  = return⁻∘return⁺
      ; right-inverse-of = return⁺∘return⁻
      }
    }

-- _∷_.

∷↔ : ∀ {a p n} {A : Set a} (P : A → Set p) {x} {xs : Vec A n} →
     (P x ⊎ Any P xs) ↔ Any P (x ∷ xs)
∷↔ P {x} {xs} =
  (P x         ⊎ Any P xs)  ↔⟨ return↔ {P = P} ⊎-cong (Any P xs ∎) ⟩
  (Any P [ x ] ⊎ Any P xs)  ↔⟨ ++↔ {P = P} {xs = [ x ]} ⟩
  Any P (x ∷ xs)            ∎


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

module Data.Fin where

open import Data.Fin.Base public


open import Prelude
open import dynamics-core

module lemmas-matching where
  -- arrow matching produces unique answers
  ▸arr-unicity : ∀{τ τ2 τ3} →
                 τ ▸arr τ2 →
                 τ ▸arr τ3 →
                 τ2 == τ3
  ▸arr-unicity MAHole MAHole = refl
  ▸arr-unicity MAArr MAArr   = refl

  -- only consistent types arrow match
  ▸arr-consist : ∀{τ1 τ2} →
                 τ1 ▸arr τ2 →
                 (τ1 ~ τ2)
  ▸arr-consist MAHole = TCHole2
  ▸arr-consist MAArr  = TCRefl

  -- if an arrow matches, then it's consistent with the
  -- least restrictive function type
  ▸arr-consist-hole : ∀{t t'} →
                      t ▸arr t' →
                      t ~ (⦇-⦈ ==> ⦇-⦈)
  ▸arr-consist-hole MAHole = TCHole2
  ▸arr-consist-hole MAArr  = TCArr TCHole1 TCHole1

  -- sum matching produces unique answers
  ▸sum-unicity : ∀{τ τ2 τ3} →
                 τ ▸sum τ2 →
                 τ ▸sum τ3 →
                 τ2 == τ3
  ▸sum-unicity MSHole MSHole = refl
  ▸sum-unicity MSSum MSSum   = refl

  -- only consistent types sum match
  ▸sum-consist : ∀{τ1 τ2} →
                 τ1 ▸sum τ2 →
                 (τ1 ~ τ2)
  ▸sum-consist MSHole = TCHole2
  ▸sum-consist MSSum  = TCRefl

  -- if a sum matches, then it's consistent with the
  -- least restrictive function type
  ▸sum-consist-hole : ∀{t t'} →
                      t ▸sum t' →
                      t ~ (⦇-⦈ ⊕ ⦇-⦈)
  ▸sum-consist-hole MSHole = TCHole2
  ▸sum-consist-hole MSSum  = TCSum TCHole1 TCHole1

  -- product matching produces unique answers
  ▸prod-unicity : ∀{τ τ2 τ3} →
                  τ ▸prod τ2 →
                  τ ▸prod τ3 →
                  τ2 == τ3
  ▸prod-unicity MPHole MPHole = refl
  ▸prod-unicity MPProd MPProd   = refl

  -- only consistent types product match
  ▸prod-consist : ∀{τ1 τ2} →
                  τ1 ▸prod τ2 →
                  (τ1 ~ τ2)
  ▸prod-consist MPHole = TCHole2
  ▸prod-consist MPProd = TCRefl

   -- if a sum matches, then it's consistent with the
  -- least restrictive function type
  ▸prod-consist-hole : ∀{t t'} →
                       t ▸prod t' →
                       t ~ (⦇-⦈ ⊠ ⦇-⦈)
  ▸prod-consist-hole MPHole = TCHole2
  ▸prod-consist-hole MPProd = TCProd TCHole1 TCHole1


------------------------------------------------------------------------
-- The Agda standard library
--
-- Applicative functors
------------------------------------------------------------------------

-- Note that currently the applicative functor laws are not included
-- here.

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

module Category.Applicative where

open import Data.Unit
open import Category.Applicative.Indexed

RawApplicative : ∀ {f} → (Set f → Set f) → Set _
RawApplicative F = RawIApplicative {I = ⊤} (λ _ _ → F)

module RawApplicative {f} {F : Set f → Set f}
                      (app : RawApplicative F) where
  open RawIApplicative app public

RawApplicativeZero : ∀ {f} → (Set f → Set f) → Set _
RawApplicativeZero F = RawIApplicativeZero {I = ⊤} (λ _ _ → F)

module RawApplicativeZero {f} {F : Set f → Set f}
                          (app : RawApplicativeZero F) where
  open RawIApplicativeZero app public

RawAlternative : ∀ {f} → (Set f → Set f) → Set _
RawAlternative F = RawIAlternative {I = ⊤} (λ _ _ → F)

module RawAlternative {f} {F : Set f → Set f}
                          (app : RawAlternative F) where
  open RawIAlternative app public


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

open import lib.Basics

module lib.types.Sigma where

-- Cartesian product
_×_ : ∀ {i j} (A : Type i) (B : Type j) → Type (lmax i j)
A × B = Σ A (λ _ → B)

infixr 5 _×_

module _ {i j} {A : Type i} {B : A → Type j} where

  pair : (a : A) (b : B a) → Σ A B
  pair a b = (a , b)

  -- pair= has already been defined

  fst= : {ab a'b' : Σ A B} (p : ab == a'b') → (fst ab == fst a'b')
  fst= = ap fst

  snd= : {ab a'b' : Σ A B} (p : ab == a'b')
    → (snd ab == snd a'b' [ B ↓ fst= p ])
  snd= {._} {_} idp = idp

  fst=-β : {a a' : A} (p : a == a')
    {b : B a} {b' : B a'} (q : b == b' [ B ↓ p ])
    → fst= (pair= p q) == p
  fst=-β idp idp = idp

  snd=-β : {a a' : A} (p : a == a')
    {b : B a} {b' : B a'} (q : b == b' [ B ↓ p ])
    → snd= (pair= p q) == q [ (λ v → b == b' [ B ↓ v ]) ↓ fst=-β p q ]
  snd=-β idp idp = idp

  pair=-η : {ab a'b' : Σ A B} (p : ab == a'b')
    → p == pair= (fst= p) (snd= p)
  pair=-η {._} {_} idp = idp

  pair== : {a a' : A} {p p' : a == a'} (α : p == p')
           {b : B a} {b' : B a'} {q : b == b' [ B ↓ p ]} {q' : b == b' [ B ↓ p' ]}
           (β : q == q' [ (λ u → b == b' [ B ↓ u ]) ↓ α ])
    → pair= p q == pair= p' q'
  pair== idp idp = idp

module _ {i j} {A : Type i} {B : Type j} where

  fst×= : {ab a'b' : A × B} (p : ab == a'b') → (fst ab == fst a'b')
  fst×= = ap fst

  snd×= : {ab a'b' : A × B} (p : ab == a'b')
    → (snd ab == snd a'b')
  snd×= = ap snd

  fst×=-β : {a a' : A} (p : a == a')
    {b b' : B} (q : b == b')
    → fst×= (pair×= p q) == p
  fst×=-β idp idp = idp

  snd×=-β : {a a' : A} (p : a == a')
    {b b' : B} (q : b == b')
    → snd×= (pair×= p q) == q
  snd×=-β idp idp = idp

  pair×=-η : {ab a'b' : A × B} (p : ab == a'b')
    → p == pair×= (fst×= p) (snd×= p)
  pair×=-η {._} {_} idp = idp

module _ {i j} {A : Type i} {B : A → Type j} where

  =Σ : (x y : Σ A B) → Type (lmax i j)
  =Σ (a , b) (a' , b') = Σ (a == a') (λ p → b == b' [ B ↓ p ])

  =Σ-eqv : (x y : Σ A B) →  (=Σ x y) ≃ (x == y)
  =Σ-eqv x y =
    equiv (λ pq → pair= (fst pq) (snd pq)) (λ p → fst= p , snd= p)
          (λ p → ! (pair=-η p))
          (λ pq → pair= (fst=-β (fst pq) (snd pq)) (snd=-β (fst pq) (snd pq)))

  =Σ-path : (x y : Σ A B) → (=Σ x y) == (x == y)
  =Σ-path x y = ua (=Σ-eqv x y)

Σ= : ∀ {i j} {A A' : Type i} (p : A == A') {B : A → Type j} {B' : A' → Type j}
  (q : B == B' [ (λ X → (X → Type j)) ↓ p ]) → Σ A B == Σ A' B'
Σ= idp idp = idp

abstract

  Σ-level : ∀ {i j} {n : ℕ₋₂} {A : Type i} {P : A → Type j}
    → (has-level n A → ((x : A) → has-level n (P x))
      → has-level n (Σ A P))
  Σ-level {n = ⟨-2⟩} p q =
    ((fst p , (fst (q (fst p)))) ,
      (λ y → pair= (snd p _) (from-transp! _ _ (snd (q _) _))))
  Σ-level {n = S n} p q = λ x y → equiv-preserves-level (=Σ-eqv x y)
    (Σ-level (p _ _)
      (λ _ → equiv-preserves-level ((to-transp-equiv _ _)⁻¹) (q _ _ _)))

  ×-level : ∀ {i j} {n : ℕ₋₂} {A : Type i} {B : Type j}
    → (has-level n A → has-level n B → has-level n (A × B))
  ×-level pA pB = Σ-level pA (λ x → pB)

-- Equivalences in a Σ-type

equiv-Σ-fst : ∀ {i j k} {A : Type i} {B : Type j} (P : B → Type k) {h : A → B}
                  → is-equiv h → (Σ A (P ∘ h)) ≃ (Σ B P)
equiv-Σ-fst {A = A} {B = B} P {h = h} e = equiv f g f-g g-f
  where f : Σ A (P ∘ h) → Σ B P
        f (a , r) = (h a , r)

        g : Σ B P → Σ A (P ∘ h)
        g (b , s) = (is-equiv.g e b , transport P (! (is-equiv.f-g e b)) s)

        f-g : ∀ y → f (g y) == y
        f-g (b , s) = pair= (is-equiv.f-g e b) (trans-↓ P (is-equiv.f-g e b) s)

        g-f : ∀ x → g (f x) == x
        g-f (a , r) =
          pair= (is-equiv.g-f e a)
                (transport (λ q → transport P (! q) r == r [ P ∘ h ↓ is-equiv.g-f e a ])
                           (is-equiv.adj e a)
                           (trans-ap-↓ P h (is-equiv.g-f e a) r) )

equiv-Σ-snd : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  → (∀ x → B x ≃ C x) → Σ A B ≃ Σ A C
equiv-Σ-snd {A = A} {B = B} {C = C} k = equiv f g f-g g-f
  where f : Σ A B → Σ A C
        f (a , b) = (a , fst (k a) b)

        g : Σ A C → Σ A B
        g (a , c) = (a , is-equiv.g (snd (k a)) c)

        f-g : ∀ p → f (g p) == p
        f-g (a , c) = pair= idp (is-equiv.f-g (snd (k a)) c)

        g-f : ∀ p → g (f p) == p
        g-f (a , b) = pair= idp (is-equiv.g-f (snd (k a)) b)

-- Two ways of simultaneously applying equivalences in each component.
module _ {i₀ i₁ j₀ j₁} {A₀ : Type i₀} {A₁ : Type i₁}
         {B₀ : A₀ → Type j₀} {B₁ : A₁ → Type j₁} where
  equiv-Σ : (u : A₀ ≃ A₁) (v : ∀ a → B₀ (<– u a) ≃ B₁ a) → Σ A₀ B₀ ≃ Σ A₁ B₁
  equiv-Σ u v = Σ A₀ B₀           ≃⟨ equiv-Σ-fst _ (snd (u ⁻¹)) ⁻¹ ⟩
                Σ A₁ (B₀ ∘ <– u)  ≃⟨ equiv-Σ-snd v ⟩
                Σ A₁ B₁           ≃∎

  equiv-Σ' : (u : A₀ ≃ A₁) (v : ∀ a → B₀ a ≃ B₁ (–> u a)) → Σ A₀ B₀ ≃ Σ A₁ B₁
  equiv-Σ' u v = Σ A₀ B₀           ≃⟨ equiv-Σ-snd v ⟩
                 Σ A₀ (B₁ ∘ –> u)  ≃⟨ equiv-Σ-fst _ (snd u) ⟩
                 Σ A₁ B₁           ≃∎

-- Implementation of [_∙'_] on Σ
Σ-∙' : ∀ {i j} {A : Type i} {B : A → Type j}
  {x y z : A} {p : x == y} {p' : y == z}
  {u : B x} {v : B y} {w : B z}
  (q : u == v [ B ↓ p ]) (r : v == w [ B ↓ p' ])
  → (pair= p q ∙' pair= p' r) == pair= (p ∙' p') (q ∙'ᵈ r)
Σ-∙' {p = idp} {p' = idp} q idp = idp

-- Implementation of [_∙_] on Σ
Σ-∙ : ∀ {i j} {A : Type i} {B : A → Type j}
  {x y z : A} {p : x == y} {p' : y == z}
  {u : B x} {v : B y} {w : B z}
  (q : u == v [ B ↓ p ]) (r : v == w [ B ↓ p' ])
  → (pair= p q ∙ pair= p' r) == pair= (p ∙ p') (q ∙ᵈ r)
Σ-∙ {p = idp} {p' = idp} idp r = idp

-- Implementation of [!] on Σ
Σ-! : ∀ {i j} {A : Type i} {B : A → Type j}
  {x y : A} {p : x == y}
  {u : B x} {v : B y}
  (q : u == v [ B ↓ p ])
  → ! (pair= p q) == pair= (! p) (!ᵈ q)
Σ-! {p = idp} idp = idp

-- Implementation of [_∙'_] on ×
×-∙' : ∀ {i j} {A : Type i} {B : Type j}
  {x y z : A} (p : x == y) (p' : y == z)
  {u v w : B} (q : u == v) (q' : v == w)
  → (pair×= p q ∙' pair×= p' q') == pair×= (p ∙' p') (q ∙' q')
×-∙' idp idp q idp = idp

-- Implementation of [_∙_] on ×
×-∙ : ∀ {i j} {A : Type i} {B : Type j}
  {x y z : A} (p : x == y) (p' : y == z)
  {u v w : B} (q : u == v) (q' : v == w)
  → (pair×= p q ∙ pair×= p' q') == pair×= (p ∙ p') (q ∙ q')
×-∙ idp idp idp r = idp

-- Implementation of [!] on ×
×-! : ∀ {i j} {A : Type i} {B : Type j}
  {x y : A} (p : x == y) {u v : B} (q : u == v)
  → ! (pair×= p q) == pair×= (! p) (! q)
×-! idp idp = idp

-- Special case of [ap-,]
ap-cst,id : ∀ {i j} {A : Type i} (B : A → Type j)
  {a : A} {x y : B a} (p : x == y)
  → ap (λ x → _,_ {B = B} a x) p == pair= idp p
ap-cst,id B idp = idp

-- hfiber fst == B
module _ {i j} {A : Type i} {B : A → Type j} where

  private
    to : ∀ a → hfiber (fst :> (Σ A B → A)) a → B a
    to a ((.a , b) , idp) = b

    from : ∀ (a : A) → B a → hfiber (fst :> (Σ A B → A)) a
    from a b = (a , b) , idp

    to-from : ∀ (a : A) (b : B a) → to a (from a b) == b
    to-from a b = idp

    from-to : ∀ a b′ → from a (to a b′) == b′
    from-to a ((.a , b) , idp) = idp

  hfiber-fst : ∀ a → hfiber (fst :> (Σ A B → A)) a ≃ B a
  hfiber-fst a = to a , is-eq (to a) (from a) (to-from a) (from-to a)

{- Dependent paths in a Σ-type -}
module _ {i j k} {A : Type i} {B : A → Type j} {C : (a : A) → B a → Type k}
  where

  ↓-Σ-in : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : C x r} {s' : C x' r'}
    (q : r == r' [ B ↓ p ])
    → s == s' [ uncurry C ↓ pair= p q ]
    → (r , s) == (r' , s') [ (λ x → Σ (B x) (C x)) ↓ p ]
  ↓-Σ-in {p = idp} idp t = pair= idp t

  ↓-Σ-fst : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : C x r} {s' : C x' r'}
    → (r , s) == (r' , s') [ (λ x → Σ (B x) (C x)) ↓ p ]
    → r == r' [ B ↓ p ]
  ↓-Σ-fst {p = idp} u = fst= u

  ↓-Σ-snd : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : C x r} {s' : C x' r'}
    → (u : (r , s) == (r' , s') [ (λ x → Σ (B x) (C x)) ↓ p ])
    → s == s' [ uncurry C ↓ pair= p (↓-Σ-fst u) ]
  ↓-Σ-snd {p = idp} idp = idp

  ↓-Σ-β-fst : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : C x r} {s' : C x' r'}
    (q : r == r' [ B ↓ p ])
    (t : s == s' [ uncurry C ↓ pair= p q ])
    → ↓-Σ-fst (↓-Σ-in q t) == q
  ↓-Σ-β-fst {p = idp} idp idp = idp

  ↓-Σ-β-snd : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : C x r} {s' : C x' r'}
    (q : r == r' [ B ↓ p ])
    (t : s == s' [ uncurry C ↓ pair= p q ])
    → ↓-Σ-snd (↓-Σ-in q t) == t
      [ (λ q' → s == s' [ uncurry C ↓ pair= p q' ]) ↓ ↓-Σ-β-fst q t ]
  ↓-Σ-β-snd {p = idp} idp idp = idp

  ↓-Σ-η : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : C x r} {s' : C x' r'}
    (u : (r , s) == (r' , s') [ (λ x → Σ (B x) (C x)) ↓ p ])
    → ↓-Σ-in (↓-Σ-fst u) (↓-Σ-snd u) == u
  ↓-Σ-η {p = idp} idp = idp

{- Dependent paths in a ×-type -}
module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  where

  ↓-×-in : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : C x} {s' : C x'}
    → r == r' [ B ↓ p ]
    → s == s' [ C ↓ p ]
    → (r , s) == (r' , s') [ (λ x → B x × C x) ↓ p ]
  ↓-×-in {p = idp} q t = pair×= q t

module _ where
  -- An orphan lemma.
  ↓-cst×app-in : ∀ {i j k} {A : Type i}
    {B : Type j} {C : A → B → Type k}
    {a₁ a₂ : A} (p : a₁ == a₂)
    {b₁ b₂ : B} (q : b₁ == b₂)
    {c₁ : C a₁ b₁}{c₂ : C a₂ b₂}
    → c₁ == c₂ [ uncurry C ↓ pair×= p q ]
    → (b₁ , c₁) == (b₂ , c₂) [ (λ x → Σ B (C x)) ↓ p ]
  ↓-cst×app-in idp idp idp = idp

{- pair= and pair×= where one argument is reflexivity -}
pair=-idp-l : ∀ {i j} {A : Type i} {B : A → Type j} (a : A) {b₁ b₂ : B a}
  (q : b₁ == b₂) → pair= {B = B} idp q == ap (λ y → (a , y)) q
pair=-idp-l _ idp = idp

pair×=-idp-l : ∀ {i j} {A : Type i} {B : Type j} (a : A) {b₁ b₂ : B}
  (q : b₁ == b₂) → pair×= idp q == ap (λ y → (a , y)) q
pair×=-idp-l _ idp = idp

pair×=-idp-r : ∀ {i j} {A : Type i} {B : Type j} {a₁ a₂ : A} (p : a₁ == a₂)
  (b : B) → pair×= p idp == ap (λ x → (x , b)) p
pair×=-idp-r idp _ = idp

pair×=-split-l : ∀ {i j} {A : Type i} {B : Type j} {a₁ a₂ : A} (p : a₁ == a₂)
  {b₁ b₂ : B} (q : b₁ == b₂)
  → pair×= p q == ap (λ a → (a , b₁)) p ∙ ap (λ b → (a₂ , b)) q
pair×=-split-l idp idp = idp

pair×=-split-r : ∀ {i j} {A : Type i} {B : Type j} {a₁ a₂ : A} (p : a₁ == a₂)
  {b₁ b₂ : B} (q : b₁ == b₂)
  → pair×= p q == ap (λ b → (a₁ , b)) q ∙ ap (λ a → (a , b₂)) p
pair×=-split-r idp idp = idp

-- Commutativity of products and derivatives.
module _ {i j} {A : Type i} {B : Type j} where
  ×-comm : Σ A (λ _ → B) ≃ Σ B (λ _ → A)
  ×-comm = equiv (λ {(a , b) → (b , a)}) (λ {(b , a) → (a , b)}) (λ _ → idp) (λ _ → idp)

module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} where
  Σ₂-×-comm : Σ (Σ A B) (λ ab → C (fst ab)) ≃ Σ (Σ A C) (λ ac → B (fst ac))
  Σ₂-×-comm = Σ-assoc ⁻¹ ∘e equiv-Σ-snd (λ a → ×-comm) ∘e Σ-assoc

module _ {i j k} {A : Type i} {B : Type j} {C : A → B → Type k} where
  Σ₁-×-comm : Σ A (λ a → Σ B (λ b → C a b)) ≃ Σ B (λ b → Σ A (λ a → C a b))
  Σ₁-×-comm = Σ-assoc ∘e equiv-Σ-fst _ (snd ×-comm) ∘e Σ-assoc ⁻¹


open import Data.Sum
open import Data.Fin
open import Data.Maybe
open import Signature

module MixedTest (Σ : Sig) (D : Set) where

-- Δ : Sig
-- Δ = record { ∥_∥ = D ; ar = λ x → Fin 1 }

mutual
  data Term : Set where
    cons : ⟪ Σ ⟫ (Term ⊎ CoTerm) → Term

  record CoTerm : Set where
    coinductive
    field destr : D → Maybe (Term ⊎ CoTerm)

open CoTerm public


{-# OPTIONS --without-K #-}
import Level as L
open L using (Lift; lift)
open import Type hiding (★)
open import Function.NP
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP hiding (_^_)
open import Data.Nat.Properties
open import Data.One hiding (_≤_)
open import Data.Sum
open import Data.Maybe.NP
open import Data.Product
open import Data.Bits
open import Data.Bool.NP as Bool
open import Data.Fin using (Fin)
open import Function.NP
open import Function.Equality using (_⟨$⟩_)
import Function.Inverse.NP as FI
open FI using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
import Function.Related as FR
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)
open import Search.Type
open import Search.Searchable renaming (Searchable to Searchable)
open import Search.Searchable.Product
open import Search.Searchable.Sum
open import Search.Searchable.Maybe
--open import Search.Searchable.Fin
open import Search.Derived

module sum where

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★ _
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

_≈Search_ : ∀ {A} → (s₀ s₁ : Search _ A) → ★₁
s₀ ≈Search s₁ = ∀ {B} (op : Op₂ B) f → s₀ op f ≡ s₁ op f

_⊎'_ : ★₀ → ★₀ → ★₀
A ⊎' B = Σ Bool (cond A B)

_μ⊎'_ : ∀ {A B} → Searchable A → Searchable B → Searchable (A ⊎' B)
μA μ⊎' μB = μΣ μBit (λ { {true} → μA ; {false} → μB })

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec.NP as Vec using (Vec; tabulate; _++_) renaming (map to vmap; sum to vsum; foldr to vfoldr; foldr₁ to vfoldr₁)

vmsum : ∀ {c ℓ} (m : Monoid c ℓ) {n} →
          let open Mon m in
          Vec C n → C
vmsum m = vfoldr _ _∙_ ε
  where open Mon m

vsgsum : ∀ {c ℓ} (sg : Semigroup c ℓ) {n} →
           let open Sgrp sg in
           Vec C (suc n) → C
vsgsum sg = vfoldr₁ _∙_
  where open Sgrp sg

-- let's recall that: tabulate f ≗ vmap f (allFin n)

-- searchMonFin : ∀ n → SearchMon (Fin n)
-- searchMonFin n m f = vmsum m (tabulate f)

searchFinSuc : ∀ {m} n → Search m (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr₁ _∙_ (tabulate f)

searchVec : ∀ {m A} n → Search m A → Search m (Vec A n)
searchVec zero    searchᴬ op f = f []
searchVec (suc n) searchᴬ op f = searchᴬ op (λ x → searchVec n searchᴬ op (f ∘ _∷_ x))

searchVec-spec : ∀ {A} (μA : Searchable A) n → searchVec n (search μA) ≈Search search (μVec μA n)
searchVec-spec μA zero    op f = ≡.refl
searchVec-spec μA (suc n) op f = search-ext μA op (λ x → searchVec-spec μA n op (f ∘ _∷_ x))

searchVec-++ : ∀ {A} n {m} (μA : Searchable A) sg
               → let open Sgrp sg in
                 (f : Vec A (n + m) → C)
               → search (μVec μA (n + m)) _∙_ f
               ≈ search (μVec μA n) _∙_ (λ xs →
                   search (μVec μA m) _∙_ (λ ys →
                     f (xs ++ ys)))
searchVec-++ zero    μA sg f = Sgrp.refl sg
searchVec-++ (suc n) μA sg f = search-sg-ext μA sg (λ x →
                                 searchVec-++ n μA sg (f ∘ _∷_ x))

sumVec-swap : ∀ {A} n {m} (μA : Searchable A)(f : Vec A (n + m) → ℕ)
            → sum (μVec μA n) (λ xs → sum (μVec μA m) (λ ys → f (xs ++ ys)))
            ≡ sum (μVec μA m) (λ ys → sum (μVec μA n) (λ xs → f (xs ++ ys)))
sumVec-swap n {m} μA f = sum-swap (μVec μA n) (μVec μA m) (λ xs ys → f (xs ++ ys))

simple : ∀ {A : Set}{P : A → A → Set} → (∀ x → P x x) → {x y : A} → x ≡ y → P x y
simple r ≡.refl = r _
-- -}
-- -}
-- -}


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

module Categories.Category.Instance.Properties.Setoids where

open import Level
open import Data.Product using (Σ; proj₁; proj₂; _,_; Σ-syntax; _×_; -,_)
open import Function.Equality using (Π)
open import Relation.Binary using (Setoid; Preorder; Rel)
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)
open import Relation.Binary.Indexed.Heterogeneous using (_=[_]⇒_)
open import Relation.Binary.Construct.Closure.SymmetricTransitive as ST using (Plus⇔; minimal)
open Plus⇔

open import Categories.Category using (Category; _[_,_])
open import Categories.Functor
open import Categories.Category.Instance.Setoids
open import Categories.Category.Complete
open import Categories.Category.Cocomplete

import Categories.Category.Construction.Cocones as Coc
import Categories.Category.Construction.Cones as Co
import Relation.Binary.Reasoning.Setoid as RS

open Π using (_⟨$⟩_)

module _ {o ℓ e} c ℓ′ {J : Category o ℓ e} (F : Functor J (Setoids (o ⊔ c) (o ⊔ ℓ ⊔ c ⊔ ℓ′))) where
  private
    module J    = Category J
    open Functor F
    module F₀ j = Setoid (F₀ j)
    open F₀ using () renaming (_≈_ to _[_≈_])

  vertex-carrier : Set (o ⊔ c)
  vertex-carrier = Σ J.Obj F₀.Carrier

  coc : Rel vertex-carrier (o ⊔ ℓ ⊔ c ⊔ ℓ′)
  coc (X , x) (Y , y) = Σ[ f ∈ J [ X , Y ] ] Y [ (F₁ f ⟨$⟩ x) ≈ y ]

  coc-preorder : Preorder (o ⊔ c) (o ⊔ c) (o ⊔ ℓ ⊔ c ⊔ ℓ′)
  coc-preorder = record
    { Carrier    = vertex-carrier
    ; _≈_        = _≡_
    ; _∼_        = coc
    ; isPreorder = record
      { isEquivalence = ≡.isEquivalence
      ; reflexive     = λ { {j , _} ≡.refl → J.id , (identity (F₀.refl j)) }
      ; trans         = λ { {a , Sa} {b , Sb} {c , Sc} (f , eq₁) (g , eq₂) →
        let open RS (F₀ c)
        in g J.∘ f , (begin
        F₁ (g J.∘ f) ⟨$⟩ Sa    ≈⟨ homomorphism (F₀.refl a) ⟩
        F₁ g ⟨$⟩ (F₁ f ⟨$⟩ Sa) ≈⟨ Π.cong (F₁ g) eq₁ ⟩
        F₁ g ⟨$⟩ Sb            ≈⟨ eq₂ ⟩
        Sc                     ∎) }
      }
    }

Setoids-Cocomplete : (o ℓ e c ℓ′ : Level) → Cocomplete o ℓ e (Setoids (o ⊔ c) (o ⊔ ℓ ⊔ c ⊔ ℓ′))
Setoids-Cocomplete o ℓ e c ℓ′ {J} F = record
  { initial =
    record
    { ⊥        = record
      { N      = ⇛-Setoid
      ; coapex = record
        { ψ       = λ j → record
          { _⟨$⟩_ = j ,_
          ; cong  = λ i≈k → forth (-, identity i≈k)
          }
        ; commute = λ {X} X⇒Y x≈y → back (-, Π.cong (F₁ X⇒Y) (F₀.sym X x≈y))
        }
      }
    ; !        = λ {K} →
      let module K = Cocone K
      in record
      { arr     = record
        { _⟨$⟩_ = to-coapex K
        ; cong  = minimal (coc c ℓ′ F) K.N (to-coapex K) (coapex-cong K)
        }
      ; commute = λ {X} x≈y → Π.cong (Coapex.ψ (Cocone.coapex K) X) x≈y
      }
    ; !-unique = λ { {K} f {a , Sa} {b , Sb} eq →
      let module K = Cocone K
          module f = Cocone⇒ f
          open RS K.N
      in begin
        K.ψ a ⟨$⟩ Sa       ≈˘⟨ f.commute (F₀.refl a) ⟩
        f.arr ⟨$⟩ (a , Sa) ≈⟨ Π.cong f.arr eq ⟩
        f.arr ⟨$⟩ (b , Sb) ∎ }
    }
  }
  where open Functor F
        open Coc F
        module J    = Category J
        module F₀ j = Setoid (F₀ j)
        open F₀ using () renaming (_≈_ to _[_≈_])

        -- this is essentially a symmetric transitive closure of coc
        ⇛-Setoid : Setoid (o ⊔ c) (o ⊔ ℓ ⊔ c ⊔ ℓ′)
        ⇛-Setoid = ST.setoid (coc c ℓ′ F) (Preorder.refl (coc-preorder c ℓ′ F))

        to-coapex : ∀ K → vertex-carrier c ℓ′ F → Setoid.Carrier (Cocone.N K)
        to-coapex K (j , Sj) = K.ψ j ⟨$⟩ Sj
          where module K = Cocone K
        coapex-cong : ∀ K → coc c ℓ′ F =[ to-coapex K ]⇒ (Setoid._≈_ (Cocone.N K))
        coapex-cong K {X , x} {Y , y} (f , fx≈y) = begin
          K.ψ X ⟨$⟩ x            ≈˘⟨ K.commute f (F₀.refl X) ⟩
          K.ψ Y ⟨$⟩ (F₁ f ⟨$⟩ x) ≈⟨ Π.cong (K.ψ Y) fx≈y ⟩
          K.ψ Y ⟨$⟩ y            ∎
          where module K = Cocone K
                open RS K.N

Setoids-Complete : (o ℓ e c ℓ′ : Level) → Complete o ℓ e (Setoids (c ⊔ ℓ ⊔ o ⊔ ℓ′) (o ⊔ ℓ′))
Setoids-Complete o ℓ e c ℓ′ {J} F =
  record
  { terminal = record
    { ⊤        = record
      { N     = record
        { Carrier       = Σ (∀ j → F₀.Carrier j)
                            (λ S → ∀ {X Y} (f : J [ X , Y ]) → [ F₀ Y ] F₁ f ⟨$⟩ S X ≈ S Y)
        ; _≈_           = λ { (S₁ , _) (S₂ , _) → ∀ j → [ F₀ j ] S₁ j ≈ S₂ j }
        ; isEquivalence = record
          { refl  = λ j → F₀.refl j
          ; sym   = λ a≈b j → F₀.sym j (a≈b j)
          ; trans = λ a≈b b≈c j → F₀.trans j (a≈b j) (b≈c j)
          }
        }
      ;  apex = record
        { ψ = λ j → record
          { _⟨$⟩_ = λ { (S , _) → S j }
          ; cong  = λ eq → eq j
          }
        ; commute = λ { {X} {Y} X⇒Y {_ , eq} {y} f≈g → F₀.trans Y (eq X⇒Y) (f≈g Y) }
        }
      }
    ; !        = λ {K} →
      let module K = Cone K
      in record
      { arr     = record
        { _⟨$⟩_ = λ x → (λ j → K.ψ j ⟨$⟩ x) , λ f → K.commute f (Setoid.refl K.N)
        ; cong  = λ a≈b j → Π.cong (K.ψ j) a≈b
        }
      ; commute = λ x≈y → Π.cong (K.ψ _) x≈y
      }
    ; !-unique = λ {K} f x≈y j →
      let module K = Cone K
      in F₀.sym j (Cone⇒.commute f (Setoid.sym K.N x≈y))
    }
  }
  where open Functor F
        open Co F
        module J    = Category J
        module F₀ j = Setoid (F₀ j)
        [_]_≈_ = Setoid._≈_


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

module Control.Monad.Levels where

open import Control.Monad.Levels.Definition public


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

open import lib.Basics
open import lib.types.Pi
open import lib.types.Pointed

module lib.types.Span where

record Span {i j k : ULevel} : Type (lsucc (lmax (lmax i j) k)) where
  constructor span
  field
    A : Type i
    B : Type j
    C : Type k
    f : C → A
    g : C → B

private
  span=-raw : ∀ {i j k} {A A' : Type i} (p : A == A')
    {B B' : Type j} (q : B == B') {C C' : Type k} (r : C == C')
    {f : C → A} {f' : C' → A'}
    (s : f == f' [ (λ CA → fst CA → snd CA) ↓ pair×= r p ])
    {g : C → B} {g' : C' → B'}
    (t : g == g' [ (λ CB → fst CB → snd CB) ↓ pair×= r q ])
    → (span A B C f g) == (span A' B' C' f' g')
  span=-raw idp idp idp idp idp = idp

abstract
  span= : ∀ {i j k} {A A' : Type i} (p : A ≃ A')
    {B B' : Type j} (q : B ≃ B') {C C' : Type k} (r : C ≃ C')
    {f : C → A} {f' : C' → A'} (s : (a : C) → (–> p) (f a) == f' (–> r a))
    {g : C → B} {g' : C' → B'} (t : (b : C) → (–> q) (g b) == g' (–> r b))
    → (span A B C f g) == (span A' B' C' f' g')
  span= p q r {f} {f'} s {g} {g'} t = span=-raw
    (ua p)
    (ua q)
    (ua r)
    (↓-→-in (λ α → ↓-snd×-in (ua r) (ua p) (↓-idf-ua-in p (
                   s _
                   ∙ ap f' (↓-idf-ua-out r (↓-fst×-out (ua r) (ua p) α))))))
    (↓-→-in (λ β → ↓-snd×-in (ua r) (ua q) (↓-idf-ua-in q (
                   t _
                   ∙ ap g' (↓-idf-ua-out r (↓-fst×-out (ua r) (ua q) β))))))

record ⊙Span {i j k : ULevel} : Type (lsucc (lmax (lmax i j) k)) where
  constructor ⊙span
  field
    X : Ptd i
    Y : Ptd j
    Z : Ptd k
    f : fst (Z ⊙→ X)
    g : fst (Z ⊙→ Y)

⊙span-out : ∀ {i j k} → ⊙Span {i} {j} {k} → Span {i} {j} {k}
⊙span-out (⊙span X Y Z f g) = span (fst X) (fst Y) (fst Z) (fst f) (fst g)

{- Helper for path induction on pointed spans -}
⊙span-J : ∀ {i j k l} (P : ⊙Span {i} {j} {k} → Type l)
  → ({A : Type i} {B : Type j} {Z : Ptd k} (f : fst Z → A) (g : fst Z → B)
     → P (⊙span (A , f (snd Z)) (B , g (snd Z)) Z (f , idp) (g , idp)))
  → Π ⊙Span P
⊙span-J P t (⊙span (A , ._) (B , ._) Z (f , idp) (g , idp)) = t f g


-- Andreas, 2020-06-21, issue #4768
-- Problem was: @0 appearing in "Not a finite domain" message.

open import Agda.Builtin.Bool
open import Agda.Primitive.Cubical

f : (i : I) → IsOne i → Set
f i (i0 = i1) = Bool

-- EXPECTED:
-- Not a finite domain: IsOne i
-- when checking that the pattern (i0 = i1) has type IsOne i


-- {-# OPTIONS -v interaction:100 #-}
module Issue810 where

record T (A : Set) : Set where
  constructor mkT
  field unT : A

introHid : {A : Set} → T A
introHid = {!!}

data Sg {A : Set} : A → Set where
  sg : (a : A) → Sg a

intro : ∀ {A}{a : A} → Sg a
intro = {!!}

intro′ : ∀ {A}(a : A) → Sg a
intro′ = {!!}