{-# OPTIONS   --safe  #-}

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped as U
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Reduction

open import Tools.Product
import Tools.PropositionalEquality as PE

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

-- The different cases of the logical relation are spread out through out
-- this file. This is due to them having different dependencies.

-- We will refer to expressions that satisfies the logical relation as reducible.

-- Reducibility of Neutrals:

-- Neutral type
record _⊩ne_^[_,_] (Γ : Con Term) (A : Term) (r : Relevance) (l : Level) : Set where
  constructor ne
  field
    K   : Term
    D   : Γ ⊢ A :⇒*: K ^ [ r , ι l ]
    neK : Neutral K
    K≡K : Γ ⊢ K ~ K ∷ (Univ r l) ^ [ ! , next l ]

-- Neutral type equality
record _⊩ne_≡_^[_,_]/_ (Γ : Con Term) (A B : Term) (r : Relevance) (l : Level) ([A] : Γ ⊩ne A ^[ r , l ]) : Set where
  constructor ne₌
  open _⊩ne_^[_,_] [A]
  field
    M   : Term
    D′  : Γ ⊢ B :⇒*: M ^ [ r , ι l ]
    neM : Neutral M
    K≡M : Γ ⊢ K ~ M ∷ (Univ r l) ^ [ ! , next l ]

-- Neutral term in WHNF
record _⊩neNf_∷_^_ (Γ : Con Term) (k A : Term) (r : TypeInfo) : Set where
  inductive
  constructor neNfₜ
  field
    neK  : Neutral k
    ⊢k   : Γ ⊢ k ∷ A ^ r
    k≡k  : Γ ⊢ k ~ k ∷ A ^ r

-- Neutral relevant term
record _⊩ne_∷_^_/_ (Γ : Con Term) (t A : Term) (l : Level) ([A] : Γ ⊩ne A ^[ ! , l ]) : Set where
  inductive
  constructor neₜ
  open _⊩ne_^[_,_] [A]
  field
    k   : Term
    d   : Γ ⊢ t :⇒*: k ∷ K ^ ι l
    nf  : Γ ⊩neNf k ∷ K ^ [ ! , ι l ]

-- Neutral irrelevant term
record _⊩neIrr_∷_^_/_ (Γ : Con Term) (t A : Term) (l : Level) ([A] : Γ ⊩ne A ^[ % , l ]) : Set where
  inductive
  constructor neₜ
  open _⊩ne_^[_,_] [A]
  field
    d : Γ ⊢ t ∷ A ^ [ % , ι l ]

-- Neutral term equality in WHNF
record _⊩neNf_≡_∷_^_ (Γ : Con Term) (k m A : Term) (r : TypeInfo) : Set where
  inductive
  constructor neNfₜ₌
  field
    neK  : Neutral k
    neM  : Neutral m
    k≡m  : Γ ⊢ k ~ m ∷ A ^ r

-- Neutral relevant term equality
record _⊩ne_≡_∷_^_/_ (Γ : Con Term) (t u A : Term) (l : Level) ([A] : Γ ⊩ne A ^[ ! , l ]) : Set where
  constructor neₜ₌
  open _⊩ne_^[_,_] [A]
  field
    k m : Term
    d   : Γ ⊢ t :⇒*: k ∷ K ^ ι l
    d′  : Γ ⊢ u :⇒*: m ∷ K ^ ι l
    nf  : Γ ⊩neNf k ≡ m ∷ K ^ [ ! , ι l ]

-- Neutral irrelevant term equality
record _⊩neIrr_≡_∷_^_/_ (Γ : Con Term) (t u A : Term) (l : Level) ([A] : Γ ⊩ne A ^[ % , l ]) : Set where
  constructor neₜ₌
  open _⊩ne_^[_,_] [A]
  field
    d   : Γ ⊢ t ∷ A ^ [ % , ι l ]
    d′  : Γ ⊢ u ∷ A ^ [ % , ι l ]

-- Reducibility of natural numbers:

-- Natural number type
_⊩ℕ_ : (Γ : Con Term) (A : Term) → Set
Γ ⊩ℕ A = Γ ⊢ A :⇒*: ℕ ^ [ ! , ι ⁰ ]

-- Natural number type equality
_⊩ℕ_≡_ : (Γ : Con Term) (A B : Term) → Set
Γ ⊩ℕ A ≡ B = Γ ⊢ B ⇒* ℕ ^ [ ! , ι ⁰ ]

mutual
  -- Natural number term
  data _⊩ℕ_∷ℕ (Γ : Con Term) (t : Term) : Set where
    ℕₜ : (n : Term) (d : Γ ⊢ t :⇒*: n ∷ ℕ ^ ι ⁰) (n≡n : Γ ⊢ n ≅ n ∷ ℕ ^ [ ! , ι ⁰ ])
         (prop : Natural-prop Γ n)
       → Γ ⊩ℕ t ∷ℕ

  -- WHNF property of natural number terms
  data Natural-prop (Γ : Con Term) : (n : Term) → Set where
    sucᵣ  : ∀ {n} → Γ ⊩ℕ n ∷ℕ → Natural-prop Γ (suc n)
    zeroᵣ : Natural-prop Γ zero
    ne    : ∀ {n} → Γ ⊩neNf n ∷ ℕ ^ [ ! , ι ⁰ ] → Natural-prop Γ n

mutual
  -- Natural number term equality
  data _⊩ℕ_≡_∷ℕ (Γ : Con Term) (t u : Term) : Set where
    ℕₜ₌ : (k k′ : Term) (d : Γ ⊢ t :⇒*: k  ∷ ℕ ^ ι ⁰) (d′ : Γ ⊢ u :⇒*: k′ ∷ ℕ ^ ι ⁰)
          (k≡k′ : Γ ⊢ k ≅ k′ ∷ ℕ ^ [ ! , ι ⁰ ])
          (prop : [Natural]-prop Γ k k′) → Γ ⊩ℕ t ≡ u ∷ℕ

  -- WHNF property of Natural number term equality
  data [Natural]-prop (Γ : Con Term) : (n n′ : Term) → Set where
    sucᵣ  : ∀ {n n′} → Γ ⊩ℕ n ≡ n′ ∷ℕ → [Natural]-prop Γ (suc n) (suc n′)
    zeroᵣ : [Natural]-prop Γ zero zero
    ne    : ∀ {n n′} → Γ ⊩neNf n ≡ n′ ∷ ℕ ^ [ ! , ι ⁰ ] → [Natural]-prop Γ n n′

-- Natural extraction from term WHNF property
natural : ∀ {Γ n} → Natural-prop Γ n → Natural n
natural (sucᵣ x) = sucₙ
natural zeroᵣ = zeroₙ
natural (ne (neNfₜ neK ⊢k k≡k)) = ne neK

-- Natural extraction from term equality WHNF property
split : ∀ {Γ a b} → [Natural]-prop Γ a b → Natural a × Natural b
split (sucᵣ x) = sucₙ , sucₙ
split zeroᵣ = zeroₙ , zeroₙ
split (ne (neNfₜ₌ neK neM k≡m)) = ne neK , ne neM

-- Reducibility of Empty

-- Empty type
_⊩Empty_^_ : (Γ : Con Term) (A : Term) (l : Level) → Set
Γ ⊩Empty A ^ l = Γ ⊢ A :⇒*: Empty l ^ [ % , ι l ]

-- Empty type equality
_⊩Empty_≡_^_ : (Γ : Con Term) (A B : Term) (l : Level) → Set
Γ ⊩Empty A ≡ B ^ l = Γ ⊢ B ⇒* Empty l ^ [ % , ι l ]

data Empty-prop (Γ : Con Term) (n : Term) (l : Level) : Set where
  ne    : Γ ⊢ n ∷ Empty l ^ [ % , ι l ] → Empty-prop Γ n l

-- -- Empty term

data _⊩Empty_∷Empty^_ (Γ : Con Term) (t : Term) (l : Level) : Set where
  Emptyₜ : (prop : Empty-prop Γ t l) → Γ ⊩Empty t ∷Empty^ l

data [Empty]-prop (Γ : Con Term) : (n n′ : Term)  (l : Level) → Set where
  ne    : ∀ {n n′ l} → Γ ⊢ n ∷ Empty l ^ [ % , ι l ] → Γ ⊢ n′ ∷ Empty l ^ [ % , ι l ]  → [Empty]-prop Γ n n′ l

-- Empty term equality
data _⊩Empty_≡_∷Empty^_ (Γ : Con Term) (t u : Term) (l : Level) : Set where
  Emptyₜ₌ : (prop : [Empty]-prop Γ t u l) → Γ ⊩Empty t ≡ u ∷Empty^ l

-- Logical relation

record LogRelKit : Set₁ where
  constructor Kit
  field
    _⊩U_^_ : (Γ : Con Term) → Term → TypeLevel → Set
    _⊩Π_^[_,_] : (Γ : Con Term) → Term → Relevance → Level → Set
    _⊩∃_^_ : (Γ : Con Term) → Term → Level → Set

    _⊩_^_ : (Γ : Con Term) → Term → TypeInfo → Set
    _⊩_≡_^_/_ : (Γ : Con Term) (A B : Term) (r : TypeInfo) → Γ ⊩ A ^ r → Set
    _⊩_∷_^_/_ : (Γ : Con Term) (t A : Term) (r : TypeInfo) → Γ ⊩ A ^ r → Set
    _⊩_≡_∷_^_/_ : (Γ : Con Term) (t u A : Term) (r : TypeInfo) → Γ ⊩ A ^ r → Set

module LogRel (l : TypeLevel) (rec : ∀ {l′} → l′ <∞ l → LogRelKit) where

  -- Reducibility of Universe:

  -- Universe type
  record _⊩¹U_^_ (Γ : Con Term) (A : Term) (ll : TypeLevel) : Set where
    constructor Uᵣ
    field
      r : Relevance
      l′ : Level
      l< : ι l′ <∞ l
      eq : next l′ PE.≡ ll
      d : Γ ⊢ A :⇒*: Univ r l′ ^ [ ! , next l′ ]

  -- Universe type equality
  _⊩¹U_≡_^_/_ : (Γ : Con Term) (A B : Term) (ll : TypeLevel) ([A] : Γ ⊩¹U A ^ ll) → Set
  Γ ⊩¹U A ≡ B ^ ll / [A] = Γ ⊢ B ⇒* Univ (_⊩¹U_^_.r [A]) (_⊩¹U_^_.l′ [A]) ^ [ ! , ll ]

  -- Universe term
  record _⊩¹U_∷_^_/_  (Γ : Con Term) (t : Term) (A : Term) (ll : TypeLevel) ([A] : Γ ⊩¹U A ^ ll) : Set where
    constructor Uₜ
    open _⊩¹U_^_ [A]
    open LogRelKit (rec l<)
    field
      K    : Term
      d     : Γ ⊢ t :⇒*: K ∷ Univ r l′ ^ next l′
      typeK : Type K
      K≡K   : Γ ⊢ K ≅ K ∷ Univ r l′ ^ [ ! , next l′ ]
      [t]   : ∀ {ρ Δ} → ρ ∷ Δ ⊆ Γ → (⊢Δ : ⊢ Δ) → Δ ⊩ U.wk ρ t ^ [ r , ι l′ ]

  -- Universe term equality
  record _⊩¹U_≡_∷_^_/_ (Γ : Con Term) (t u : Term) (X : Term) (ll : TypeLevel) ([X] : Γ ⊩¹U X ^ ll) : Set where
    constructor Uₜ₌
    open _⊩¹U_^_ [X]
    open LogRelKit (rec l<)
    field
      [t]   : Γ ⊩¹U t ∷ X ^ ll / [X]
      [u]   : Γ ⊩¹U u ∷ X ^ ll / [X]
      A≡B   : Γ ⊢ _⊩¹U_∷_^_/_.K [t] ≅ _⊩¹U_∷_^_/_.K [u] ∷ Univ r l′ ^ [ ! , next l′ ]
      [t≡u] : ∀ {ρ Δ} → ([ρ] : ρ ∷ Δ ⊆ Γ) → (⊢Δ : ⊢ Δ) → Δ ⊩ U.wk ρ t ≡ U.wk ρ u ^ [ r , ι l′ ] / _⊩¹U_∷_^_/_.[t] [t] [ρ] ⊢Δ

  mutual

    -- Reducibility of Π:

    -- Π-type
    record _⊩¹Π_^[_,_] (Γ : Con Term) (A : Term) (r : Relevance) (lΠ : Level)  : Set where
      inductive
      eta-equality
      constructor Πᵣ
      field
        rF : Relevance
        lF : Level
        lG : Level
        lF≤ : lF ≤ lΠ
        lG≤ : lG ≤ lΠ
        F : Term
        G : Term
        D : Γ ⊢ A :⇒*: Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ r , ι lΠ ]
        ⊢F : Γ ⊢ F ^ [ rF , ι lF ]
        ⊢G : Γ ∙ F ^ [ rF , ι lF ] ⊢ G ^ [ r , ι lG ]
        A≡A : Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ ≅ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ r , ι lΠ ]
        [F] : ∀ {ρ Δ} → ρ ∷ Δ ⊆ Γ → (⊢Δ : ⊢ Δ) → Δ ⊩¹ U.wk ρ F ^ [ rF , ι lF ]
        [G] : ∀ {ρ Δ a}
            → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
            → Δ ⊩¹ a ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ
            → Δ ⊩¹ U.wk (lift ρ) G [ a ] ^ [ r , ι lG ]
        G-ext : ∀ {ρ Δ a b}
              → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
              → ([a] : Δ ⊩¹ a ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
              → ([b] : Δ ⊩¹ b ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
              → Δ ⊩¹ a ≡ b ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ
              → Δ ⊩¹ U.wk (lift ρ) G [ a ] ≡ U.wk (lift ρ) G [ b ] ^ [ r , ι lG ] / [G] [ρ] ⊢Δ [a]

    -- Π-type equality
    record _⊩¹Π_≡_^[_,_]/_ (Γ : Con Term) (A B : Term) (r : Relevance) (lΠ : Level) ([A] : Γ ⊩¹Π A ^[ r , lΠ ]) : Set where
      inductive
      eta-equality
      constructor Π₌
      open _⊩¹Π_^[_,_] [A]
      field
        F′     : Term
        G′     : Term
        D′     : Γ ⊢ B ⇒* Π F′ ^ rF ° lF ▹ G′ ° lG ° lΠ ^ [ r , ι lΠ ]
        A≡B    : Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ ≅ Π F′ ^ rF ° lF ▹ G′ ° lG ° lΠ ^ [ r , ι lΠ ]
        [F≡F′] : ∀ {ρ Δ}
               → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
               → Δ ⊩¹ U.wk ρ F ≡ U.wk ρ F′ ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ
        [G≡G′] : ∀ {ρ Δ a}
               → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
               → ([a] : Δ ⊩¹ a ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
               → Δ ⊩¹ U.wk (lift ρ) G [ a ] ≡ U.wk (lift ρ) G′ [ a ] ^ [ r , ι lG ] / [G] [ρ] ⊢Δ [a]

    -- relevant Term of Π-type
    _⊩¹Π_∷_^_/_ : (Γ : Con Term) (t A : Term) (lΠ : Level) ([A] : Γ ⊩¹Π A ^[ ! , lΠ ]) → Set
    Γ ⊩¹Π t ∷ A ^ lΠ / Πᵣ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext =
      ∃ λ f → Γ ⊢ t :⇒*: f ∷ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ ι lΠ
            × Function f
            × Γ ⊢ f ≅ f ∷ Π F ^ rF ° lF ▹ G ° lG ° lΠ ^ [ ! , ι lΠ ]
            × (∀ {ρ Δ a b}
              → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
                ([a] : Δ ⊩¹ a ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
                ([b] : Δ ⊩¹ b ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
                ([a≡b] : Δ ⊩¹ a ≡ b ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
              → Δ ⊩¹ U.wk ρ f ∘ a ^ lΠ ≡ U.wk ρ f ∘ b ^ lΠ ∷ U.wk (lift ρ) G [ a ] ^ [ ! , ι lG ] / [G] [ρ] ⊢Δ [a])
            × (∀ {ρ Δ a} → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
              → ([a] : Δ ⊩¹ a ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
              → Δ ⊩¹ U.wk ρ f ∘ a ^ lΠ ∷ U.wk (lift ρ) G [ a ] ^ [ ! , ι lG ] / [G] [ρ] ⊢Δ [a])
    -- Issue: Agda complains about record use not being strictly positive.
    --        Therefore we have to use ×

    -- Irrelevant term of Π-type
    _⊩¹Πirr_∷_^_/_ : (Γ : Con Term) (t A : Term) (l′ : Level) ([A] : Γ ⊩¹Π A ^[ % , l′ ]) → Set
    Γ ⊩¹Πirr t ∷ A ^ l′ / Πᵣ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext =
      Γ ⊢ t ∷ Π F ^ rF ° lF ▹ G ° lG ° l′ ^ [ % , ι l′ ]

    -- Term equality of Π-type
    _⊩¹Π_≡_∷_^_/_ : (Γ : Con Term) (t u A : Term) (l′ : Level) ([A] : Γ ⊩¹Π A ^[ ! , l′ ]) → Set
    Γ ⊩¹Π t ≡ u ∷ A ^ l′ / Πᵣ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext =
      let [A] = Πᵣ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext
      in  ∃₂ λ f g →
          ( Γ ⊢ t :⇒*: f ∷ Π F ^ rF ° lF ▹ G ° lG ° l′ ^ ι l′ )
      ×   ( Γ ⊢ u :⇒*: g ∷ Π F ^ rF ° lF ▹ G ° lG ° l′ ^ ι l′ )
      ×   Function f
      ×   Function g
      ×   Γ ⊢ f ≅ g ∷ Π F ^ rF ° lF ▹ G ° lG ° l′ ^ [ ! , ι l′ ]
      ×   Γ ⊩¹Π t ∷ A ^ l′ / [A]
      ×   Γ ⊩¹Π u ∷ A ^ l′ / [A]
      ×   (∀ {ρ Δ a} → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
          → ([a] : Δ ⊩¹ a ∷ U.wk ρ F ^ [ rF , ι lF ] / [F] [ρ] ⊢Δ)
          → Δ ⊩¹ U.wk ρ f ∘ a ^ l′ ≡ U.wk ρ g ∘ a ^ l′ ∷ U.wk (lift ρ) G [ a ] ^ [ ! , ι lG ] / [G] [ρ] ⊢Δ [a])
    -- Issue: Same as above.

    -- Irrelevant term equality of Π-type
    _⊩¹Πirr_≡_∷_^_/_ : (Γ : Con Term) (t u A : Term) (l′ : Level) ([A] : Γ ⊩¹Π A ^[ % , l′ ] ) → Set
    Γ ⊩¹Πirr t ≡ u ∷ A ^ l′ / Πᵣ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext =
          (Γ ⊢ t ∷ Π F ^ rF ° lF ▹ G ° lG ° l′ ^ [ % , ι l′ ])
          ×
          (Γ ⊢ u ∷ Π F ^ rF ° lF ▹ G ° lG ° l′ ^ [ % , ι l′ ])

    -- Existential types
    record _⊩¹∃_^_ (Γ : Con Term) (A : Term) (l′ : Level) : Set where
      inductive
      eta-equality
      constructor ∃ᵣ
      field
        F : Term
        G : Term
        D : Γ ⊢ A :⇒*: ∃ F ▹ G ^ [ % , ι l′ ]
        ⊢F : Γ ⊢ F ^ [ % , ι l′ ]
        ⊢G : Γ ∙ F ^ [ % , ι l′ ] ⊢ G ^ [ % , ι l′ ]
        A≡A : Γ ⊢ (∃ F ▹ G) ≅ (∃ F ▹ G) ^ [ % , ι l′ ]
        [F] : ∀ {ρ Δ} → ρ ∷ Δ ⊆ Γ → (⊢Δ : ⊢ Δ) → Δ ⊩¹ U.wk ρ F ^ [ % , ι l′ ]
        [G] : ∀ {ρ Δ a}
            → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
            → Δ ⊩¹ a ∷ U.wk ρ F ^ [ % , ι l′ ] / [F] [ρ] ⊢Δ
            → Δ ⊩¹ U.wk (lift ρ) G [ a ] ^ [ % , ι l′ ]
        G-ext : ∀ {ρ Δ a b}
              → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
              → ([a] : Δ ⊩¹ a ∷ U.wk ρ F ^ [ % , ι l′ ] / [F] [ρ] ⊢Δ)
              → ([b] : Δ ⊩¹ b ∷ U.wk ρ F ^ [ % , ι l′ ] / [F] [ρ] ⊢Δ)
              → Δ ⊩¹ a ≡ b ∷ U.wk ρ F ^ [ % , ι l′ ] / [F] [ρ] ⊢Δ
              → Δ ⊩¹ U.wk (lift ρ) G [ a ] ≡ U.wk (lift ρ) G [ b ] ^ [ % , ι l′ ] / [G] [ρ] ⊢Δ [a]

    -- ∃-type equality
    record _⊩¹∃_≡_^_/_ (Γ : Con Term) (A B : Term) (l′ : Level) ([A] : Γ ⊩¹∃ A ^ l′) : Set where
      inductive
      eta-equality
      constructor ∃₌
      open _⊩¹∃_^_ [A]
      field
        F′     : Term
        G′     : Term
        D′     : Γ ⊢ B ⇒* ∃ F′ ▹ G′ ^ [ % , ι l′ ]
        A≡B    : Γ ⊢ ∃ F ▹ G ≅ ∃ F′ ▹ G′ ^ [ % , ι l′ ]
        [F≡F′] : ∀ {ρ Δ}
               → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
               → Δ ⊩¹ U.wk ρ F ≡ U.wk ρ F′ ^ [ % , ι l′ ] / [F] [ρ] ⊢Δ
        [G≡G′] : ∀ {ρ Δ a}
               → ([ρ] : ρ ∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
               → ([a] : Δ ⊩¹ a ∷ U.wk ρ F ^ [ % , ι l′ ] / [F] [ρ] ⊢Δ)
               → Δ ⊩¹ U.wk (lift ρ) G [ a ] ≡ U.wk (lift ρ) G′ [ a ] ^ [ % , ι l′ ] / [G] [ρ] ⊢Δ [a]

    -- Terms of ∃-types (always irrelevant)
    _⊩¹∃_∷_^_/_ : (Γ : Con Term) (t A : Term) (l′ : Level) ([A] : Γ ⊩¹∃ A ^ l′) → Set
    Γ ⊩¹∃ t ∷ A ^ l′ / ∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext =
      Γ ⊢ t ∷ ∃ F ▹ G ^ [ % , ι l′ ]

    -- Term equality for ∃-types
    _⊩¹∃_≡_∷_^_/_ : (Γ : Con Term) (t u A : Term) (l′ : Level) ([A] : Γ ⊩¹∃ A ^ l′) → Set
    Γ ⊩¹∃ t ≡ u ∷ A ^ l′ / ∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext =
          (Γ ⊢ t ∷ ∃ F ▹ G ^ [ % , ι l′ ])
          ×
          (Γ ⊢ u ∷ ∃ F ▹ G ^ [ % , ι l′ ])

    -- Logical relation definition

    data _⊩¹_^_ (Γ : Con Term) : Term → TypeInfo → Set where
      Uᵣ  : ∀ {A ll} → (UA : Γ ⊩¹U A ^ ll) → Γ ⊩¹ A ^ [ ! , ll ]
      ℕᵣ  : ∀ {A} → Γ ⊩ℕ A → Γ ⊩¹ A ^ [ ! , ι ⁰ ]
      Emptyᵣ : ∀ {A l} → Γ ⊩Empty A ^ l → Γ ⊩¹ A ^ [ % , ι l ]
      ne  : ∀ {A r l} → Γ ⊩ne A ^[ r , l ] → Γ ⊩¹ A ^ [ r , ι l ]
      Πᵣ  : ∀ {A r l} → Γ ⊩¹Π A ^[ r , l ] → Γ ⊩¹ A ^ [ r , ι l ]
      ∃ᵣ  : ∀ {A l} → Γ ⊩¹∃ A ^ l → Γ ⊩¹ A ^ [ % , ι l ]
      emb : ∀ {A r l′} (l< : l′ <∞ l) (let open LogRelKit (rec l<))
            ([A] : Γ ⊩ A ^ r) → Γ ⊩¹ A ^ r

    _⊩¹_≡_^_/_ : (Γ : Con Term) (A B : Term) (r : TypeInfo) → Γ ⊩¹ A ^ r  → Set
    Γ ⊩¹ A ≡ B ^ [ .! , l ] / Uᵣ UA = Γ ⊩¹U A ≡ B ^ l / UA
    Γ ⊩¹ A ≡ B ^ [ .! , .ι ⁰ ] / ℕᵣ D = Γ ⊩ℕ A ≡ B
    Γ ⊩¹ A ≡ B ^ [ .% , .ι l ] / Emptyᵣ D = Γ ⊩Empty A ≡ B ^ l
    Γ ⊩¹ A ≡ B ^ [ r , ι l ] / ne neA = Γ ⊩ne A ≡ B ^[ r , l ]/ neA
    Γ ⊩¹ A ≡ B ^ [ r , ι l ] / Πᵣ ΠA =  Γ ⊩¹Π A ≡ B ^[ r , l ]/ ΠA
    Γ ⊩¹ A ≡ B ^ [ .% , ι l ] / ∃ᵣ ∃A = Γ ⊩¹∃ A ≡ B ^ l / ∃A
    Γ ⊩¹ A ≡ B ^ r / emb l< [A] = Γ ⊩ A ≡ B ^ r / [A]
      where open LogRelKit (rec l<)

    _⊩¹_∷_^_/_ : (Γ : Con Term) (t A : Term) (r : TypeInfo) → Γ ⊩¹ A ^ r  → Set
    Γ ⊩¹ t ∷ A ^ [ .! , ll ] / Uᵣ UA = Γ ⊩¹U t ∷ A ^ ll / UA
    Γ ⊩¹ t ∷ A ^ .([ ! , ι ⁰ ]) / ℕᵣ x = Γ ⊩ℕ t ∷ℕ
    Γ ⊩¹ t ∷ A ^ [ .% , ι ll ] / Emptyᵣ x =  Γ ⊩Empty t ∷Empty^ ll
    Γ ⊩¹ t ∷ A ^ .([ ! , ι l ]) / ne {r = !} {l} neA = Γ ⊩ne t ∷ A ^ l / neA
    Γ ⊩¹ t ∷ A ^ .([ % , ι l ]) / ne {r = %} {l} neA = Γ ⊩neIrr t ∷ A ^ l / neA
    Γ ⊩¹ t ∷ A ^ [ ! , ι l ] / Πᵣ ΠA  = Γ ⊩¹Π t ∷ A ^ l / ΠA
    Γ ⊩¹ t ∷ A ^ [ % , ι l ] / Πᵣ ΠA  = Γ ⊩¹Πirr t ∷ A ^ l / ΠA
    Γ ⊩¹ t ∷ A ^ .([ % , ι l ]) / ∃ᵣ {l = l} ∃A = Γ ⊩¹∃ t ∷ A ^ l / ∃A
    Γ ⊩¹ t ∷ A ^ r / emb l< [A] =  Γ ⊩ t ∷ A ^ r / [A]
      where open LogRelKit (rec l<)

    _⊩¹_≡_∷_^_/_ : (Γ : Con Term) (t u A : Term) (r : TypeInfo) → Γ ⊩¹ A ^ r → Set
    Γ ⊩¹ t ≡ u ∷ A ^ [ .! , ll ] / Uᵣ UA = Γ ⊩¹U t ≡ u ∷ A ^ ll / UA
    Γ ⊩¹ t ≡ u ∷ A ^ .([ ! , ι ⁰ ]) / ℕᵣ D = Γ ⊩ℕ t ≡ u ∷ℕ
    Γ ⊩¹ t ≡ u ∷ A ^ [ .% , ι ll ] / Emptyᵣ D = Γ ⊩Empty t ≡ u ∷Empty^ ll
    Γ ⊩¹ t ≡ u ∷ A ^ .([ ! , ι l ]) / ne {r = !} {l} neA = Γ ⊩ne t ≡ u ∷ A ^  l / neA
    Γ ⊩¹ t ≡ u ∷ A ^ .([ % , ι l ]) / ne {r = %} {l} neA = Γ ⊩neIrr t ≡ u ∷ A ^ l / neA
    Γ ⊩¹ t ≡ u ∷ A ^ [ ! , ι l ] / Πᵣ ΠA = Γ ⊩¹Π t ≡ u ∷ A ^ l  / ΠA
    Γ ⊩¹ t ≡ u ∷ A ^ [ % , ι l ] / Πᵣ ΠA = Γ ⊩¹Πirr t ≡ u ∷ A ^ l / ΠA
    Γ ⊩¹ t ≡ u ∷ A ^ .([ % , ι l ]) / ∃ᵣ {l = l} ∃A = Γ ⊩¹∃ t ≡ u ∷ A ^ l / ∃A
    Γ ⊩¹ t ≡ u ∷ A ^ r / emb l< [A] = Γ ⊩ t ≡ u ∷ A ^ r / [A]
      where open LogRelKit (rec l<)

    kit : LogRelKit
    kit = Kit _⊩¹U_^_ _⊩¹Π_^[_,_] _⊩¹∃_^_
              _⊩¹_^_ _⊩¹_≡_^_/_ _⊩¹_∷_^_/_ _⊩¹_≡_∷_^_/_

open LogRel public using (Uᵣ; ℕᵣ; Emptyᵣ; ne; Πᵣ ; ∃ᵣ ; emb; Uₜ; Uₜ₌; Π₌; ∃₌)

-- Patterns for the non-records of Π
pattern Πₜ a b c d e f = a , b , c , d , e , f
pattern Πₜ₌ a b c d e f g h i j = a , b , c , d , e , f , g , h , i , j

pattern Uᵣ′ A ll r l a e d = Uᵣ {A = A} {ll = ll} (Uᵣ r l a e d)
pattern ne′ b c d e = ne (ne b c d e)
pattern Πᵣ′  a a' a'' lf lg b c d e f g h i j = Πᵣ (Πᵣ a a' a'' lf lg b c d e f g h i j)
pattern ∃ᵣ′  a b c d e f g h i = ∃ᵣ (∃ᵣ a b c d e f g h i)

-- we need to split the LogRelKit into the level part and the general part to convince Agda termination checker

logRelRec : ∀ l {l′} → l′ <∞ l → LogRelKit
logRelRec (ι ⁰) = λ ()
logRelRec (ι ¹) X = LogRel.kit (ι ⁰) λ ()
logRelRec ∞ X = LogRel.kit (ι ¹) (λ X → LogRel.kit (ι ⁰) λ ())

kit : ∀ (i : TypeLevel) → LogRelKit
kit l =  LogRel.kit l (logRelRec l)

_⊩′⟨_⟩U_^_ : (Γ : Con Term) (l : TypeLevel) → Term → TypeLevel → Set
Γ ⊩′⟨ l ⟩U A ^ ll = Γ ⊩U A ^ ll where open LogRelKit (kit l)

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

_⊩′⟨_⟩∃_^_ : (Γ : Con Term) (l : TypeLevel) → Term → Level → Set
Γ ⊩′⟨ l ⟩∃ A ^ l' = Γ ⊩∃ A ^ l' where open LogRelKit (kit l)

_⊩⟨_⟩_^_ : (Γ : Con Term) (l : TypeLevel) → Term → TypeInfo → Set
Γ ⊩⟨ l ⟩ A ^ r = Γ ⊩ A ^ r where open LogRelKit (kit l)

_⊩⟨_⟩_≡_^_/_ : (Γ : Con Term) (l : TypeLevel) (A B : Term) (r : TypeInfo) → Γ ⊩⟨ l ⟩ A ^ r → Set
Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A] = Γ ⊩ A ≡ B ^ r / [A] where open LogRelKit (kit l)

_⊩⟨_⟩_∷_^_/_ : (Γ : Con Term) (l : TypeLevel) (t A : Term) (r : TypeInfo) → Γ ⊩⟨ l ⟩ A ^ r → Set
Γ ⊩⟨ l ⟩ t ∷ A ^ r / [A] = Γ ⊩ t ∷ A ^ r / [A] where open LogRelKit (kit l)

_⊩⟨_⟩_≡_∷_^_/_ : (Γ : Con Term) (l : TypeLevel) (t u A : Term) (r : TypeInfo) → Γ ⊩⟨ l ⟩ A ^ r → Set
Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ r / [A] = Γ ⊩ t ≡ u ∷ A ^ r / [A] where open LogRelKit (kit l)

-- Well-typed irrelevant terms are always reducible
logRelIrr : ∀ {l t Γ l' A} ([A] : Γ ⊩⟨ l ⟩ A ^ [ % , l' ]) (⊢t : Γ ⊢ t ∷ A ^ [ % , l' ]) → Γ ⊩⟨ l ⟩ t ∷ A ^ [ % , l' ] / [A]
logRelIrr (Emptyᵣ [[ ⊢A , ⊢B , D ]]) ⊢t = Emptyₜ (ne (conv ⊢t (reduction D (id ⊢B) Emptyₙ Emptyₙ (refl ⊢B))))
logRelIrr (ne x) ⊢t = neₜ ⊢t
logRelIrr (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ⊢t = conv ⊢t (reduction (red D) (id (_⊢_:⇒*:_^_.⊢B D)) Πₙ Πₙ (refl (_⊢_:⇒*:_^_.⊢B D)))
logRelIrr (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ⊢t = conv ⊢t (reduction (red D) (id (_⊢_:⇒*:_^_.⊢B D)) ∃ₙ ∃ₙ (refl (_⊢_:⇒*:_^_.⊢B D)))
logRelIrr {ι ¹} (emb X [A]) ⊢t = logRelIrr [A] ⊢t
logRelIrr {∞} (emb X [A]) ⊢t = logRelIrr [A] ⊢t

-- Well-typed irrelevant terms are reducibly equal as soon as they have the same type
logRelIrrEq : ∀ {l t u Γ l' A} ([A] : Γ ⊩⟨ l ⟩ A ^ [ % , l' ]) (⊢t : Γ ⊢ t ∷ A ^ [ % , l' ]) (⊢u : Γ ⊢ u ∷ A ^ [ % , l' ]) → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ % , l' ] / [A]
logRelIrrEq (Emptyᵣ [[ ⊢A , ⊢B , D ]]) ⊢t ⊢u = Emptyₜ₌ (ne ((conv ⊢t (reduction D (id ⊢B) Emptyₙ Emptyₙ (refl ⊢B))))
                                                         (conv ⊢u (reduction D (id ⊢B) Emptyₙ Emptyₙ (refl ⊢B))))
logRelIrrEq (ne x) ⊢t ⊢u = neₜ₌ ⊢t ⊢u
logRelIrrEq (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ⊢t ⊢u = (conv ⊢t (reduction (red D) (id (_⊢_:⇒*:_^_.⊢B D)) Πₙ Πₙ (refl (_⊢_:⇒*:_^_.⊢B D))) ) , (conv ⊢u (reduction (red D) (id (_⊢_:⇒*:_^_.⊢B D)) Πₙ Πₙ (refl (_⊢_:⇒*:_^_.⊢B D))) )
logRelIrrEq (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) ⊢t ⊢u = (conv ⊢t (reduction (red D) (id (_⊢_:⇒*:_^_.⊢B D)) ∃ₙ ∃ₙ (refl (_⊢_:⇒*:_^_.⊢B D))) ) , (conv ⊢u (reduction (red D) (id (_⊢_:⇒*:_^_.⊢B D)) ∃ₙ ∃ₙ (refl (_⊢_:⇒*:_^_.⊢B D))) )
logRelIrrEq {ι ¹} (emb X [A]) ⊢t = logRelIrrEq [A] ⊢t
logRelIrrEq {∞} (emb X [A]) ⊢t = logRelIrrEq [A] ⊢t


open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; subst)

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.VRenaming
import SecondOrder.MRenaming
import SecondOrder.Term
import SecondOrder.Substitution
import SecondOrder.RelativeMonadMorphism

module SecondOrder.Instantiation
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.Signature.Signature Σ
  open SecondOrder.Metavariable Σ
  open SecondOrder.Term Σ
  open SecondOrder.VRenaming Σ
  open SecondOrder.MRenaming Σ
  open SecondOrder.Substitution Σ
  open import SecondOrder.RelativeMonadMorphism

  -- metavariable instantiation

  _⇒ⁱ_⊕_ : MContext → MContext → VContext → Set ℓ
  Θ ⇒ⁱ Ξ ⊕ Γ = ∀ {Γᴹ Aᴹ} (M : [ Γᴹ , Aᴹ ]∈ Θ) → Term Ξ (Γ ,, Γᴹ) Aᴹ

  -- syntactic equality of instantiations

  infix 5 _≈ⁱ_

  _≈ⁱ_ : ∀ {Θ Ψ Γ} (I J : Θ ⇒ⁱ Ψ ⊕ Γ) → Set ℓ
  _≈ⁱ_ {Θ} I J = ∀ {Γᴹ Aᴹ} (M : [ Γᴹ , Aᴹ ]∈ Θ) → I M ≈ J M

  -- equality of instantiations is an equivalence relation

  ≈ⁱ-refl : ∀ {Θ Ψ Γ} {I : Θ ⇒ⁱ Ψ ⊕ Γ} → I ≈ⁱ I
  ≈ⁱ-refl M = ≈-refl

  ≈ⁱ-sym : ∀ {Θ Ψ Γ} {I J : Θ ⇒ⁱ Ψ ⊕ Γ} → I ≈ⁱ J → J ≈ⁱ I
  ≈ⁱ-sym ξ M = ≈-sym (ξ M)

  ≈ⁱ-trans : ∀ {Θ Ψ Γ} {I J K : Θ ⇒ⁱ Ψ ⊕ Γ} → I ≈ⁱ J → J ≈ⁱ K → I ≈ⁱ K
  ≈ⁱ-trans ζ ξ M = ≈-trans (ζ M) (ξ M)

  -- extension of an instantiation

  ⇑ⁱ : ∀ {Θ Ψ Γ Δ} → Θ ⇒ⁱ Ψ ⊕ Γ → Θ ⇒ⁱ Ψ ⊕ (Γ ,, Δ)
  ⇑ⁱ I M =  [ ⇑ᵛ var-inl ]ᵛ I M

  -- extension of instantiations preserve equality of instantiations

  ⇑ⁱ-resp-≈ⁱ : ∀ {Θ Ψ Γ Δ} (I J : Θ ⇒ⁱ Ψ ⊕ Γ) → (I ≈ⁱ J) → (⇑ⁱ {Δ = Δ} I ≈ⁱ ⇑ⁱ J)
  ⇑ⁱ-resp-≈ⁱ I J ξ M = []ᵛ-resp-≈ (ξ M)

  -- action of a metavariable instantiation on terms

  infixr 6 [_]ⁱ_

  [_]ⁱ_ : ∀ {Θ ψ Γ} → ψ ⇒ⁱ Θ ⊕ Γ → ∀ {A} → Term ψ Γ A → Term Θ Γ A
  [ I ]ⁱ (tm-var x) = tm-var x
  [ I ]ⁱ (tm-meta M ts) = [ [ idˢ , (λ i → [ I ]ⁱ ts i) ]ˢ ]ˢ (I M)
  [ I ]ⁱ (tm-oper f es) = tm-oper f λ i → [ ⇑ⁱ I ]ⁱ es i

  -- instantiation preserves equality of terms

  []ⁱ-resp-≈ : ∀ {Θ Ξ Γ} (I : Ξ ⇒ⁱ Θ ⊕ Γ) → ∀ {A} {t u : Term Ξ Γ A} →
               t ≈ u → [ I ]ⁱ t ≈ [ I ]ⁱ u
  []ⁱ-resp-≈ I (≈-≡ refl) = ≈-refl
  []ⁱ-resp-≈ I (≈-meta {M = M} ξ) = []ˢ-resp-≈ˢ (I M) ([,]ˢ-resp-≈ˢ (λ x → ≈-refl) λ i → []ⁱ-resp-≈ I (ξ i))
  []ⁱ-resp-≈ I (≈-oper ξ) = ≈-oper λ i → []ⁱ-resp-≈ (⇑ⁱ I) (ξ i)

  -- action preserves equality of instantiation

  []ⁱ-resp-≈ⁱ : ∀ {Θ Ξ Γ} {I J : Ξ ⇒ⁱ Θ ⊕ Γ} → ∀ {A} (t : Term Ξ Γ A) →
               I ≈ⁱ J → [ I ]ⁱ t ≈ [ J ]ⁱ t
  []ⁱ-resp-≈ⁱ (tm-var x) ξ = ≈-refl
  []ⁱ-resp-≈ⁱ (tm-meta M ts) ξ =
    []ˢ-resp-≈ˢ-≈ ([,]ˢ-resp-≈ˢ (λ x → ≈-refl) λ i → []ⁱ-resp-≈ⁱ (ts i) ξ) (ξ M)
  []ⁱ-resp-≈ⁱ {I = I} {J = J} (tm-oper f es) ξ = ≈-oper λ i → []ⁱ-resp-≈ⁱ (es i) (⇑ⁱ-resp-≈ⁱ I J ξ)

  -- generically applied metavariable

  tm-meta-generic : ∀ {Θ} {Γ} {Γᴹ Aᴹ} (M : [ Γᴹ , Aᴹ ]∈ Θ) → Term Θ (Γ ,, Γᴹ) Aᴹ
  tm-meta-generic M = tm-meta M λ i → tm-var (var-inr i)

  -- the action of an instantiation on a generically applied metavariable

  []ⁱ-generic : ∀ {Θ Ξ} {Γ} {I : Θ ⇒ⁱ Ξ ⊕ Γ} {Γᴹ Aᴹ} {M : [ Γᴹ , Aᴹ ]∈ Θ} →
                [ ⇑ⁱ {Δ = Γᴹ} I ]ⁱ tm-meta-generic M ≈ I M
  []ⁱ-generic {Θ = Θ} {Ξ = Ξ} {Γ = Γ} {I = I} {Γᴹ = Γᴹ} {M = M} =
    ≈-trans
      (≈-sym ([ˢ∘ᵛ] (I M)))
      (≈ˢ-idˢ-[]ˢ (λ { (var-inl _) → ≈-refl ; (var-inr _) → ≈-refl}))

  -- Interactions involving instantiations

  -- the identity metavariable instantiation

  idⁱ : ∀ {Θ Γ} → Θ ⇒ⁱ Θ ⊕ Γ
  idⁱ M = tm-meta-generic M

  -- composition of metavariable instantiations

  infixl 6 _∘ⁱ_

  _∘ⁱ_ : ∀ {Θ Ξ Ω Γ} → Ξ ⇒ⁱ Ω ⊕ Γ → Θ ⇒ⁱ Ξ ⊕ Γ → (Θ ⇒ⁱ Ω ⊕ Γ)
  (I ∘ⁱ J) M =  [ ⇑ⁱ I ]ⁱ J M

  -- composition of a renaming and an instantiation

  _ᵛ∘ⁱ_ : ∀ {Θ ψ Γ Δ} → Γ ⇒ᵛ Δ → Θ ⇒ⁱ ψ ⊕ Γ → Θ ⇒ⁱ ψ ⊕ Δ
  (ρ ᵛ∘ⁱ I) M = [ ⇑ᵛ ρ ]ᵛ I M

  -- composition of a substitution and an instantiation

  _ˢ∘ⁱ_ : ∀ {Θ ψ Γ Δ} → ψ ⊕ Γ ⇒ˢ Δ → Θ ⇒ⁱ ψ ⊕ Γ → Θ ⇒ⁱ ψ ⊕ Δ
  (σ ˢ∘ⁱ I) M = [ ⇑ˢ σ ]ˢ I M

  -- composition of an instantiation and a substitution

  _ⁱ∘ˢ_ : ∀ {Θ ψ Γ Δ} → Θ ⇒ⁱ ψ ⊕ Δ → Θ ⊕ Γ ⇒ˢ Δ →  ψ ⊕ Γ ⇒ˢ Δ
  (I ⁱ∘ˢ σ) x = [ I ]ⁱ σ x

  -- composition of a renaming and an instantiation preerve equality of instantiations

  [ᵛ∘ⁱ]-resp-≈ⁱ : ∀ {Θ ψ Γ Δ} (ρ : Γ ⇒ᵛ Δ) (I J : Θ ⇒ⁱ ψ ⊕ Γ) → (I ≈ⁱ J) → (ρ ᵛ∘ⁱ I) ≈ⁱ (ρ ᵛ∘ⁱ J)
  [ᵛ∘ⁱ]-resp-≈ⁱ σ I J ξ M = []ᵛ-resp-≈ (ξ M)

  -- composition of a renaming and an instantiation preserve equality of instantiations

  [ˢ∘ⁱ]-resp-≈ⁱ : ∀ {Θ ψ Γ Δ} (σ : ψ ⊕ Γ ⇒ˢ Δ) (I J : Θ ⇒ⁱ ψ ⊕ Γ) → (I ≈ⁱ J) → (σ ˢ∘ⁱ I) ≈ⁱ (σ ˢ∘ⁱ J)
  [ˢ∘ⁱ]-resp-≈ⁱ σ I J ξ M = []ˢ-resp-≈ (⇑ˢ σ) (ξ M)

  -- Actions correspondig to the interactions

  -- the action of the identity

  [idⁱ] : ∀ {Θ Γ A Δ} {t : Term Θ (Γ ,, Δ) A}  → [ idⁱ ]ⁱ t ≈ t
  [idⁱ] {t = tm-var x} = ≈-refl
  [idⁱ] {t = tm-meta M ts} = ≈-meta (λ i → [idⁱ])
  [idⁱ] {t = tm-oper f es} = ≈-oper (λ i → [idⁱ])

  -- extension commutes with composition of renaming and substitution

  ⇑ⁱ-resp-ᵛ∘ⁱ : ∀ {Θ ψ} {Γ Δ Ξ} {I : Θ ⇒ⁱ ψ ⊕ Γ} {ρ : Γ ⇒ᵛ Δ}
               → ⇑ⁱ {Δ = Ξ} (ρ ᵛ∘ⁱ I) ≈ⁱ ⇑ᵛ ρ ᵛ∘ⁱ ⇑ⁱ I
  ⇑ⁱ-resp-ᵛ∘ⁱ {ρ = ρ} M = ≈-trans (≈-sym [∘ᵛ]) (≈-trans ([]ᵛ-resp-≡ᵛ λ {(var-inl _) → refl ; (var-inr x) → refl}) [∘ᵛ])

  -- the action of the composition of an instantiation and a renaming

  [ᵛ∘ⁱ] : ∀ {Θ Ψ Γ Δ A} {ρ : Γ ⇒ᵛ Δ} {I : Θ ⇒ⁱ Ψ ⊕ Γ} (t : Term Θ Γ A) →
           [ ρ ]ᵛ [ I ]ⁱ t ≈ [ ρ ᵛ∘ⁱ I ]ⁱ [ ρ ]ᵛ t
  [ᵛ∘ⁱ] (tm-var x) = ≈-refl
  [ᵛ∘ⁱ] {I = I} (tm-meta M ts) =
    ≈-trans
     (≈-sym ([ᵛ∘ˢ] (I M)))
     (≈-trans
       ([]ˢ-resp-≈ˢ (I M) (λ { (var-inl _) → ≈-refl ; (var-inr j) → [ᵛ∘ⁱ] (ts j)}))
       ([ˢ∘ᵛ] (I M)))
  [ᵛ∘ⁱ] {ρ = ρ} {I = I} (tm-oper f es) =
    ≈-oper λ i → ≈-trans ([ᵛ∘ⁱ] (es i)) ([]ⁱ-resp-≈ⁱ ([ ⇑ᵛ ρ ]ᵛ es i) (≈ⁱ-sym (⇑ⁱ-resp-ᵛ∘ⁱ {I = I})))

  -- extension commutes with composition

  ⇑ⁱ-resp-∘ⁱ : ∀ {Θ Ξ Ω} {Γ Δ} {I : Θ ⇒ⁱ Ξ ⊕ Γ} {J : Ξ ⇒ⁱ Ω ⊕ Γ} →
               ⇑ⁱ {Δ = Δ} (J ∘ⁱ I) ≈ⁱ ⇑ⁱ J ∘ⁱ ⇑ⁱ I
  ⇑ⁱ-resp-∘ⁱ {I = I} {J = J} M =
    ≈-trans
     ([ᵛ∘ⁱ] (I M))
     ([]ⁱ-resp-≈ⁱ
        ([ ⇑ᵛ var-inl ]ᵛ I M)
        (λ N → ≈-trans
                 (≈-sym [∘ᵛ])
                 (≈-trans
                   ([]ᵛ-resp-≡ᵛ (λ { (var-inl x) → refl ; (var-inr x) → refl }))
                   [∘ᵛ])))

  ⇑ˢ-resp-ⁱ∘ˢ : ∀ {Θ ψ Γ Δ Ξ} → {I : Θ ⇒ⁱ ψ ⊕ Δ} → {σ : Θ ⊕ Γ ⇒ˢ Δ} → ⇑ˢ {Ξ = Ξ} (I ⁱ∘ˢ σ) ≈ˢ ⇑ⁱ I ⁱ∘ˢ ⇑ˢ σ
  ⇑ˢ-resp-ⁱ∘ˢ {σ = σ} (var-inl x) = [ᵛ∘ⁱ] (σ x)
  ⇑ˢ-resp-ⁱ∘ˢ (var-inr x) = ≈-refl

  -- interaction lemma
  []ⁱ-[]ˢ : ∀ {Θ Ψ Γ Δ A} {I : Θ ⇒ⁱ Ψ ⊕ Δ} {σ : Θ ⊕ Γ ⇒ˢ Δ} {ρ : Δ ⇒ᵛ Γ} (t : Term Θ Γ A) →
        σ ˢ∘ᵛ ρ ≈ˢ idˢ → ([ I ]ⁱ ([ σ ]ˢ t)) ≈ ([ I ⁱ∘ˢ σ ]ˢ [ ρ ᵛ∘ⁱ I ]ⁱ t)
  []ⁱ-[]ˢ (tm-var x) ξ = ≈-refl
  []ⁱ-[]ˢ {I = I} {σ = σ} {ρ = ρ} (tm-meta M ts) ξ =
   ≈-trans
     ([]ˢ-resp-≈ˢ (I M)
        (λ { (var-inl i) → []ⁱ-resp-≈ I (≈-sym (ξ i)) ; (var-inr j) → []ⁱ-[]ˢ (ts j) ξ}))
     (≈-trans
       ([ˢ∘ᵛ] (I M))
       ([∘ˢ] ((ρ ᵛ∘ⁱ I) M)))
  []ⁱ-[]ˢ {I = I} {σ = σ} {ρ = ρ} (tm-oper f es) ξ =
    ≈-oper λ i →
      ≈-trans
       ([]ⁱ-[]ˢ {σ = ⇑ˢ σ} {ρ = ⇑ᵛ ρ} (es i)
         (≈ˢ-trans
           (≈ˢ-sym (⇑ˢ-resp-ˢ∘ᵛ  {ρ = ρ} {σ = σ}))
           (≈ˢ-trans (⇑ˢ-resp-≈ˢ ξ) ⇑ˢ-resp-idˢ)))
       ([]ˢ-resp-≈ˢ-≈
          {σ = ⇑ⁱ I ⁱ∘ˢ ⇑ˢ σ }
          {τ = ⇑ˢ (I ⁱ∘ˢ σ)}
          {t = ([ ⇑ᵛ ρ ᵛ∘ⁱ ⇑ⁱ I ]ⁱ es i)}
          {u = ([ ⇑ⁱ (ρ ᵛ∘ⁱ I) ]ⁱ es i)}
          (≈ˢ-sym ⇑ˢ-resp-ⁱ∘ˢ)
          ([]ⁱ-resp-≈ⁱ (es i) (≈ⁱ-sym (⇑ⁱ-resp-ᵛ∘ⁱ {I = I}))))

  -- the action of a composition

  [∘ⁱ] : ∀ {Θ Ξ Ω Γ} → {I : Θ ⇒ⁱ Ξ ⊕ Γ} → {J : Ξ ⇒ⁱ Ω ⊕ Γ} →
           ∀ {A} → ∀ (t : Term Θ Γ A) → [ J ∘ⁱ I ]ⁱ t ≈ [ J ]ⁱ [ I ]ⁱ t
  [∘ⁱ] (tm-var x) = ≈-refl
  [∘ⁱ] {Θ = Θ} {Ξ = Ξ} {Γ = Γ} {I = I} {J = J} (tm-meta {Γᴹ = Γᴹ} M ts) =
    ≈-trans
      ([]ˢ-resp-≈ˢ
        ([ ⇑ⁱ J ]ⁱ (I M))
        ([,]ˢ-resp-≈ˢ (λ x → ≈-refl) (λ i → [∘ⁱ] {I = I} {J = J} (ts i))))
      (≈-trans
        ([]ˢ-resp-≈ˢ {τ = λ i → [ J ]ⁱ var-or-ts i} ([ ⇑ⁱ J ]ⁱ (I M))
        λ {(var-inl x) → ≈-refl ; (var-inr y) → ≈-refl})
        (≈-trans
           (≈-sym ([]ⁱ-[]ˢ {I = J} {σ = var-or-ts} {ρ = var-inl} (I M) λ x → ≈-refl))
            ([]ⁱ-resp-≈ J
                       ([]ˢ-resp-≈ˢ (I M) λ { (var-inl x) → ≈-refl ; (var-inr x) → ≈-refl}))))
                 where
                 var-or-ts : ∀ {A} → A ∈ (Γ ,, Γᴹ) → Term Ξ Γ A
                 var-or-ts (var-inl x) = tm-var x
                 var-or-ts (var-inr y) = [ I ]ⁱ ts y

  [∘ⁱ] {I = I} {J = J} (tm-oper f es) =
            ≈-oper (λ i → ≈-trans ([]ⁱ-resp-≈ⁱ (es i) (⇑ⁱ-resp-∘ⁱ {I = I})) ([∘ⁱ] (es i)))


------------------------------------------------------------------------
-- Various constants
------------------------------------------------------------------------

open import Atom

module Constants (atoms : χ-atoms) where

open χ-atoms atoms

c-zero : Const
c-zero = C.name 0

c-suc : Const
c-suc = C.name 1

c-nil : Const
c-nil = C.name 2

c-cons : Const
c-cons = C.name 3

c-apply : Const
c-apply = C.name 4

c-case : Const
c-case = C.name 5

c-rec : Const
c-rec = C.name 6

c-lambda : Const
c-lambda = C.name 7

c-const : Const
c-const = C.name 8

c-var : Const
c-var = C.name 9

c-branch : Const
c-branch = C.name 10

c-true : Const
c-true = C.name 11

c-false : Const
c-false = C.name 12

c-pair : Const
c-pair = C.name 13

v-equal : Var
v-equal = V.name 0

v-m : Var
v-m = V.name 1

v-n : Var
v-n = V.name 2

v-x : Var
v-x = V.name 3

v-new : Var
v-new = V.name 4

v-e : Var
v-e = V.name 5

v-subst : Var
v-subst = V.name 6

v-e₁ : Var
v-e₁ = V.name 7

v-e₂ : Var
v-e₂ = V.name 8

v-bs : Var
v-bs = V.name 9

v-y : Var
v-y = V.name 10

v-c : Var
v-c = V.name 11

v-es : Var
v-es = V.name 12

v-ys : Var
v-ys = V.name 13

v-member : Var
v-member = V.name 14

v-xs : Var
v-xs = V.name 15

v-lookup : Var
v-lookup = V.name 16

v-b : Var
v-b = V.name 17

v-c′ : Var
v-c′ = V.name 18

v-underscore : Var
v-underscore = V.name 19

v-substs : Var
v-substs = V.name 20

v-e′ : Var
v-e′ = V.name 21

v-map : Var
v-map = V.name 22

v-p : Var
v-p = V.name 23

v-eval : Var
v-eval = V.name 24

v-internal-code : Var
v-internal-code = V.name 25

v-halts : Var
v-halts = V.name 26

v-z : Var
v-z = V.name 27

v-f : Var
v-f = V.name 28

v-g : Var
v-g = V.name 29


open import Proc

module Interp (param : Param) where

import Hear
open import Basics

private
  open module P = Process param
  open module H = Hear param

open Tran

data Result {a : U}(p : Proc a) : Set where
  speak  : forall {w q} -> p -! w !-> q -> Result p
  refuse : Silent p -> Result p

upR : {a b : U}{p : Proc b}(φ : Tran a b) -> Result p -> Result (φ /| p)
upR φ (speak  s) = speak  (tx-/| s)
upR φ (refuse s) = refuse (silent-/| s)

Oracle : Set
Oracle = Nat -> LR

prophecy : Oracle -> LR
prophecy ol = ol zero

nextOracle : Oracle -> Oracle
nextOracle ol = ol % suc

anyOracle : Oracle
anyOracle _ = left

ocons : LR -> Oracle -> Oracle
ocons l or zero    = l
ocons l or (suc n) = or n

step : {a : U}{p : Proc a} -> Guard p -> Oracle -> Result p
step og           _  = refuse silent-o
step (>g _)       _  = refuse silent->
step (w !g p)     _  = speak tx-!
step (w ! p +g f) _  = speak tx-+
step (defg x g)   ol with step g ol
... | refuse s1 = refuse (silent-def s1)
... | speak  s1 = speak (tx-def s1)
step (g1 ||g g2)  ol with step g1 (nextOracle ol)
                        | step g2 (nextOracle ol)
                        | prophecy ol
... | refuse s1 | refuse s2 | _     = refuse (silent-|| s1 s2)
... | speak s1  | refuse s2 | _     = speak (tx-!| s1 (sound g2))
... | refuse s1 | speak s2  | _     = speak (tx-|! (sound g1) s2)
... | speak s1  | speak _   | left  = speak (tx-!| s1 (sound g2))
... | speak _   | speak s2  | right = speak (tx-|! (sound g1) s2)
step (φ /|g g)    ol = upR φ (step g ol)


module Prelude.String where

open import Agda.Primitive
open import Prelude.Unit
open import Prelude.Char
open import Prelude.Bool
open import Prelude.Nat
open import Prelude.List
open import Prelude.Maybe
open import Prelude.Equality
open import Prelude.Equality.Unsafe
open import Prelude.Decidable
open import Prelude.Ord
open import Prelude.Function
open import Prelude.Monad
open import Prelude.Semiring

open import Agda.Builtin.String public
open import Agda.Builtin.FromString public

unpackString = primStringToList
packString   = primStringFromList

unpackString-inj : ∀ {x y} → unpackString x ≡ unpackString y → x ≡ y
unpackString-inj {x} p with unpackString x
unpackString-inj refl | ._ = unsafeEqual

infixr 5 _&_
_&_ = primStringAppend

-- Eq --

instance
  EqString : Eq String
  _==_ {{EqString}} x y with primStringEquality x y
  ... | true  = yes unsafeEqual
  ... | false = no  unsafeNotEqual

-- Ord --

instance
  OrdString : Ord String
  OrdString = OrdBy unpackString-inj

  OrdLawsString : Ord/Laws String
  OrdLawsString = OrdLawsBy unpackString-inj

-- Overloaded literals --

instance
  StringIsString : IsString String
  IsString.Constraint StringIsString _ = ⊤
  IsString.fromString StringIsString s = s

  ListIsString : IsString (List Char)
  IsString.Constraint ListIsString _ = ⊤
  IsString.fromString ListIsString s = unpackString s

-- Monoid --

instance
  open import Prelude.Monoid
  SemigroupString : Semigroup String
  _<>_   {{SemigroupString}} = primStringAppend

  MonoidString : Monoid String
  Monoid.super MonoidString = it
  mempty {{MonoidString}} = ""

-- More functions --

parseNat : String → Maybe Nat
parseNat = parseNat′ ∘ unpackString
  where
    pDigit : Char → Maybe Nat
    pDigit c =
      if isDigit c then just (charToNat c - charToNat '0')
                   else nothing

    pNat : Nat → List Char → Maybe Nat
    pNat n [] = just n
    pNat n (c ∷ s) = pDigit c >>= λ d → pNat (n * 10 + d) s

    parseNat′ : List Char → Maybe Nat
    parseNat′ [] = nothing
    parseNat′ (c ∷ s) = pDigit c >>= λ d → pNat d s

onChars : (List Char → List Char) → String → String
onChars f = packString ∘ f ∘ unpackString

words : String → List String
words = map packString ∘ wordsBy isSpace ∘ unpackString

ltrim : String → String
ltrim = onChars (dropWhile isSpace)

rtrim : String → String
rtrim = onChars (reverse ∘ dropWhile isSpace ∘ reverse)

trim : String → String
trim = rtrim ∘ ltrim

strTake : Nat → String → String
strTake n = onChars (take n)

strDrop : Nat → String → String
strDrop n = onChars (drop n)

strLength : String → Nat
strLength = length ∘ unpackString

strIsPrefixOf? : String → String → Bool
strIsPrefixOf? = isPrefixOf? on unpackString

strCommonPrefix : String → String → String
strCommonPrefix s₁ s₂ = packString $ (commonPrefix! on unpackString) s₁ s₂


module Generic.Lib.Reflection.Fold where

open import Generic.Lib.Intro
open import Generic.Lib.Decidable
open import Generic.Lib.Category
open import Generic.Lib.Data.Nat
open import Generic.Lib.Data.String
open import Generic.Lib.Data.Maybe
open import Generic.Lib.Data.List
open import Generic.Lib.Reflection.Core

foldTypeOf : Data Type -> Type
foldTypeOf (packData d a b cs ns) = appendType iab ∘ pi "π" π ∘ pi "P" P $ cs ʰ→ from ‵→ to where
  infixr 5 _ʰ→_
  i    = countPis a
  j    = countPis b
  ab   = appendType a b
  iab  = implicitize ab
  π    = implRelArg (quoteTerm Level)
  P    = explRelArg ∘ appendType (shiftBy (suc j) b) ∘ agda-sort ∘ set $ pureVar j
  hyp  = mapName (λ p -> appVar p ∘ drop i) d ∘ shiftBy (2 + j)
  _ʰ→_ = flip $ foldr (λ c r -> hyp c ‵→ shift r)
  from = appDef d (pisToArgVars (2 + i + j) ab)
  to   = appVar 1 (pisToArgVars (3 + j) b)

foldClausesOf : Name -> Data Type -> List Clause
foldClausesOf f (packData d a b cs ns) = allToList $ mapAllInd (λ {a} n -> clauseOf n a) ns where
  k = length cs

  clauseOf : ℕ -> Type -> Name -> Clause
  clauseOf i c n = clause lhs rhs where
    args = explPisToNames c
    j    = length args
    lhs  = patVars ("P" ∷ unmap (λ n -> "f" ++ˢ showName n) ns)
         ∷ʳ explRelArg (patCon n (patVars args))

    tryHyp : ℕ -> ℕ -> Type -> Maybe Term
    tryHyp m l (explPi r s a b) = explLam s <$> tryHyp (suc m) l b
    tryHyp m l (pi       s a b) = tryHyp m l b
    tryHyp m l (appDef e _)     = d == e ?> vis appDef f (pars ∷ʳ rarg) where
      pars = map (λ i -> pureVar (m + i)) $ downFromTo (suc k + j) j
      rarg = vis appVar (m + l) $ map pureVar (downFrom m)
    tryHyp m l  b               = nothing

    hyps : ℕ -> Type -> List Term
    hyps (suc l) (explPi r s a b) = fromMaybe (pureVar l) (tryHyp 0 l a) ∷ hyps l b
    hyps  l      (pi       s a b) = hyps l b
    hyps  l       b               = []

    rhs = vis appVar (k + j ∸ suc i) (hyps j c)

    -- i = 1: f
    -- j = 3: x t r
    -- k = 2: g f
    --      5 4 3       2 1 0    3 2       4 3 1     1 0         6 5  2 1 0
    -- fold P g f (cons x t r) = f x (fold g f t) (λ y u -> fold g f (r y u))

defineFold : Name -> Data Type -> TC _
defineFold f D =
  declareDef (explRelArg f) (foldTypeOf D) >>
  defineFun f (foldClausesOf f D)

deriveFold : Name -> Data Type -> TC Name
deriveFold d D =
  freshName ("fold" ++ˢ showName d) >>= λ f ->
  f <$ defineFold f D

deriveFoldTo : Name -> Name -> TC _
deriveFoldTo f = getData >=> defineFold f


------------------------------------------------------------------------------
-- Common properties for the alternating bit protocol
------------------------------------------------------------------------------

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

module FOTC.Program.ABP.PropertiesI where

open import FOTC.Base
open import FOTC.Program.ABP.ABP

------------------------------------------------------------------------------
-- Congruence properties

awaitCong₄ : ∀ {b i is ds₁ ds₂} → ds₁ ≡ ds₂ →
             await b i is ds₁ ≡ await b i is ds₂
awaitCong₄ refl = refl

corruptCong : ∀ {os₁ os₂} → os₁ ≡ os₂ → corrupt os₁ ≡ corrupt os₂
corruptCong refl = refl


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

module lib.groupoids.Groupoids where

open import lib.groupoids.FundamentalPreGroupoid public


module Fough where

open import Agda.Primitive renaming (_⊔_ to lmax)

record Setoid l : Set (lsuc l) where
  field
    El : Set l
    Eq : El -> El -> Set l
    Rf : (x : El) -> Eq x x
    Sy : (x y : El) -> Eq x y -> Eq y x
    Tr : (x y z : El) -> Eq x y -> Eq y z -> Eq x z
open Setoid

module PACKQ {l}(X : Setoid l) where

  record _|-_~~_ (x y : El X) : Set l where
    constructor eq
    field
      qe : Eq X x y

  open _|-_~~_ public

  qprf = qe

module _ {l}{X : Setoid l} where

  open PACKQ X

  infixr 5 _~[_>~_ _~<_]~_
  infixr 6 _[SQED]

  _~[_>~_ : forall x {y z} -> _|-_~~_ x y -> _|-_~~_ y z -> _|-_~~_ x z
  x ~[ eq q >~ eq q' = eq (Tr X _ _ _ q q')

  _~<_]~_ : forall x {y z} -> _|-_~~_ y x -> _|-_~~_ y z -> _|-_~~_ x z
  x ~< eq q ]~ eq q' = eq (Tr X _ _ _ (Sy X _ _ q) q')

  _[SQED] : forall x -> _|-_~~_ x x
  _[SQED] x = eq (Rf X x)

  rS : forall {x} -> _|-_~~_ x x
  rS {x} = eq (Rf X x)

open PACKQ public

module _ {l}{X : Set l} where
  data _~_ (x : X) : X -> Set l where
    r~ : x ~ x

{-# BUILTIN EQUALITY _~_ #-}

module _ {l}(X : Set l) where

  IN : Setoid l
  El IN = X
  Eq IN = _~_
  Rf IN x = r~
  Sy IN x y r~ = r~
  Tr IN x y z r~ q = q

module _ {k l}(S : Set k)(T : S -> Set l) where

  record _><_ : Set (lmax k l) where
    constructor _,_
    field
      fst : S
      snd : T fst
  open _><_ public

  infixr 10 _,_
  infixr 20 _><_

module _ (l : Level) where
  record One : Set l where constructor <>

infixr 20 _*_
_*_ : forall {k l} -> Set k -> Set l -> Set (lmax k l)
S * T = S >< \ _ -> T

infix 22 <_>
<_> : forall {k l}{S : Set k}(T : S -> Set l) -> Set (lmax k l)
< T > = _ >< T

infixr 23 _:*_
_:*_ : forall {k l}{S : Set k}(T U : S -> Set l) -> S -> Set l
(T :* U) s = T s * U s

infixr 11 _&_
pattern _&_ s t = _ , s , t

infixr 9 _/\_
_/\_ : forall {k l}{S : Set k}{T : Set l} -> S -> T -> S * T
s /\ t = s , t

module _ {k l}(S : Set k)(T : S -> Setoid l) where

  PI : Setoid (lmax k l)
  El PI     = (s : S) -> El (T s)
  Eq PI f g = (s : S) -> Eq (T s) (f s) (g s)
  Rf PI f s         = Rf (T s) (f s)
  Sy PI f g q s     = Sy (T s) (f s) (g s) (q s)
  Tr PI f g h p q s = Tr (T s) (f s) (g s) (h s) (p s) (q s)

  IM : Setoid (lmax k l)
  El IM     = {s : S} -> El (T s)
  Eq IM f g = (s : S) -> Eq (T s) (f {s}) (g {s})
  Rf IM f s         = Rf (T s) f
  Sy IM f g q s     = Sy (T s) f g (q s)
  Tr IM f g h p q s = Tr (T s) f g h (p s) (q s)

  SG : Setoid (lmax k l)
  El SG = S >< \ s -> El (T s)
  Eq SG (s0 , t0) (s1 , t1) = (s0 ~ s1) >< \ { r~ -> Eq (T s0) t0 t1 }
  Rf SG (s , t) = r~ , Rf (T s) t
  Sy SG (s0 , t0) (.s0 , t1) (r~ , q) = r~ , Sy (T s0) t0 t1 q
  fst (Tr SG (s0 , t0) (.s0 , t1) (s2 , t2) (r~ , q01) (q , q12)) = q
  snd (Tr SG (s0 , t0) (.s0 , t1) (.s0 , t2) (r~ , q01) (r~ , q12)) = Tr (T s0) t0 t1 t2 q01 q12

module _ {k l}(T : Setoid k)(P : El T -> Set l) where

  EX : Setoid (lmax k l)
  El EX = El T >< P
  Eq EX (t0 , _) (t1 , _) = Eq T t0 t1 * One l
  Rf EX (t , _) = Rf T t , <>
  Sy EX (t0 , _) (t1 , _) (q , <>) = Sy T t0 t1 q , <>
  Tr EX (t0 , _) (t1 , _) (t2 , _) (q01 , <>) (q12 , <>) =
    Tr T t0 t1 t2 q01 q12 , <>

module _ (k l : Level) where

  record Cat : Set (lsuc (lmax k l)) where
    field
      Obj  : Set k
      Arr  : Obj -> Obj -> Setoid l
    _~>_ : Obj -> Obj -> Set l
    S ~> T = El (Arr S T)
    _~~_ : {S T : Obj}(f g : S ~> T) -> Set l
    _~~_ {S}{T} = _|-_~~_ (Arr S T)
    field
      id   : {T : Obj} -> T ~> T
      _-_  : {R S T : Obj} -> R ~> S -> S ~> T -> R ~> T
      coex : {R S T : Obj}{f f' : R ~> S}{g g' : S ~> T} ->
             f ~~ f' -> g ~~ g' -> (f - g) ~~ (f' - g')
      idco : {S T : Obj}(f : S ~> T) -> (id - f) ~~ f
      coid : {S T : Obj}(f : S ~> T) -> (f - id) ~~ f
      coco : {R S T U : Obj}(f : R ~> S)(g : S ~> T)(h : T ~> U) ->
               (f - (g - h)) ~~ ((f - g) - h)

module _ (l : Level) where
  open Cat

  SET : Cat (lsuc l) l
  Obj  SET = Set l
  Arr  SET S T = PI S \ _ -> IN T
  id   SET x = x
  _-_  SET f g x = g (f x)
  qe (coex SET (eq qf) (eq qg)) x rewrite qf x = qg _
  qe (idco SET f) x = r~
  qe (coid SET f) x = r~
  qe (coco SET f g h) x = r~

module _ {l k l' k'}(C : Cat l k)(D : Cat l' k') where
  private module C = Cat C ; module D = Cat D

  Fun : Setoid (lmax l (lmax k (lmax l' k')))
  Fun = SG (C.Obj -> D.Obj) \ Map ->
        EX (IM C.Obj \ S -> IM C.Obj \ T ->
            PI (S C.~> T) \ _ -> D.Arr (Map S) (Map T)) \ map ->
        ({S T : C.Obj}{f g : S C.~> T} -> f C.~~ g -> map f D.~~ map g)
      * ({X : C.Obj} -> map (C.id {X}) D.~~ D.id {Map X})
      * ({R S T : C.Obj}(f : R C.~> S)(g : S C.~> T) ->
          map (f C.- g) D.~~ (map f D.- map g))

module _ (l k : Level) where

  CAT : Cat (lsuc (lmax l k)) (lmax l k)
  Cat.Obj CAT = Cat l k
  Cat.Arr CAT = Fun
  Cat.id CAT {C}
    = (\ X -> X) , (\ f -> f)
    , (\ q -> q)
    , rS
    , \ _ _ -> rS
    where open Cat C
  Cat._-_  CAT {C}{D}{E} (F , fm , fx , fi , fc) (G , gm , gx , gi , gc)
    = (\ X -> G (F X)) , (\ a -> gm (fm a))
    , (\ q -> gx (fx q))
    , (gm (fm C.id) ~[ gx fi >~
       gm (D.id)    ~[ gi >~
       E.id          [SQED])
    , \ f g ->
       gm (fm (f C.- g))         ~[ gx (fc _ _) >~
       gm (fm f D.- fm g)        ~[ gc _ _ >~
       (gm (fm f) E.- gm (fm g))  [SQED]
    where private module C = Cat C ; module D = Cat D ; module E = Cat E
  qe (Cat.coex CAT {C} {D} {E} {F , fm , fz} {F' , fm' , fz'} {G , gm , gx , gz} {G' , gm' , gz'}
     (eq (r~ , qf , <>)) (eq (r~ , qg , <>)))
     = r~
     , (\ S T f -> qe {X = Cat.Arr E (G (F S)) (G (F T))}
       (gm (fm f)    ~[ gx (eq (qf _ _ _)) >~
        gm (fm' f)   ~[ eq (qg _ _ _) >~
        gm' (fm' f)   [SQED]))
     , <>
  qe (Cat.idco CAT {C}{D} (F , fm , fz)) =
    r~ , (\ S T f -> qprf (D.Arr (F S) (F T)) rS) , <>
    where private module C = Cat C ; module D = Cat D
  qe (Cat.coid CAT {C} {D} (F , fm , fz)) =
    r~ , (\ S T f -> qprf (D.Arr (F S) (F T)) rS) , <>
    where private module C = Cat C ; module D = Cat D
  qe (Cat.coco CAT {B} {C} {D} {E} (F , fm , fz) (G , gm , gz) (H , hm , hz))
    = r~
    , (\ S T f -> qprf (Cat.Arr E (H (G (F S))) (H (G (F T)))) rS )
    , <>

module _ {l k l' k' : Level}(C : Cat l k)(D : Cat l' k') where
  private module C = Cat C ; module D = Cat D

  _=>_ : Cat (lmax l (lmax k (lmax l' k'))) (lmax l (lmax k k'))
  Cat.Obj _=>_ = El (Fun C D)
  Cat.Arr _=>_ (F , fm , _) (G , gm , _) =
    EX (IM C.Obj \ X -> D.Arr (F X) (G X)) \ n ->
    {S T : C.Obj}(f : S C.~> T) -> (fm f D.- n {T}) D.~~ (n {S} D.- gm f)
  Cat.id _=>_ {F , fm , _}
    = D.id
    , \ f ->
      fm f D.- D.id   ~[ D.coid _ >~
      fm f            ~< D.idco _ ]~
      (D.id D.- fm f)  [SQED]
  Cat._-_ _=>_ {F , fm , fx , fi , fc} {G , gm , gx , gi , gc} {H , hm , hx , hi , hc}
    (n , na) (p , pa)
    = n D.- p
    , \ f ->
      fm f D.- (n D.- p)   ~[ D.coco _ _ _ >~
      (fm f D.- n) D.- p   ~[ D.coex (na f) rS >~
      (n D.- gm f) D.- p   ~< D.coco _ _ _ ]~
      n D.- (gm f D.- p)   ~[ D.coex rS (pa f) >~
      n D.- (p D.- hm f)   ~[ D.coco _ _ _ >~
      ((n D.- p) D.- hm f   [SQED])
  qe (Cat.coex _=>_ (eq (nq , <>)) (eq (pq , <>)))
    = (\ X -> qe (D.coex (eq (nq X)) (eq (pq X))))
    , <>
  qe (Cat.idco _=>_ _) = (\ _ -> qe (D.idco _)) , <>
  qe (Cat.coid _=>_ _) = (\ _ -> qe (D.coid _)) , <>
  qe (Cat.coco _=>_ _ _ _) = (\ _ -> qe (D.coco _ _ _)) , <>

module _ {l k : Level}(C : Cat l k)(I : Cat.Obj C) where
  open Cat C

  _/_ : Cat (lmax l k) k
  Cat.Obj _/_ = Obj >< \ X -> X ~> I
  Cat.Arr _/_ (X , f) (Y , g) = EX (Arr X Y) \ h -> (h - g) ~~ f
  Cat.id _/_ = id , idco _
  Cat._-_ _/_ {R , r}{S , s}{T , t} (f , p) (g , q)
    = (f - g)
    , ((f - g) - t ~< coco _ _ _ ]~
       f - (g - t) ~[ coex rS q >~
       f - s ~[ p >~
       r [SQED])
  qe (Cat.coex _/_ (eq (q , <>)) (eq (q' , <>))) = qe (coex (eq q) (eq q')) , <>
  qe (Cat.idco _/_ _) = qe (idco _) , <>
  qe (Cat.coid _/_ _) = qe (coid _) , <>
  qe (Cat.coco _/_ _ _ _) = qe (coco _ _ _) , <>

module BWD (X : Set) where
  data Bwd : Set where
    _-,_ : Bwd -> X -> Bwd
    [] : Bwd
  infixl 30 _-,_

module _ {X : Set} where
  open BWD X

  data _<=_ : Bwd -> Bwd -> Set where
    _-^_ : forall {ga de} -> ga <= de -> forall x -> ga <= (de -, x)
    _-,_ : forall {ga de} -> ga <= de -> forall x -> (ga -, x) <= (de -, x)
    []   : [] <= []
  infixl 30 _-^_

  data <_-_>~_ : forall {ga de ze}(th : ga <= de)(ph : de <= ze)(ps : ga <= ze) -> Set where
    _-^_  : forall {ga de ze}{th : ga <= de}{ph : de <= ze}{ps : ga <= ze} ->
            < th - ph >~ ps -> forall x -> < th - ph -^ x >~ ps -^ x
    _-^,_ : forall {ga de ze}{th : ga <= de}{ph : de <= ze}{ps : ga <= ze} ->
            < th - ph >~ ps -> forall x -> < th -^ x - ph -, x >~ ps -^ x
    _-,_  : forall {ga de ze}{th : ga <= de}{ph : de <= ze}{ps : ga <= ze} ->
            < th - ph >~ ps -> forall x -> < th -, x - ph -, x >~ ps -, x
    []    : < [] - [] >~ []
  infix 25 <_-_>~_
  infixl 30 _-^,_

  io : forall {ga} -> ga <= ga
  io {ga -, x} = io {ga} -, x
  io {[]} = []

  mkCo : forall {ga de ze}(th : ga <= de)(ph : de <= ze) -> <(< th - ph >~_)>
  mkCo th         (ph -^ x) = let _ , v = mkCo th ph in _ , v -^ x
  mkCo (th -^ .x) (ph -, x) = let _ , v = mkCo th ph in _ , v -^, x
  mkCo (th -, .x) (ph -, x) = let _ , v = mkCo th ph in _ , v -, x
  mkCo []         []        = _ , []

  _~-~_ : forall {ga de ze}{th : ga <= de}{ph : de <= ze}{ps0 ps1 : ga <= ze} ->
          (v0 : < th - ph >~ ps0)(v1 : < th - ph >~ ps1) ->
          (ps0 ~ ps1) >< \ { r~ -> v0 ~ v1 }
  (v0 -^ x)  ~-~ (v1 -^ .x)   with r~ , r~ <- v0 ~-~ v1 = r~ , r~
  (v0 -^, x) ~-~ (v1 -^, .x)  with r~ , r~ <- v0 ~-~ v1 = r~ , r~
  (v0 -, x)  ~-~ (v1 -, .x)   with r~ , r~ <- v0 ~-~ v1 = r~ , r~
  []         ~-~ []                                     = r~ , r~

  _-<=_ : forall {ga de ze} -> ga <= de -> de <= ze -> ga <= ze
  th -<= ph = fst (mkCo th ph)

  io- : forall {ga de}(th : ga <= de) -> < io - th >~ th
  io- (th -^ x) = io- th -^ x
  io- (th -, x) = io- th -, x
  io- [] = []

  infixl 30 _-io
  _-io : forall {ga de}(th : ga <= de) -> < th - io >~ th
  th -^ x -io = th -io -^, x
  th -, x -io = th -io -, x
  [] -io = []

  assoc02 : forall {ga0 ga1 ga2 ga3}
              {th01 : ga0 <= ga1}{th23 : ga2 <= ga3}
              {th03 : ga0 <= ga3}{th12 : ga1 <= ga2} ->
              <(< th01 -_>~ th03)  :* (< th12 - th23 >~_)> ->
              <(< th01 - th12 >~_) :* (<_- th23 >~ th03)>
  assoc02 (v -^ .x & w -^ x) = let v' & w' = assoc02 (v & w) in v' & w' -^ x
  assoc02 (v -^ .x & w -^, x) = let v' & w' = assoc02 (v & w) in v' -^ x & w' -^, x
  assoc02 (v -^, .x & w -, x) = let v' & w' = assoc02 (v & w) in v' -^, x & w' -^, x
  assoc02 (v -, .x & w -, x) = let v' & w' = assoc02 (v & w) in v' -, x & w' -, x
  assoc02 ([] & []) = [] & []

  assoc03 : forall {ga0 ga1 ga2 ga3}
              {th01 : ga0 <= ga1}{th23 : ga2 <= ga3}
              {th02 : ga0 <= ga2}{th13 : ga1 <= ga3} ->
              <(< th01 -_>~ th02)  :* (<_- th23 >~ th13)> ->
              <(< th01 - th13 >~_) :* (< th02 - th23 >~_)>
  assoc03 {th01 = th}{th13 = ph} (v & w) with _ , v' <- mkCo th ph |
    v0 & v1 <- assoc02 (v' & w) | r~ , r~ <- v ~-~ v0 = v' & v1

  assoc13 : forall {ga0 ga1 ga2 ga3}
              {th01 : ga0 <= ga1}{th23 : ga2 <= ga3}
              {th03 : ga0 <= ga3}{th12 : ga1 <= ga2} ->
              <(< th01 - th12 >~_)  :* (<_- th23 >~ th03)> ->
              <(< th01 -_>~ th03) :* (< th12 - th23 >~_)>
  assoc13 {th23 = ph}{th12 = th} (v & w) with  _ , v' <- mkCo th ph |
    v0 & v1 <- assoc03 (v & v') | r~ , r~ <- w ~-~ v1 = v0 & v'

  THIN : Cat lzero lzero
  Cat.Obj  THIN = Bwd
  Cat.Arr  THIN ga de = IN (ga <= de)
  Cat.id   THIN = io
  Cat._-_  THIN = _-<=_
  Cat.coex THIN (eq r~) (eq r~) = eq r~
  Cat.idco THIN th with v <- io- th | _ , w <- mkCo io th | r~ , r~ <- v ~-~ w
    = rS
  Cat.coid THIN ph with v <- ph -io | _ , w <- mkCo ph io | r~ , r~ <- v ~-~ w
    = rS
  Cat.coco THIN th ph ps with thph , v <- mkCo th ph | phps , w <- mkCo ph ps |
    _ , v1 <- mkCo thph ps | _ , w1 <- mkCo th phps |
    v2 & w2 <- assoc02 (w1 & w) | r~ , r~ <- v ~-~ v2 | r~ , r~ <- v1 ~-~ w2
    = rS

  THIN/ : Bwd -> Cat lzero lzero
  Cat.Obj (THIN/ de) = <(_<= de)>
  Cat.Arr (THIN/ de) (_ , th0) (_ , th1) = EX (IN _) (<_- th1 >~ th0)
  Cat.id (THIN/ de) = io , io- _
  Cat._-_ (THIN/ de) (th0 , v0) (th1 , v1) with w0 & w1 <- assoc02 (v0 & v1)
    = _ , w1
  qe (Cat.coex (THIN/ de) {f = _ , v0} {._ , w0} {_ , v1} {._ , w1}
    (eq (r~ , <>)) (eq (r~ , <>))) with
    (r~ , r~) , (r~ , r~) <- v0 ~-~ w0 /\ v1 ~-~ w1
    = r~ , <>
  qe (Cat.idco (THIN/ de) {_ , ph} (th , v)) with
    w <- io- th | w' & _ <- assoc02 (io- ph & v) | r~ , r~ <- w ~-~ w'
    = r~ , <>
  qe (Cat.coid (THIN/ de) {T = _ , ph} (th , v)) with
    w <- th -io | w' & _ <- assoc02 (v & io- ph) | r~ , r~ <- w ~-~ w'
    = r~ , <>
  qe (Cat.coco (THIN/ de) (_ , v01) (_ , v12) (_ , v23)) with
    w13  & v13  <- assoc02 (v12 & v23) | w02  & v02  <- assoc02 (v01 & v12) |
    w013 & v013 <- assoc02 (v01 & v13) | w023 & v023 <- assoc02 (v02 & v23) |
    w013' & w023' <- assoc03 (w02 & w13) |
    (r~ , r~) , (r~ , r~) <- w013' ~-~ w013 /\ w023' ~-~ w023
    = r~ , <>


-- {-# OPTIONS -v tc.proj.like:10 #-}
-- {-# OPTIONS -v tc.conv:10 #-}
open import Common.Level

module ProjectionLikeAndModules (A : Set) (a : A) where

record ⊤ : Set where
  constructor tt

data Wrap (W : Set) : Set where
  wrap : W → Wrap W

data Bool : Set where
  true false : Bool

-- postulate

-- `or' should be projection like in the module parameters
if : Bool → {ℓ : Level} {B : Set ℓ} → B → B → B
if true  a b = a
if false a b = b

postulate
  u v : ⊤
  P : {ℓ : Level} {C : Set ℓ} (c : C) -> Set

test : (y : Bool)
  -> P (if y (wrap u) (wrap tt))
  -> P (if y (wrap tt) (wrap v))
test y h = h

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


module FFI.Data.Maybe where

{-# FOREIGN GHC import qualified Data.Maybe #-}

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just : A → Maybe A
{-# COMPILE GHC Maybe = data Data.Maybe.Maybe (Data.Maybe.Nothing|Data.Maybe.Just) #-}


-- Andreas, 2017-09-09
-- Builtin constructors may be ambiguous / overloaded.

data Semmel : Set where
  false : Semmel

data Bool : Set where
  true  : Bool
  false : Bool

{-# BUILTIN BOOL  Bool #-}
{-# BUILTIN TRUE  true #-}
{-# BUILTIN FALSE false  #-}  -- This is accepted.

data Brezel A : Set where
  _∷_ : (x : A) (xs : Brezel A) → Brezel A

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

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

{-# BUILTIN LIST List₀ #-}


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

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

open import LibraBFT.Prelude

-- This module defines functionality modeling an RWS monad, which we use to
-- define an implementation, and functionality for proving properties about
-- programs written using this RWS monad. The main definitions are:
-- 1. RWS, a datatype for the ASTs of stateful programs that read from an
--    environment and produce output.
--    This datatype includes constructors for branching code, to aid in the
--    verification effort (see below).
-- 2. RWS-weakestPre, a large elimination that, given an RWS program and a
--    post condition for the program, produces the weakest precondition needed
--    to satisfy that post condition. Branches in code using the constructors
--    `RWS-if` and friends are translated into products, with each component of
--    the product corresponding to a possible branch taken.
-- 3. RWS-Contract is the type of proofs that, given a stateful computation and
--    a post condition, the weakest precondition suffices to prove that post
--    condition.
-- 4. RWS-contract proves RWS-Contract, i.e., for every stateful computation
--    `m` and post condition `P`, given a proof over a pre-state `pre` the
--    weakest precondition for `P` holds, then postcondition `P` holds for the
--    post-state obtained from running `m` in state `pre`.

-- TODO-2: this module is independent of any particular implementation
-- and arguably belongs somewhere more general, such as next to Optics.

module LibraBFT.ImplShared.Util.Dijkstra.RWS where

-- RWS, the AST of computations with state `St` reading from an environment
-- `Ev` and producing a list of outputs of type `Wr`
data RWS (Ev Wr St : Set) : Set → Set₁ where
  -- Primitive combinators
  RWS-return : ∀ {A}   → A                                       → RWS Ev Wr St A
  RWS-bind   : ∀ {A B} → RWS Ev Wr St A → (A → RWS Ev Wr St B)   → RWS Ev Wr St B
  RWS-gets   : ∀ {A} → (St → A)                                  → RWS Ev Wr St A
  RWS-put    : St                                                → RWS Ev Wr St Unit
  RWS-ask    :                                                     RWS Ev Wr St Ev
  RWS-tell   : List Wr                                           → RWS Ev Wr St Unit
  -- Branching combinators (used for creating more convenient contracts)
  RWS-if     : ∀ {A} → Guards (RWS Ev Wr St A)                   → RWS Ev Wr St A
  RWS-either : ∀ {A B C} → Either B C
                → (B → RWS Ev Wr St A) → (C → RWS Ev Wr St A)    → RWS Ev Wr St A
  RWS-ebind  : ∀ {A B C}
                → RWS Ev Wr St (Either C A)
                → (A → RWS Ev Wr St (Either C B))                → RWS Ev Wr St (Either C B)
  RWS-maybe  : ∀ {A B} → Maybe B
                → (RWS Ev Wr St A) → (B → RWS Ev Wr St A)        → RWS Ev Wr St A

private
  variable
    Ev Wr St : Set
    A B C    : Set

-- To execute an RWS program, you provide an environment and prestate. This
-- produces a result value, poststate, and list of outputs.
RWS-run : RWS Ev Wr St A → Ev → St → A × St × List Wr
RWS-run (RWS-return x) ev st  = x , st , []
RWS-run (RWS-bind m f) ev st
   with RWS-run m ev st
...| x₁ , st₁ , outs₁
   with RWS-run (f x₁) ev st₁
...| x₂ , st₂ , outs₂           = x₂ , st₂ , outs₁ ++ outs₂
RWS-run (RWS-gets f) ev st    = f st , st , []
RWS-run (RWS-put st) ev _     = unit , st , []
RWS-run RWS-ask ev st         = ev , st , []
RWS-run (RWS-tell outs) ev st = unit , st , outs
RWS-run (RWS-if (clause (b ≔ c) gs)) ev st =
  if toBool b then RWS-run c ev st else RWS-run (RWS-if gs) ev st
RWS-run (RWS-if (otherwise≔ c)) ev st = RWS-run c ev st
RWS-run (RWS-either (Left x) f₁ f₂) ev st = RWS-run (f₁ x) ev st
RWS-run (RWS-either (Right y) f₁ f₂) ev st = RWS-run (f₂ y) ev st
RWS-run (RWS-ebind m f) ev st
   with RWS-run m ev st
...| Left c , st₁ , outs₁ = Left c , st₁ , outs₁
...| Right a , st₁ , outs₁
   with RWS-run (f a) ev st₁
...| r , st₂ , outs₂ = r , st₂ , outs₁ ++ outs₂
RWS-run (RWS-maybe nothing f₁ f₂) ev st = RWS-run f₁ ev st
RWS-run (RWS-maybe (just x) f₁ f₂) ev st = RWS-run (f₂ x) ev st

-- Accessors for the result, poststate, and outputs.
RWS-result : RWS Ev Wr St A → Ev → St → A
RWS-result m ev st = proj₁ (RWS-run m ev st)

RWS-post : RWS Ev Wr St A → Ev → St → St
RWS-post m ev st = proj₁ (proj₂ (RWS-run m ev st))

RWS-outs : RWS Ev Wr St A → Ev → St → List Wr
RWS-outs m ev st = proj₂ (proj₂ (RWS-run m ev st))

-- Preconditions are predicates over environments and prestates.
RWS-Pre : (Ev St : Set) → Set₁
RWS-Pre Ev St = (ev : Ev) (pre : St) → Set

-- Postconditions are predicates over a result, poststate, and list of outputs.
RWS-Post : (Wr St A : Set) → Set₁
RWS-Post Wr St A = (x : A) (post : St) (outs : List Wr) → Set

RWS-Post-⇒ : (P Q : RWS-Post Wr St A) → Set
RWS-Post-⇒ P Q = ∀ r st outs → P r st outs → Q r st outs

-- RWS-weakestPre computes a predicate transformer: it maps a RWS
-- computation `m` and desired postcondition `Post` to the weakest precondition
-- needed to prove `P` holds after running `m`.
RWS-PredTrans : (Ev Wr St A : Set) → Set₁
RWS-PredTrans Ev Wr St A = RWS-Post Wr St A → RWS-Pre Ev St

-- When RWS computations are sequenced, e.g., `RWS-bind m λ x → f x`,
-- outputs are concatenated. The postcondition desired for the above sequence
-- becomes a postcondition for `f x` in which the outputs of `m` are prepended
-- to the outputs of `f x`.
RWS-Post++ : ∀ {Wr St A} → RWS-Post Wr St A → List Wr → RWS-Post Wr St A
RWS-Post++ P outs x post outs₁ = P x post (outs ++ outs₁)

-- Consider again the sequence `RWS-bind m₁ λ x → f x`. We also translate a
-- postcondition `P` for the sequence into a postcondition for `m` ---
-- specifically, the post condition we want for `m` is that the weakest
-- precondition for `RWS-Post++ P outs` holds, where `outs` are the outputs of
-- `m`.
RWS-weakestPre-bindPost  : (ev : Ev) (f : A → RWS Ev Wr St B) → RWS-Post Wr St B → RWS-Post Wr St A
RWS-weakestPre-ebindPost : (ev : Ev) (f : A → RWS Ev Wr St (C ⊎ B)) → RWS-Post Wr St (C ⊎ B) → RWS-Post Wr St (C ⊎ A)

RWS-weakestPre : (m : RWS Ev Wr St A) → RWS-PredTrans Ev Wr St A
RWS-weakestPre (RWS-return x) P ev pre = P x pre []
RWS-weakestPre (RWS-bind m f) P ev pre =
  RWS-weakestPre m (RWS-weakestPre-bindPost ev f P) ev pre
RWS-weakestPre (RWS-gets f) P ev pre = P (f pre) pre []
RWS-weakestPre (RWS-put post) P ev pre = P unit post []
RWS-weakestPre RWS-ask P ev pre = P ev pre []
RWS-weakestPre (RWS-tell outs) P ev pre = P unit pre outs
RWS-weakestPre (RWS-if (clause (b ≔ c) gs)) P ev pre =
  (toBool b ≡ true → RWS-weakestPre c P ev pre)
  × (toBool b ≡ false → RWS-weakestPre (RWS-if gs) P ev pre)
RWS-weakestPre (RWS-if (otherwise≔ c)) P ev pre =
  RWS-weakestPre c P ev pre
RWS-weakestPre (RWS-either e f₁ f₂) P ev pre =
    (∀ x → (e ≡ Left x) →
      RWS-weakestPre (f₁ x) P ev pre)
  × (∀ y → (e ≡ Right y) →
       RWS-weakestPre (f₂ y) P ev pre)
RWS-weakestPre (RWS-ebind m f) P ev pre =
  RWS-weakestPre m (RWS-weakestPre-ebindPost ev f P) ev pre
RWS-weakestPre (RWS-maybe m f₁ f₂) P ev pre =
  (m ≡ nothing → RWS-weakestPre f₁ P ev pre)
  × (∀ j → m ≡ just j → RWS-weakestPre (f₂ j) P ev pre)

RWS-weakestPre-ebindPost ev f Post (Left r) post outs =
  Post (Left r) post outs
RWS-weakestPre-ebindPost ev f Post (Right r) post outs =
  ∀ c → c ≡ r → RWS-weakestPre (f c) (RWS-Post++ Post outs) ev post

RWS-weakestPre-bindPost ev f Post x post outs =
  ∀ r → r ≡ x → RWS-weakestPre (f r) (RWS-Post++ Post outs) ev post

-- The post condition `P` holds for `m` with environment `ev` and prestate `pre`
RWS-Post-True : (P : RWS-Post Wr St A) (m : RWS Ev Wr St A) (ev : Ev) (pre : St) → Set
RWS-Post-True P m ev pre =
  let (x , post , outs) = RWS-run m ev pre in
  P x post outs

-- For every RWS computation `m`, `RWS-Contract m` is the type of proofs that,
-- for all post conditions `P`, starting environments `ev` and prestates `pre`,
-- to prove that `P` holds after running `m` in `ev` and `pre`, it suffices to
-- provide a proof of the weakest precondition for `P` with respect to `m`,
-- `ev`, and `pre`.
RWS-Contract : (m : RWS Ev Wr St A) → Set₁
RWS-Contract{Ev}{Wr}{St}{A} m =
  (P : RWS-Post Wr St A)
  → (ev : Ev) (pre : St) → RWS-weakestPre m P ev pre
  → RWS-Post-True P m ev pre

-- This proves that `RWS-weakestPre` gives a *sufficient* precondition for
-- establishing a desired postcondition. Note thought that it does not prove
-- that this precondition is the weakest such one; even though this is true, it
-- is not important for our purposes.
RWS-contract : (m : RWS Ev Wr St A) → RWS-Contract m
RWS-contract (RWS-return x₁) P ev pre wp = wp
RWS-contract (RWS-bind m f) P ev pre wp
   with RWS-contract m _ ev pre wp
...| con
   with RWS-run m ev pre
...| x₁ , st₁ , outs₁ =
  RWS-contract (f x₁) _ ev st₁ (con x₁ refl)
RWS-contract (RWS-gets f) P ev pre wp = wp
RWS-contract (RWS-put x₁) P ev pre wp = wp
RWS-contract RWS-ask P ev pre wp = wp
RWS-contract (RWS-tell x₁) P ev pre wp = wp
RWS-contract{Ev}{Wr}{St}{A} (RWS-if gs) P ev pre wp = RWS-contract-if gs P ev pre wp
  where
  RWS-contract-if : (gs : Guards (RWS Ev Wr St A)) → RWS-Contract (RWS-if gs)
  RWS-contract-if (clause (b ≔ c) gs) P ev pre (wp₁ , wp₂)
    with toBool b
  ...| true = RWS-contract c _ ev pre (wp₁ refl)
  ...| false = RWS-contract-if gs _ ev pre (wp₂ refl)
  RWS-contract-if (otherwise≔ x) P ev pre wp =
    RWS-contract x P ev pre wp
RWS-contract (RWS-either (Left x) f₁ f₂) P ev pre (wp₁ , wp₂) =
  RWS-contract (f₁ x) _ ev pre (wp₁ x refl)
RWS-contract (RWS-either (Right y) f₁ f₂) P ev pre (wp₁ , wp₂) =
  RWS-contract (f₂ y) _ ev pre (wp₂ y refl)
RWS-contract (RWS-ebind m f) P ev pre wp
   with RWS-contract m _ ev pre wp
...| con
   with RWS-run m ev pre
... | Left x , st₁ , outs₁ = con
... | Right y , st₁ , outs₁ = RWS-contract (f y) _ ev st₁ (con y refl)
RWS-contract (RWS-maybe nothing f₁ f₂) P ev pre (wp₁ , wp₂)
  = RWS-contract f₁ _ ev pre (wp₁ refl)
RWS-contract (RWS-maybe (just x) f₁ f₂) P ev pre (wp₁ , wp₂) =
  RWS-contract (f₂ x) _ ev pre (wp₂ x refl)

-- This helper function is primarily used to take a proof concerning one
-- computation `m` and show that that proof implies a property concerning a
-- larger computation which contains `m`.
RWS-⇒
  : (P Q : RWS-Post Wr St A) → (RWS-Post-⇒ P Q)
    → ∀ m (ev : Ev) st → RWS-weakestPre m P ev st → RWS-weakestPre m Q ev st
RWS-⇒ P Q pf (RWS-return x) ev st pre = pf x st [] pre
RWS-⇒ P Q pf (RWS-bind m f) ev st pre =
  RWS-⇒ _ _
    (λ r₁ st₁ outs₁ pf₁ x x≡ →
      RWS-⇒ _ _
        (λ r₂ st₂ outs₂ pf₂ → pf r₂ st₂ (outs₁ ++ outs₂) pf₂)
        (f x) ev st₁ (pf₁ x x≡))
    m ev st pre
RWS-⇒ P Q pf (RWS-gets f) ev st pre = pf _ _ _ pre
RWS-⇒ P Q pf (RWS-put x) ev st pre = pf _ _ _ pre
RWS-⇒ P Q pf RWS-ask ev st pre = pf _ _ _ pre
RWS-⇒ P Q pf (RWS-tell x) ev st pre = pf _ _ _ pre
RWS-⇒ P Q pf (RWS-if (otherwise≔ x)) ev st pre = RWS-⇒ _ _ pf x ev st pre
RWS-⇒ P Q pf (RWS-if (clause (b ≔ c) cs)) ev st (pre₁ , pre₂) =
  (λ pf' → RWS-⇒ _ _ pf c ev st (pre₁ pf'))
  , λ pf' → RWS-⇒ _ _ pf (RWS-if cs) ev st (pre₂ pf')
proj₁ (RWS-⇒ P Q pf (RWS-either (Left x) f₁ f₂) ev st (pre₁ , pre₂)) x₁ x₁≡ =
  RWS-⇒ _ _ pf (f₁ x₁) ev st (pre₁ x₁ x₁≡)
proj₂ (RWS-⇒ P Q pf (RWS-either (Left x) f₁ f₂) ev st (pre₁ , pre₂)) y ()
proj₁ (RWS-⇒ P Q pf (RWS-either (Right y) f₁ f₂) ev st (pre₁ , pre₂)) y₁ ()
proj₂ (RWS-⇒ P Q pf (RWS-either (Right y) f₁ f₂) ev st (pre₁ , pre₂)) y₁ y₁≡ =
  RWS-⇒ _ _ pf (f₂ y₁) ev st (pre₂ y₁ y₁≡)
RWS-⇒ P Q pf (RWS-ebind m f) ev st pre =
  RWS-⇒ _ _
    (λ { (Left x₁) st₁ outs x → pf _ _ _ x
       ; (Right y) st₁ outs x → λ c x₁ →
           RWS-⇒ _ _ (λ r st₂ outs₁ x₂ → pf r st₂ (outs ++ outs₁) x₂) (f c) ev st₁ (x c x₁)})
    m ev st pre
proj₁ (RWS-⇒ P Q pf (RWS-maybe x m f) ev st (pre₁ , pre₂)) ≡nothing = RWS-⇒ _ _ pf m ev st (pre₁ ≡nothing)
proj₂ (RWS-⇒ P Q pf (RWS-maybe x m f) ev st (pre₁ , pre₂)) b b≡ = RWS-⇒ _ _ pf (f b) ev st (pre₂ b b≡)

RWS-⇒-bind
  : (P : RWS-Post Wr St A) (Q : RWS-Post Wr St B)
    → (f : A → RWS Ev Wr St B) (ev : Ev)
    → RWS-Post-⇒ P (RWS-weakestPre-bindPost ev f Q)
    → ∀ m st → RWS-weakestPre m P ev st
    → RWS-weakestPre (RWS-bind m f) Q ev st
RWS-⇒-bind P Q f ev pf m st con =
  RWS-⇒ P ((RWS-weakestPre-bindPost ev f Q)) pf m ev st con

RWS-⇒-ebind
  : (P : RWS-Post Wr St (Either C A)) (Q : RWS-Post Wr St (Either C B))
    → (f : A → RWS Ev Wr St (Either C B)) (ev : Ev)
    → RWS-Post-⇒ P (RWS-weakestPre-ebindPost ev f Q)
    → ∀ m st → RWS-weakestPre m P ev st
    → RWS-weakestPre (RWS-ebind m f) Q ev st
RWS-⇒-ebind P Q f ev pf m st con =
  RWS-⇒ P ((RWS-weakestPre-ebindPost ev f Q)) pf m ev st con


open import Common.Prelude

test : Nat → Nat
test = _Common.Prelude.+ 2


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Maybe type
------------------------------------------------------------------------

-- The definitions in this file are reexported by Data.Maybe.

module Data.Maybe.Core where

open import Level

data Maybe {a} (A : Set a) : Set a where
  just    : (x : A) → Maybe A
  nothing : Maybe A

{-# IMPORT Data.FFI #-}
{-# COMPILED_DATA Maybe Data.FFI.AgdaMaybe Just Nothing #-}


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

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

module Data.List.Relation.Pointwise where

open import Data.List.Relation.Binary.Pointwise public

{-# WARNING_ON_IMPORT
"Data.List.Relation.Pointwise was deprecated in v1.0.
Use Data.List.Relation.Binary.Pointwise instead."
#-}


-- Export only the experiments that are expected to compile (without
-- any holes)
{-# OPTIONS --cubical --no-import-sorts #-}
module Cubical.Experiments.Everything where

open import Cubical.Experiments.Brunerie public
open import Cubical.Experiments.EscardoSIP public
open import Cubical.Experiments.Generic public
open import Cubical.Experiments.NatMinusTwo
open import Cubical.Experiments.Problem
open import Cubical.Experiments.FunExtFromUA public
open import Cubical.Experiments.HoTT-UF
open import Cubical.Experiments.Rng