------------------------------------------------------------------------
-- CCS
------------------------------------------------------------------------

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

open import Prelude

module Labelled-transition-system.CCS {ℓ} (Name : Type ℓ) where

open import Equality.Propositional
open import Prelude.Size

open import Bool equality-with-J
open import Function-universe equality-with-J hiding (id; _∘_)

open import Labelled-transition-system

------------------------------------------------------------------------
-- Fixity declarations

infix  12 _∙
infixr 12 _·_ _∙_
infix  10 !_
infix   8 _⊕_
infix   6 _∣_
infix   5 _[_] _[_]′
infix   4 _[_]⟶_ _∉_

------------------------------------------------------------------------
-- CCS, roughly as defined in "Enhancements of the bisimulation proof
-- method" by Pous and Sangiorgi, with support for corecursive
-- processes (instead of the named process constants presented in
-- "Coinduction All the Way Up" by Pous)

-- Names with kinds: (a , true) stands for "a", and (a , false) stands
-- for "a̅".

Name-with-kind : Type ℓ
Name-with-kind = Name × Bool

-- Turns names of one kind into names of the other kind.

co : Name-with-kind → Name-with-kind
co (a , kind) = a , not kind

-- Actions.

data Action : Type ℓ where
  name : Name-with-kind → Action
  τ    : Action

-- The only silent action is τ.

is-silent : Action → Bool
is-silent (name _) = false
is-silent τ        = true

-- Processes.

mutual

  data Proc (i : Size) : Type ℓ where
    ∅       : Proc i
    _∣_ _⊕_ : Proc i → Proc i → Proc i
    _·_     : Action → Proc′ i → Proc i
    ⟨ν_⟩    : Name → Proc i → Proc i
    !_      : Proc i → Proc i

  record Proc′ (i : Size) : Type ℓ where
    coinductive
    field
      force : {j : Size< i} → Proc j

open Proc′ public

-- An inductive variant of _·_.

_∙_ : ∀ {i} → Action → Proc i → Proc i
μ ∙ P = μ · λ { .force → P }

-- An abbreviation.

_∙ : Name-with-kind → Proc ∞
a ∙ = name a ∙ ∅

-- The predicate a ∉ μ holds if a is not the underlying name of μ (if
-- any).

_∉_ : Name → Action → Type ℓ
a ∉ name (b , _) = ¬ a ≡ b
a ∉ τ            = ↑ ℓ ⊤

-- Transition relation.

data _[_]⟶_ : Proc ∞ → Action → Proc ∞ → Type ℓ where
  par-left    : ∀ {P Q P′ μ} → P [ μ ]⟶ P′ → P ∣ Q [ μ ]⟶ P′ ∣ Q
  par-right   : ∀ {P Q Q′ μ} → Q [ μ ]⟶ Q′ → P ∣ Q [ μ ]⟶ P  ∣ Q′
  par-τ       : ∀ {P P′ Q Q′ a} →
                P [ name a ]⟶ P′ → Q [ name (co a) ]⟶ Q′ →
                P ∣ Q [ τ ]⟶ P′ ∣ Q′
  sum-left    : ∀ {P Q P′ μ} → P [ μ ]⟶ P′ → P ⊕ Q [ μ ]⟶ P′
  sum-right   : ∀ {P Q Q′ μ} → Q [ μ ]⟶ Q′ → P ⊕ Q [ μ ]⟶ Q′
  action      : ∀ {P μ} → μ · P [ μ ]⟶ force P
  restriction : ∀ {P P′ a μ} →
                a ∉ μ → P [ μ ]⟶ P′ → ⟨ν a ⟩ P [ μ ]⟶ ⟨ν a ⟩ P′
  replication : ∀ {P P′ μ} → ! P ∣ P [ μ ]⟶ P′ → ! P [ μ ]⟶ P′

-- The CCS LTS.

CCS : LTS ℓ
CCS = record
  { Proc      = Proc ∞
  ; Label     = Action
  ; _[_]⟶_    = _[_]⟶_
  ; is-silent = is-silent
  }

open LTS CCS public hiding (Proc; _[_]⟶_; is-silent)

------------------------------------------------------------------------
-- Contexts and some related definitions, roughly following
-- "Enhancements of the bisimulation proof method" by Pous and
-- Sangiorgi

mutual

  -- Polyadic contexts.

  data Context (i : Size) (n : ℕ) : Type ℓ where
    hole    : (x : Fin n) → Context i n
    ∅       : Context i n
    _∣_ _⊕_ : Context i n → Context i n → Context i n
    _·_     : (μ : Action) → Context′ i n → Context i n
    ⟨ν_⟩    : (a : Name) → Context i n → Context i n
    !_      : Context i n → Context i n

  record Context′ (i : Size) (n : ℕ) : Type ℓ where
    coinductive
    field
      force : {j : Size< i} → Context j n

open Context′ public

mutual

  -- Hole filling.

  _[_] : ∀ {i n} → Context i n → (Fin n → Proc ∞) → Proc i
  hole x   [ Ps ] = Ps x
  ∅        [ Ps ] = ∅
  C₁ ∣ C₂  [ Ps ] = (C₁ [ Ps ]) ∣ (C₂ [ Ps ])
  C₁ ⊕ C₂  [ Ps ] = (C₁ [ Ps ]) ⊕ (C₂ [ Ps ])
  μ · C    [ Ps ] = μ · (C [ Ps ]′)
  ⟨ν a ⟩ C [ Ps ] = ⟨ν a ⟩ (C [ Ps ])
  ! C      [ Ps ] = ! (C [ Ps ])

  _[_]′ : ∀ {i n} → Context′ i n → (Fin n → Proc ∞) → Proc′ i
  force (C [ Ps ]′) = force C [ Ps ]

-- A context is weakly guarded if every hole is under a prefix (μ ·_).

data Weakly-guarded {n : ℕ} : Context ∞ n → Type ℓ where
  ∅      : Weakly-guarded ∅
  _∣_    : ∀ {C₁ C₂} →
           Weakly-guarded C₁ → Weakly-guarded C₂ →
           Weakly-guarded (C₁ ∣ C₂)
  _⊕_    : ∀ {C₁ C₂} →
           Weakly-guarded C₁ → Weakly-guarded C₂ →
           Weakly-guarded (C₁ ⊕ C₂)
  action : ∀ {μ C} → Weakly-guarded (μ · C)
  ⟨ν⟩    : ∀ {a C} → Weakly-guarded C → Weakly-guarded (⟨ν a ⟩ C)
  !_     : ∀ {C} → Weakly-guarded C → Weakly-guarded (! C)

-- Turns processes into contexts without holes.

context : ∀ {i n} → Proc i → Context i n
context ∅          = ∅
context (P₁ ∣ P₂)  = context P₁ ∣ context P₂
context (P₁ ⊕ P₂)  = context P₁ ⊕ context P₂
context (μ · P)    = μ · λ { .force → context (force P) }
context (⟨ν a ⟩ P) = ⟨ν a ⟩ (context P)
context (! P)      = ! context P

-- Non-degenerate contexts.

mutual

  data Non-degenerate (i : Size) {n : ℕ} : Context ∞ n → Type ℓ where
    hole   : ∀ {x} → Non-degenerate i (hole x)
    ∅      : Non-degenerate i ∅
    _∣_    : ∀ {C₁ C₂} →
             Non-degenerate i C₁ → Non-degenerate i C₂ →
             Non-degenerate i (C₁ ∣ C₂)
    _⊕_    : ∀ {C₁ C₂} →
             Non-degenerate-summand i C₁ →
             Non-degenerate-summand i C₂ →
             Non-degenerate i (C₁ ⊕ C₂)
    action : ∀ {μ C} →
             Non-degenerate′ i (force C) → Non-degenerate i (μ · C)
    ⟨ν⟩    : ∀ {a C} → Non-degenerate i C → Non-degenerate i (⟨ν a ⟩ C)
    !_     : ∀ {C} → Non-degenerate i C → Non-degenerate i (! C)

  data Non-degenerate-summand (i : Size) {n : ℕ} :
                              Context ∞ n → Type ℓ where
    process : ∀ P → Non-degenerate-summand i (context P)
    action  : ∀ {μ C} →
              Non-degenerate′ i (force C) →
              Non-degenerate-summand i (μ · C)

  record Non-degenerate′ (i : Size) {n} (C : Context ∞ n) : Type ℓ where
    coinductive
    field
      force : {j : Size< i} → Non-degenerate j C

open Non-degenerate′ public

------------------------------------------------------------------------
-- Very strong bisimilarity

-- "Very strong" bisimilarity for processes: Equal ∞ P Q means that P
-- and Q have the same structure.

mutual

  data Equal (i : Size) : Proc ∞ → Proc ∞ → Type ℓ where
    ∅    : Equal i ∅ ∅
    _∣_  : ∀ {P₁ P₂ Q₁ Q₂} →
           Equal i P₁ P₂ → Equal i Q₁ Q₂ → Equal i (P₁ ∣ Q₁) (P₂ ∣ Q₂)
    _⊕_  : ∀ {P₁ P₂ Q₁ Q₂} →
           Equal i P₁ P₂ → Equal i Q₁ Q₂ → Equal i (P₁ ⊕ Q₁) (P₂ ⊕ Q₂)
    _·_  : ∀ {μ₁ μ₂ P₁ P₂} →
           μ₁ ≡ μ₂ → Equal′ i (force P₁) (force P₂) →
           Equal i (μ₁ · P₁) (μ₂ · P₂)
    ⟨ν_⟩ : ∀ {a₁ a₂ P₁ P₂} →
           a₁ ≡ a₂ → Equal i P₁ P₂ → Equal i (⟨ν a₁ ⟩ P₁) (⟨ν a₂ ⟩ P₂)
    !_   : ∀ {P₁ P₂} → Equal i P₁ P₂ → Equal i (! P₁) (! P₂)

  record Equal′ (i : Size) (P₁ P₂ : Proc ∞) : Type ℓ where
    coinductive
    field
      force : {j : Size< i} → Equal j P₁ P₂

open Equal′ public

-- Extensionality for very strong bisimilarity.

Proc-extensionality : Type ℓ
Proc-extensionality = ∀ {P Q} → Equal ∞ P Q → P ≡ Q

------------------------------------------------------------------------
-- Some lemmas

-- The co function is involutive.

co-involutive : ∀ a → co (co a) ≡ a
co-involutive (a , kind) =
  (a , not (not kind))  ≡⟨ cong (_ ,_) $ not-involutive kind ⟩∎
  (a , kind)            ∎

-- A name is not equal to the corresponding coname.

id≢co : ∀ {a} → a ≢ co a
id≢co {a} =
  a ≡ co a                 ↝⟨ cong proj₂ ⟩
  proj₂ a ≡ not (proj₂ a)  ↝⟨ not≡⇒≢ _ _ ∘ sym ⟩
  proj₂ a ≢ proj₂ a        ↝⟨ _$ refl ⟩□
  ⊥                        □

-- A cancellation law.

cancel-name : ∀ {a b} → name a ≡ name b → a ≡ b
cancel-name refl = refl

-- A disjointness law.

name≢τ : ∀ {a} → name a ≢ τ
name≢τ ()

-- The only silent label is τ.

silent≡τ : ∀ {μ} → Silent μ → μ ≡ τ
silent≡τ {τ}      _  = refl
silent≡τ {name _} ()

-- Names do not match (the only silent label) τ.

∉τ : ∀ {μ a} → Silent μ → a ∉ μ
∉τ s rewrite silent≡τ s = _

-- A variant of par-τ.

par-τ′ : ∀ {P P′ Q Q′ a b} →
         b ≡ co a → P [ name a ]⟶ P′ → Q [ name b ]⟶ Q′ →
         P ∣ Q [ τ ]⟶ P′ ∣ Q′
par-τ′ refl = par-τ

-- The process μ · P can only make μ-transitions.

·-only : ∀ {μ₁ μ₂ P Q} → μ₁ · P [ μ₂ ]⟶ Q → μ₁ ≡ μ₂
·-only action = refl

-- The process μ · P can only transition to force P.

·-only⟶ : ∀ {μ₁ μ₂ P Q} → μ₁ · P [ μ₂ ]⟶ Q → Q ≡ force P
·-only⟶ action = refl

-- A simple corollary.

names-are-not-inverted :
  ∀ {a P Q} → ¬ (name a · P [ name (co a) ]⟶ Q)
names-are-not-inverted {a} {P} {Q} =
  name a · P [ name (co a) ]⟶ Q  ↝⟨ ·-only ⟩
  name a ≡ name (co a)           ↝⟨ id≢co ∘ cancel-name ⟩□
  ⊥                              □

-- If P₁ and P₂ can only make μ-transitions, then P₁ ∣ P₂ can only
-- make μ-transitions.

∣-only : ∀ {μ₀ P₁ P₂} →
         (∀ {P′ μ} → P₁ [ μ ]⟶ P′ → μ₀ ≡ μ) →
         (∀ {P′ μ} → P₂ [ μ ]⟶ P′ → μ₀ ≡ μ) →
         ∀ {P′ μ} → P₁ ∣ P₂ [ μ ]⟶ P′ → μ₀ ≡ μ
∣-only      only₁ only₂ (par-left tr)           = only₁ tr
∣-only      only₁ only₂ (par-right tr)          = only₂ tr
∣-only {μ₀} only₁ only₂ (par-τ {a = a} tr₁ tr₂) = ⊥-elim (
                                  $⟨ only₁ tr₁ , only₂ tr₂ ⟩
  μ₀ ≡ name a × μ₀ ≡ name (co a)  ↝⟨ uncurry trans ∘ Σ-map sym id ⟩
  name a ≡ name (co a)            ↝⟨ id≢co ∘ cancel-name ⟩□
  ⊥                               □)

-- If P can only make μ-transitions, then ! P can only make
-- μ-transitions.

!-only : ∀ {μ₀ P} →
         (∀ {P′ μ} → P [ μ ]⟶ P′ → μ₀ ≡ μ) →
         ∀ {P′ μ} → ! P [ μ ]⟶ P′ → μ₀ ≡ μ
!-only      only (replication (par-left  tr)) = !-only only tr
!-only      only (replication (par-right tr)) = only tr
!-only {μ₀} only (replication (par-τ {a = a} tr₁ tr₂)) = ⊥-elim (
                                  $⟨ !-only only tr₁ , only tr₂ ⟩
  μ₀ ≡ name a × μ₀ ≡ name (co a)  ↝⟨ uncurry trans ∘ Σ-map sym id ⟩
  name a ≡ name (co a)            ↝⟨ id≢co ∘ cancel-name ⟩□
  ⊥                               □)

-- If P₁ and P₂ can only make μ-transitions, then P₁ ⊕ P₂ can only
-- make μ-transitions.

⊕-only : ∀ {μ₀ P₁ P₂} →
         (∀ {P′ μ} → P₁ [ μ ]⟶ P′ → μ₀ ≡ μ) →
         (∀ {P′ μ} → P₂ [ μ ]⟶ P′ → μ₀ ≡ μ) →
         ∀ {P′ μ} → P₁ ⊕ P₂ [ μ ]⟶ P′ → μ₀ ≡ μ
⊕-only only₁ only₂ (sum-left tr)  = only₁ tr
⊕-only only₁ only₂ (sum-right tr) = only₂ tr

-- If P can only make μ-transitions, then ⟨ν a ⟩ P can only make
-- μ-transitions.

⟨ν⟩-only : ∀ {μ₀ a P} →
           (∀ {P′ μ} → P [ μ ]⟶ P′ → μ₀ ≡ μ) →
           ∀ {P′ μ} → ⟨ν a ⟩ P [ μ ]⟶ P′ → μ₀ ≡ μ
⟨ν⟩-only only (restriction _ tr) = only tr

-- A simple lemma.

·⊕·-co :
  ∀ {a b c P Q R S} →
  name a · P ⊕ name b · Q [ name c ]⟶      R →
  name a · P ⊕ name b · Q [ name (co c) ]⟶ S →
  b ≡ co a × (R ≡ force P × S ≡ force Q ⊎ R ≡ force Q × S ≡ force P)
·⊕·-co (sum-left  action)
       (sum-left  tr)     = ⊥-elim (names-are-not-inverted tr)
·⊕·-co (sum-left  action)
       (sum-right action) = refl , inj₁ (refl , refl)
·⊕·-co (sum-right action)
       (sum-left  action) =   sym (co-involutive _)
                            , inj₂ (refl , refl)
·⊕·-co (sum-right action)
       (sum-right tr)     = ⊥-elim (names-are-not-inverted tr)

-- Very strong bisimilarity is reflexive.

Proc-refl : ∀ {i} P → Equal i P P
Proc-refl ∅          = ∅
Proc-refl (P₁ ∣ P₂)  = Proc-refl P₁ ∣ Proc-refl P₂
Proc-refl (P₁ ⊕ P₂)  = Proc-refl P₁ ⊕ Proc-refl P₂
Proc-refl (μ · P)    = refl · λ { .force → Proc-refl (force P) }
Proc-refl (⟨ν a ⟩ P) = ⟨ν refl ⟩ (Proc-refl P)
Proc-refl (! P)      = ! Proc-refl P

-- Very strong bisimilarity is symmetric.

Proc-sym : ∀ {i P Q} → Equal i P Q → Equal i Q P
Proc-sym ∅          = ∅
Proc-sym (P₁ ∣ P₂)  = Proc-sym P₁ ∣ Proc-sym P₂
Proc-sym (P₁ ⊕ P₂)  = Proc-sym P₁ ⊕ Proc-sym P₂
Proc-sym (p · P)    = sym p · λ { .force → Proc-sym (force P) }
Proc-sym (⟨ν p ⟩ P) = ⟨ν sym p ⟩ (Proc-sym P)
Proc-sym (! P)      = ! Proc-sym P

-- Very strong bisimilarity is transitive.

Proc-trans : ∀ {i P Q R} → Equal i P Q → Equal i Q R → Equal i P R
Proc-trans ∅          ∅          = ∅
Proc-trans (P₁ ∣ P₂)  (Q₁ ∣ Q₂)  = Proc-trans P₁ Q₁ ∣ Proc-trans P₂ Q₂
Proc-trans (P₁ ⊕ P₂)  (Q₁ ⊕ Q₂)  = Proc-trans P₁ Q₁ ⊕ Proc-trans P₂ Q₂
Proc-trans (p · P)    (q · Q)    = trans p q · λ { .force →
                                     Proc-trans (force P) (force Q) }
Proc-trans (⟨ν p ⟩ P) (⟨ν q ⟩ Q) = ⟨ν trans p q ⟩ (Proc-trans P Q)
Proc-trans (! P)      (! Q)      = ! Proc-trans P Q

-- Weakening of contexts.

weaken : ∀ {i n} → Context i n → Context i (suc n)
weaken (hole x)   = hole (fsuc x)
weaken ∅          = ∅
weaken (C₁ ∣ C₂)  = weaken C₁ ∣ weaken C₂
weaken (C₁ ⊕ C₂)  = weaken C₁ ⊕ weaken C₂
weaken (μ · C)    = μ · λ { .force → weaken (force C) }
weaken (⟨ν a ⟩ C) = ⟨ν a ⟩ (weaken C)
weaken (! C)      = ! weaken C

-- A lemma relating weakening and hole filling.

weaken-[] :
  ∀ {i n ps} (C : Context ∞ n) →
  Equal i (weaken C [ ps ]) (C [ ps ∘ fsuc ])
weaken-[] (hole x)   = Proc-refl _
weaken-[] ∅          = ∅
weaken-[] (C₁ ∣ C₂)  = weaken-[] C₁ ∣ weaken-[] C₂
weaken-[] (C₁ ⊕ C₂)  = weaken-[] C₁ ⊕ weaken-[] C₂
weaken-[] (μ · C)    = refl · λ { .force → weaken-[] (force C) }
weaken-[] (⟨ν a ⟩ C) = ⟨ν refl ⟩ (weaken-[] C)
weaken-[] (! C)      = ! weaken-[] C

-- The result of filling the holes in the context "context P" is P.

context-[] : ∀ {i n} {Ps : Fin n → Proc ∞} P →
             Equal i P (context P [ Ps ])
context-[] ∅          = ∅
context-[] (P₁ ∣ P₂)  = context-[] P₁ ∣ context-[] P₂
context-[] (P₁ ⊕ P₂)  = context-[] P₁ ⊕ context-[] P₂
context-[] (μ · P)    = refl · λ { .force → context-[] (force P) }
context-[] (⟨ν a ⟩ P) = ⟨ν refl ⟩ (context-[] P)
context-[] (! P)      = ! (context-[] P)

-- The contexts constructed by the context function are always
-- non-degenerate.

context-non-degenerate :
  ∀ {i n} (P : Proc ∞) → Non-degenerate i (context {n = n} P)
context-non-degenerate ∅          = ∅
context-non-degenerate (P₁ ∣ P₂)  = context-non-degenerate P₁ ∣
                                    context-non-degenerate P₂
context-non-degenerate (P₁ ⊕ P₂)  = process P₁ ⊕ process P₂
context-non-degenerate (μ · P)    = action λ { .force →
                                      context-non-degenerate (force P) }
context-non-degenerate (⟨ν a ⟩ P) = ⟨ν⟩ (context-non-degenerate P)
context-non-degenerate (! P)      = ! context-non-degenerate P

mutual

  -- A relation expressing that a certain process matches a certain
  -- context.

  data Matches (i : Size) {n} : Proc ∞ → Context ∞ n → Type ℓ where
    hole   : ∀ {P} (x : Fin n) → Matches i P (hole x)
    ∅      : Matches i ∅ ∅
    _∣_    : ∀ {P₁ P₂ C₁ C₂} →
             Matches i P₁ C₁ → Matches i P₂ C₂ →
             Matches i (P₁ ∣ P₂) (C₁ ∣ C₂)
    _⊕_    : ∀ {P₁ P₂ C₁ C₂} →
             Matches i P₁ C₁ → Matches i P₂ C₂ →
             Matches i (P₁ ⊕ P₂) (C₁ ⊕ C₂)
    action : ∀ {μ P C} →
             Matches′ i (force P) (force C) →
             Matches i (μ · P) (μ · C)
    ⟨ν⟩    : ∀ {a P C} → Matches i P C → Matches i (⟨ν a ⟩ P) (⟨ν a ⟩ C)
    !_     : ∀ {P C} → Matches i P C → Matches i (! P) (! C)

  record Matches′
           (i : Size) {n} (P : Proc ∞) (C : Context ∞ n) : Type ℓ where
    coinductive
    field
      force : {j : Size< i} → Matches j P C

open Matches′ public

-- The process obtained by filling a context's holes matches the
-- context.

Matches-[] : ∀ {i n Ps} (C : Context ∞ n) → Matches i (C [ Ps ]) C
Matches-[] (hole x)   = hole x
Matches-[] ∅          = ∅
Matches-[] (C₁ ∣ C₂)  = Matches-[] C₁ ∣ Matches-[] C₂
Matches-[] (C₁ ⊕ C₂)  = Matches-[] C₁ ⊕ Matches-[] C₂
Matches-[] (μ · C)    = action λ { .force → Matches-[] (force C) }
Matches-[] (⟨ν a ⟩ C) = ⟨ν⟩ (Matches-[] C)
Matches-[] (! C)      = ! Matches-[] C

-- Matches respects very strong bisimilarity.

Matches-cong : ∀ {i P Q n} {C : Context ∞ n} →
               Equal i P Q → Matches i P C → Matches i Q C
Matches-cong _             (hole x)   = hole x
Matches-cong ∅             ∅          = ∅
Matches-cong (p₁ ∣ p₂)     (q₁ ∣ q₂)  = Matches-cong p₁ q₁ ∣
                                        Matches-cong p₂ q₂
Matches-cong (p₁ ⊕ p₂)     (q₁ ⊕ q₂)  = Matches-cong p₁ q₁ ⊕
                                        Matches-cong p₂ q₂
Matches-cong (refl · p)    (action q) = action λ { .force →
                                          Matches-cong (force p)
                                                       (force q) }
Matches-cong (⟨ν refl ⟩ p) (⟨ν⟩ q)    = ⟨ν⟩ (Matches-cong p q)
Matches-cong (! p)         (! q)      = ! Matches-cong p q

-- A predicate that identifies a process as being finite. Note that
-- this is an inductive definition.

data Finite : Proc ∞ → Type ℓ where
  ∅      : Finite ∅
  _∣_    : ∀ {P Q} → Finite P → Finite Q → Finite (P ∣ Q)
  _⊕_    : ∀ {P Q} → Finite P → Finite Q → Finite (P ⊕ Q)
  action : ∀ {μ P} → Finite (force P) → Finite (μ · P)
  ⟨ν_⟩   : ∀ {a P} → Finite P → Finite (⟨ν a ⟩ P)
  !_     : ∀ {P} → Finite P → Finite (! P)

-- The transition relation takes finite processes to finite processes.

finite→finite : ∀ {P μ Q} → P [ μ ]⟶ Q → Finite P → Finite Q
finite→finite (par-left tr)       (f₁ ∣ f₂)  = finite→finite tr f₁ ∣ f₂
finite→finite (par-right tr)      (f₁ ∣ f₂)  = f₁ ∣ finite→finite tr f₂
finite→finite (par-τ tr₁ tr₂)     (f₁ ∣ f₂)  = finite→finite tr₁ f₁ ∣
                                               finite→finite tr₂ f₂
finite→finite (sum-left tr)       (f₁ ⊕ f₂)  = finite→finite tr f₁
finite→finite (sum-right tr)      (f₁ ⊕ f₂)  = finite→finite tr f₂
finite→finite action              (action f) = f
finite→finite (restriction a∉ tr) ⟨ν f ⟩     = ⟨ν finite→finite tr f ⟩
finite→finite (replication tr)    (! f)      = finite→finite tr (! f ∣ f)

-- Subprocess P Q means that P is a syntactic subprocess of Q.

data Subprocess (P : Proc ∞) : Proc ∞ → Type ℓ where
  refl        : ∀ {Q} → Equal ∞ P Q → Subprocess P Q
  par-left    : ∀ {Q₁ Q₂} → Subprocess P Q₁ → Subprocess P (Q₁ ∣ Q₂)
  par-right   : ∀ {Q₁ Q₂} → Subprocess P Q₂ → Subprocess P (Q₁ ∣ Q₂)
  sum-left    : ∀ {Q₁ Q₂} → Subprocess P Q₁ → Subprocess P (Q₁ ⊕ Q₂)
  sum-right   : ∀ {Q₁ Q₂} → Subprocess P Q₂ → Subprocess P (Q₁ ⊕ Q₂)
  action      : ∀ {μ Q} → Subprocess P (force Q) → Subprocess P (μ · Q)
  restriction : ∀ {a Q} → Subprocess P Q → Subprocess P (⟨ν a ⟩ Q)
  replication : ∀ {Q} → Subprocess P Q → Subprocess P (! Q)

-- A process is regular if it has a finite number of distinct
-- subprocesses.

Regular : Proc ∞ → Type ℓ
Regular P =
  ∃ λ n → ∃ λ (Qs : Fin n → Proc ∞) →
    ∀ {Q} → Subprocess Q P →
      ∃ λ (i : Fin n) → Equal ∞ Q (Qs i)

-- Lemma 6.2.15 from "Enhancements of the bisimulation proof method".
-- That text claims that the lemma is proved by induction on the
-- structure of the context. Perhaps that is possible, but the proof
-- below uses induction on the structure of the transition relation,
-- and in the replication case's recursive call the context is not
-- structurally smaller.

6-2-15 :
  ∀ {n Ps μ P}
  (C : Context ∞ n) → Weakly-guarded C →
  C [ Ps ] [ μ ]⟶ P →
  ∃ λ (C′ : Context ∞ n) →
    P ≡ C′ [ Ps ] × ∀ Qs → C [ Qs ] [ μ ]⟶ C′ [ Qs ]
6-2-15 ∅          ∅         ()
6-2-15 (C₁ ∣ C₂)  (w₁ ∣ w₂) (par-left  tr)       = Σ-map (_∣ C₂) (Σ-map (cong (_∣ _)) (par-left  ∘_)) (6-2-15 C₁ w₁ tr)
6-2-15 (C₁ ∣ C₂)  (w₁ ∣ w₂) (par-right tr)       = Σ-map (C₁ ∣_) (Σ-map (cong (_ ∣_)) (par-right ∘_)) (6-2-15 C₂ w₂ tr)
6-2-15 (C₁ ∣ C₂)  (w₁ ∣ w₂) (par-τ tr₁ tr₂)      = Σ-zip _∣_ (Σ-zip (cong₂ _)
                                                                    (λ trs₁ trs₂ Qs → par-τ (trs₁ Qs) (trs₂ Qs)))
                                                     (6-2-15 C₁ w₁ tr₁) (6-2-15 C₂ w₂ tr₂)
6-2-15 (C₁ ⊕ C₂)  (w₁ ⊕ w₂) (sum-left  tr)       = Σ-map id (Σ-map id (sum-left  ∘_)) (6-2-15 C₁ w₁ tr)
6-2-15 (C₁ ⊕ C₂)  (w₁ ⊕ w₂) (sum-right tr)       = Σ-map id (Σ-map id (sum-right ∘_)) (6-2-15 C₂ w₂ tr)
6-2-15 (μ · C)    action    action               = force C , refl , λ _ → action
6-2-15 (⟨ν a ⟩ C) (⟨ν⟩ w)   (restriction a∉μ tr) = Σ-map ⟨ν a ⟩ (Σ-map (cong _) (restriction a∉μ ∘_)) (6-2-15 C w tr)
6-2-15 (! C)      (! w)     (replication tr)     = Σ-map id (Σ-map id (replication ∘_)) (6-2-15 (! C ∣ C) (! w ∣ w) tr)

-- A variant of the previous lemma.

6-2-15-nd :
  Proc-extensionality →
  ∀ {n Ps μ P}
  (C : Context ∞ n) → Weakly-guarded C → Non-degenerate ∞ C →
  C [ Ps ] [ μ ]⟶ P →
  ∃ λ (C′ : Context ∞ n) →
    Non-degenerate ∞ C′ ×
    P ≡ C′ [ Ps ] × ∀ Qs → C [ Qs ] [ μ ]⟶ C′ [ Qs ]
6-2-15-nd ext ∅          ∅         ∅ ()
6-2-15-nd ext (C₁ ∣ C₂)  (w₁ ∣ w₂) (n₁ ∣ n₂)         (par-left  tr)       = Σ-map (_∣ C₂) (Σ-map (_∣ n₂) (Σ-map (cong (_∣ _)) (par-left  ∘_)))
                                                                              (6-2-15-nd ext C₁ w₁ n₁ tr)
6-2-15-nd ext (C₁ ∣ C₂)  (w₁ ∣ w₂) (n₁ ∣ n₂)         (par-right tr)       = Σ-map (C₁ ∣_) (Σ-map (n₁ ∣_) (Σ-map (cong (_ ∣_)) (par-right ∘_)))
                                                                              (6-2-15-nd ext C₂ w₂ n₂ tr)
6-2-15-nd ext (C₁ ∣ C₂)  (w₁ ∣ w₂) (n₁ ∣ n₂)         (par-τ tr₁ tr₂)      = Σ-zip _∣_ (Σ-zip _∣_ (Σ-zip (cong₂ _) (λ trs₁ trs₂ Qs →
                                                                                par-τ (trs₁ Qs) (trs₂ Qs))))
                                                                              (6-2-15-nd ext C₁ w₁ n₁ tr₁) (6-2-15-nd ext C₂ w₂ n₂ tr₂)
6-2-15-nd ext (μ · C)    action    (action n)        action               = force C , force n , refl , λ _ → action
6-2-15-nd ext (⟨ν a ⟩ C) (⟨ν⟩ w)   (⟨ν⟩ n)           (restriction a∉μ tr) = Σ-map ⟨ν a ⟩ (Σ-map ⟨ν⟩ (Σ-map (cong _) (restriction a∉μ ∘_)))
                                                                              (6-2-15-nd ext C w n tr)
6-2-15-nd ext (! C)      (! w)     (! n)             (replication tr)     = Σ-map id (Σ-map id (Σ-map id (replication ∘_)))
                                                                              (6-2-15-nd ext (! C ∣ C) (! w ∣ w) (! n ∣ n) tr)
6-2-15-nd ext (C₁ ⊕ C₂)  (w₁ ⊕ w₂) (action n₁  ⊕ n₂) (sum-left  tr)       = Σ-map id (Σ-map id (Σ-map id (sum-left ∘_)))
                                                                              (6-2-15-nd ext (_ · _) action (action n₁) tr)
6-2-15-nd ext {Ps = Ps} {P = P}
              (C₁ ⊕ C₂)  (w₁ ⊕ w₂) (process P₁ ⊕ n₂) (sum-left  tr)       = context P , context-non-degenerate P , ext (context-[] P) , λ Qs →
                                                                              subst (_ [ _ ]⟶_) (ext $ context-[] P) $
                                                                              subst (λ P → P ⊕ _ [ _ ]⟶ _)
                                                                                (context P₁ [ Ps ]  ≡⟨ sym $ ext $ context-[] P₁ ⟩
                                                                                P₁                 ≡⟨ ext $ context-[] P₁ ⟩∎
                                                                                context P₁ [ Qs ]  ∎) $
                                                                              sum-left tr
6-2-15-nd ext (C₁ ⊕ C₂)  (w₁ ⊕ w₂) (n₁ ⊕ action n₂)  (sum-right tr)       = Σ-map id (Σ-map id (Σ-map id (sum-right ∘_)))
                                                                              (6-2-15-nd ext (_ · _) action (action n₂) tr)
6-2-15-nd ext {Ps = Ps} {P = P}
              (C₁ ⊕ C₂)  (w₁ ⊕ w₂) (n₁ ⊕ process P₂) (sum-right tr)       = context P , context-non-degenerate P , ext (context-[] P) , λ Qs →
                                                                              subst (_ [ _ ]⟶_) (ext $ context-[] P) $
                                                                              subst (λ P → _ ⊕ P [ _ ]⟶ _)
                                                                                (context P₂ [ Ps ]  ≡⟨ sym $ ext $ context-[] P₂ ⟩
                                                                                P₂                 ≡⟨ ext $ context-[] P₂ ⟩∎
                                                                                context P₂ [ Qs ]  ∎) $
                                                                              sum-right tr


-- The type checker was a little too eager to prune metavariables in
-- order to get the occurs check to pass. In this particular case it
-- got the constraint
--   _41 A B x == B (_42 A B (x , y))
-- and tried to make it work by pruning the third argument to _42. The
-- correct solution _42 A B p := fst p was thus lost.
module Issue458 where

data Σ (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) → Σ A B

uncurry : {A : Set} {B : A → Set} {P : Σ A B → Set} →
          ((x : A) (y : B x) → P (x , y)) →
          (p : Σ A B) → P p
uncurry f (x , y) = f x y

fst : {A : Set} {B : A → Set} → Σ A B → A
fst = uncurry λ x y → x

snd : {A : Set} {B : A → Set} (p : Σ A B) → B (fst p)
snd = uncurry λ x y → y

-- Bug.agda:15,7-24
-- Cannot instantiate the metavariable _50 to .B x since it contains
-- the variable x which is not in scope of the metavariable
-- when checking that the expression uncurry (λ x y → y) has type
-- (p : Σ .A .B) → .B (fst p)


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties using (wkSingleSubstId)
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Substitution

open import Tools.Product
open import Tools.Unit
open import Tools.Empty
open import Tools.Nat

import Tools.PropositionalEquality as PE
import Data.Nat as Nat

~-quasirefl : ∀ {Γ n n′ A r} → Γ ⊢ n ~ n′ ∷ A ^ r → Γ ⊢ n ~ n ∷ A ^ r
~-quasirefl p = ~-trans p (~-sym p)

≅-quasirefl : ∀ {Γ n n′ A r} → Γ ⊢ n ≅ n′ ∷ A ^ r → Γ ⊢ n ≅ n ∷ A ^ r
≅-quasirefl p = ≅ₜ-trans p (≅ₜ-sym p)

proof-irrelevanceRel : ∀ {Γ A t u l l′} ([A] : Γ ⊩⟨ l ⟩ A ^ [ % , l′ ])
                   → Γ ⊩⟨ l ⟩ t ∷ A ^ [ % , l′ ] / [A]
                   → Γ ⊩⟨ l ⟩ u ∷ A ^ [ % , l′ ] / [A]
                   → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ % , l′ ] / [A]
proof-irrelevanceRel (Emptyᵣ x)
                   (Emptyₜ (ne ⊢t))
                   (Emptyₜ (ne ⊢t₁)) = Emptyₜ₌ (ne ⊢t ⊢t₁)

proof-irrelevanceRel (ne x)
                   (neₜ ⊢t)
                   (neₜ ⊢t₁) =
                   neₜ₌ ⊢t  ⊢t₁
proof-irrelevanceRel {Γ} {l = l} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) [f] [f₁] =
  [f] , [f₁]
proof-irrelevanceRel {Γ} {l = l} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) [f] [f₁] =
  [f] , [f₁]

proof-irrelevanceRel (emb emb< [A]) [t] [u] = proof-irrelevanceRel [A] [t] [u]
proof-irrelevanceRel (emb ∞< [A]) [t] [u] = proof-irrelevanceRel [A] [t] [u]

proof-irrelevanceᵛ : ∀ {Γ A t u l l′} ([Γ] : ⊩ᵛ Γ) ([A] : Γ ⊩ᵛ⟨ l ⟩ A ^ [ % , l′ ] / [Γ])
                   → Γ ⊩ᵛ⟨ l ⟩ t ∷ A ^ [ % , l′ ] / [Γ] / [A]
                   → Γ ⊩ᵛ⟨ l ⟩ u ∷ A ^ [ % , l′ ] / [Γ] / [A]
                   → Γ ⊩ᵛ⟨ l ⟩ t ≡ u ∷ A ^ [ % , l′ ] / [Γ] / [A]
proof-irrelevanceᵛ [Γ] [A] [t] [u] {σ = σ} ⊢Δ [σ] =
  proof-irrelevanceRel (proj₁ ([A] ⊢Δ [σ])) (proj₁ ([t] ⊢Δ [σ])) (proj₁ ([u] ⊢Δ [σ]))

validityIrr : ∀ {l A t Γ l'} ([Γ] : ⊩ᵛ Γ) ([A] : Γ ⊩ᵛ⟨ l ⟩ A ^ [ % , l' ] / [Γ])
                (⊢t : ∀ {Δ σ} (⊢Δ : ⊢ Δ) ([σ] : Δ ⊩ˢ σ ∷ Γ / [Γ] / ⊢Δ) → Δ ⊢ subst σ t ∷ subst σ A ^ [ % , l' ]) → Γ ⊩ᵛ⟨ l ⟩ t ∷ A ^ [ % , l' ] / [Γ] / [A]
validityIrr [Γ] [A] ⊢t {Δ} {σ} ⊢Δ [σ] =
  let [Aσ] = proj₁ ([A] ⊢Δ [σ])
      [tσ] = logRelIrr [Aσ] (⊢t ⊢Δ [σ])
      -- [tσ] = proj₁ ([t] ⊢Δ [σ])
  in  logRelIrr [Aσ] (⊢t ⊢Δ [σ]) ,
      λ [σ′] [σ≡σ′] → let [Aσ′] = proj₁ ([A] ⊢Δ [σ′])
                          [tσ′] = logRelIrr [Aσ′] (⊢t ⊢Δ [σ′])
                          [Aσ≡σ′] = proj₂ ([A] ⊢Δ [σ]) [σ′] [σ≡σ′]
                      in logRelIrrEq [Aσ] (⊢t ⊢Δ [σ]) (escapeTerm [Aσ] (convTerm₂ [Aσ] [Aσ′] [Aσ≡σ′] [tσ′]))


-- New feature by Jesper Cockx in commit be89d4a8b264dd2719cb8c601a2c7f45a95ba220 :
-- disabling the universe check for a data or record type.

-- Andreas, 2018-10-27, re issue #3327: restructured test cases.

-- Andreas, 2019-07-16, issue #3916:
-- {-# NO_UNIVERSE_CHECK #-} should also disable the index sort check
-- for --cubical-compatible.

{-# OPTIONS --cubical-compatible #-}

module _ where

-- Switch off the index sort check

module BigHetEq where

  {-# NO_UNIVERSE_CHECK #-}
  data _≅_ {a}{A : Set a} (x : A) : {B : Set a} → B → Set where
     refl : x ≅ x

module PittsHetEq where

  {-# NO_UNIVERSE_CHECK #-}
  data _≅_ {a}{A : Set a} (x : A) : {B : Set a} → B → Set a where
     refl : x ≅ x

-- Pragma is naturally attached to definition.

module DataDef where

  data U : Set
  T : U → Set

  {-# NO_UNIVERSE_CHECK #-}
  data U where
    pi : (A : Set)(b : A → U) → U

  T (pi A b) = (x : A) → T (b x)

-- Pragma can also be attached to signature.

module DataSig where

  {-# NO_UNIVERSE_CHECK #-}
  data U : Set
  T : U → Set

  data U where
    pi : (A : Set)(b : A → U) → U

  T (pi A b) = (x : A) → T (b x)

-- Works also for explicit mutual blocks.

module Mutual where

  {-# NO_UNIVERSE_CHECK #-}
  data U : Set where
    pi : (A : Set)(b : A → U) → U

  T : U → Set
  T (pi A b) = (x : A) → T (b x)

-- Records:

module Records where

  {-# NO_UNIVERSE_CHECK #-}
  record R : Set where
    field out : Set

  {-# NO_UNIVERSE_CHECK #-}
  record S : Set

  record S where
    field out : Set


module Issue4130 where

module Foo where
  data D : Set where
    con : D

module Bar (S : Set) where
  open Foo public using (con)

open Bar using (con)
open Foo using (D; con)

data B : Set where
  tt : B
  ff : B

module _ (S : Set) where
  open Bar S
  f : D -> B
  -- 'con' is not ambiguous, because although 'con' may refer to
  -- 'Foo.D.con' or 'Bar.con', they are two different names of the
  -- same constructor.
  f con = tt


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Basic Kripke-style semantics with abstract worlds, for soundness only.
-- Ono-style conditions.

module BasicIS4.Semantics.BasicKripkeOno where

open import BasicIS4.Syntax.Common public

-- Intuitionistic modal Kripke models, with frame conditions given by Ono.

record Model : Set₁ where
  infix 3 _⊩ᵅ_
  field
    World : Set

    -- Intuitionistic accessibility; preorder.
    _≤_    : World → World → Set
    refl≤  : ∀ {w} → w ≤ w
    trans≤ : ∀ {w w′ w″} → w ≤ w′ → w′ ≤ w″ → w ≤ w″

    -- Modal accessibility; preorder.
    _R_    : World → World → Set
    reflR  : ∀ {w} → w R w
    transR : ∀ {w w′ w″} → w R w′ → w′ R w″ → w R w″

    -- Forcing for atomic propositions; monotonic.
    _⊩ᵅ_   : World → Atom → Set
    mono⊩ᵅ : ∀ {P w w′} → w ≤ w′ → w ⊩ᵅ P → w′ ⊩ᵅ P

  -- Composition of accessibility.

  _≤⨾R_ : World → World → Set
  _≤⨾R_ = _≤_ ⨾ _R_

  _R⨾≤_ : World → World → Set
  _R⨾≤_ = _R_ ⨾ _≤_

  -- Persistence condition.
  --
  --   w′      v′  →           v′
  --   ◌───R───●   →           ●
  --   │           →         ╱
  --   ≤  ξ,ζ      →       R
  --   │           →     ╱
  --   ●           →   ●
  --   w           →   w

  field
    ≤⨾R→R : ∀ {v′ w} → w ≤⨾R v′ → w R v′

  -- Minor persistence condition.
  --
  --   w′      v′  →           v′
  --   ◌───R───●   →           ●
  --   │           →           │
  --   ≤  ξ,ζ      →           ≤
  --   │           →           │
  --   ●           →   ●───R───◌
  --   w           →   w       v
  --
  --                   w″  →                   w″
  --                   ●   →                   ●
  --                   │   →                   │
  --             ξ′,ζ′ ≤   →                   │
  --                   │   →                   │
  --           ●───R───◌   →                   ≤
  --           │       v′  →                   │
  --      ξ,ζ  ≤           →                   │
  --           │           →                   │
  --   ●───R───◌           →   ●───────R───────◌
  --   w       v           →   w               v″

  ≤⨾R→R⨾≤ : ∀ {v′ w} → w ≤⨾R v′ → w R⨾≤ v′
  ≤⨾R→R⨾≤ {v′} ξ,ζ = v′ , (≤⨾R→R ξ,ζ , refl≤)

  reflR⨾≤ : ∀ {w} → w R⨾≤ w
  reflR⨾≤ {w} = w , (reflR , refl≤)

  transR⨾≤ : ∀ {w′ w w″} → w R⨾≤ w′ → w′ R⨾≤ w″ → w R⨾≤ w″
  transR⨾≤ {w′} (v , (ζ , ξ)) (v′ , (ζ′ , ξ′)) = let v″ , (ζ″ , ξ″) = ≤⨾R→R⨾≤ (w′ , (ξ , ζ′))
                                                 in  v″ , (transR ζ ζ″ , trans≤ ξ″ ξ′)

  ≤→R : ∀ {v′ w} → w ≤ v′ → w R v′
  ≤→R {v′} ξ = ≤⨾R→R (v′ , (ξ , reflR))

open Model {{…}} public

-- Forcing in a particular world of a particular model.

module _ {{_ : Model}} where
  infix 3 _⊩_
  _⊩_ : World → Ty → Set
  w ⊩ α P   = w ⊩ᵅ P
  w ⊩ A ▻ B = ∀ {w′} → w ≤ w′ → w′ ⊩ A → w′ ⊩ B
  w ⊩ □ A   = ∀ {v′} → w R v′ → v′ ⊩ A
  w ⊩ A ∧ B = w ⊩ A × w ⊩ B
  w ⊩ ⊤    = 𝟙

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

-- Monotonicity with respect to intuitionistic accessibility.

module _ {{_ : Model}} where
  mono⊩ : ∀ {A w w′} → w ≤ w′ → w ⊩ A → w′ ⊩ A
  mono⊩ {α P}   ξ s = mono⊩ᵅ ξ s
  mono⊩ {A ▻ B} ξ s = λ ξ′ a → s (trans≤ ξ ξ′) a
  mono⊩ {□ A}   ξ s = λ ζ → s (transR (≤→R ξ) ζ)
  mono⊩ {A ∧ B} ξ s = mono⊩ {A} ξ (π₁ s) , mono⊩ {B} ξ (π₂ s)
  mono⊩ {⊤}    ξ s = ∙

  mono⊩⋆ : ∀ {Γ w w′} → w ≤ w′ → w ⊩⋆ Γ → w′ ⊩⋆ Γ
  mono⊩⋆ {∅}     ξ ∙       = ∙
  mono⊩⋆ {Γ , A} ξ (γ , a) = mono⊩⋆ {Γ} ξ γ , mono⊩ {A} ξ a

-- Additional useful equipment.

module _ {{_ : Model}} where
  _⟪$⟫_ : ∀ {A B w} → w ⊩ A ▻ B → w ⊩ A → w ⊩ B
  s ⟪$⟫ a = s refl≤ a

  ⟪K⟫ : ∀ {A B w} → w ⊩ A → w ⊩ B ▻ A
  ⟪K⟫ {A} a ξ = K (mono⊩ {A} ξ a)

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

  ⟪S⟫′ : ∀ {A B C w} → w ⊩ A ▻ B ▻ C → w ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ {A} {B} {C} s₁ ξ s₂ ξ′ a = let s₁′ = mono⊩ {A ▻ B ▻ C} (trans≤ ξ ξ′) s₁
                                      s₂′ = mono⊩ {A ▻ B} ξ′ s₂
                                  in  ⟪S⟫ {A} {B} {C} s₁′ s₂′ a

  _⟪D⟫_ : ∀ {A B w} → w ⊩ □ (A ▻ B) → w ⊩ □ A → w ⊩ □ B
  _⟪D⟫_ {A} {B} s₁ s₂ ζ = let s₁′ = s₁ ζ
                              s₂′ = s₂ ζ
                          in  _⟪$⟫_ {A} {B} s₁′ s₂′

  _⟪D⟫′_ : ∀ {A B w} → w ⊩ □ (A ▻ B) → w ⊩ □ A ▻ □ B
  _⟪D⟫′_ {A} {B} s₁ ξ = _⟪D⟫_ {A} {B} (mono⊩ {□ (A ▻ B)} ξ s₁)

  ⟪↑⟫ : ∀ {A w} → w ⊩ □ A → w ⊩ □ □ A
  ⟪↑⟫ s ζ ζ′ = s (transR ζ ζ′)

  ⟪↓⟫ : ∀ {A w} → w ⊩ □ A → w ⊩ A
  ⟪↓⟫ s = s reflR

  _⟪,⟫′_ : ∀ {A B w} → w ⊩ A → w ⊩ B ▻ A ∧ B
  _⟪,⟫′_ {A} {B} a ξ = _,_ (mono⊩ {A} ξ a)

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

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

  infix 3 _⊩_⇒⋆_
  _⊩_⇒⋆_ : World → 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 : World} → w ⊩ Γ ⇒ A

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

infix 3 _⁏_⊨_
_⁏_⊨_ : Cx Ty → Cx Ty → Ty → Set₁
Γ ⁏ Δ ⊨ A = ∀ {{_ : Model}} {w : World}
             → w ⊩⋆ Γ → (∀ {v′} → w R v′ → v′ ⊩⋆ Δ) → w ⊩ A

-- Additional useful equipment, for sequents.

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


{-

In this file we apply the cubical machinery to Martin Hötzel-Escardó's
structure identity principle:

https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#sns

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.Foundations.SIP where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence renaming (ua-pathToEquiv to ua-pathToEquiv')
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Path
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.Properties renaming (cong≃ to _⋆_)
open import Cubical.Foundations.HAEquiv
open import Cubical.Data.Prod.Base hiding (_×_) renaming (_×Σ_ to _×_)

open import Cubical.Foundations.Structure public

private
  variable
    ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ : Level
    S : Type ℓ₁ → Type ℓ₂

  -- For technical reasons we reprove ua-pathToEquiv using the
  -- particular proof constructed by iso→HAEquiv. The reason is that we
  -- want to later be able to extract
  --
  --   eq : ua-au (ua e) ≡ cong ua (au-ua e)
  --
  uaHAEquiv : (A B : Type ℓ₁) → HAEquiv (A ≃ B) (A ≡ B)
  uaHAEquiv A B = iso→HAEquiv (iso ua pathToEquiv ua-pathToEquiv' pathToEquiv-ua)

  open isHAEquiv

  -- We now extract the particular proof constructed from iso→HAEquiv
  -- for reasons explained above.
  ua-pathToEquiv : {A B : Type ℓ₁} (e : A ≡ B) → ua (pathToEquiv e) ≡ e
  ua-pathToEquiv e = uaHAEquiv _ _ .snd .ret e

-- Note that for any equivalence (f , e) : X ≃ Y the type  ι (X , s) (Y , t) (f , e) need not to be
-- a proposition. Indeed this type should correspond to the ways s and t can be identified
-- as S-structures. This we call a standard notion of structure or SNS.
-- We will use a different definition, but the two definitions are interchangeable.
SNS-≡ : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃) → Type (ℓ-max (ℓ-max (ℓ-suc ℓ₁) ℓ₂) ℓ₃)
SNS-≡ {ℓ₁} S ι = ∀ {X : Type ℓ₁} (s t : S X) → ι (X , s) (X , t) (idEquiv X) ≃ (s ≡ t)

-- We introduce the notation for structure preserving equivalences a
-- bit differently, but this definition doesn't actually change from
-- Escardó's notes.
_≃[_]_ : (A : TypeWithStr ℓ₁ S) (ι : StrIso S ℓ₂) (B : TypeWithStr ℓ₁ S) → Type (ℓ-max ℓ₁ ℓ₂)
A ≃[ ι ] B = Σ[ e ∈ typ A ≃ typ B ] (ι A B e)

-- The following PathP version of SNS-≡ is a bit easier to work with
-- for the proof of the SIP
SNS-PathP : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃) → Type (ℓ-max (ℓ-max (ℓ-suc ℓ₁) ℓ₂) ℓ₃)
SNS-PathP {ℓ₁} S ι = {A B : TypeWithStr ℓ₁ S} (e : typ A ≃ typ B)
                  → ι A B e ≃ PathP (λ i → S (ua e i)) (str A) (str B)

-- A quick sanity-check that our definition is interchangeable with
-- Escardó's. The direction SNS-≡→SNS-PathP corresponds more or less
-- to a dependent EquivJ formulation of Escardó's homomorphism-lemma.
SNS-PathP→SNS-≡ : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃) → SNS-PathP S ι → SNS-≡ S ι
SNS-PathP→SNS-≡ S ι θ {X = X} s t = ι (X , s) (X , t) (idEquiv X)           ≃⟨ θ (idEquiv X) ⟩
                                   PathP (λ i → S (ua (idEquiv X) i)) s t  ≃⟨ φ ⟩
                                   s ≡ t                                   ■
  where
   φ = transportEquiv (λ j → PathP (λ i → S (uaIdEquiv {A = X} j i)) s t)

SNS-≡→SNS-PathP : (ι : StrIso S ℓ₃) → SNS-≡ S ι → SNS-PathP S ι
SNS-≡→SNS-PathP {S = S} ι θ {A = A} {B = B} e = EquivJ P C e (str A) (str B)
  where
   Y = typ B

   P : (X : Type _) → X ≃ Y → Type _
   P X e' = (s : S X) (t : S Y) → ι (X , s) (Y , t) e' ≃ PathP (λ i → S (ua e' i)) s t

   C : (s t : S Y) → ι (Y , s) (Y , t) (idEquiv Y) ≃ PathP (λ i → S (ua (idEquiv Y) i)) s t
   C s t = ι (Y , s) (Y , t) (idEquiv Y)           ≃⟨ θ s t ⟩
           s ≡ t                                   ≃⟨ ψ ⟩
           PathP (λ i → S (ua (idEquiv Y) i)) s t  ■
    where
     ψ = transportEquiv λ j → PathP (λ i → S (uaIdEquiv {A = Y} (~ j) i)) s t

-- We can now directly define an invertible function
--
--    sip : A ≃[ ι ] B → A ≡ B
--
sip : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃) (θ : SNS-PathP S ι)
      (A B : TypeWithStr ℓ₁ S) → A ≃[ ι ] B → A ≡ B
sip S ι θ A B (e , p) i = ua e i , θ e .fst p i

-- The inverse to sip uses the following little lemma
private
  lem : (S : Type ℓ₁ → Type ℓ₂) (A B : TypeWithStr ℓ₁ S) (e : typ A ≡ typ B)
      → PathP (λ i → S (ua (pathToEquiv e) i)) (A .snd) (B .snd) ≡
        PathP (λ i → S (e i)) (A .snd) (B .snd)
  lem S A B e i = PathP (λ j → S (ua-pathToEquiv e i j)) (A .snd) (B .snd)

-- The inverse
sip⁻ : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃) (θ : SNS-PathP S ι)
       (A B : TypeWithStr ℓ₁ S) → A ≡ B → A ≃[ ι ] B
sip⁻ S ι θ A B r = pathToEquiv p , invEq (θ (pathToEquiv p)) q
  where
  p : typ A ≡ typ B
  p = cong fst r
  q : PathP (λ i → S (ua (pathToEquiv p) i)) (A .snd) (B .snd)
  q = transport⁻ (lem S A B p) (cong snd r)

-- We can rather directly show that sip and sip⁻ are mutually inverse:
sip-sip⁻ : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃) (θ : SNS-PathP S ι)
           (A B : TypeWithStr ℓ₁ S) (r : A ≡ B)
         → sip S ι θ A B (sip⁻ S ι θ A B r) ≡ r
sip-sip⁻ S ι θ A B r =
  let p : typ A ≡ typ B
      p = cong fst r
      q : PathP (λ i → S (p i)) (str A) (str B)
      q = cong snd r
  in sip S ι θ A B (sip⁻ S ι θ A B r)
   ≡⟨ refl ⟩
     (λ i → ( ua (pathToEquiv p) i)
            , θ (pathToEquiv p) .fst
                (invEq (θ (pathToEquiv p))
                       (transport⁻ (lem S A B p) q)) i)
   ≡⟨ (λ i j → ( ua (pathToEquiv p) j
               , retEq (θ (pathToEquiv p))
                       (transport⁻ (lem S A B p) q) i j)) ⟩
     (λ i → ( ua (pathToEquiv p) i
            , transport⁻ (lem S A B p) q i))
   ≡⟨ (λ i j → ( ua-pathToEquiv p i j
               , transp (λ k → PathP (λ j → S (ua-pathToEquiv p (i ∧ k) j)) (str A) (str B))
                        (~ i) (transport⁻ (lem S A B p) q) j)) ⟩
     (λ i → ( p i
            , transport (λ i → lem S A B p i) (transport⁻ (lem S A B p) q) i))
   ≡⟨ (λ i j → ( p j
               , transportTransport⁻ (lem S A B p) q i j)) ⟩
     r ∎

-- The trickier direction:
sip⁻-sip : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃) (θ : SNS-PathP S ι)
           (A B : TypeWithStr ℓ₁ S) (r : A ≃[ ι ] B)
         → sip⁻ S ι θ A B (sip S ι θ A B r) ≡ r
sip⁻-sip S ι θ A B (e , p) =
    sip⁻ S ι θ A B (sip S ι θ A B (e , p))
  ≡⟨ refl ⟩
    pathToEquiv (ua e) , invEq (θ (pathToEquiv (ua e))) (f⁺ p')
  ≡⟨ (λ i → pathToEquiv-ua e i , invEq (θ (pathToEquiv-ua e i)) (pth' i)) ⟩
    e , invEq (θ e) (f⁻ (f⁺ p'))
  ≡⟨ (λ i → e , invEq (θ e) (transportTransport⁻ (lem S A B (ua e)) p' i)) ⟩
    e , invEq (θ e) (θ e .fst p)
  ≡⟨ (λ i → e , (secEq (θ e) p i)) ⟩
    e , p ∎
  where
  p' : PathP (λ i → S (ua e i)) (str A) (str B)
  p' = θ e .fst p

  f⁺ : PathP (λ i → S (ua e i)) (str A) (str B)
     → PathP (λ i → S (ua (pathToEquiv (ua e)) i)) (str A) (str B)
  f⁺ = transport (λ i → PathP (λ j → S (ua-pathToEquiv (ua e) (~ i) j)) (str A) (str B))

  f⁻ : PathP (λ i → S (ua (pathToEquiv (ua e)) i)) (str A) (str B)
     → PathP (λ i → S (ua e i)) (str A) (str B)
  f⁻ = transport (λ i → PathP (λ j → S (ua-pathToEquiv (ua e) i j)) (str A) (str B))

  -- We can prove the following as in sip∘pis-id, but the type is not
  -- what we want as it should be "cong ua (pathToEquiv-ua e)"
  pth : PathP (λ j → PathP (λ k → S (ua-pathToEquiv (ua e) j k)) (str A) (str B))
              (f⁺ p') (f⁻ (f⁺ p'))
  pth i = transp (λ k → PathP (λ j → S (ua-pathToEquiv (ua e) (i ∧ k) j)) (str A) (str B))
                 (~ i) (f⁺ p')

  -- So we build an equality that we want to cast the types with
  casteq : PathP (λ j → PathP (λ k → S (ua-pathToEquiv (ua e) j k)) (str A) (str B))
                 (f⁺ p') (f⁻ (f⁺ p'))
         ≡ PathP (λ j → PathP (λ k → S (cong ua (pathToEquiv-ua e) j k)) (str A) (str B))
                 (f⁺ p') (f⁻ (f⁺ p'))
  casteq i = PathP (λ j → PathP (λ k → S (eq i j k)) (str A) (str B)) (f⁺ p') (f⁻ (f⁺ p'))
    where
    -- This is where we need the half-adjoint equivalence property
    eq : ua-pathToEquiv (ua e) ≡ cong ua (pathToEquiv-ua e)
    eq = sym (uaHAEquiv (typ A) (typ B) .snd .com e)

  -- We then get a term of the type we need
  pth' : PathP (λ j → PathP (λ k → S (cong ua (pathToEquiv-ua e) j k)) (str A) (str B))
               (f⁺ p') (f⁻ (f⁺ p'))
  pth' = transport (λ i → casteq i) pth

-- Finally package everything up to get the cubical SIP
SIP : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃)
      (θ : SNS-PathP S ι) (A B : TypeWithStr ℓ₁ S)
    → A ≃[ ι ] B ≃ (A ≡ B)
SIP S ι θ A B = isoToEquiv (iso (sip S ι θ A B) (sip⁻ S ι θ A B)
                               (sip-sip⁻ S ι θ A B) (sip⁻-sip S ι θ A B))

-- Now, we want to add axioms (i.e. propositions) to our Structure S that don't affect the ι.
-- We use a lemma due to Zesen Qian, which can now be found in Foundations.Prelude:
-- https://github.com/riaqn/cubical/blob/hgroup/Cubical/Data/Group/Properties.agda#L83

add-to-structure : (S : Type ℓ₁ → Type ℓ₂)
                   (axioms : (X : Type ℓ₁) → S X → Type ℓ₄)
                 → Type ℓ₁ → Type (ℓ-max ℓ₂ ℓ₄)
add-to-structure S axioms X = Σ[ s ∈ S X ] (axioms X s)

add-to-iso : (S : Type ℓ₁ → Type ℓ₂) (ι : StrIso S ℓ₃)
             (axioms : (X : Type ℓ₁) → S X → Type ℓ₄)
           → StrIso (add-to-structure S axioms) ℓ₃
add-to-iso S ι axioms (X , (s , a)) (Y , (t , b)) f = ι (X , s) (Y , t) f

add-ax-lemma : (S : Type ℓ₁ → Type ℓ₂)
               (axioms : (X : Type ℓ₁) → S X → Type ℓ₄)
               (axioms-are-Props : (X : Type ℓ₁) (s : S X) → isProp (axioms X s))
               {X Y : Type ℓ₁} {s : S X} {t : S Y} {a : axioms X s} {b : axioms Y t}
               (f : X ≃ Y)
             → PathP (λ i → S (ua f i)) s t ≃
               PathP (λ i → add-to-structure S axioms (ua f i)) (s , a) (t , b)
add-ax-lemma S axioms axioms-are-Props {s = s} {t = t} {a = a} {b = b} f = isoToEquiv (iso φ ψ η ε)
      where
       φ : PathP (λ i → S (ua f i)) s t → PathP (λ i → add-to-structure S axioms (ua f i)) (s , a) (t , b)
       φ p i = p i , isProp→PathP (λ i → axioms-are-Props (ua f i) (p i)) a b i

       ψ : PathP (λ i → add-to-structure S axioms (ua f i)) (s , a) (t , b) → PathP (λ i → S (ua f i)) s t
       ψ r i = r i .fst

       η : section φ ψ
       η r i j =  r j .fst , isProp→isSet-PathP (λ k → axioms-are-Props (ua f k) (r k .fst)) _ _
                                                (isProp→PathP (λ k → axioms-are-Props (ua f k) (r k .fst)) a b)
                                                (λ k → r k .snd) i j

       ε : retract φ ψ
       ε p = refl

add-axioms-SNS : (S : Type ℓ₁ → Type ℓ₂)
                 (ι : (A B : Σ[ X ∈ (Type ℓ₁) ] (S X)) → A .fst ≃ B .fst → Type ℓ₃)
                 (axioms : (X : Type ℓ₁) → S X → Type ℓ₄)
                 (axioms-are-Props : (X : Type ℓ₁) (s : S X) → isProp (axioms X s))
                 (θ : SNS-PathP S ι)
               → SNS-PathP (add-to-structure S axioms) (add-to-iso S ι axioms)
add-axioms-SNS S ι axioms axioms-are-Props θ {X , s , a} {Y , t , b} f =
  add-to-iso S ι axioms (X , s , a) (Y , t , b) f                      ≃⟨ θ f ⟩
  PathP (λ i → S (ua f i)) s t                                        ≃⟨ add-ax-lemma S axioms axioms-are-Props f ⟩
  PathP (λ i → (add-to-structure S axioms) (ua f i)) (s , a) (t , b)  ■

-- Now, we want to join two structures. Together with the adding of
-- axioms this will allow us to prove that a lot of mathematical
-- structures are a standard notion of structure

join-structure : (S₁ : Type ℓ₁ → Type ℓ₂) (S₂ : Type ℓ₁ → Type ℓ₄)
               → Type ℓ₁ → Type (ℓ-max ℓ₂ ℓ₄)
join-structure S₁ S₂ X = S₁ X × S₂ X

join-iso : {S₁ : Type ℓ₁ → Type ℓ₂} (ι₁ : StrIso S₁ ℓ₃)
           {S₂ : Type ℓ₁ → Type ℓ₄} (ι₂ : StrIso S₂ ℓ₅)
         → StrIso (join-structure S₁ S₂) (ℓ-max ℓ₃ ℓ₅)
join-iso ι₁ ι₂ (X , s₁ , s₂) (Y , t₁ , t₂) f = (ι₁ (X , s₁) (Y , t₁) f) × (ι₂ (X , s₂) (Y , t₂) f)

join-SNS : (S₁ : Type ℓ₁ → Type ℓ₂) (ι₁ : StrIso S₁ ℓ₃) (θ₁ : SNS-PathP S₁ ι₁)
           (S₂ : Type ℓ₁ → Type ℓ₄) (ι₂ : StrIso S₂ ℓ₅) (θ₂ : SNS-PathP S₂ ι₂)
         → SNS-PathP (join-structure S₁ S₂) (join-iso ι₁ ι₂)
join-SNS S₁ ι₁ θ₁ S₂ ι₂ θ₂ {X , s₁ , s₂} {Y , t₁ , t₂} e = isoToEquiv (iso φ ψ η ε)
   where
    φ : join-iso ι₁ ι₂ (X , s₁ , s₂) (Y , t₁ , t₂) e
      → PathP (λ i → join-structure S₁ S₂ (ua e i)) (s₁ , s₂) (t₁ , t₂)
    φ (p , q) i = (θ₁ e .fst p i) , (θ₂ e .fst q i)

    ψ : PathP (λ i → join-structure S₁ S₂ (ua e i)) (s₁ , s₂) (t₁ , t₂)
      → join-iso ι₁ ι₂ (X , s₁ , s₂) (Y , t₁ , t₂) e
    ψ p = invEq (θ₁ e) (λ i → p i .fst) , invEq (θ₂ e) (λ i → p i .snd)

    η : section φ ψ
    η p i j = retEq (θ₁ e) (λ k → p k .fst) i j , retEq (θ₂ e) (λ k → p k .snd) i j

    ε : retract φ ψ
    ε (p , q) i = secEq (θ₁ e) p i , secEq (θ₂ e) q i


open import Relation.Binary
open import Level

module Experiments.Infer {c ℓ₁ ℓ₂}(PO : Preorder c ℓ₁ ℓ₂) where

open Preorder PO renaming (_∼_ to _⊑_)

record IsIncluded (W W' : Carrier) : Set ℓ₂ where
  field
    is-included : W ⊑ W'

record IsIncludedOnce (W W' : Carrier) : Set ℓ₂ where
  field
    is-included-once : W ⊑ W'

instance
  is-included-refl : ∀ {W} → IsIncluded W W
  is-included-refl = record { is-included = refl }

  is-included-step : ∀ {W W' W''} ⦃ p : IsIncludedOnce W W' ⦄ ⦃ q : IsIncluded W' W'' ⦄ → IsIncluded W W''
  is-included-step
    {{p = record { is-included-once = p }}}
    {{record { is-included = q }}} = record { is-included = trans p q }

-- typeclass for world-indexed things that support weakening
record Weakenable {i}(I : Carrier → Set i) : Set (i ⊔ ℓ₂ ⊔ c) where
  field
    weaken : ∀ {W W'} → W ⊑ W' → I W → I W'

  wk     : ∀ {W W'} → I W → ⦃ p : IsIncluded W W' ⦄ → I W'
  wk x ⦃ record { is-included = p } ⦄ = weaken p x

ISet = Carrier → Set

module Monad
  (M    : ISet → ISet)
  (ret  : ∀ {P : ISet}{c} → P c → M P c)
  (bind : ∀ {P Q : ISet}{c} → (∀ {c'} ⦃ sub : IsIncludedOnce c c' ⦄ → P c' → M Q c') → M P c → M Q c)
  (V    : ISet)
  (wV   : Weakenable V)
  (get  : ∀ {c} → M V c)
  (App  : ∀ {c} → V c → V c → V c)
  where

  instance
    weakenable-val = wV

  open Weakenable ⦃...⦄

  {- uncomment to see the compiler error -}
  -- test : ∀ {c} → M V c
  -- test = bind (λ x → bind (λ y → ret (App (wk x) (wk y))) get) get


{-# OPTIONS --without-K #-}
open import container.core

module container.w.fibration
  {li la lb}(c : Container li la lb) where

open import sum
open import equality
open import function
open import container.w.core
open import container.w.algebra c
open import hott.level

open Container c

AlgFib : ∀ ℓ → Set _
AlgFib ℓ = Σ ((i : I) → W c i → Set ℓ) λ P
         → (∀ i x → ((b : B (proj₁ x)) → P (r b) (proj₂ x b)) → P i (inW c i x))

AlgSection : ∀ {ℓ} (𝓟 : AlgFib ℓ) → Set _
AlgSection (P , θ) = Σ (∀ i x → P i x) λ f
                   → _≡_ {A = ∀ i x → P i (inW c i x)}
                     (λ i x → θ i x (λ b → f (r b) (proj₂ x b)))
                     (λ i x → f i (inW c i x))

alg-total : ∀ {ℓ} → AlgFib ℓ → Alg _
alg-total (P , θ) = X , ψ
  where
    X : I → Set _
    X i = Σ (W c i) (P i)

    ψ : F X →ⁱ X
    ψ i (a , u) = inW c i (a , λ b → proj₁ (u b))
                , θ i (a , λ b → proj₁ (u b)) (λ b → proj₂ (u b))

module _ {ℓ} (𝓟 : AlgFib ℓ) where
  private 𝓧 = alg-total 𝓟
  open Σ 𝓟 renaming (proj₁ to P ; proj₂ to θ)
  open Σ (alg-total 𝓟) renaming (proj₁ to X ; proj₂ to ψ)

  section : AlgSection 𝓟
  section = f₀ , refl
    where
      f₀ : ∀ i x → P i x
      f₀ i (sup a u) = θ i (a , u) (λ b → f₀ (r b) (u b))

  private
    split-lem : ∀ {ℓ'} (Y : I → Set ℓ')
              → (Y →ⁱ X)
              ≅ ( Σ (Y →ⁱ W c) λ g₀
                → ∀ i x → P i (g₀ i x) )
    split-lem Y
      = sym≅ (curry-iso (λ i _ → X i))
      ·≅ ΠΣ-swap-iso
      ·≅ Σ-ap-iso (curry-iso (λ i _ → W c i))
                  (λ g₀ → curry-iso (λ i x → P i (g₀ (i , x))))

  section-mor-iso : Mor 𝓦 𝓧 ≅ AlgSection 𝓟
  section-mor-iso = begin
      ( Σ (W c →ⁱ X) λ f → ψ ∘ⁱ imap f ≡ f ∘ⁱ inW c )
    ≅⟨ Σ-ap-iso (split-lem (W c)) (λ _ → refl≅) ⟩
      ( Σ (Σ (W c →ⁱ W c) λ f₀ → ∀ i → (w : W c i) → P i (f₀ i w)) λ { (f₀ , f₁)
        → _≡_ {A = ∀ i (x : F (W c) i) → X i}
          (λ i x → let x' = imap f₀ i x
                    in (inW c i x' , θ i x' (λ b → f₁ (r b) (proj₂ x b))))
          (λ i x → (f₀ i (inW c i x) , f₁ i (inW c i x))) } )
    ≅⟨ ( Σ-ap-iso refl≅ λ { (f₀ , f₁) → iso≡ (split-lem (F (W c)))
                                      ·≅ sym≅ Σ-split-iso } ) ⟩
      ( Σ (Σ (W c →ⁱ W c) λ f₀ → ∀ i → (w : W c i) → P i (f₀ i w)) λ { (f₀ , f₁)
      → Σ ( _≡_ {A = ∀ i (x : F (W c) i) → W c i}
            (λ i x → inW c i (imap f₀ i x))
            (λ i x → f₀ i (inW c i x)) ) λ eq
      → subst (λ g → ∀ i (x : F (W c) i) → P i (g i x)) eq
            (λ i x → θ i (imap f₀ i x) (λ b → f₁ (r b) (proj₂ x b)))
          ≡ (λ i x → f₁ i (inW c i x)) } )
    ≅⟨ record
          { to = λ { ((f₀ , f₁) , (α₀ , α₁)) → ((f₀ , α₀) , (f₁ , α₁)) }
          ; from = λ { ((f₀ , α₀) , (f₁ , α₁)) → ((f₀ , f₁) , (α₀ , α₁)) }
          ; iso₁ = λ { ((f₀ , f₁) , (α₀ , α₁)) → refl }
          ; iso₂ = λ { ((f₀ , α₀) , (f₁ , α₁)) → refl } } ⟩
      ( Σ ( Σ (∀ i → W c i → W c i) λ f₀
          → ( _≡_ {A = ∀ i (x : F (W c) i) → W c i}
              (λ i x → inW c i (imap f₀ i x))
              (λ i x → f₀ i (inW c i x)) ) ) λ { (f₀ , eq)
      → Σ (∀ i w → P i (f₀ i w)) λ f₁
      → subst (λ g → ∀ i (x : F (W c) i) → P i (g i x)) eq
            (λ i x → θ i (imap f₀ i x) (λ b → f₁ (r b) (proj₂ x b)))
          ≡ (λ i x → f₁ i (inW c i x)) } )
    ≅⟨ sym≅ ( Σ-ap-iso (sym≅ (contr-⊤-iso W-initial-W)) λ _ → refl≅ ) ·≅ ×-left-unit ⟩
      ( Σ (∀ i w → P i w) λ f₁
      → (λ i x → θ i x (λ b → f₁ (r b) (proj₂ x b)))
      ≡ (λ i x → f₁ i (inW c i x)) )
    ∎
    where
      open ≅-Reasoning

  W-section-contr : contr (AlgSection 𝓟)
  W-section-contr = iso-level section-mor-iso (W-initial 𝓧)


open import Prelude

module Implicits.Resolution.Termination.Lemmas.Stack
  where

open import Induction.WellFounded
open import Induction.Nat
open import Data.Fin.Substitution
open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Data.Nat hiding (_<_)
open import Data.Nat.Properties

open import Implicits.Resolution.Termination.SizeMeasures
open import Implicits.Resolution.Termination.Stack

open import Data.Nat.Base
+k<+k : ∀ {n m} k → n N< m → k N+ n N< k N+ m
+k<+k zero p = p
+k<+k (suc k) p = s≤s (+k<+k k p)

+k<+k' : ∀ {n m} k → n N< m → n N+ k N< m N+ k
+k<+k' {n} {m} k p = subst₂ (λ u v → u N< v) (+-comm k n) (+-comm k m) (+k<+k k p)
  where open import Data.Nat.Properties.Simple

-k<-k : ∀ {n m} k → k N+ n N< k N+ m → n < m
-k<-k zero x = x
-k<-k (suc k) (s≤s x) = -k<-k k x

-k<-k' : ∀ {n m} k → n N+ k N< m N+ k → n < m
-k<-k' {n} {m} k p = -k<-k k (subst₂ _N<_ (+-comm n k) (+-comm m k) p)
  where open import Data.Nat.Properties.Simple

----------------------------------------------------------------
-- stack properties

push< : ∀ {ν r a} {Δ : ICtx ν} (s : Stack Δ) (r∈Δ : r List.∈ Δ) →
        (, a) ρ< (, s get r∈Δ) → (s push a for r∈Δ) s< s
push< (b All.∷ s) (here _) a<b = +k<+k' (ssum s) a<b
push< (b All.∷ s) (there r∈Δ) p = +k<+k h|| b || (push< s r∈Δ p)

push≮ : ∀ {ν r a} {Δ : ICtx ν} (s : Stack Δ) (r∈Δ : r List.∈ Δ) →
        ¬ ((, a) ρ< (, s get r∈Δ)) → ¬ (s push a for r∈Δ) s< s
push≮ (b All.∷ s) (here _) ¬a<b = λ x → ¬a<b (-k<-k' (ssum s) x)
push≮ (b All.∷ s) (there r∈Δ) ¬a<b = λ x → push≮ s r∈Δ ¬a<b (-k<-k h|| b || x)

----------------------------------------------------------------
-- a type dominates a stack if pushing it to the stack makes the stack bigger

_for_?⊬dom_ : ∀ {ν r} {Δ : ICtx ν} → (a : Type ν) → (r∈Δ : r List.∈ Δ) → (s : Stack Δ) →
               Dec (a for r∈Δ ⊬dom s)
a for r∈Δ ?⊬dom s with (, a) ρ<? (, s get r∈Δ)
a for r∈Δ ?⊬dom s | yes p = yes (push< s r∈Δ p)
a for r∈Δ ?⊬dom s | no ¬p = no (push≮ s r∈Δ ¬p)

-- we also show that the ordering on stacks is well founded
s<-well-founded : ∀ {ν} {Δ : ICtx ν} → Well-founded (_s<_ {ν} {Δ})
s<-well-founded = sub.well-founded (image.well-founded <-well-founded)
  where
    open import Data.Nat.Base
    open import Data.Nat.Properties
    module sub = Inverse-image (λ{ s → ssum s})
    module image = Subrelation {A = ℕ} {_N<_} {_<′_} ≤⇒≤′

{-}
-- we can show that our strict size measure a ρ< b is well founded
-- by relating it to the well-foundedness proof of _<'_
sρ<-well-founded : Well-founded _sρ<_
sρ<-well-founded = sub.well-founded (image.well-founded <-well-founded)
  where
    module sub = Inverse-image (λ{ (_ , a) → || a ||})
    module image = Subrelation {A = ℕ} {_N<_} {_<′_} ≤⇒≤′
-}


{- 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.Lemmas
open import LibraBFT.Prelude
open import LibraBFT.Base.Encode
open import LibraBFT.Base.ByteString

-- This module contains a model of cryptographic signatures on
-- certain data structures, and creation and verification
-- thereof.  These data structures, defined by the WithVerSig
-- type, can be optionally signed, and if they are signed, the
-- signature covers a ByteString derived from the data structure,
-- enabling support for signature that cover only (functions of)
-- specific parts of the data structure.  The module also
-- contains some properties we have found useful in other
-- contexts, though they are not yet used in this repo.

module LibraBFT.Base.PKCS where

 postulate -- valid assumption
   signature-size : ℕ

 Signature : Set
 Signature = Σ ByteString (λ s → length s ≡ signature-size)

 postulate -- valid assumptions
   PK : Set
   SK : Set
   IsKeyPair : PK → SK → Set
   _≟PK_ : (pk1 pk2 : PK) → Dec (pk1 ≡ pk2)

   instance
     enc-PK    : Encoder PK
     enc-SigMB : Encoder (Maybe Signature)

   sign-raw : ByteString → SK → Signature
   verify   : ByteString → Signature → PK → Bool

   -- We assume no "signature collisions", as represented by verify-pk-inj
   verify-pk-inj : ∀{bs sig pk pk'}
                 → verify bs sig pk  ≡ true
                 → verify bs sig pk' ≡ true
                 → pk ≡ pk'

   verify-bs-inj : ∀{bs bs' sig pk}
                 → verify bs  sig pk ≡ true
                 → verify bs' sig pk ≡ true
                 → bs ≡ bs'

   verify-sign : ∀{bs pk sk}
               → IsKeyPair pk sk
               → verify bs (sign-raw bs sk) pk ≡ true

   verify-fail : ∀{bs pk sk}
               → ¬ IsKeyPair pk sk
               → verify bs (sign-raw bs sk) pk ≡ false

   -- We consider a PK to be (permanently) either honest or not,
   -- respresented by the following postulate.  This is relevant
   -- in reasoning about possible behaviours of a modeled system.
   -- Specifically, the secret key corresponding to an honest PK
   -- is assumed not to be leaked, ensuring that cheaters cannot
   -- forge new signatures for honest PKs.  Furthermore, if a peer
   -- is assigned we use possession
   -- of an honest PK in a given epoch to modelWe will postulate that, among
   -- the PKs chosen for a particular epoch, the number of them
   -- that are dishonest is at most the number of faults to be
   -- tolerated for that epoch.  This definition is /meta/: the
   -- information about which PKs are (dis)honest should never be
   -- used by the implementation -- it is only for modeling and
   -- proofs.
   Meta-Dishonest-PK : PK → Set

   Meta-DishonestPK? : (pk : PK) → Dec (Meta-Dishonest-PK pk)

 verify-pi : ∀{bs sig pk}
           → (v1 : verify bs sig pk ≡ true)
           → (v2 : verify bs sig pk ≡ true)
           → v1 ≡ v2
 verify-pi {bs} {sig} {pk} _ _
    with verify bs sig pk
 verify-pi {bs} {sig} {pk} refl refl | .true = refl

 Meta-Honest-PK : PK → Set
 Meta-Honest-PK  = ¬_ ∘ Meta-Dishonest-PK

 -- A datatype C might that might carry values with
 -- signatures should be an instance of 'WithSig' below.
 record WithSig (C : Set) : Set₁ where
   field
     -- A decidable predicate indicates whether values have
     -- been signed
     Signed         : C → Set
     Signed-pi      : ∀ (c : C)
                    → (is1 : Signed c)
                    → (is2 : Signed c)
                    → is1 ≡ is2
     isSigned?      : (c : C) → Dec (Signed c)

     -- Signed values must have a signature
     signature      : (c : C)(hasSig : Signed c) → Signature

     -- All values must be /encoded/ into a ByteString that
     -- is supposed to be verified against a signature.
     signableFields : C → ByteString
 open WithSig {{...}} public

 sign : {C : Set} ⦃ ws : WithSig C ⦄ → C → SK → Signature
 sign c = sign-raw (signableFields c)

 Signature≡ : {C : Set} ⦃ ws : WithSig C ⦄ → C → Signature → Set
 Signature≡ c sig = Σ (Signed c) (λ s → signature c s ≡ sig)

 -- A value of a datatype C can have its signature
 -- verified; A value of type WithVerSig c is a proof of that.
 -- Hence; the set (Σ C WithVerSig) is the set of values of
 -- type C with verified signatures.
 record WithVerSig {C : Set} ⦃ ws : WithSig C ⦄ (pk : PK) (c : C) : Set where
   constructor mkWithVerSig
   field
     isSigned  : Signed c
     verified  : verify (signableFields c) (signature c isSigned) pk
               ≡ true
 open WithVerSig public

 ver-signature : ∀{C pk}⦃ ws : WithSig C ⦄{c : C} → WithVerSig pk c → Signature
 ver-signature {c = c} wvs = signature c (isSigned wvs)

 verCast : {C : Set} ⦃ ws : WithSig C ⦄ {c : C} {is1 is2 : Signed c} {pk1 pk2 : PK}
         → verify (signableFields c) (signature c is1) pk1 ≡ true
         → pk1 ≡ pk2
         → is1 ≡ is2
         → verify (signableFields c) (signature c is2) pk2 ≡ true
 verCast prf refl refl = prf

 wvsCast : {C : Set} ⦃ ws : WithSig C ⦄ {c : C} {pk1 pk2 : PK}
         → WithVerSig pk1 c
         → pk2 ≡ pk1
         → WithVerSig pk2 c
 wvsCast {c = c} wvs refl = wvs

 withVerSig-≡ : {C : Set} ⦃ ws : WithSig C ⦄ {pk : PK} {c : C}
              → {wvs1 : WithVerSig pk c}
              → {wvs2 : WithVerSig pk c}
              → isSigned  wvs1 ≡ isSigned  wvs2
              → wvs1 ≡ wvs2
 withVerSig-≡ {wvs1 = wvs1} {wvs2 = wvs2} refl
    with verified wvs2 | inspect verified wvs2 | verCast (verified wvs1) refl refl
 ...| vwvs2 | [ R ] | vwvs1 rewrite verify-pi vwvs1 vwvs2 | sym R = refl

 withVerSig-pi : {C : Set} {pk : PK} {c : C} ⦃ ws : WithSig C ⦄
               → (wvs1 : WithVerSig pk c)
               → (wvs2 : WithVerSig pk c)
               → wvs2 ≡ wvs1
 withVerSig-pi {C} {pk} {c} ⦃ ws ⦄ wvs2 wvs1
    with isSigned? c
 ...| no ¬Signed = ⊥-elim (¬Signed (isSigned wvs1))
 ...| yes sc = withVerSig-≡ {wvs1 = wvs1} {wvs2 = wvs2} (Signed-pi c (isSigned wvs1) (isSigned wvs2))

 data SigCheckResult {C : Set} ⦃ ws : WithSig C ⦄ (pk : PK) (c : C) : Set where
   notSigned   : ¬ Signed c → SigCheckResult pk c
   checkFailed : (sc : Signed c) → verify (signableFields c) (signature c sc) pk ≡ false → SigCheckResult pk c
   sigVerified : WithVerSig pk c → SigCheckResult pk c

 checkFailed≢sigVerified : {C : Set} ⦃ ws : WithSig C ⦄ {pk : PK} {c : C}
                           {wvs : WithVerSig ⦃ ws ⦄ pk c}
                           {sc : Signed c} {v : verify (signableFields c) (signature c sc) pk ≡ false}
                         → checkFailed sc v ≡ sigVerified wvs → ⊥
 checkFailed≢sigVerified ()

 data SigCheckOutcome : Set where
   notSigned   : SigCheckOutcome
   checkFailed : SigCheckOutcome
   sigVerified : SigCheckOutcome

 data SigCheckFailed : Set where
   notSigned   : SigCheckFailed
   checkFailed : SigCheckFailed

 check-signature : {C : Set} ⦃ ws : WithSig C ⦄ → (pk : PK) → (c : C) → SigCheckResult pk c
 check-signature pk c with isSigned? c
 ...| no  ns  = notSigned ns
 ...| yes sc with verify (signableFields c) (signature c sc) pk
                | inspect (verify (signableFields c) (signature c sc)) pk
 ...| false | [ nv ] = checkFailed sc nv
 ...| true  | [ v  ] = sigVerified (record { isSigned  = sc
                                           ; verified  = v })

 sigCheckOutcomeFor : {C : Set} ⦃ ws : WithSig C ⦄ (pk : PK) (c : C) → SigCheckOutcome
 sigCheckOutcomeFor pk c with check-signature pk c
 ...| notSigned _     = notSigned
 ...| checkFailed _ _ = checkFailed
 ...| sigVerified _   = sigVerified

 sigVerifiedVerSigCS : {C : Set} ⦃ ws : WithSig C ⦄ {pk : PK} {c : C}
                     → sigCheckOutcomeFor pk c ≡ sigVerified
                     → ∃[ wvs ] (check-signature ⦃ ws ⦄ pk c ≡ sigVerified wvs)
 sigVerifiedVerSigCS {pk = pk} {c = c} prf
    with  check-signature pk  c | inspect
         (check-signature pk) c
 ...| sigVerified verSig | [ R ] rewrite R =  verSig , refl

 sigVerifiedVerSig : {C : Set} ⦃ ws : WithSig C ⦄ {pk : PK} {c : C}
                   → sigCheckOutcomeFor pk c ≡ sigVerified
                   → WithVerSig pk c
 sigVerifiedVerSig = proj₁ ∘ sigVerifiedVerSigCS

 sigVerifiedSCO : {C : Set} ⦃ ws : WithSig C ⦄ {pk : PK} {c : C}
                   → (wvs : WithVerSig pk c)
                   → sigCheckOutcomeFor pk c ≡ sigVerified
 sigVerifiedSCO {pk = pk} {c = c} wvs
   with check-signature pk c
 ...| notSigned  ns      = ⊥-elim (ns (isSigned wvs))
 ...| checkFailed xx xxs rewrite Signed-pi c xx (isSigned wvs) = ⊥-elim (false≢true (trans (sym xxs) (verified wvs)))
 ...| sigVerified wvs' = refl

 failedSigCheckOutcome : {C : Set} ⦃ ws : WithSig C ⦄ (pk : PK) (c : C)
                       → sigCheckOutcomeFor pk c ≢ sigVerified
                       → SigCheckFailed
 failedSigCheckOutcome pk c prf with sigCheckOutcomeFor pk c
 ...| notSigned   = notSigned
 ...| checkFailed = checkFailed
 ...| sigVerified = ⊥-elim (prf refl)


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

module Light.Subtyping where

open import Light.Level using (_⊔_ ; ++_)
open import Light.Variable.Levels
open import Light.Variable.Sets

record DirectSubtyping (𝕒 : Set aℓ) (𝕓 : Set bℓ) : Set (aℓ ⊔ bℓ) where
      constructor #_
      field cast₁ : 𝕒 → 𝕓
open DirectSubtyping ⦃ ... ⦄ public

record StrictSubtyping (𝕒 : Set aℓ) (𝕓 : Set aℓ) : Set (++ aℓ)
data Subtyping {aℓ} : ∀ (𝕒 : Set aℓ) (𝕓 : Set aℓ) → Set (++ aℓ)

record StrictSubtyping {aℓ} 𝕒 𝕓 where
      inductive
      instance constructor transitivity′
      field {Thing} : Set aℓ
      field ⦃ direct ⦄ : DirectSubtyping 𝕒 Thing
      field ⦃ indirect ⦄ : Subtyping Thing 𝕓

data Subtyping where
      instance reflexivity : Subtyping 𝕒 𝕒
      instance from‐strict : ∀ ⦃ strict : StrictSubtyping 𝕒 𝕓 ⦄ → Subtyping 𝕒 𝕓

cast : ∀ ⦃ subtyping : Subtyping 𝕒 𝕓 ⦄ → 𝕒 → 𝕓
cast ⦃ subtyping = reflexivity ⦄ a = a
cast ⦃ subtyping = from‐strict ⦄ a = cast (cast₁ a)

-- Note: These cannot be instances, they must be written explicitly.
transitivity′′ : ∀ ⦃ a‐to‐b : Subtyping 𝕒 𝕓 ⦄ ⦃ b‐to‐c : Subtyping 𝕓 𝕔 ⦄ → DirectSubtyping 𝕒 𝕔
transitivity′′ ⦃ a‐to‐b = a‐to‐b ⦄ ⦃ b‐to‐c = b‐to‐c ⦄ = # λ a → cast ⦃ subtyping = b‐to‐c ⦄ (cast ⦃ subtyping = a‐to‐b ⦄ a)
transitivity : ∀ ⦃ a‐to‐b : Subtyping 𝕒 𝕓 ⦄ ⦃ b‐to‐c : Subtyping 𝕓 𝕔 ⦄ → Subtyping 𝕒 𝕔
transitivity ⦃ a‐to‐b = a‐to‐b ⦄ ⦃ b‐to‐c = b‐to‐c ⦄ = from‐strict where instance _ = transitivity′′ ⦃ a‐to‐b = a‐to‐b ⦄ ⦃ b‐to‐c = b‐to‐c ⦄

module _ ⦃ c‐to‐a : Subtyping 𝕔 𝕒 ⦄ ⦃ b‐to‐d : Subtyping 𝕓 𝕕 ⦄ where
      instance
            explicit‐variance : DirectSubtyping (𝕒 → 𝕓) (𝕔 → 𝕕)
            implicit‐variance : DirectSubtyping (∀ {a : 𝕒} → 𝕓) (∀ {c : 𝕔} → 𝕕)
            instance‐variance : DirectSubtyping (∀ ⦃ a : 𝕒 ⦄ → 𝕓) (∀ ⦃ c : 𝕔 ⦄ → 𝕕)
      explicit‐variance = # λ f c → cast ⦃ subtyping = b‐to‐d ⦄ (f (cast c))
      implicit‐variance = # λ f {c = c} → cast ⦃ subtyping = b‐to‐d ⦄ (f {a = cast c})
      instance‐variance = # λ f ⦃ c = c ⦄ → cast ⦃ subtyping = b‐to‐d ⦄ (f ⦃ a = cast c ⦄)


------------------------------------------------------------------------------
-- The types used by the mirror function
------------------------------------------------------------------------------

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

module FOTC.Program.Mirror.Type where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List

------------------------------------------------------------------------------
-- Tree terms.
postulate node : D → D → D

-- The mutually totality predicates

data Forest : D → Set  -- The list of rose trees (called forest).
data Tree   : D → Set  -- The rose tree type.

data Forest where
  fnil  : Forest []
  fcons : ∀ {t ts} → Tree t → Forest ts → Forest (t ∷ ts)
{-# ATP axioms fnil fcons #-}

data Tree where
  tree : ∀ d {ts} → Forest ts → Tree (node d ts)
{-# ATP axiom tree #-}

------------------------------------------------------------------------------
-- Mutual induction for Tree and Forest

-- Adapted from the mutual induction principles generate from Coq
-- 8.4pl4 using the command (see Coq'Art p. 401).
--
-- Scheme Tree_mutual_ind :=
--   Minimality for Tree Sort Prop
-- with Forest_mutual_ind :=
--   Minimality for Forest Sort Prop.

Tree-mutual-ind :
  {A B : D → Set} →
  (∀ d {ts} → Forest ts → B ts → A (node d ts)) →
  B [] →
  (∀ {t ts} → Tree t → A t → Forest ts → B ts → B (t ∷ ts)) →
  ∀ {t} → Tree t → A t

Forest-mutual-ind :
  {A B : D → Set} →
  (∀ d {ts} → Forest ts → B ts → A (node d ts)) →
  B [] →
  (∀ {t ts} → Tree t → A t → Forest ts → B ts → B (t ∷ ts)) →
  ∀ {ts} → Forest ts → B ts

Tree-mutual-ind hA B[] _ (tree d fnil) = hA d fnil B[]
Tree-mutual-ind hA B[] hB (tree d (fcons Tt Fts)) =
  hA d (fcons Tt Fts) (hB Tt (Tree-mutual-ind hA B[] hB Tt)
                          Fts (Forest-mutual-ind hA B[] hB Fts))

Forest-mutual-ind _  B[] _ fnil = B[]
Forest-mutual-ind hA B[] hB (fcons Tt Fts) =
  hB Tt (Tree-mutual-ind hA B[] hB Tt) Fts (Forest-mutual-ind hA B[] hB Fts)


-- Categories with objects parameterised by a sort
module SOAS.Sorting {T : Set} where

open import SOAS.Common

import Categories.Category.CartesianClosed.Canonical as Canonical
import Categories.Category.CartesianClosed as CCC
open import Categories.Category.Cocartesian
open import Categories.Category.BicartesianClosed
import Categories.Category.Monoidal as Monoidal
import Categories.Category.Monoidal.Closed as MonClosed
open import Categories.Object.Product
open import Categories.Functor.Bifunctor

-- Add sorting to a set
Sorted : Set₁ → Set₁
Sorted Obj = T → Obj

-- Lift a function on Obj to one on sorted Obj
sorted : {O₁ O₂ : Set₁} → (O₁ → O₂) → Sorted O₁ → Sorted O₂
sorted f 𝒳 τ = f (𝒳 τ)

-- Lift a binary operation on Obj to one on sorted Obj
sorted₂ : {O₁ O₂ O₃ : Set₁} → (O₁ → O₂ → O₃)
                            → Sorted O₁ → Sorted O₂ → Sorted O₃
sorted₂ op 𝒳 𝒴 τ = op (𝒳 τ) (𝒴 τ)

sortedᵣ : {O₁ O₂ O₃ : Set₁} → (O₁ → O₂ → O₃)
                            → O₁ → Sorted O₂ → Sorted O₃
sortedᵣ op X 𝒴 τ = op X (𝒴 τ)

sortedₗ : {O₁ O₂ O₃ : Set₁} → (O₁ → O₂ → O₃)
                           → Sorted O₁ → O₂ → Sorted O₃
sortedₗ op 𝒳 Y τ = op (𝒳 τ) Y

-- Turn a category into a sorted category
𝕊orted : Category 1ℓ 0ℓ 0ℓ → Category 1ℓ 0ℓ 0ℓ
𝕊orted Cat = categoryHelper (record
  { Obj = Sorted Obj
  ; _⇒_ = λ A B → ∀{τ : T} → A τ ⇒ B τ
  ; _≈_ = λ f g → ∀{α : T} → f {α} ≈ g {α}
  ; id = id Cat
  ; _∘_ = λ g f → Category._∘_ Cat g f
  ; assoc = assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; equiv = record { refl = E.refl equiv ; sym = λ p → E.sym equiv p
                   ; trans = λ p q → E.trans equiv p q }
  ; ∘-resp-≈ = λ p q → ∘-resp-≈ p q
  })
  where
  open Category Cat
  open import Relation.Binary.Structures renaming (IsEquivalence to E)

-- Lift functors to functors between sorted categories
𝕊orted-Functor : {ℂ 𝔻 : Category 1ℓ 0ℓ 0ℓ} → Functor ℂ 𝔻 → Functor (𝕊orted ℂ) (𝕊orted 𝔻)
𝕊orted-Functor F = record
  { F₀ = λ X τ → Functor.₀ F (X τ)
  ; F₁ = λ f → Functor.₁ F f
  ; identity = Functor.identity F
  ; homomorphism = Functor.homomorphism F
  ; F-resp-≈ = λ z → Functor.F-resp-≈ F z
  }

-- Lift bifunctors to bifunctors between sorted categories
𝕊orted-Bifunctor : {ℂ 𝔻 𝔼 : Category 1ℓ 0ℓ 0ℓ} → Bifunctor ℂ 𝔻 𝔼 → Bifunctor (𝕊orted ℂ) (𝕊orted 𝔻) (𝕊orted 𝔼)
𝕊orted-Bifunctor F = record
  { F₀ = λ{ (X , Y) τ → Functor.₀ F (X τ , Y τ)}
  ; F₁ = λ{ (f , g) → Functor.₁ F (f , g)}
  ; identity = Functor.identity F
  ; homomorphism = Functor.homomorphism F
  ; F-resp-≈ = λ{ (p , q) → Functor.F-resp-≈ F (p , q)}
  }

private
  variable C : Category 1ℓ 0ℓ 0ℓ

-- A sorted CCC is itself a CCC
𝕊orted-CanCCC : Canonical.CartesianClosed C
              → Canonical.CartesianClosed (𝕊orted C)
𝕊orted-CanCCC CCC = record
  { ⊤ = λ τ → 𝓒.terminal.⊤
  ; _×_ = λ A B τ → (A τ) 𝓒.× (B τ)
  ; ! = 𝓒.terminal.!
  ; π₁ = 𝓒.π₁
  ; π₂ = 𝓒.π₂
  ; ⟨_,_⟩ = λ f g → 𝓒.⟨ f , g ⟩
  ; !-unique = λ f → 𝓒.terminal.!-unique f
  ; π₁-comp = 𝓒.π₁-comp
  ; π₂-comp = 𝓒.π₂-comp
  ; ⟨,⟩-unique = λ p₁ p₂ → 𝓒.⟨,⟩-unique p₁ p₂
  ; _^_ = λ B A τ → B τ 𝓒.^ A τ
  ; eval = 𝓒.eval
  ; curry = λ f → 𝓒.curry f
  ; eval-comp = 𝓒.eval-comp
  ; curry-resp-≈ = λ p → 𝓒.curry-resp-≈ p
  ; curry-unique = λ p → 𝓒.curry-unique p
  } where private module 𝓒 = Canonical.CartesianClosed CCC

-- A sorted co-Cartesian category is co-Cartesian
𝕊orted-Cocartesian : Cocartesian C
                   → Cocartesian (𝕊orted C)
𝕊orted-Cocartesian Cocart = record
  { initial = record
    { ⊥ = λ τ → 𝓒.⊥ ; ⊥-is-initial = record
      { ! = 𝓒.initial.! ; !-unique = λ f → 𝓒.initial.!-unique f } }
  ; coproducts = record { coproduct = λ {A}{B} → record
    { A+B = λ τ → 𝓒.coproduct.A+B {A τ}{B τ}
    ; i₁ = 𝓒.i₁
    ; i₂ = 𝓒.i₂
    ; [_,_] = λ f g → 𝓒.[ f , g ]
    ; inject₁ = 𝓒.inject₁
    ; inject₂ = 𝓒.inject₂
    ; unique = λ p₁ p₂ → 𝓒.coproduct.unique p₁ p₂
    } }
  } where private module 𝓒 = Cocartesian Cocart

-- A sorted bi-Cartesian closed category is itself bi-Cartesian closed
𝕊orted-BCCC : BicartesianClosed C
            → BicartesianClosed (𝕊orted C)
𝕊orted-BCCC BCCC = record
  { cartesianClosed = fromCanonical _ (𝕊orted-CanCCC (toCanonical _ cartesianClosed))
  ; cocartesian = 𝕊orted-Cocartesian cocartesian
  }
  where
  open BicartesianClosed BCCC
  open Canonical.Equivalence

-- A sorted monoidal category is itself monoidal
𝕊orted-Monoidal : Monoidal.Monoidal C
                → Monoidal.Monoidal (𝕊orted C)
𝕊orted-Monoidal {C} Mon = record
  { ⊗ = record
    { F₀ = λ{ (X , Y) τ → X τ 𝓒.⊗₀ Y τ }
    ; F₁ = λ{ (f , g) → f 𝓒.⊗₁ g}
    ; identity = Functor.identity 𝓒.⊗
    ; homomorphism = Functor.homomorphism 𝓒.⊗
    ; F-resp-≈ = λ{ (p₁ , p₂) {α} → Functor.F-resp-≈ 𝓒.⊗ (p₁ , p₂) }
    }
  ; unit = λ τ → 𝓒.unit
  ; unitorˡ = record { from = λ {τ} → 𝓒.unitorˡ.from ; to = 𝓒.unitorˡ.to
                     ; iso = record { isoˡ = Iso.isoˡ 𝓒.unitorˡ.iso ; isoʳ = Iso.isoʳ 𝓒.unitorˡ.iso } }
  ; unitorʳ = record { from = λ {τ} → 𝓒.unitorʳ.from ; to = 𝓒.unitorʳ.to
                     ; iso = record { isoˡ = Iso.isoˡ 𝓒.unitorʳ.iso ; isoʳ = Iso.isoʳ 𝓒.unitorʳ.iso } }
  ; associator = record { from = λ {τ} → 𝓒.associator.from ; to = 𝓒.associator.to
                        ; iso = record { isoˡ = Iso.isoˡ 𝓒.associator.iso ; isoʳ = Iso.isoʳ 𝓒.associator.iso } }
  ; unitorˡ-commute-from = 𝓒.unitorˡ-commute-from
  ; unitorˡ-commute-to = 𝓒.unitorˡ-commute-to
  ; unitorʳ-commute-from = 𝓒.unitorʳ-commute-from
  ; unitorʳ-commute-to = 𝓒.unitorʳ-commute-to
  ; assoc-commute-from = 𝓒.assoc-commute-from
  ; assoc-commute-to = 𝓒.assoc-commute-to
  ; triangle = 𝓒.triangle
  ; pentagon = 𝓒.pentagon
  }
  where
  private module 𝓒 = Monoidal.Monoidal Mon
  open import Categories.Morphism C

-- A sorted monoidal closed category is itself monoidal closed
𝕊orted-MonClosed : {Mon : Monoidal.Monoidal C}
                 → MonClosed.Closed Mon
                 → MonClosed.Closed (𝕊orted-Monoidal Mon)
𝕊orted-MonClosed {Mon} Cl = record
  { [-,-] = record
    { F₀ = λ (X , Y) τ → 𝓒.[ X τ , Y τ ]₀
    ; F₁ = λ (f , g) → 𝓒.[ f , g ]₁
    ; identity = λ {A} {α} → Functor.identity 𝓒.[-,-]
    ; homomorphism = Functor.homomorphism 𝓒.[-,-]
    ; F-resp-≈ = λ{ (p₁ , p₂) {α} → Functor.F-resp-≈ 𝓒.[-,-] (p₁ , p₂) }
    }
  ; adjoint = record
    { unit = ntHelper record
      { η = λ X {τ} → NT.η 𝓒.adjoint.unit (X τ)
      ; commute = λ f → NT.commute 𝓒.adjoint.unit f
      }
    ; counit = ntHelper record
      { η = λ X {τ} → NT.η 𝓒.adjoint.counit (X τ)
      ; commute = λ f → NT.commute 𝓒.adjoint.counit f
      }
    ; zig = 𝓒.adjoint.zig
    ; zag = 𝓒.adjoint.zag
    }
  ; mate = λ f → record { commute₁ = 𝓒.mate.commute₁ f ; commute₂ = 𝓒.mate.commute₂ f }
  } where private module 𝓒 = MonClosed.Closed Cl


module Structure.Logic.Constructive.Proofs where

open import Functional as Fn
open import Lang.Instance
open import Logic.Propositional as Logic using (_←_ ; _↔_)
open import Logic.Predicate     as Logic hiding (∀ₗ)
import      Lvl
import      Structure.Logic.Constructive.BoundedPredicate
import      Structure.Logic.Constructive.Predicate
import      Structure.Logic.Constructive.Propositional
open import Syntax.Function
open import Type

private variable ℓ ℓₗ ℓₘₗ ℓₒ ℓₚ : Lvl.Level
private variable Formula : Type{ℓₗ}
private variable Proof : Formula → Type{ℓₘₗ}
private variable Predicate : Type{ℓₚ}
private variable Domain : Type{ℓₒ}

module _ (Proof : Formula → Type{ℓₘₗ}) where
  open Structure.Logic.Constructive.Propositional(Proof)
  private variable X Y Z : Formula

  {-
  module _ ⦃ logic : ConstructiveLogic ⦄ where
    [⟵][⟶][∧]-[⟷]-equivalence : Proof(X ⟷ Y) ↔ (Proof(X ⟵ Y) Logic.∧ Proof(X ⟶ Y))
    [⟵][⟶][∧]-[⟷]-equivalence {X} {Y} = Logic.[↔]-intro
      (p ↦ ⟷.intro (⟵.elim(Logic.[∧]-elimₗ p)) (⟶.elim(Logic.[∧]-elimᵣ p)))
      (p ↦ Logic.[∧]-intro (⟵.intro (⟷.elimₗ p)) (⟶.intro (⟷.elimᵣ p)))
  -}

  [⟶]-redundancyₗ : ⦃ impl : ∃(Implication) ⦄ → Proof(X ⟶ (X ⟶ Y)) → Proof(X ⟶ Y)
  [⟶]-redundancyₗ = ⟶.intro ∘ swap apply₂ ∘ (⟶.elim ∘₂ ⟶.elim)

  [⟷]-reflexivity : ∀{_⟷_} → ⦃ Equivalence(_⟷_) ⦄ → Proof(X ⟷ X)
  [⟷]-reflexivity = ⟷.intro id id

  [⟵]-to-[⟶] : ⦃ con : ∃(Consequence) ⦄ → ∃(Implication)
  ∃.witness [⟵]-to-[⟶] = swap(_⟵_)
  Implication.intro (∃.proof [⟵]-to-[⟶]) = ⟵.intro
  Implication.elim  (∃.proof [⟵]-to-[⟶]) = ⟵.elim

  [⟶]-to-[⟵] : ⦃ impl : ∃(Implication) ⦄ → ∃(Consequence)
  ∃.witness [⟶]-to-[⟵] = swap(_⟶_)
  Consequence.intro (∃.proof [⟶]-to-[⟵]) = ⟶.intro
  Consequence.elim  (∃.proof [⟶]-to-[⟵]) = ⟶.elim

  [⟵][⟶][∧]-to-[⟷] : ⦃ con : ∃(Consequence) ⦄ → ⦃ impl : ∃(Implication) ⦄ → ⦃ or : ∃(Conjunction) ⦄ → ∃(Equivalence)
  ∃.witness [⟵][⟶][∧]-to-[⟷] X Y = (X ⟵ Y) ∧ (X ⟶ Y)
  Equivalence.intro (∃.proof [⟵][⟶][∧]-to-[⟷]) yx xy = ∧.intro (⟵.intro yx) (⟶.intro xy)
  Equivalence.elimₗ (∃.proof [⟵][⟶][∧]-to-[⟷])       = ⟵.elim ∘ ∧.elimₗ
  Equivalence.elimᵣ (∃.proof [⟵][⟶][∧]-to-[⟷])       = ⟶.elim ∘ ∧.elimᵣ

  [⟶][⟷]-to-[∧] : ⦃ impl : ∃(Implication) ⦄ → ⦃ eq : ∃(Equivalence) ⦄ → ∃(Conjunction)
  ∃.witness [⟶][⟷]-to-[∧] X Y = (X ⟶ Y) ⟷ X
  Conjunction.intro (∃.proof [⟶][⟷]-to-[∧]) x y = ⟷.intro (const(⟶.intro(const y))) (const x)
  Conjunction.elimₗ (∃.proof [⟶][⟷]-to-[∧]) xyx = ⟷.elimᵣ xyx (⟶.intro(swap apply₂(⟶.elim ∘ ⟷.elimₗ xyx)))
  Conjunction.elimᵣ (∃.proof [⟶][⟷]-to-[∧]) xyx = apply₂(⟷.elimᵣ xyx (⟶.intro(swap apply₂ (⟶.elim ∘ ⟷.elimₗ xyx)))) (⟶.elim ∘ (⟷.elimₗ xyx))

  [∨][⟷]-to-[⟶] : ⦃ or : ∃(Disjunction) ⦄ → ⦃ eq : ∃(Equivalence) ⦄ → ∃(Implication)
  ∃.witness [∨][⟷]-to-[⟶] X Y = (X ∨ Y) ⟷ Y
  Implication.intro (∃.proof [∨][⟷]-to-[⟶])       = ⟷.intro ∨.introᵣ ∘ swap ∨.elim id
  Implication.elim  (∃.proof [∨][⟷]-to-[⟶]) xyy x = ⟷.elimᵣ xyy (∨.introₗ x)

  [∧][⟷]-to-[⟶] : ⦃ and : ∃(Conjunction) ⦄ → ⦃ eq : ∃(Equivalence) ⦄ → ∃(Implication)
  ∃.witness [∧][⟷]-to-[⟶] X Y = (X ∧ Y) ⟷ X
  Implication.intro (∃.proof [∧][⟷]-to-[⟶]) xy    = ⟷.intro (x ↦ ∧.intro x (xy x)) ∧.elimₗ
  Implication.elim  (∃.proof [∧][⟷]-to-[⟶]) xyx x = ∧.elimᵣ(⟷.elimₗ xyx x)

  [¬][⊤]-to-[⊥] : ⦃ neg : ∃(Negation) ⦄ → ⦃ top : ∃(Top) ⦄ → ∃(Bottom)
  ∃.witness [¬][⊤]-to-[⊥] = ¬ ⊤
  Bottom.elim (∃.proof [¬][⊤]-to-[⊥]) = ¬.elim ⊤.intro

  [¬][⊥]-to-[⊤] : ⦃ neg : ∃(Negation) ⦄ → ⦃ bot : ∃(Bottom) ⦄ → ∃(Top)
  ∃.witness [¬][⊥]-to-[⊤] = ¬ ⊥
  Top.intro (∃.proof [¬][⊥]-to-[⊤]) = ¬.intro{Y = ⊥} ⊥.elim ⊥.elim

  [⟷]-to-[⊤] : Formula → ⦃ eq : ∃(Equivalence) ⦄ → ∃(Top)
  ∃.witness ([⟷]-to-[⊤] φ) = φ ⟷ φ
  Top.intro (∃.proof ([⟷]-to-[⊤] φ)) = [⟷]-reflexivity

  [⟷][⊥]-to-[¬] : ⦃ eq : ∃(Equivalence) ⦄ → ⦃ bot : ∃(Bottom) ⦄ → ∃(Negation)
  ∃.witness [⟷][⊥]-to-[¬] = _⟷ ⊥
  Negation.intro (∃.proof [⟷][⊥]-to-[¬]) xy xy⊥ = ⟷.intro ⊥.elim ((⟷.elimᵣ ∘ xy⊥) ∘ₛ xy)
  Negation.elim  (∃.proof [⟷][⊥]-to-[¬])        = ⊥.elim ∘₂ swap ⟷.elimᵣ

  [∨][⟷][⊥]-adequacy : ⦃ or : ∃(Disjunction) ⦄ → ⦃ eq : ∃(Equivalence) ⦄ → ⦃ bot : ∃(Bottom) ⦄ → Logic
  Logic.top         [∨][⟷][⊥]-adequacy = [⟷]-to-[⊤] ⊥
  Logic.implication [∨][⟷][⊥]-adequacy = [∨][⟷]-to-[⟶]
  Logic.negation    [∨][⟷][⊥]-adequacy = [⟷][⊥]-to-[¬]
  Logic.conjunction [∨][⟷][⊥]-adequacy = [⟶][⟷]-to-[∧] where instance _ = Logic.implication [∨][⟷][⊥]-adequacy
  Logic.consequence [∨][⟷][⊥]-adequacy = [⟶]-to-[⟵]    where instance _ = Logic.implication [∨][⟷][⊥]-adequacy

module _ (Proof : Formula → Type{ℓₘₗ}) where
  open Structure.Logic.Constructive.Propositional(Proof)
  private variable X Y Z : Formula

  open import Data.Tuple as Tuple using ()

  [⊤]-preserving-type : ⦃ top : ∃(Top) ⦄ → Proof(⊤) ↔ Logic.⊤
  Tuple.left  [⊤]-preserving-type = const ⊤.intro
  Tuple.right [⊤]-preserving-type = const Logic.[⊤]-intro

  [∧]-preserving-type : ⦃ and : ∃(Conjunction) ⦄ → Proof(X ∧ Y) ↔ (Proof(X) Logic.∧ Proof(Y))
  Tuple.left  [∧]-preserving-type (Logic.[∧]-intro x y) = ∧.intro x y
  Tuple.right [∧]-preserving-type xy                    = Logic.[∧]-intro (∧.elimₗ xy) (∧.elimᵣ xy)

  [∨]-preserving-type : ⦃ or : ∃(Disjunction) ⦄ → Proof(X ∨ Y) ← (Proof(X) Logic.∨ Proof(Y))
  [∨]-preserving-type = Logic.[∨]-elim ∨.introₗ ∨.introᵣ

  [⟶]-preserving-type : ⦃ impl : ∃(Implication) ⦄ → Proof(X ⟶ Y) ↔ (Proof(X) → Proof(Y))
  Tuple.left  [⟶]-preserving-type = ⟶.intro
  Tuple.right [⟶]-preserving-type = ⟶.elim

  [⟵]-preserving-type : ⦃ cons : ∃(Consequence) ⦄ → Proof(X ⟵ Y) ↔ (Proof(X) ← Proof(Y))
  Tuple.left  [⟵]-preserving-type = ⟵.intro
  Tuple.right [⟵]-preserving-type = ⟵.elim

  [⟷]-preserving-type : ⦃ eq : ∃(Equivalence) ⦄ → Proof(X ⟷ Y) ↔ (Proof(X) ↔ Proof(Y))
  Tuple.left  [⟷]-preserving-type xy = ⟷.intro (Logic.[↔]-to-[←] xy) (Logic.[↔]-to-[→] xy)
  Tuple.right [⟷]-preserving-type xy = Logic.[↔]-intro (⟷.elimₗ xy) (⟷.elimᵣ xy)

  {-
  module Test ⦃ logic : Logic ⦄ where
    pure : ∀{A : Formula} → Proof(A) → Proof(A)
    pure = id

    _<*>_ : ∀{A B : Formula} → Proof(A ⟶ B) → Proof(A) → Proof(B)
    _<*>_ = ⟶.elim

    test : ∀{A B} → Proof(A ⟶ (A ⟶ B)) → Proof(A) → Proof(B)
    test ab a = ⦇ ab a a ⦈

  module Test2 ⦃ logic : ConstructiveLogic ⦄ {Obj : Type{ℓ}} where
    private variable P : Obj → Formula

    module _ ⦃ all : ∃(Universal) ⦄ where
      pure : ∀{A : Formula} → Proof(A) → Proof(A)
      pure = id

      _<*>_ : ∀{P : Obj → Formula} → Proof(∀ₗ P) → (x : Obj) → Proof(P(x))
      _<*>_ = ∀ₗ.elim

      test : ∀{A : Obj → Obj → Formula} → Proof(∀ₗ(x ↦ ∀ₗ(y ↦ A x y))) → (x : Obj) → Proof(A x x)
      test a x  = ⦇ a x x ⦈
  -}

module _ where
  open import Data
  open import Data.Tuple
  open import Data.Either as Either
  open        Structure.Logic.Constructive.BoundedPredicate renaming (Logic to BoundedPredicateLogic)
  open        Structure.Logic.Constructive.Predicate        renaming (Logic to PredicateLogic)
  open        Structure.Logic.Constructive.Propositional    renaming (Logic to PropositionalLogic)

  instance
    typePropositionalLogic : PropositionalLogic{Formula = Type{ℓ}} id
    PropositionalLogic.bottom      typePropositionalLogic = [∃]-intro Empty     ⦃ record{elim = empty} ⦄
    PropositionalLogic.top         typePropositionalLogic = [∃]-intro Unit      ⦃ record{intro = <>} ⦄
    PropositionalLogic.implication typePropositionalLogic = [∃]-intro _→ᶠ_      ⦃ record{intro = _$_ ; elim = id} ⦄
    PropositionalLogic.conjunction typePropositionalLogic = [∃]-intro _⨯_       ⦃ record{intro = _,_ ; elimₗ = left ; elimᵣ = right} ⦄
    PropositionalLogic.disjunction typePropositionalLogic = [∃]-intro _‖_       ⦃ record{introₗ = Left ; introᵣ = Right ; elim = Either.map1} ⦄
    PropositionalLogic.consequence typePropositionalLogic = [∃]-intro _←ᶠ_      ⦃ record{intro = id ; elim = _$_} ⦄
    PropositionalLogic.equivalence typePropositionalLogic = [∃]-intro Logic._↔_ ⦃ record{intro = _,_ ; elimₗ = left ; elimᵣ = right} ⦄
    PropositionalLogic.negation    typePropositionalLogic = [∃]-intro Logic.¬_  ⦃ record{intro = Fn.swap(_∘ₛ_) ; elim = empty ∘₂ apply} ⦄

  instance
    typePredicateLogic : ∀{T : Type{ℓₒ}} → PredicateLogic{Formula = Type{ℓₒ Lvl.⊔ ℓₗ}} id {Predicate = T → Type{ℓₒ Lvl.⊔ ℓₗ}} {Domain = T} id
    PredicateLogic.universal   typePredicateLogic = [∃]-intro Logic.∀ₗ ⦃ record{intro = id ; elim = id} ⦄
    PredicateLogic.existential typePredicateLogic = [∃]-intro Logic.∃  ⦃ record{intro = \{_}{x} p → Logic.[∃]-intro x ⦃ p ⦄ ; elim = Logic.[∃]-elim} ⦄

  open import Type.Dependent

  instance
    typeBoundedPredicateLogic : ∀{T : Type{ℓₒ}} → BoundedPredicateLogic{Formula = Type{ℓₒ Lvl.⊔ ℓₗ}} id {Predicate = (x : T) → ∀{B : T → Type{ℓₒ Lvl.⊔ ℓₗ}} → B(x) → Type{ℓₒ Lvl.⊔ ℓₗ}} {Domain = T} id
    BoundedPredicateLogic.universal   typeBoundedPredicateLogic = [∃]-intro (\B P → ∀{x} → (bx : B(x)) → P(x){B}(bx)) ⦃ record{intro = \p bx → p bx ; elim = \p bx → p bx} ⦄
    BoundedPredicateLogic.existential typeBoundedPredicateLogic = [∃]-intro (\B P → Logic.∃(x ↦ Σ(B(x)) (P(x){B}))) ⦃ record{intro = \{_}{x} bx p → Logic.[∃]-intro x ⦃ intro bx p ⦄ ; elim = \p → Logic.[∃]-elim (\(intro bx px) → p bx px)} ⦄

  {- TODO: Maybe have some more assumptions
  boundedPredicateLogic-to-predicateLogic : ∀{Formula Domain Predicate : Type{ℓₒ}}{Proof : Formula → Type}{_$_} → BoundedPredicateLogic{Formula = Formula} Proof {Predicate = Predicate} {Domain = Domain} (_$_) → PredicateLogic{Formula = Formula} Proof {Predicate = (Domain → Formula) ⨯ Predicate} {Domain = Σ(Predicate ⨯ Domain) (\(P , x) → Proof((P $ x) {{!!}} {!!}))} {!!}
  PredicateLogic.propositional (boundedPredicateLogic-to-predicateLogic L) = BoundedPredicateLogic.propositional L
  ∃.witness (PredicateLogic.universal (boundedPredicateLogic-to-predicateLogic L)) (B , P) = ∃.witness (BoundedPredicateLogic.universal L) B P
  Universal.intro (∃.proof (PredicateLogic.universal (boundedPredicateLogic-to-predicateLogic L))) {B , P} p = BoundedUniversal.intro
                                                                                (∃.proof (BoundedPredicateLogic.universal L)) (\{x} pp → p{intro (P , x) {!!}})
  Universal.elim (∃.proof (PredicateLogic.universal (boundedPredicateLogic-to-predicateLogic L))) = {!!}
  ∃.witness (PredicateLogic.existential (boundedPredicateLogic-to-predicateLogic L)) (B , P) = ∃.witness (BoundedPredicateLogic.existential L) B P
  Existential.intro (∃.proof (PredicateLogic.existential (boundedPredicateLogic-to-predicateLogic L))) = {!!}
  Existential.elim (∃.proof (PredicateLogic.existential (boundedPredicateLogic-to-predicateLogic L))) = {!!}
  -}

  {- TODO: Seems to need a duplicate (Domain → Formula) in Predicate. Also, does not work with this generality
  boundedPredicateLogic-to-predicateLogic : ∀{_$_} → BoundedPredicateLogic{Formula = Formula} Proof {Predicate = Predicate} {Domain = Domain} (_$_) → PredicateLogic{Formula = Formula} Proof {Predicate = Predicate} {Domain = Σ((Domain → Formula) ⨯ Domain) (\(B , x) → Proof(B(x)))} (\P (intro(B , x) bx) → (P $ x) {B} bx)
  PredicateLogic.propositional (boundedPredicateLogic-to-predicateLogic L) = BoundedPredicateLogic.propositional L
  PredicateLogic.universal (boundedPredicateLogic-to-predicateLogic L) = [∃]-intro {!!} ⦃ record{intro = {!!} ; elim = {!!}} ⦄
  PredicateLogic.existential (boundedPredicateLogic-to-predicateLogic L) = [∃]-intro {!!} ⦃ record{intro = {!!} ; elim = {!!}} ⦄
  -}

  {-instance
    typeBoundedPredicateLogic : ∀{T : Type{ℓₒ}}{B : T → Type{ℓ}} → PredicateLogic{Formula = Type{ℓₒ Lvl.⊔ ℓₗ Lvl.⊔ ℓ}} id {Predicate = (x : T) → ⦃ B(x) ⦄ → Type{ℓₒ Lvl.⊔ ℓₗ Lvl.⊔ ℓ}} {Domain = Σ T B} (\f (intro x b) → f x ⦃ b ⦄)
    PredicateLogic.universal   (typeBoundedPredicateLogic {B = B}) = [∃]-intro (f ↦ (∀{x} ⦃ bx ⦄ → f(x) ⦃ bx ⦄)) ⦃ record{intro = \px → px ; elim = \{P} px {x} → px{Σ.left x} ⦃ Σ.right x ⦄} ⦄
    PredicateLogic.existential (typeBoundedPredicateLogic {B = B}) = [∃]-intro (f ↦ Logic.∃(x ↦ Σ(B(x)) (bx ↦ f x ⦃ bx ⦄)) ) ⦃ record{intro = {!!} ; elim = {!!}} ⦄
  -}

  import      Logic.Classical.DoubleNegated as DoubleNegated
  open import Logic.Names
  import      Logic.Propositional.Theorems as Logic
  instance
    doubleNegatedTypeLogic : PropositionalLogic{ℓₘₗ = Lvl.𝟎}(Logic.¬¬_)
    PropositionalLogic.bottom      doubleNegatedTypeLogic = Logic.[∃]-intro Logic.⊥     ⦃ record{elim = DoubleNegated.[⊥]-elim} ⦄
    PropositionalLogic.top         doubleNegatedTypeLogic = Logic.[∃]-intro Logic.⊤     ⦃ record{intro = DoubleNegated.[⊤]-intro} ⦄
    PropositionalLogic.implication doubleNegatedTypeLogic = Logic.[∃]-intro (_→ᶠ_)      ⦃ record{intro = DoubleNegated.[→]-intro ; elim = DoubleNegated.[→]-elim} ⦄
    PropositionalLogic.conjunction doubleNegatedTypeLogic = Logic.[∃]-intro (Logic._∧_) ⦃ record{intro = DoubleNegated.[∧]-intro ; elimₗ = DoubleNegated.[∧]-elimₗ ; elimᵣ = DoubleNegated.[∧]-elimᵣ} ⦄
    PropositionalLogic.disjunction doubleNegatedTypeLogic = Logic.[∃]-intro (Logic._∨_) ⦃ record{introₗ = DoubleNegated.[∨]-introₗ ; introᵣ = DoubleNegated.[∨]-introᵣ ; elim = DoubleNegated.[∨]-elim} ⦄
    PropositionalLogic.consequence doubleNegatedTypeLogic = Logic.[∃]-intro (Logic._←_) ⦃ record{intro = DoubleNegated.[←]-intro ; elim = DoubleNegated.[→]-elim} ⦄
    PropositionalLogic.equivalence doubleNegatedTypeLogic = Logic.[∃]-intro (Logic._↔_) ⦃ record{intro = DoubleNegated.[↔]-intro ; elimₗ = DoubleNegated.[↔]-elimₗ ; elimᵣ = DoubleNegated.[↔]-elimᵣ} ⦄
    PropositionalLogic.negation    doubleNegatedTypeLogic = Logic.[∃]-intro (Logic.¬_)  ⦃ record{intro = Fn.swap(_∘ₛ_) ; elim = const ∘₂ apply} ⦄

  open import Data.Boolean
  import      Data.Boolean.Operators
  open        Data.Boolean.Operators.Programming
  open import Data.Boolean.Stmt
  open import Data.Boolean.Stmt.Proofs
  instance
    booleanLogic : PropositionalLogic IsTrue
    PropositionalLogic.bottom      booleanLogic = [∃]-intro 𝐹    ⦃ record{elim = Logic.[⊥]-elim ∘ IsTrue.[𝐹]-elim} ⦄
    PropositionalLogic.top         booleanLogic = [∃]-intro 𝑇    ⦃ record{intro = IsTrue.[𝑇]-intro} ⦄
    PropositionalLogic.conjunction booleanLogic = [∃]-intro _&&_ ⦃ record{intro = IsTrue.[∧]-intro ; elimₗ = IsTrue.[∧]-elimₗ ; elimᵣ = IsTrue.[∧]-elimᵣ} ⦄
    PropositionalLogic.disjunction booleanLogic = [∃]-intro _||_ ⦃ record{introₗ = IsTrue.[∨]-introₗ ; introᵣ = IsTrue.[∨]-introᵣ ; elim = IsTrue.[∨]-elim} ⦄
    PropositionalLogic.negation    booleanLogic = [∃]-intro !    ⦃ record{intro = IsTrue.[!]-intro ; elim = IsTrue.[!]-elim} ⦄
    PropositionalLogic.implication booleanLogic = [∃]-intro _→?_ ⦃ record{intro = IsTrue.[→?]-intro ; elim = IsTrue.[→?]-elim} ⦄
    PropositionalLogic.consequence booleanLogic = [∃]-intro _←?_ ⦃ record{intro = IsTrue.[←?]-intro ; elim = IsTrue.[←?]-elim} ⦄
    PropositionalLogic.equivalence booleanLogic = [∃]-intro _==_ ⦃ record{intro = IsTrue.[==]-intro ; elimₗ = IsTrue.[==]-elimₗ ; elimᵣ = IsTrue.[==]-elimᵣ} ⦄

  booleanPredicateLogic : ∀{T : Type{ℓ}}{all exist : (T → Bool) → Bool} → (∀{P} → (∀{x} → IsTrue(P(x))) ↔ IsTrue(all P)) → (∀{P} → (Logic.∃(x ↦ IsTrue(P(x)))) ↔ IsTrue(exist P)) → PredicateLogic IsTrue {Domain = T} id
  PredicateLogic.universal   (booleanPredicateLogic {all = all} {exist = exist} all-eq exist-eq) = [∃]-intro all   ⦃ record{intro = Logic.[↔]-to-[→] all-eq ; elim = Logic.[↔]-to-[←] all-eq} ⦄
  PredicateLogic.existential (booleanPredicateLogic {all = all} {exist = exist} all-eq exist-eq) = [∃]-intro exist ⦃ record{intro = Logic.[↔]-to-[→] exist-eq ∘ (p ↦ [∃]-intro _ ⦃ p ⦄) ; elim = p ↦ ep ↦ p(Logic.[∃]-proof(Logic.[↔]-to-[←] exist-eq ep))} ⦄


------------------------------------------------------------------------
-- A counterexample: The trace of stack sizes produced by the virtual
-- machine is not necessarily bisimilar to that produced by the
-- instrumented interpreter
------------------------------------------------------------------------

module Lambda.Interpreter.Stack-sizes.Counterexample where

open import Equality.Propositional as E using (_≡_)
open import Prelude
open import Prelude.Size

open import Colist E.equality-with-J
open import Function-universe E.equality-with-J
open import Vec.Data E.equality-with-J

import Lambda.Compiler
import Lambda.Interpreter.Stack-sizes
import Lambda.Virtual-machine
import Lambda.Virtual-machine.Instructions

-- This module uses a name type with two inhabitants.

open import Lambda.Syntax Bool

open Closure Tm

-- Two unary functions.

def : Bool → Tm 1
def true  = call false (con true)
def false = con true

-- The instrumented interpreter, compiler and virtual machine are
-- instantiated with this definition.

module I = Lambda.Interpreter.Stack-sizes def
open Lambda.Compiler def
open Lambda.Virtual-machine.Instructions Bool
open module VM = Lambda.Virtual-machine comp-name

-- A top-level term to get things going. The important property of
-- this term is that when it is compiled and the resulting code is
-- executed on the virtual machine, then one tail call is made to a
-- function that terminates successfully.

go : Tm 0
go = call true (con true)

-- The trace of stack sizes produced by the virtual machine is not
-- necessarily bisimilar to that produced by the instrumented
-- interpreter.

stack-sizes-not-bisimilar :
  ¬ [ ∞ ] VM.stack-sizes ⟨ comp₀ go , [] , [] ⟩ ∼ I.stack-sizes go
stack-sizes-not-bisimilar =
  [ ∞ ] VM.stack-sizes ⟨ comp₀ go , [] , [] ⟩ ∼ I.stack-sizes go  ↝⟨ take-cong 8 ⟩

  take 8 (VM.stack-sizes ⟨ comp₀ go , [] , [] ⟩) ≡
  take 8 (I.stack-sizes go)                                       ↔⟨⟩

  0 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ 2 ∷ 1 ∷ [] ≡
  0 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ 2 ∷ 2 ∷ 1 ∷ []                              ↝⟨ (λ ()) ⟩□

  ⊥                                                               □


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

open import lib.Base
open import lib.Function
open import lib.PathFunctor
open import lib.PathGroupoid

module lib.path-seq.Concat {i} {A : Type i} where

infixr 80 _∙∙_
_∙∙_ : {a a' a'' : A}
  → a =-= a' → a' =-= a'' → a =-= a''
_∙∙_ [] t = t
_∙∙_ (p ◃∙ s) t = p ◃∙ (s ∙∙ t)

∙∙-assoc : {a a' a'' a''' : A}
  (s : a =-= a') (t : a' =-= a'') (u : a'' =-= a''')
  → (s ∙∙ t) ∙∙ u == s ∙∙ (t ∙∙ u)
∙∙-assoc [] t u = idp
∙∙-assoc (p ◃∙ s) t u = ap (p ◃∙_) (∙∙-assoc s t u)

∙∙-unit-r : {a a' : A} (s : a =-= a')
  → s ∙∙ [] == s
∙∙-unit-r [] = idp
∙∙-unit-r (p ◃∙ s) = ap (p ◃∙_) (∙∙-unit-r s)

infixl 80 _∙▹_
_∙▹_ : {a a' a'' : A}
  → a =-= a' → a' == a'' → a =-= a''
_∙▹_ {a} {a'} {a''} s p = s ∙∙ (p ◃∙ [])

↯-∙∙ : {a a' a'' : A} (s : a =-= a') (t : a' =-= a'')
  → ↯ (s ∙∙ t) == ↯ s ∙ ↯ t
↯-∙∙ [] t = idp
↯-∙∙ (p ◃∙ []) [] = ! (∙-unit-r p)
↯-∙∙ (p ◃∙ []) (p' ◃∙ t) = idp
↯-∙∙ (p ◃∙ s@(_ ◃∙ _)) t =
  ap (λ y → p ∙ y) (↯-∙∙ s t) ∙
  ! (∙-assoc p (↯ s) (↯ t))


{-# OPTIONS --universe-polymorphism #-}

module Issue354 where

------------------------------------------------------------------------
-- Preliminaries

postulate
  Level : Set
  zero : Level
  suc  : (i : Level) → Level
  _⊔_ : Level → Level → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

_≗_ : ∀ {a b} {A : Set a} {B : Set b} (f g : A → B) → Set (a ⊔ b)
f ≗ g = ∀ x → f x ≡ g x

------------------------------------------------------------------------
-- Example

postulate
  a     : Level
  A     : Set a
  P     : A → Set
  x     : A
  f     : ∀ {a} {A : Set a} → A → A
  g     : A → A
  lemma : f ≗ g

p : f x ≡ g x
p with f x | lemma x
... | .(g x) | refl = refl

-- The code above fails to type check, even though lemma x has the
-- type f x ≡ g x. However, if A is given the type Set zero, then the
-- code checks.

-- Excerpt from agda -vtc.with:100 --show-implicit Bug.agda:
--
--   checkWithFunction
--     delta1 =
--     delta2 =
--     gamma  =
--     as     = [A, _≡_ {a} {A} (f {a ⊔ a} {A} x) (g x)]
--     vs     = [f {a} {A} x, lemma x]
--     b      = _≡_ {a} {A} (f {a} {A} x) (g x)
--     qs     = []
--     perm   =  ->
--
-- Notice the occurrence of a ⊔ a.