-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness #-}

open import Data.Product
open import Data.List using (List; []; _∷_; _∷ʳ_; _++_)
open import Data.List.Properties using (∷-injective)

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; cong)

open import Common

module Trace {ℙ : Set} (message : Message ℙ)
  where

open import Action message public
open import SessionType message

Trace : Set
Trace = List Action

--| CO-TRACES |--

co-trace : Trace -> Trace
co-trace = Data.List.map co-action

co-trace-involution : (φ : Trace) -> co-trace (co-trace φ) ≡ φ
co-trace-involution [] = refl
co-trace-involution (α ∷ φ) rewrite co-action-involution α | co-trace-involution φ = refl

co-trace-++ : (φ ψ : Trace) -> co-trace (φ ++ ψ) ≡ co-trace φ ++ co-trace ψ
co-trace-++ []      _ = refl
co-trace-++ (α ∷ φ) ψ = cong (co-action α ∷_) (co-trace-++ φ ψ)

co-trace-injective : ∀{φ ψ} -> co-trace φ ≡ co-trace ψ -> φ ≡ ψ
co-trace-injective {[]} {[]} eq = refl
co-trace-injective {x ∷ φ} {x₁ ∷ ψ} eq with ∷-injective eq
... | eq1 , eq2 rewrite co-action-injective eq1 | co-trace-injective eq2 = refl

--| PREFIX RELATION |--

data _⊑_ : Trace -> Trace -> Set where
  none : ∀{φ}     -> [] ⊑ φ
  some : ∀{φ ψ α} -> φ ⊑ ψ -> (α ∷ φ) ⊑ (α ∷ ψ)

⊑-refl : (φ : Trace) -> φ ⊑ φ
⊑-refl [] = none
⊑-refl (_ ∷ φ) = some (⊑-refl φ)

⊑-tran : ∀{φ ψ χ} -> φ ⊑ ψ -> ψ ⊑ χ -> φ ⊑ χ
⊑-tran none _ = none
⊑-tran (some le1) (some le2) = some (⊑-tran le1 le2)

⊑-++ : ∀{φ χ} -> φ ⊑ (φ ++ χ)
⊑-++ {[]} = none
⊑-++ {_ ∷ φ} = some (⊑-++ {φ})

⊑-precong-++ : ∀{φ ψ χ} -> ψ ⊑ χ -> (φ ++ ψ) ⊑ (φ ++ χ)
⊑-precong-++ {[]} le = le
⊑-precong-++ {_ ∷ _} le = some (⊑-precong-++ le)

⊑-co-trace : ∀{φ ψ} -> φ ⊑ ψ -> co-trace φ ⊑ co-trace ψ
⊑-co-trace none = none
⊑-co-trace (some le) = some (⊑-co-trace le)

⊑-trace : ∀{φ ψ} -> ψ ⊑ φ -> ∃[ φ' ] (φ ≡ ψ ++ φ')
⊑-trace {φ} none = φ , refl
⊑-trace {α ∷ φ} (some le) with ⊑-trace le
... | φ' , eq rewrite eq = φ' , refl

absurd-++-≡ : ∀{φ ψ : Trace}{α} -> (φ ++ α ∷ ψ) ≢ []
absurd-++-≡ {[]} ()
absurd-++-≡ {_ ∷ _} ()

absurd-++-⊑ : ∀{φ α ψ} -> ¬ (φ ++ α ∷ ψ) ⊑ []
absurd-++-⊑ {[]} ()
absurd-++-⊑ {_ ∷ _} ()

--| STRICT PREFIX RELATION |--

data _⊏_ : Trace -> Trace -> Set where
  none : ∀{α φ} -> [] ⊏ (α ∷ φ)
  some : ∀{φ ψ α} -> φ ⊏ ψ -> (α ∷ φ) ⊏ (α ∷ ψ)

⊏-irreflexive : ∀{φ} -> ¬ φ ⊏ φ
⊏-irreflexive (some lt) = ⊏-irreflexive lt

⊏-++ : ∀{φ ψ α} -> φ ⊏ (φ ++ (ψ ∷ʳ α))
⊏-++ {[]} {[]} = none
⊏-++ {[]} {_ ∷ _} = none
⊏-++ {_ ∷ φ} = some (⊏-++ {φ})

⊏->≢ : ∀{φ ψ} -> φ ⊏ ψ -> φ ≢ ψ
⊏->≢ (some lt) refl = ⊏-irreflexive lt

⊏->⊑ : ∀{φ ψ} -> φ ⊏ ψ -> φ ⊑ ψ
⊏->⊑ none = none
⊏->⊑ (some lt) = some (⊏->⊑ lt)


module Oscar.Prelude where

module _ where -- Objectevel

  open import Agda.Primitive public
    using ()
    renaming ( Level to Ł
             ; lzero to ∅̂
             ; lsuc to ↑̂_
             ; _⊔_ to _∙̂_ )

  infix 0 Ø_
  Ø_ : ∀ 𝔬 → Set (↑̂ 𝔬)
  Ø_ 𝔬 = Set 𝔬

  Ø₀ = Ø ∅̂
  Ø₁ = Ø (↑̂ ∅̂)

postulate
  magic : ∀ {a} {A : Ø a} → A

module _ where -- Function

  infixr 9 _∘_
  _∘_ : ∀ {a b c}
          {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
          (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
          ((x : A) → C (g x))
  f ∘ g = λ x → f (g x)

  infixr 9 _∘′_
  _∘′_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
           (B → C) → (A → B) → (A → C)
  f ∘′ g = f ∘ g

  ¡ : ∀ {𝔬} {𝔒 : Ø 𝔬} → 𝔒 → 𝔒
  ¡ 𝓞 = 𝓞

  infixl -10 ¡
  syntax ¡ {𝔒 = A} x = x ofType A

  ¡[_] : ∀ {𝔬} (𝔒 : Ø 𝔬) → 𝔒 → 𝔒
  ¡[ _ ] = ¡

  _∋_ : ∀ {a} (A : Set a) → A → A
  A ∋ x = x

  _∞ : ∀ {a} {A : Set a} → A → ∀ {b} {B : Set b} → B → A
  _∞ x = λ _ → x

  _∞⟦_⟧ : ∀ {a} {A : Set a} → A → ∀ {b} (B : Set b) → B → A
  x ∞⟦ B ⟧ = _∞ x {B = B}

  _∞₁ : ∀ ..{a} ..{A : Set a} → A → ∀ ..{b} ..{B : Set b} → ∀ ..{h} ..{H : Set h} → .(_ : B) .{_ : H} → A
  _∞₁ f _ = f

  _∞₃ : ∀ ..{a} ..{A : Set a} → A → ∀ ..{b} ..{B : Set b} → ∀ ..{h₁ h₂ h₃} ..{H₁ : Set h₁} ..{H₂ : Set h₂} ..{H₃ : Set h₃} → .(_ : B) .{_ : H₁} .{_ : H₂} .{_ : H₃} → A
  _∞₃ f _ = f

  hid : ∀ {a} {A : Set a} {x : A} → A
  hid {x = x} = x

  it : ∀ {a} {A : Set a} {{x : A}} → A
  it {{x}} = x
  {-# INLINE it #-}

  ! = it

  asInstance : ∀ {a b} {A : Set a} {B : A → Set b} (x : A) → (∀ {{x}} → B x) → B x
  asInstance x f = f {{x}}
  {-# INLINE asInstance #-}

  flip : ∀ {a b c} {A : Set a} {B : Set b} {C : A → B → Set c} → (∀ x y → C x y) → ∀ y x → C x y
  flip f x y = f y x
  {-# INLINE flip #-}

  infixr -20 _$_
  _$_ : ∀ {a b} {A : Set a} {B : A → Set b} → (∀ x → B x) → ∀ x → B x
  f $ x = f x

  infixr -20 _$′_
  _$′_ : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → A → B
  f $′ x = f x

  -- The S combinator. (Written infix as in Conor McBride's paper
  -- "Outrageous but Meaningful Coincidences: Dependent type-safe syntax
  -- and evaluation".)

  _ˢ_ : ∀ {a b c}
          {A : Set a} {B : A → Set b} {C : (x : A) → B x → Set c} →
        ((x : A) (y : B x) → C x y) →
        (g : (x : A) → B x) →
        ((x : A) → C x (g x))
  f ˢ g = λ x → f x (g x)

  infixr 0 case_of_ case_return_of_

  case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
  case x of f = f x

  case_return_of_ : ∀ {a b} {A : Set a} (x : A) (B : A → Set b) → (∀ x → B x) → B x
  case x return B of f = f x

  infixl 8 _on_
  _on_ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x y → B x → B y → Set c} →
           (∀ {x y} (z : B x) (w : B y) → C x y z w) → (f : ∀ x → B x) → ∀ x y →
           C x y (f x) (f y)
  h on f = λ x y → h (f x) (f y)
  {-# INLINE _on_ #-}

Function : ∀ {a} → Ø a → Ø a → Ø a
Function A B = A → B

Function⟦_⟧ : ∀ a → Ø a → Ø a → Ø a
Function⟦ a ⟧ = Function {a = a}

MFunction : ∀ {a b} (M : Ø a → Ø b) → Ø a → Ø a → Ø b
MFunction M A B = M A → M B

Arrow : ∀ {𝔵} {𝔛 : Ø 𝔵} {𝔞} {𝔟} → (𝔛 → Ø 𝔞) → (𝔛 → Ø 𝔟) → 𝔛 → 𝔛 → Ø 𝔞 ∙̂ 𝔟
Arrow 𝔄 𝔅 x y = 𝔄 x → 𝔅 y

module _ where

  Extension : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} (𝔓 : 𝔒 → Ø 𝔭) → 𝔒 → 𝔒 → Ø 𝔭
  Extension 𝔓 = Arrow 𝔓 𝔓

module _ where

  _⟨_⟩→_ : ∀ {𝔬} {𝔒 : Ø 𝔬} → 𝔒 → ∀ {𝔭} → (𝔒 → Ø 𝔭) → 𝔒 → Ø 𝔭
  m ⟨ 𝔓 ⟩→ n = Extension 𝔓 m n

π̂ : ∀ {𝔵} ℓ (𝔛 : Ø 𝔵) → Ø 𝔵 ∙̂ ↑̂ ℓ
π̂ ℓ 𝔛 = 𝔛 → Ø ℓ

infixl 21 _←̂_
_←̂_ = π̂

π̇ : ∀ {𝔞 𝔟} (𝔄 : Ø 𝔞) (𝔅 : 𝔄 → Ø 𝔟) → Ø 𝔞 ∙̂ 𝔟
π̇ 𝔄 𝔅 = (𝓐 : 𝔄) → 𝔅 𝓐

infixl 20 π̇
syntax π̇ 𝔄 (λ 𝓐 → 𝔅𝓐) = 𝔅𝓐 ← 𝓐 ≔ 𝔄

π̇-hidden-quantifier-syntax = π̇
infixl 20 π̇-hidden-quantifier-syntax
syntax π̇-hidden-quantifier-syntax 𝔄 (λ _ → 𝔅𝓐) = 𝔅𝓐 ← 𝔄

π̂² : ∀ {𝔞} ℓ → Ø 𝔞 → Ø 𝔞 ∙̂ ↑̂ ℓ
π̂² ℓ 𝔄 = ℓ ←̂ 𝔄 ← 𝔄

_→̂²_ : ∀ {𝔞} → Ø 𝔞 → ∀ ℓ → Ø 𝔞 ∙̂ ↑̂ ℓ
_→̂²_ 𝔒 ℓ = π̂² ℓ 𝔒

record Lift {a ℓ} (A : Set a) : Set (a ∙̂ ℓ) where
  instance constructor lift
  field lower : A

open Lift public

record Wrap {𝔵} (𝔛 : Ø 𝔵) : Ø 𝔵 where
  constructor ∁
  field
    π₀ : 𝔛

open Wrap public

∀̇ : ∀ {𝔵} {𝔛 : Ø 𝔵} {𝔞}
  → (∀ ℓ (𝔄 : Ø 𝔞) → Ø 𝔞 ∙̂ ↑̂ ℓ)
  → ∀ ℓ → (𝔛 → Ø 𝔞) → Ø 𝔵 ∙̂ 𝔞 ∙̂ ↑̂ ℓ
∀̇ Q ℓ 𝔄 = ∀ {x} → Q ℓ (𝔄 x)

Ṙelation : ∀ {𝔵} {𝔛 : Ø 𝔵} {𝔞} ℓ → (𝔞 ←̂ 𝔛) → Ø 𝔵 ∙̂ 𝔞 ∙̂ ↑̂ ℓ
Ṙelation ℓ P = Wrap (∀̇ π̂² ℓ P)

Pointwise : ∀ {𝔞} {𝔄 : Ø 𝔞} {𝔟} {𝔅 : Ø 𝔟} {ℓ} → 𝔅 →̂² ℓ → (𝔅 ← 𝔄) → (𝔄 → 𝔅) → Ø 𝔞 ∙̂ ℓ
Pointwise _≈_ = λ f g → ∀ x → f x ≈ g x

Ṗroperty : ∀ {𝔵} {𝔛 : Ø 𝔵} {𝔬} ℓ → (𝔵 ∙̂ 𝔬 ∙̂ ↑̂ ℓ) ←̂ (𝔬 ←̂ 𝔛)
Ṗroperty ℓ P = Wrap (∀̇ π̂ ℓ P)

LeftṖroperty : ∀ {𝔵} {𝔛 : Ø 𝔵} {𝔶} {𝔜 : 𝔛 → Ø 𝔶} {𝔯} → ∀ ℓ → ((x : 𝔛) → 𝔜 x → Ø 𝔯) → 𝔛 → Ø 𝔶 ∙̂ 𝔯 ∙̂ ↑̂ ℓ
LeftṖroperty ℓ _↦_ = Ṗroperty ℓ ∘ _↦_

ArrowṖroperty : ∀ {𝔵} {𝔛 : Ø 𝔵} {𝔭₁ 𝔭₂} → ∀ ℓ → (𝔛 → Ø 𝔭₁) → (𝔛 → Ø 𝔭₂) → 𝔛 → Ø 𝔵 ∙̂ 𝔭₁ ∙̂ 𝔭₂ ∙̂ ↑̂ ℓ
ArrowṖroperty ℓ 𝔒₁ 𝔒₂ = LeftṖroperty ℓ (Arrow 𝔒₁ 𝔒₂)

module _ where

  infixr 5 _,_
  record Σ {𝔬} (𝔒 : Ø 𝔬) {𝔭} (𝔓 : 𝔒 → Ø 𝔭) : Ø 𝔬 ∙̂ 𝔭 where
    instance constructor _,_
    field
      π₀ : 𝔒
      π₁ : 𝔓 π₀

  open Σ public

  infixr 5 _,,_
  record Σ′ {𝔬} (𝔒 : Ø 𝔬) {𝔭} (𝔓 : Ø 𝔭) : Ø 𝔬 ∙̂ 𝔭 where
    instance constructor _,,_
    field
      π₀ : 𝔒
      π₁ : 𝔓

  open Σ′ public

  _×_ : ∀ {𝔬₁ 𝔬₂} (𝔒₁ : Ø 𝔬₁) (𝔒₂ : Ø 𝔬₂) → Ø 𝔬₁ ∙̂ 𝔬₂
  _×_ O₁ O₂ = Σ O₁ (λ _ → O₂)

  ∃_ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} (𝔓 : 𝔒 → Ø 𝔭) → Ø 𝔬 ∙̂ 𝔭
  ∃_ = Σ _

  uncurry : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x → B x → Set c} →
              (∀ x (y : B x) → C x y) → (p : Σ A B) → C (π₀ p) (π₁ p)
  uncurry f (x , y) = f x y

  uncurry′ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : Set c} →
              (∀ x → B x → C) → Σ A B → C
  uncurry′ f (x , y) = f x y

  curry : ∀ {a b c} {A : Set a} {B : A → Set b} {C : Σ A B → Set c} →
            (∀ p → C p) → ∀ x (y : B x) → C (x , y)
  curry f x y = f (x , y)

ExtensionṖroperty : ∀ {𝔵} {𝔛 : Ø 𝔵} {𝔬} {ℓ̇}
  ℓ (𝔒 : 𝔛 → Ø 𝔬) (_↦_ : ∀̇ π̂² ℓ̇ 𝔒)
  → Ø 𝔵 ∙̂ 𝔬 ∙̂ ↑̂ ℓ ∙̂ ℓ̇
ExtensionṖroperty ℓ 𝔒 _↦_ = Σ (Ṗroperty ℓ 𝔒) (λ P → ∀ {x} {f g : 𝔒 x} → f ↦ g → Extension (π₀ P) f g)

LeftExtensionṖroperty : ∀ {𝔶} {𝔜 : Ø 𝔶} {𝔵} {𝔛 : 𝔜 → Ø 𝔵} {𝔬} {ℓ̇}
  ℓ (𝔒 : (y : 𝔜) → 𝔛 y → Ø 𝔬) (_↦_ : ∀ {y} → ∀̇ π̂² ℓ̇ (𝔒 y))
  → 𝔜
  → Ø 𝔵 ∙̂ 𝔬 ∙̂ ↑̂ ℓ ∙̂ ℓ̇
LeftExtensionṖroperty ℓ 𝔒 _↦_ y = ExtensionṖroperty ℓ (𝔒 y) _↦_

ArrowExtensionṖroperty : ∀
  {𝔵} {𝔛 : Ø 𝔵}
  {𝔬₁} ℓ (𝔒₁ : 𝔛 → Ø 𝔬₁)
  {𝔬₂} (𝔒₂ : 𝔛 → Ø 𝔬₂)
  → ∀ {ℓ̇} (_↦_ : ∀̇ π̂² ℓ̇ 𝔒₂)
  → 𝔛
  → Ø 𝔵 ∙̂ 𝔬₁ ∙̂ 𝔬₂ ∙̂ ↑̂ ℓ ∙̂ ℓ̇
ArrowExtensionṖroperty ℓ 𝔒₁ 𝔒₂ _↦_ = LeftExtensionṖroperty ℓ (Arrow 𝔒₁ 𝔒₂) (Pointwise _↦_)

record Instance {a} (A : Set a) : Set a where
  constructor ∁
  field {{x}} : A

mkInstance : ∀ {a} {A : Set a} → A → Instance A
mkInstance x = ∁ {{x}}


module lib where

open import datatypes public
open import logic public
open import thms public
open import termination public
open import error public
open import io public


module BuiltinMustBeConstructor where

data Bool : Set where
  true  : Bool
  other : Bool

false : Bool
false = true

{-# BUILTIN BOOL Bool #-}
{-# BUILTIN TRUE true #-}
{-# BUILTIN FALSE false #-}


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

-- Theorems about noninterference.

open import Calf.CostMonoid

module Calf.Noninterference (costMonoid : CostMonoid) where

open import Calf.Prelude
open import Calf.Metalanguage
open import Calf.Step costMonoid
open import Calf.PhaseDistinction
open import Calf.Types.Eq

open import Data.Product
open import Relation.Binary.PropositionalEquality as P

oblivious : ∀ {A B} (f : cmp (F A) → val (◯⁺ B)) →
      ∀ c e → f (step (F A) c e) ≡ f e
oblivious {A} {B} f c e = funext/Ω (λ u →
  begin
  f (step (F A) c e) u ≡⟨ cong (λ e → f e u) (step/ext (F A) e c u) ⟩
  f e u
  ∎
  )
  where open ≡-Reasoning

unique : ∀ {A} → (a : val (● A)) → (u : ext) → a ≡ ∗ u
unique {A} a u =
  eq/ref
  (●/ind {A} a (λ a → F (eq (● A) a (∗ u)))
  (λ a → ret (eq/intro (η≡∗ a u)))
  (λ u → ret (eq/intro refl))
  (λ a u → eq/uni _ _ u))

constant : ∀ {A B} (f : val (● A) → val (◯⁺ B)) →
  Σ (val (◯⁺ B)) λ b → f ≡ λ _ → b
constant f =
  (λ u → f (∗ u) u) , funext (λ a → funext/Ω (λ u →
    P.cong (λ a → f a u) (unique a u)))

optimization : ∀ {C B : tp pos} {A : val C → tp pos}
  (f : val (Σ++ C λ c → ● (A c)) → val (◯⁺ B)) →
  Σ (val C → val (◯⁺ B)) λ f' → ∀ c a → f (c , a) ≡ f' c
optimization {C} {B} {A} f =
  (λ c →
    let g : val (● (A c)) → val (◯⁺ B)
        g a = f (c , a) in
    let (b , h) = constant {A c} {B} g in
    b) ,
    λ c a →
    let g : val (● (A c)) → val (◯⁺ B)
        g a = f (c , a) in
    let (b , h) = constant {A c} {B} g in
    P.cong-app h a


{-# OPTIONS --rewriting #-}

module Luau.OpSem where

open import Agda.Builtin.Equality using (_≡_)
open import Agda.Builtin.Float using (Float; primFloatPlus; primFloatMinus; primFloatTimes; primFloatDiv; primFloatEquality; primFloatLess; primFloatInequality)
open import Agda.Builtin.Bool using (Bool; true; false)
open import Agda.Builtin.String using (primStringEquality; primStringAppend)
open import Utility.Bool using (not; _or_; _and_)
open import Agda.Builtin.Nat using () renaming (_==_ to _==ᴬ_)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import Luau.Heap using (Heap; _≡_⊕_↦_; _[_]; function_is_end)
open import Luau.Substitution using (_[_/_]ᴮ)
open import Luau.Syntax using (Value; Expr; Stat; Block; nil; addr; val; var; function_is_end; _$_; block_is_end; local_←_; _∙_; done; return; name; fun; arg; binexp; BinaryOperator; +; -; *; /; <; >; ==; ~=; <=; >=; ··; number; bool; string)
open import Luau.RuntimeType using (RuntimeType; valueType)
open import Properties.Product using (_×_; _,_)

evalEqOp : Value → Value → Bool
evalEqOp Value.nil Value.nil = true
evalEqOp (addr x) (addr y) = (x ==ᴬ y)
evalEqOp (number x) (number y) = primFloatEquality x y
evalEqOp (bool true) (bool y) = y
evalEqOp (bool false) (bool y) = not y
evalEqOp _ _ = false

evalNeqOp : Value → Value → Bool
evalNeqOp (number x) (number y) = primFloatInequality x y
evalNeqOp x y = not (evalEqOp x y)

data _⟦_⟧_⟶_ : Value → BinaryOperator → Value → Value → Set where
  + : ∀ m n → (number m) ⟦ + ⟧ (number n) ⟶ number (primFloatPlus m n)
  - : ∀ m n → (number m) ⟦ - ⟧ (number n) ⟶ number (primFloatMinus m n)
  / : ∀ m n → (number m) ⟦ / ⟧ (number n) ⟶ number (primFloatTimes m n)
  * : ∀ m n → (number m) ⟦ * ⟧ (number n) ⟶ number (primFloatDiv m n)
  < : ∀ m n → (number m) ⟦ < ⟧ (number n) ⟶ bool (primFloatLess m n)
  > : ∀ m n → (number m) ⟦ > ⟧ (number n) ⟶ bool (primFloatLess n m)
  <= : ∀ m n → (number m) ⟦ <= ⟧ (number n) ⟶ bool ((primFloatLess m n) or (primFloatEquality m n))
  >= : ∀ m n → (number m) ⟦ >= ⟧ (number n) ⟶ bool ((primFloatLess n m) or (primFloatEquality m n))
  == : ∀ v w → v ⟦ == ⟧ w ⟶ bool (evalEqOp v w)
  ~= : ∀ v w → v ⟦ ~= ⟧ w ⟶ bool (evalNeqOp v w)
  ·· : ∀ x y → (string x) ⟦ ·· ⟧ (string y) ⟶ string (primStringAppend x y)

data _⊢_⟶ᴮ_⊣_ {a} : Heap a → Block a → Block a → Heap a → Set
data _⊢_⟶ᴱ_⊣_ {a} : Heap a → Expr a → Expr a → Heap a → Set

data _⊢_⟶ᴱ_⊣_  where

  function : ∀ a {H H′ F B} →

    H′ ≡ H ⊕ a ↦ (function F is B end) →
    -------------------------------------------
    H ⊢ (function F is B end) ⟶ᴱ val(addr a) ⊣ H′

  app₁ : ∀ {H H′ M M′ N} →

    H ⊢ M ⟶ᴱ M′ ⊣ H′ →
    -----------------------------
    H ⊢ (M $ N) ⟶ᴱ (M′ $ N) ⊣ H′

  app₂ : ∀ v {H H′ N N′} →

    H ⊢ N ⟶ᴱ N′ ⊣ H′ →
    -----------------------------
    H ⊢ (val v $ N) ⟶ᴱ (val v $ N′) ⊣ H′

  beta : ∀ O v {H a F B} →

    (O ≡ function F is B end) →
    H [ a ] ≡ just(O) →
    -----------------------------------------------------------------------------
    H ⊢ (val (addr a) $ val v) ⟶ᴱ (block (fun F) is (B [ v / name(arg F) ]ᴮ) end) ⊣ H

  block : ∀ {H H′ B B′ b} →

    H ⊢ B ⟶ᴮ B′ ⊣ H′ →
    ----------------------------------------------------
    H ⊢ (block b is B end) ⟶ᴱ (block b is B′ end) ⊣ H′

  return : ∀ v {H B b} →

    --------------------------------------------------------
    H ⊢ (block b is return (val v) ∙ B end) ⟶ᴱ val v ⊣ H

  done : ∀ {H b} →

    --------------------------------------------
    H ⊢ (block b is done end) ⟶ᴱ (val nil) ⊣ H

  binOp₀ : ∀ {H op v₁ v₂ w} →

    v₁ ⟦ op ⟧ v₂ ⟶ w →
    --------------------------------------------------
    H ⊢ (binexp (val v₁) op (val v₂)) ⟶ᴱ (val w) ⊣ H

  binOp₁ : ∀ {H H′ x x′ op y} →

    H ⊢ x ⟶ᴱ x′ ⊣ H′ →
    ---------------------------------------------
    H ⊢ (binexp x op y) ⟶ᴱ (binexp x′ op y) ⊣ H′

  binOp₂ : ∀ {H H′ x op y y′} →

    H ⊢ y ⟶ᴱ y′ ⊣ H′ →
    ---------------------------------------------
    H ⊢ (binexp x op y) ⟶ᴱ (binexp x op y′) ⊣ H′

data _⊢_⟶ᴮ_⊣_  where

  local : ∀ {H H′ x M M′ B} →

    H ⊢ M ⟶ᴱ M′ ⊣ H′ →
    -------------------------------------------------
    H ⊢ (local x ← M ∙ B) ⟶ᴮ (local x ← M′ ∙ B) ⊣ H′

  subst : ∀ v {H x B} →

    ------------------------------------------------------
    H ⊢ (local x ← val v ∙ B) ⟶ᴮ (B [ v / name x ]ᴮ) ⊣ H

  function : ∀ a {H H′ F B C} →

    H′ ≡ H ⊕ a ↦ (function F is C end) →
    --------------------------------------------------------------
    H ⊢ (function F is C end ∙ B) ⟶ᴮ (B [ addr a / name(fun F) ]ᴮ) ⊣ H′

  return : ∀ {H H′ M M′ B} →

    H ⊢ M ⟶ᴱ M′ ⊣ H′ →
    --------------------------------------------
    H ⊢ (return M ∙ B) ⟶ᴮ (return M′ ∙ B) ⊣ H′

data _⊢_⟶*_⊣_ {a} : Heap a → Block a → Block a → Heap a → Set where

  refl : ∀ {H B} →

    ----------------
    H ⊢ B ⟶* B ⊣ H

  step : ∀ {H H′ H″ B B′ B″} →
    H ⊢ B ⟶ᴮ B′ ⊣ H′ →
    H′ ⊢ B′ ⟶* B″ ⊣ H″ →
    ------------------
    H ⊢ B ⟶* B″ ⊣ H″


-- New NO_POSITIVITY_CHECK pragma for data definitions and mutual
-- blocks

-- Skipping a single data definition.
{-# NO_POSITIVITY_CHECK #-}
data D : Set where
  lam : (D → D) → D


module Text.Printf where

open import Prelude hiding (parseNat)
open import Builtin.Float

private
  data Padding : Set where
    noPad     : Padding
    lPad rPad : Nat → Padding

  record Flags : Set where
    field
      padding   : Padding
      padChar   : Char
      alternate : Bool
      precision : Maybe Nat

  defaultFlags : Flags
  Flags.padding   defaultFlags = noPad
  Flags.padChar   defaultFlags = ' '
  Flags.alternate defaultFlags = false
  Flags.precision defaultFlags = nothing

  data Format : Set where
    natArg    : Flags → Format
    strArg    : Flags → Format
    ustrArg   : Flags → Format
    floatArg  : Flags → Format
    charArg   : Format
    hexArg    : Bool → Flags → Format
    litString : String → Format
    badFormat : String → Format

data BadFormat (s : String) : Set where

private
  BadFormat′ : String → Set
  BadFormat′ "" = ⊥
  BadFormat′ s = BadFormat s

private
  consLit : String → List Format → List Format
  consLit s (litString s′ ∷ fmt) = litString (s & s′) ∷ fmt
  consLit s fmt = litString s ∷ fmt

private
  parseFormat : List Char → List Format
  parseFormatWithFlags : Flags → List Char → List Format

  parseNat′ : (Nat → Flags) → Nat → List Char → List Format
  parseNat′ flags n [] = parseFormatWithFlags (flags n) []
  parseNat′ flags n (c ∷ s) =
    if isDigit c then parseNat′ flags (n * 10 + charToNat c - charToNat '0') s
                 else parseFormatWithFlags (flags n) (c ∷ s)

  parseNat : (Nat → Flags) → List Char → List Format
  parseNat p s = parseNat′ p 0 s

  parsePadding : Flags → List Char → List Format
  parsePadding f [] = parseFormatWithFlags f []
  parsePadding f ('-' ∷ c ∷ s) =
    if isDigit c then parseNat (λ n → record f { padding = rPad n }) (c ∷ s)
                 else badFormat (packString ('-' ∷ c ∷ [])) ∷ parseFormat s
  parsePadding f ('0' ∷ s) = parsePadding (record f { padChar = '0' }) s
  parsePadding f ('.' ∷ c ∷ s) =
    if isDigit c then parseNat (λ n → record f { precision = just n }) (c ∷ s)
                 else badFormat (packString ('.' ∷ c ∷ [])) ∷ parseFormat s
  parsePadding f (c ∷ s) =
    if isDigit c then parseNat (λ n → record f { padding = lPad n }) (c ∷ s)
                 else parseFormatWithFlags f (c ∷ s)

  parseFlags : Flags → List Char → List Format
  parseFlags f ('#' ∷ s) = parseFlags (record f { alternate = true }) s
  parseFlags f s = parsePadding f s

  parseFormatWithFlags f [] = badFormat "" ∷ []
  parseFormatWithFlags f ('d' ∷ s) = natArg f ∷ parseFormat s
  parseFormatWithFlags f ('x' ∷ s) = hexArg false f ∷ parseFormat s
  parseFormatWithFlags f ('X' ∷ s) = hexArg true  f ∷ parseFormat s
  parseFormatWithFlags f ('c' ∷ s) = charArg ∷ parseFormat s
  parseFormatWithFlags f ('s' ∷ s) = strArg f ∷ parseFormat s
  parseFormatWithFlags f ('S' ∷ s) = ustrArg f ∷ parseFormat s
  parseFormatWithFlags f ('f' ∷ s) = floatArg f ∷ parseFormat s
  parseFormatWithFlags f ('%' ∷ s) = consLit "%" $ parseFormat s
  parseFormatWithFlags f ( c  ∷ s) = badFormat (packString ('%' ∷ c ∷ [])) ∷ parseFormat s

  parseFormat [] = []
  parseFormat ('%' ∷ fmt) = parseFlags defaultFlags fmt
  parseFormat (c   ∷ fmt) = consLit (packString [ c ]) $ parseFormat fmt

private
  pad : (String → String → String) → Char → Nat → String → String
  pad _+_ c n s =
    case n - length (unpackString s) of
    λ { 0 → s ; d → packString (replicate d c) + s}

  padLeft padRight : Char → Nat → String → String
  padLeft  = pad _&_
  padRight = pad (flip _&_)

  hexDigit : Char → Nat → String
  hexDigit a n = if n <? 10 then packString [ natToChar (n + charToNat '0') ]
                            else packString [ natToChar (n - 10 + charToNat a) ]

  {-# TERMINATING #-}
  showHex′ : Char → Nat → String
  showHex′ _ 0 = ""
  showHex′ a n = showHex′ a (n div 16) & hexDigit a (n mod 16)

  add0x : Flags → String → String
  add0x flags s = if Flags.alternate flags then "0x" & s else s

  pad0 : Flags → String → String
  pad0 flags s =
    let c = Flags.padChar flags in
    ifYes c == ' ' then s else
    case Flags.padding flags of
    λ { noPad → s ; (lPad n) → padLeft c (n - 2) s ; (rPad _) → s }

  showHex : Flags → Bool → Nat → String
  showHex f _ 0 = add0x f $ pad0 f $ "0"
  showHex f u n = add0x f $ pad0 f $ showHex′ (if u then 'A' else 'a') n

  showFrac : Nat → Float → String
  showFrac 0       _ = ""
  showFrac 1       x = show (round (10 * x))
  showFrac (suc p) x = show n & showFrac p (x′ - intToFloat n)
    where x′ = 10 * x
          n  = floor x′

  showPosFloat : Flags → Float → String
  showPosFloat f x =
    case Flags.precision f of λ
    { nothing  → show x
    ; (just 0) → show (floor x)
    ; (just p) → show (floor x) & "." & showFrac p (x - intToFloat (floor x))
    }

  showFloat : Flags → Float → String
  showFloat f x with x <? 0.0
  ... | true = "-" & showPosFloat f (negate x)
  ... | false = showPosFloat f x

  withPad : Flags → String → ShowS
  withPad flags s =
    let c = Flags.padChar flags in
    case Flags.padding flags of
    λ { noPad → showString s
      ; (lPad n) → showString (padLeft  c n s)
      ; (rPad n) → showString (padRight c n s)
      }

private
  Printf′ : List Format → Set
  Printf′ []                  = String
  Printf′ (natArg _    ∷ fmt) = Nat → Printf′ fmt
  Printf′ (hexArg _ _  ∷ fmt) = Nat → Printf′ fmt
  Printf′ (strArg _    ∷ fmt) = String → Printf′ fmt
  Printf′ (ustrArg _   ∷ fmt) = List Char → Printf′ fmt
  Printf′ (charArg     ∷ fmt) = Char → Printf′ fmt
  Printf′ (floatArg _  ∷ fmt) = Float → Printf′ fmt
  Printf′ (litString _ ∷ fmt) = Printf′ fmt
  Printf′ (badFormat e ∷ fmt) = BadFormat′ e → Printf′ fmt

  printf′ : (fmt : List Format) → ShowS → Printf′ fmt
  printf′ [] acc = acc ""
  printf′ (natArg p    ∷ fmt) acc n = printf′ fmt (acc ∘ withPad p (show n))
  printf′ (hexArg u p  ∷ fmt) acc n = printf′ fmt (acc ∘ withPad p (showHex p u n))
  printf′ (strArg p    ∷ fmt) acc s = printf′ fmt (acc ∘ withPad p s)
  printf′ (ustrArg p   ∷ fmt) acc s = printf′ fmt (acc ∘ withPad p (packString s))
  printf′ (floatArg p  ∷ fmt) acc x = printf′ fmt (acc ∘ withPad p (showFloat p x))
  printf′ (charArg     ∷ fmt) acc c = printf′ fmt (acc ∘ showString (packString [ c ]))
  printf′ (litString s ∷ fmt) acc   = printf′ fmt (acc ∘ showString s)
  printf′ (badFormat _ ∷ fmt) acc _ = printf′ fmt acc

Printf : String → Set
Printf = Printf′ ∘ parseFormat ∘ unpackString

printf : (fmt : String) → Printf fmt
printf fmt = printf′ (parseFormat $ unpackString fmt) id


------------------------------------------------------------------------
-- A parametrised coinductive definition that can be used to define
-- strong and weak bisimilarity as well as expansion
------------------------------------------------------------------------

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

open import Prelude

open import Labelled-transition-system

module Bisimilarity.General
         {ℓ}
         (lts : LTS ℓ)
         (open LTS lts)
         (_[_]↝₁_ _[_]↝₂_ : Proc → Label → Proc → Type ℓ)
         (⟶→↝₁ : ∀ {p μ q} → p [ μ ]⟶ q → p [ μ ]↝₁ q)
         (⟶→↝₂ : ∀ {p μ q} → p [ μ ]⟶ q → p [ μ ]↝₂ q)
         where

open import Equality.Propositional as Eq hiding (Extensionality)
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Bijection equality-with-J as Bijection using (_↔_)
open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J

open import Bisimilarity.Step lts _[_]↝₁_ _[_]↝₂_ as Step public
  using (StepC)
open import Indexed-container hiding (⟨_⟩; Bisimilarity)
open import Indexed-container.Combinators hiding (id; _∘_)
open import Relation
import Similarity.Step lts _[_]↝₁_ as Step₁
import Similarity.Step lts _[_]↝₂_ as Step₂

open Indexed-container public using (force)

------------------------------------------------------------------------
-- Bisimilarity

-- Bisimilarity. Note that this definition is small.

infix 4 _∼_ _∼′_ [_]_∼_ [_]_∼′_

Bisimilarity : Size → Rel₂ ℓ Proc
Bisimilarity = ν StepC

Bisimilarity′ : Size → Rel₂ ℓ Proc
Bisimilarity′ = ν′ StepC

[_]_∼_ : Size → Proc → Proc → Type ℓ
[_]_∼_ i = curry (Bisimilarity i)

[_]_∼′_ : Size → Proc → Proc → Type ℓ
[_]_∼′_ i = curry (Bisimilarity′ i)

_∼_ : Proc → Proc → Type ℓ
_∼_ = [ ∞ ]_∼_

_∼′_ : Proc → Proc → Type ℓ
_∼′_ = [ ∞ ]_∼′_

-- Bisimilarity is reflexive.

mutual

  reflexive-∼ : ∀ {p i} → [ i ] p ∼ p
  reflexive-∼ =
    StepC.⟨ (λ p⟶p′ → _ , ⟶→↝₁ p⟶p′ , reflexive-∼′)
          , (λ q⟶q′ → _ , ⟶→↝₂ q⟶q′ , reflexive-∼′)
          ⟩

  reflexive-∼′ : ∀ {p i} → [ i ] p ∼′ p
  force reflexive-∼′ = reflexive-∼

≡⇒∼ : ∀ {p q} → p ≡ q → p ∼ q
≡⇒∼ refl = reflexive-∼

-- Functions that can be used to aid the instance resolution
-- mechanism.

infix -2 ∼:_ ∼′:_

∼:_ : ∀ {i p q} → [ i ] p ∼ q → [ i ] p ∼ q
∼:_ = id

∼′:_ : ∀ {i p q} → [ i ] p ∼′ q → [ i ] p ∼′ q
∼′:_ = id

------------------------------------------------------------------------
-- Bisimilarity for bisimilarity

-- Bisimilarity of bisimilarity proofs.

infix 4 [_]_≡_ [_]_≡′_

[_]_≡_ : ∀ {p q} → Size → (_ _ : ν StepC ∞ (p , q)) → Type ℓ
[_]_≡_ i = curry (ν-bisimilar i)

[_]_≡′_ : ∀ {p q} → Size → (_ _ : ν′ StepC ∞ (p , q)) → Type ℓ
[_]_≡′_ i = curry (ν′-bisimilar i)

-- An alternative characterisation of bisimilarity of bisimilarity
-- proofs.

[]≡↔ :
  Eq.Extensionality ℓ ℓ →
  ∀ {p q} {i : Size} (p∼q₁ p∼q₂ : ν StepC ∞ (p , q)) →

  [ i ] p∼q₁ ≡ p∼q₂

    ↔

  (∀ {p′ μ} (p⟶p′ : p [ μ ]⟶ p′) →
   let q′₁ , q⟶q′₁ , p′∼q′₁ = StepC.left-to-right p∼q₁ p⟶p′
       q′₂ , q⟶q′₂ , p′∼q′₂ = StepC.left-to-right p∼q₂ p⟶p′
   in ∃ λ (q′₁≡q′₂ : q′₁ ≡ q′₂) →
        subst (q [ μ ]↝₁_) q′₁≡q′₂ q⟶q′₁ ≡ q⟶q′₂
          ×
        [ i ] subst (ν′ StepC ∞ ∘ (p′ ,_)) q′₁≡q′₂ p′∼q′₁ ≡′ p′∼q′₂)
    ×
  (∀ {q′ μ} (q⟶q′ : q [ μ ]⟶ q′) →
   let p′₁ , p⟶p′₁ , p′∼q′₁ = StepC.right-to-left p∼q₁ q⟶q′
       p′₂ , p⟶p′₂ , p′∼q′₂ = StepC.right-to-left p∼q₂ q⟶q′
   in ∃ λ (p′₁≡p′₂ : p′₁ ≡ p′₂) →
        subst (p [ μ ]↝₂_) p′₁≡p′₂ p⟶p′₁ ≡ p⟶p′₂
          ×
        [ i ] subst (ν′ StepC ∞ ∘ (_, q′)) p′₁≡p′₂ p′∼q′₁ ≡′ p′∼q′₂)

[]≡↔ ext {p} {q} {i} p∼q₁@(s₁ , f₁) p∼q₂@(s₂ , f₂) =

  [ i ] p∼q₁ ≡ p∼q₂                                                    ↝⟨ ν-bisimilar↔ ext p∼q₁ p∼q₂ ⟩

  ⟦ StepC₁ ⟷ StepC₂ ⟧₂ (ν′-bisimilar i) (p∼q₁ , p∼q₂)                  ↝⟨ ⟦⟷⟧₂↔ ext StepC₁ StepC₂ (ν′-bisimilar i) p∼q₁ p∼q₂ ⟩

  ⟦ StepC₁ ⟧₂ (ν′-bisimilar i)
    ((proj₁ s₁ , f₁ ∘ inj₁) , (proj₁ s₂ , f₂ ∘ inj₁))
    ×
  ⟦ StepC₂ ⟧₂ (ν′-bisimilar i)
    ( (proj₂ s₁ , λ p → f₁ (inj₂ (_ , refl , p)))
    , (proj₂ s₂ , λ p → f₂ (inj₂ (_ , refl , p)))
    )                                                                  ↝⟨ Step₁.⟦StepC⟧₂↔ ext (ν′-bisimilar i) (proj₁ s₁ , f₁ ∘ inj₁)
                                                                                (proj₁ s₂ , f₂ ∘ inj₁)
                                                                            ×-cong
                                                                          Step₂.⟦StepC⟧₂↔ ext (ν′-bisimilar i)
                                                                            (proj₂ s₁ , λ p → f₁ (inj₂ (_ , refl , p)))
                                                                            (proj₂ s₂ , λ p → f₂ (inj₂ (_ , refl , p))) ⟩
  (∀ {p′ μ} (p⟶p′ : p [ μ ]⟶ p′) →
   let q′₁ , q⟶q′₁ , p′∼q′₁ =
         Step₁.StepC.challenge (proj₁ s₁ , f₁ ∘ inj₁) p⟶p′
       q′₂ , q⟶q′₂ , p′∼q′₂ =
         Step₁.StepC.challenge (proj₁ s₂ , f₂ ∘ inj₁) p⟶p′
   in ∃ λ (q′₁≡q′₂ : q′₁ ≡ q′₂) →
        subst (q [ μ ]↝₁_) q′₁≡q′₂ q⟶q′₁ ≡ q⟶q′₂
          ×
        [ i ] subst (ν′ StepC ∞ ∘ (p′ ,_)) q′₁≡q′₂ p′∼q′₁ ≡′ p′∼q′₂)
    ×
  ((∀ {q′ μ} (q⟶q′ : q [ μ ]⟶ q′) →
   let p′₁ , p⟶p′₁ , p′∼q′₁ =
          Step₂.StepC.challenge
             (proj₂ s₁ , λ p → f₁ (inj₂ (_ , refl , p))) q⟶q′
       p′₂ , p⟶p′₂ , p′∼q′₂ =
          Step₂.StepC.challenge
             (proj₂ s₂ , λ p → f₂ (inj₂ (_ , refl , p))) q⟶q′
   in ∃ λ (p′₁≡p′₂ : p′₁ ≡ p′₂) →
        subst (p [ μ ]↝₂_) p′₁≡p′₂ p⟶p′₁ ≡ p⟶p′₂
          ×
        [ i ] subst (ν′ StepC ∞ ∘ (_, q′)) p′₁≡p′₂ p′∼q′₁ ≡′ p′∼q′₂))  ↔⟨⟩

  (∀ {p′ μ} (p⟶p′ : p [ μ ]⟶ p′) →
   let q′₁ , q⟶q′₁ , p′∼q′₁ = StepC.left-to-right p∼q₁ p⟶p′
       q′₂ , q⟶q′₂ , p′∼q′₂ = StepC.left-to-right p∼q₂ p⟶p′
   in ∃ λ (q′₁≡q′₂ : q′₁ ≡ q′₂) →
        subst (q [ μ ]↝₁_) q′₁≡q′₂ q⟶q′₁ ≡ q⟶q′₂
          ×
        [ i ] subst (ν′ StepC ∞ ∘ (p′ ,_)) q′₁≡q′₂ p′∼q′₁ ≡′ p′∼q′₂)
    ×
  (∀ {q′ μ} (q⟶q′ : q [ μ ]⟶ q′) →
   let p′₁ , p⟶p′₁ , p′∼q′₁ = StepC.right-to-left p∼q₁ q⟶q′
       p′₂ , p⟶p′₂ , p′∼q′₂ = StepC.right-to-left p∼q₂ q⟶q′
   in ∃ λ (p′₁≡p′₂ : p′₁ ≡ p′₂) →
        subst (p [ μ ]↝₂_) p′₁≡p′₂ p⟶p′₁ ≡ p⟶p′₂
          ×
        [ i ] subst (ν′ StepC ∞ ∘ (_, q′)) p′₁≡p′₂ p′∼q′₁ ≡′ p′∼q′₂)   □

  where
  open Container

  StepC₁ = Step₁.StepC
  StepC₂ = Step₂.StepC

module Bisimilarity-of-∼
         (ext : Eq.Extensionality ℓ ℓ)
         {p q} {i : Size}
         (p∼q₁ p∼q₂ : ν StepC ∞ (p , q))
         where

  -- A "constructor".

  ⟨_,_,_,_,_⟩ :
    (∀ {p′ μ} (p⟶p′ : p [ μ ]⟶ p′) →
     let q′₁ , q⟶q′₁ , p′∼q′₁ = StepC.left-to-right p∼q₁ p⟶p′
         q′₂ , q⟶q′₂ , p′∼q′₂ = StepC.left-to-right p∼q₂ p⟶p′
     in ∃ λ (q′₁≡q′₂ : q′₁ ≡ q′₂) →
          subst (q [ μ ]↝₁_) q′₁≡q′₂ q⟶q′₁ ≡ q⟶q′₂
            ×
          [ i ] subst (ν′ StepC ∞ ∘ (p′ ,_)) q′₁≡q′₂ p′∼q′₁ ≡′ p′∼q′₂) →
    (∀ {q′ μ} (q⟶q′ : q [ μ ]⟶ q′) →
     let p′₁ , p⟶p′₁ , p′∼q′₁ = StepC.right-to-left p∼q₁ q⟶q′
         p′₂ , p⟶p′₂ , p′∼q′₂ = StepC.right-to-left p∼q₂ q⟶q′
     in ∃ λ (p′₁≡p′₂ : p′₁ ≡ p′₂) →
          subst (p [ μ ]↝₂_) p′₁≡p′₂ p⟶p′₁ ≡ p⟶p′₂
            ×
          [ i ] subst (ν′ StepC ∞ ∘ (_, q′)) p′₁≡p′₂ p′∼q′₁ ≡′ p′∼q′₂) →
    [ i ] p∼q₁ ≡ p∼q₂
  ⟨_,_,_,_,_⟩ = curry (_↔_.from ([]≡↔ ext p∼q₁ p∼q₂))

  -- Some "projections".

  left-to-right :
    [ i ] p∼q₁ ≡ p∼q₂ →
    ∀ {p′ μ} (p⟶p′ : p [ μ ]⟶ p′) →
    let q′₁ , q⟶q′₁ , p′∼q′₁ = StepC.left-to-right p∼q₁ p⟶p′
        q′₂ , q⟶q′₂ , p′∼q′₂ = StepC.left-to-right p∼q₂ p⟶p′
    in ∃ λ (q′₁≡q′₂ : q′₁ ≡ q′₂) →
         subst (q [ μ ]↝₁_) q′₁≡q′₂ q⟶q′₁ ≡ q⟶q′₂
           ×
         [ i ] subst (ν′ StepC ∞ ∘ (p′ ,_)) q′₁≡q′₂ p′∼q′₁ ≡′ p′∼q′₂
  left-to-right = proj₁ ∘ _↔_.to ([]≡↔ ext p∼q₁ p∼q₂)

  right-to-left :
    [ i ] p∼q₁ ≡ p∼q₂ →
    ∀ {q′ μ} (q⟶q′ : q [ μ ]⟶ q′) →
    let p′₁ , p⟶p′₁ , p′∼q′₁ = StepC.right-to-left p∼q₁ q⟶q′
        p′₂ , p⟶p′₂ , p′∼q′₂ = StepC.right-to-left p∼q₂ q⟶q′
    in ∃ λ (p′₁≡p′₂ : p′₁ ≡ p′₂) →
         subst (p [ μ ]↝₂_) p′₁≡p′₂ p⟶p′₁ ≡ p⟶p′₂
           ×
         [ i ] subst (ν′ StepC ∞ ∘ (_, q′)) p′₁≡p′₂ p′∼q′₁ ≡′ p′∼q′₂
  right-to-left = proj₂ ∘ _↔_.to ([]≡↔ ext p∼q₁ p∼q₂)

-- A statement of extensionality for bisimilarity.

Extensionality : Type ℓ
Extensionality = ν′-extensionality StepC

-- This form of extensionality can be used to derive another form
-- (in the presence of extensionality for functions).

extensionality :
  Eq.Extensionality ℓ ℓ →
  Extensionality →
  ∀ {p q} {p∼q₁ p∼q₂ : ν StepC ∞ (p , q)} →
  [ ∞ ] p∼q₁ ≡ p∼q₂ → p∼q₁ ≡ p∼q₂
extensionality ext ν-ext = ν-extensionality ext ν-ext

open StepC public using (⟨_,_⟩; left-to-right; right-to-left)


module Generic.Lib.Prelude where

open import Generic.Lib.Intro                  public
open import Generic.Lib.Equality.Propositional public
open import Generic.Lib.Equality.Coerce        public
open import Generic.Lib.Equality.Heteroindexed public
open import Generic.Lib.Equality.Congn         public
open import Generic.Lib.Decidable              public
open import Generic.Lib.Category               public
open import Generic.Lib.Data.Nat               public
open import Generic.Lib.Data.String            public
open import Generic.Lib.Data.Maybe             public
open import Generic.Lib.Data.Sum               public
open import Generic.Lib.Data.Product           public
open import Generic.Lib.Data.List              public
open import Generic.Lib.Data.Pow               public
open import Generic.Lib.Data.Sets              public
open import Generic.Lib.Reflection.Core        public
open import Generic.Lib.Reflection.Fold        public


------------------------------------------------------------------------------
-- Translation of projection-like functions
------------------------------------------------------------------------------

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

-- 2012-04-03: More information about what is a projection-like in the
-- patch:
--
--   Mon Apr  2 02:41:41 COT 2012  Andreas Abel <andreas.abel@ifi.lmu.de>
--   * Type signatures and comments explaining what is considered projection-like.

-- 2012-02-23: The function P is not considered a projection-like
-- function after the patch:
--
--   Tue Feb 21 11:41:08 COT 2012  Nils Anders Danielsson <nils.anders.danielsson@gmail.com>
--   * The positivity checker (and more) is now only run once per mutual block.

-- 2011-09-23: From the Agda mailing list
-- Subject: Compiler internals for projection functions
-- There is some additional information about this issue.

-- 2011-09-19: Maybe the information in the issue 465 (Missing
-- patterns in funClauses) is useful.

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

module ProjectionLikeFunction where

open import Common.FOL

postulate
  N : D → Set

-- See Issue #81.
P : D → Set
P i = i ≡ i
{-# ATP definition P #-}

foo : ∀ {n} → N n → n ≡ n
foo {n} Nn = bar
  where
  postulate bar : P n
  {-# ATP prove bar #-}


module consoleExamples.helloWorld where

open import ConsoleLib

main : ConsoleProg
main = run (WriteString "Hello World")


open import Issue3188.Issue3188a

B : Set
B = Set


-- Andreas, 2020-03-27, issue #3684
-- Warn about duplicate fields instead of hard error.

module DuplicateFields where

postulate X : Set

record D : Set where
  field x : X

d : X → X → D
d x y = record{ x = x; x = y }


module Examples.Syntax where

open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.String using (_++_)
open import Luau.Syntax using (var; _$_; return; nil; function_is_end; local_←_; done; _∙_; _⟨_⟩)
open import Luau.Syntax.ToString using (exprToString; blockToString)

ex1 : exprToString(function "" ⟨ var "x" ⟩ is return (var "f" $ var "x") ∙ done end) ≡
  "function(x)\n" ++
  "  return f(x)\n" ++
  "end"
ex1 = refl

ex2 : blockToString(local var "x" ← nil ∙ return (var "x") ∙ done) ≡
  "local x = nil\n" ++
  "return x"
ex2 = refl

ex3 : blockToString(function "f" ⟨ var "x" ⟩ is return (var "x") ∙ done end ∙ return (var "f") ∙ done) ≡
  "local function f(x)\n" ++
  "  return x\n" ++
  "end\n" ++
  "return f"
ex3 = refl


-- Bug: With abstraction depended on bound variable names!
module Issue233 where

postulate
  T   : (Set → Set) → Set
  mkT : (F : Set → Set) → T F

foo : T (λ A → A)
foo with λ (B : Set) → B
... | F = mkT F


{- Denotational semantics of the terms in the category of temporal types. -}
module Semantics.Terms where

open import Syntax.Context renaming (_,_ to _,,_)
open import Syntax.Terms
open import Syntax.Types

open import Semantics.Types
open import Semantics.Context

open import CategoryTheory.Instances.Reactive
open import CategoryTheory.Linear
open import TemporalOps.Box
open import TemporalOps.Diamond
open import TemporalOps.OtherOps
open import TemporalOps.Linear
open import TemporalOps.StrongMonad

open import CategoryTheory.Functor
open import CategoryTheory.NatTrans renaming (_⟹_ to ⟹)
import CategoryTheory.Monad as M
import CategoryTheory.Comonad as W

open import Data.Product
open import Data.Sum hiding ([_,_])
import Data.Nat as N

open W.Comonad W-□
open M.Monad M-◇
private module F-◇ = Functor F-◇
private module F-□ = Functor F-□
-- open Linear ℝeactive-linear

mutual
    -- Denotation of pure terms as morphisms from contexts to types.
    ⟦_⟧ₘ : ∀{Γ A} -> Γ ⊢ A -> (⟦ Γ ⟧ₓ ⇴ ⟦ A ⟧ⱼ)
    ⟦ var top       ⟧ₘ = π₂
    ⟦ var (pop x)   ⟧ₘ = ⟦ var x ⟧ₘ ∘ π₁
    ⟦ lam M         ⟧ₘ = Λ ⟦ M ⟧ₘ
    ⟦ F $ M         ⟧ₘ = eval ∘ ⟨ ⟦ F ⟧ₘ , ⟦ M ⟧ₘ ⟩
    ⟦ unit          ⟧ₘ = !
    ⟦ [ M ,, N ]    ⟧ₘ = ⟨ ⟦ M ⟧ₘ , ⟦ N ⟧ₘ ⟩
    ⟦ fst M         ⟧ₘ = π₁ ∘ ⟦ M ⟧ₘ
    ⟦ snd M         ⟧ₘ = π₂ ∘ ⟦ M ⟧ₘ
    ⟦ inl M         ⟧ₘ = ι₁ ∘ ⟦ M ⟧ₘ
    ⟦ inr M         ⟧ₘ = ι₂ ∘ ⟦ M ⟧ₘ
    ⟦ case M inl↦ B₁ ||inr↦ B₂ ⟧ₘ = [ ⟦ B₁ ⟧ₘ ⁏ ⟦ B₂ ⟧ₘ ] ∘ dist ∘ ⟨ id , ⟦ M ⟧ₘ ⟩
    ⟦ sample {A} S  ⟧ₘ = ε.at ⟦ A ⟧ₜ ∘ ⟦ S ⟧ₘ
    ⟦ stable {Γ} S  ⟧ₘ = F-□.fmap ⟦ S ⟧ₘ ∘ ⟦ Γ ˢ⟧□
    ⟦ sig S         ⟧ₘ = ⟦ S ⟧ₘ
    ⟦ letSig S In B ⟧ₘ = ⟦ B ⟧ₘ ∘ ⟨ id , ⟦ S ⟧ₘ ⟩
    ⟦ event E       ⟧ₘ = ⟦ E ⟧ᵐ

    -- Helper function for interpreting bound events
    bindEvent : ∀ Γ {⟦A⟧ ⟦B⟧} -> (⟦E⟧ : ⟦ Γ ⟧ₓ ⇴ ◇ ⟦A⟧) (⟦C⟧ : ⟦ Γ ˢ ⟧ₓ ⊗ ⟦A⟧ ⇴ ◇ ⟦B⟧)
                  -> (⟦ Γ ⟧ₓ ⇴ ◇ ⟦B⟧)
    bindEvent Γ {⟦A⟧}{⟦B⟧} ⟦E⟧ ⟦C⟧ =
        μ.at ⟦B⟧ ∘ F-◇.fmap (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) ∘ st ⟦ Γ ˢ ⟧ₓ ⟦A⟧ ∘ ⟨ ⟦ Γ ˢ⟧□ , ⟦E⟧ ⟩

    -- Denotation of computational terms as Kleisli morphisms from contexts to types.
    ⟦_⟧ᵐ : ∀{Γ A} -> Γ ⊨ A -> (⟦ Γ ⟧ₓ ⇴ ◇ ⟦ A ⟧ⱼ)
    ⟦ pure {A} M     ⟧ᵐ = η.at ⟦ A ⟧ⱼ ∘ ⟦ M ⟧ₘ
    ⟦ letSig S InC C ⟧ᵐ = ⟦ C ⟧ᵐ ∘ ⟨ id , ⟦ S ⟧ₘ ⟩
    ⟦ letEvt_In_ {Γ} E C ⟧ᵐ = bindEvent Γ ⟦ E ⟧ₘ ⟦ C ⟧ᵐ
    ⟦ select_↦_||_↦_||both↦_ {Γ} E₁ C₁ E₂ C₂ C₃ ⟧ᵐ =
        bindEvent Γ (⟪ ⟦ E₁ ⟧ₘ , ⟦ E₂ ⟧ₘ ⟫) (handle ⟦ C₁ ⟧ᵐ ⟦ C₂ ⟧ᵐ ⟦ C₃ ⟧ᵐ)


{-# OPTIONS --copatterns #-}
module Issue1290 where

record R : Set1 where
  constructor con
  field
    A : Set
open R

postulate
  X : Set

x : R
A x = X

exp : R -> R
A (exp x) = A x


-- {-# OPTIONS -v 100 -v tc.meta.name:100 -v interactive.meta:10 #-}
module Issue526 where

-- Don't just write _49,
-- include the corresponding implicit variable name as well (if any)

postulate
  f : {A : Set} → {a : A} → Set1 → {B : Set} → Set

test : Set
test = f Set

test₁ : Set
test₁ = f {A = _} Set

postulate
  g : (B : Set) → Set

test₂ : Set
test₂ = g _

test₃ : _ → Set
test₃ ()


module Implicits.Resolution.Infinite.NormalFormEquiv where

open import Prelude

open import Implicits.Syntax
open import Implicits.Resolution.Infinite.Resolution
open import Implicits.Resolution.Embedding
open import Implicits.Resolution.Embedding.Lemmas

open import SystemF.Everything as F using ()
open import SystemF.NormalForm

open import Data.Vec hiding ([_])
open import Relation.Binary.HeterogeneousEquality as H using ()
open import Data.List.Any
open import Data.List.Properties
open import Data.Vec.Properties as VP using ()
open import Extensions.Vec
open import Function.Equivalence using (_⇔_; equivalence)

mutual

  from-⇓ : ∀ {ν n t a τ} {Γ : F.Ctx ν n} → Γ ⊢ t ⇓ a → ⟦ Γ ⟧ctx← ⊢ ⟦ a ⟧tp← ↓ τ →
           ∃ λ i → ⟦ Γ ⟧ctx← ⊢ ⟦ lookup i Γ ⟧tp← ↓ τ
  from-⇓ {Γ = Γ} (nvar i) ↓τ = i , ↓τ
  from-⇓ (napp p x) ↓τ = from-⇓ p (i-iabs (from-⇑ x) ↓τ)
  from-⇓ {Γ = Γ} (ntapp {a = a} b p) ↓τ = from-⇓ p
    (i-tabs ⟦ b ⟧tp← (subst (λ z → ⟦ Γ ⟧ctx← ⊢ z ↓ _) (⟦a/sub⟧tp← a b) ↓τ))

  from-⇑ : ∀ {ν n t a} {Γ : F.Ctx ν n} → Γ ⊢ t ⇑ a → ⟦ Γ ⟧ctx← ⊢ᵣ ⟦ a ⟧tp←
  from-⇑ (nbase b x) with ⟦base⟧tp← b
  from-⇑ (nbase b x) | τ , eq with from-⇓ x (subst (λ z → _ ⊢ z ↓ τ) (sym $ eq) (i-simp τ))
  from-⇑ (nbase b x) | τ , eq | i , lookup-i↓tc =
    subst (λ z → _ ⊢ᵣ z) (sym $ eq) (r-simp (lookup-∈ i _) lookup-i↓tc)
  from-⇑ (nabs p) = r-iabs (from-⇑ p)
  from-⇑ (ntabs p) = r-tabs (subst (λ z → z ⊢ᵣ _) (⟦weaken⟧ctx← _) (from-⇑ p))

  to-⇓ : ∀ {ν} {Δ : ICtx ν} {a τ t₁} → Δ ⊢ a ↓ τ → ⟦ Δ ⟧ctx→ ⊢ t₁ ⇓ ⟦ a ⟧tp→ →
        ∃ λ t₂ → ⟦ Δ ⟧ctx→ ⊢ t₂ ⇓ ⟦ simpl τ ⟧tp→
  to-⇓ (i-simp a) q = , q
  to-⇓ (i-iabs x p) q = to-⇓ p (napp q (proj₂ $ to-⇑ x))
  to-⇓ {Δ = Δ} (i-tabs {ρ = a} b p) q =
    to-⇓ p (subst (λ z → ⟦ Δ ⟧ctx→ ⊢ _ ⇓ z) (sym $ ⟦a/sub⟧tp→ a b) (ntapp ⟦ b ⟧tp→ q))

  to-⇑ : ∀ {ν} {Δ : ICtx ν} {a} → Δ ⊢ᵣ a → ∃ λ t → ⟦ Δ ⟧ctx→ ⊢ t ⇑ ⟦ a ⟧tp→
  to-⇑ {Δ = Δ} (r-simp {r = a} r r↓τ) = , nbase (⟦simpl⟧tp→ _) (proj₂ $ to-⇓ r↓τ var⇓a)
    where
      var⇓a : ⟦ Δ ⟧ctx→ ⊢ _ ⇓ ⟦ a ⟧tp→
      var⇓a = let (i , eq) = ∈⟶index (VP.List-∈⇒∈ r) in
        let i' = (subst Fin (sym $ length-map _ Δ) i) in
          subst (λ z → ⟦ Δ ⟧ctx→ ⊢ (F.var i') ⇓ z) (lookup⟦⟧ Δ i eq) (nvar i')
  to-⇑ (r-iabs p) =
    , nabs (proj₂ $ to-⇑ p)
  to-⇑ {Δ = Δ} (r-tabs {ρ = a} p) =
    , ntabs (⇑-subst-n (length-weaken-Δ Δ) (H.sym $ ⟦weaken⟧ctx→ Δ) (proj₂ (to-⇑ p)))

-- System F η-long-β-normal forms are isomorphic to infinite resolution derivations
equivalent : ∀ {ν} (Δ : ICtx ν) r → Δ ⊢ᵣ r ⇔ (∃ λ t → ⟦ Δ ⟧ctx→ ⊢ t ⇑ ⟦ r ⟧tp→)
equivalent Δ r = equivalence
  (λ x → to-⇑ x)
  (λ x → subst₂ (λ Δ' r' → Δ' ⊢ᵣ r') (ctx→← _) (tp→← r) (from-⇑ (proj₂ x)))

{-}
open import Function.Inverse
open import Function.Equality

-- from-⇑ : ∀ {ν n t a} {Γ : F.Ctx ν n} → Γ ⊢ t ⇑ a → ⟦ Γ ⟧ctx← ⊢ᵣ ⟦ a ⟧tp←
from-⇑' : ∀ {ν a} {Δ : ICtx ν} → (∃ λ t → ⟦ Δ ⟧ctx→ ⊢ t ⇑ ⟦ a ⟧tp→) → Δ ⊢ᵣ a
from-⇑' (_ , p) = subst₂ (λ Δ a → Δ ⊢ᵣ a) (ctx→← _) (tp→← _) (from-⇑ p)

-- from-⇓' : ∀ {ν a} {Δ : ICtx ν} {τ} → (∃ λ t → ⟦ Δ ⟧ctx→ ⊢ t ⇓ ⟦ a ⟧tp→) → Δ ⊢ Δ ⊢ a ↓ τ
-- from-⇓' {τ = τ} (_ , p) = subst₂ (λ Δ a → Δ ⊢ a ↓ τ) (ctx→← _) (tp→← _) (from-⇓ p)

-- from-to-⇓ : ∀ {ν a} {Δ : ICtx ν} {τ} → (p : Δ ⊢ a ↓ τ) → from-⇓' (to-⇓ p) ≡ p
-- from-to-⇓ p = ?

from-to-⇑ : ∀ {ν a} {Δ : ICtx ν} → (p : Δ ⊢ᵣ a) → from-⇑' (to-⇑ p) ≡ p
from-to-⇑ (r-simp x x₁) = {!!}
from-to-⇑ (r-iabs p) = begin
  from-⇑' (, (nabs (proj₂ (to-⇑ p))))
    ≡⟨ refl ⟩
  subst₂ (λ Δ a → Δ ⊢ᵣ a) (ctx→← _) (tp→← _) (from-⇑ (nabs (proj₂ (to-⇑ p))))
    ≡⟨ refl ⟩
  subst₂ (λ Δ a → Δ ⊢ᵣ a) (ctx→← _) (tp→← _) (r-iabs (from-⇑ (proj₂ (to-⇑ p))))
    ≡⟨ {!!} ⟩
  r-iabs (subst₂ (λ Δ a → Δ ⊢ᵣ a) (ctx→← _) (tp→← _) (from-⇑ (proj₂ (to-⇑ p))))
    ≡⟨ refl ⟩
  r-iabs (from-⇑' (to-⇑ p))
    ≡⟨ Prelude.cong r-iabs (from-to-⇑ p) ⟩
  r-iabs p ∎
from-to-⇑ (r-tabs p) with from-to-⇑ p
from-to-⇑ (r-tabs p) | x = {!x!}
  where
    lem : ∀ {ν a} {Δ : ICtx ν} →

to-from-⇑ : ∀ {ν a} {Δ : ICtx ν} → (p : ∃ λ t → ⟦ Δ ⟧ctx→ ⊢ t ⇑ ⟦ a ⟧tp→) → to-⇑ (from-⇑' p) ≡ p
to-from-⇑ p = {!!}

iso' : ∀ {ν a} {Δ : ICtx ν} → (→-to-⟶ (to-⇑ {Δ = Δ} {a = a})) InverseOf (→-to-⟶ from-⇑')
iso' = record { left-inverse-of = to-from-⇑; right-inverse-of = from-to-⇑ }
-}


-- Andreas, 2018-08-14, issue #1556
-- Rule out very dependent types by looking for recursive calls
-- in the types of definitions.

-- {-# OPTIONS -v term:20 -v rec.graph:80 #-}

A : Set
data D : A → Set      -- D --> A  (new!)
a : A                 -- a --> A  (new!)

A = D a               -- A --> D, a
data D where d : D a  -- TODO: D --> a
a = d                 -- a --> d

-- Should be rejected, e.g., by termination checker.


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Binary.Equality.Propositional directly.
------------------------------------------------------------------------

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

module Data.Vec.Relation.Equality.Propositional where

open import Data.Vec.Relation.Binary.Equality.Propositional public


-- Andreas, 2015-03-10, issue reported by Andrea Vezzosi

postulate
  X : Set

data D p : X → Set p where
  c : ∀ i → D _ i

-- WAS: internal error in Substitute.hs due to negative De Bruijn index

-- should work now


-- Andreas, 2020-03-27, re #3684

record R : Set₁ where

_ : R
_ = record { f = Set; f = Set }

-- Should complain about alien fields rather than duplicate fields

-- The record type R does not have the fields f, f
-- when checking that the expression record { f = Set ; f = Set } has type R


-- Andreas, 2017-01-12, issue #2386

-- Should be rejected:
data Eq (A : Set) : (x y : A) → Set where
  refl : (x y : A) → Eq A x y

{-# BUILTIN EQUALITY Eq #-}

-- Expected error:
-- Wrong type of constructor of BUILTIN EQUALITY
-- when checking the pragma BUILTIN EQUALITY Eq


------------------------------------------------------------------------
-- A terminating parser data type and the accompanying interpreter
------------------------------------------------------------------------

module RecursiveDescent.Coinductive.Internal where

open import RecursiveDescent.Index
open import Data.Bool
open import Data.Product.Record
open import Data.Maybe
open import Data.BoundedVec.Inefficient
import Data.List as L
open import Data.Nat
open import Category.Applicative.Indexed
open import Category.Monad.Indexed
open import Category.Monad.State
open import Utilities

------------------------------------------------------------------------
-- Parser data type

-- A type for parsers which can be implemented using recursive
-- descent. The types used ensure that the implementation below is
-- structurally recursive.

codata Parser (tok : Set) : ParserType₁ where
  symbol :  Parser tok (false , leaf) tok
  ret    :  forall {r} -> r -> Parser tok (true , leaf) r
  fail   :  forall {r} -> Parser tok (false , leaf) r
  bind₀  :  forall {c₁ e₂ c₂ r₁ r₂}
         -> Parser tok (true , c₁) r₁
         -> (r₁ -> Parser tok (e₂ , c₂) r₂)
         -> Parser tok (e₂ , node c₁ c₂) r₂
  bind₁  :  forall {c₁ r₁ r₂} {i₂ : r₁ -> Index}
         -> Parser tok (false , c₁) r₁
         -> ((x : r₁) -> Parser tok (i₂ x) r₂)
         -> Parser tok (false , step c₁) r₂
  alt₀   :  forall {c₁ e₂ c₂ r}
         -> Parser tok (true , c₁)         r
         -> Parser tok (e₂   , c₂)         r
         -> Parser tok (true , node c₁ c₂) r
  alt₁   :  forall {c₁} e₂ {c₂ r}
         -> Parser tok (false , c₁)         r
         -> Parser tok (e₂    , c₂)         r
         -> Parser tok (e₂    , node c₁ c₂) r

------------------------------------------------------------------------
-- Run function for the parsers

-- Parser monad.

P : Set -> IFun ℕ
P tok = IStateT (BoundedVec tok) L.List

PIMonadPlus : (tok : Set) -> RawIMonadPlus (P tok)
PIMonadPlus tok = StateTIMonadPlus (BoundedVec tok) L.monadPlus

PIMonadState : (tok : Set) -> RawIMonadState (BoundedVec tok) (P tok)
PIMonadState tok = StateTIMonadState (BoundedVec tok) L.monad

private
  open module LM {tok} = RawIMonadPlus  (PIMonadPlus  tok)
  open module SM {tok} = RawIMonadState (PIMonadState tok)
                           using (get; put; modify)

-- For every successful parse the run function returns the remaining
-- string. (Since there can be several successful parses a list of
-- strings is returned.)

-- This function is structurally recursive with respect to the
-- following lexicographic measure:
--
-- 1) The upper bound of the length of the input string.
-- 2) The parser's proper left corner tree.

mutual

  parse : forall n {tok e c r} ->
          Parser tok (e , c) r ->
          P tok n (if e then n else pred n) r
  parse zero    symbol             = ∅
  parse (suc n) symbol             = eat =<< get
  parse n       (ret x)            = return x
  parse n       fail               = ∅
  parse n       (bind₀      p₁ p₂) = parse  n      p₁ >>= parse  n ∘′ p₂
  parse zero    (bind₁      p₁ p₂) = ∅
  parse (suc n) (bind₁      p₁ p₂) = parse (suc n) p₁ >>= parse↑ n ∘′ p₂
  parse n       (alt₀       p₁ p₂) = parse  n      p₁ ∣   parse↑ n    p₂
  parse n       (alt₁ true  p₁ p₂) = parse↑ n      p₁ ∣   parse  n    p₂
  parse n       (alt₁ false p₁ p₂) = parse  n      p₁ ∣   parse  n    p₂

  parse↑ : forall n {e tok c r} -> Parser tok (e , c) r -> P tok n n r
  parse↑ n       {true}  p = parse n p
  parse↑ zero    {false} p = ∅
  parse↑ (suc n) {false} p = parse (suc n) p >>= \r ->
                             modify ↑ >>
                             return r

  eat : forall {tok n} -> BoundedVec tok (suc n) -> P tok (suc n) n tok
  eat []      = ∅
  eat (c ∷ s) = put s >> return c


-- Andreas, 2019-06-25, issue #3855 reported by nad
-- Constraint solver needs to respect erasure.

open import Agda.Builtin.Bool

module _ where

  record RB (b : Bool) : Set where
    bPar : Bool
    bPar = b

  myBPar : (@0 b : Bool) → RB b → Bool
  myBPar b r = RB.bPar {b = {!b!}} r         -- should be rejected


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

module Light.Implementation.Data.Unit where

open import Light.Library.Data.Unit using (Library ; Dependencies)

instance dependencies : Dependencies
dependencies = record {}

instance library : Library dependencies
library = record { Implementation }
      where
      module Implementation where
            record Unit : Set where constructor unit


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

open import Cubical.Modalities.Modality public


{-# OPTIONS --cubical --safe --no-import-sorts #-}

module Cubical.HITs.Delooping.Two.Properties where

open import Cubical.Functions.Involution

open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence

open import Cubical.Data.Bool
open import Cubical.Data.Empty
open import Cubical.Data.Unit

open import Cubical.HITs.Delooping.Two.Base
open import Cubical.HITs.PropositionalTruncation

private
  variable
    ℓ : Level

module Embed where
  isSetIsPropDep : isOfHLevelDep {ℓ' = ℓ} 1 isSet
  isSetIsPropDep = isOfHLevel→isOfHLevelDep 1 (λ _ → isPropIsSet)

  notSet : PathP (λ i → isSet (notEq i)) isSetBool isSetBool
  notSet = isSetIsPropDep isSetBool isSetBool notEq

  notNot² : Square notEq refl refl notEq
  notNot² = involPath² notnot

  notNotSet
    : SquareP (λ i j → isSet (notNot² i j)) notSet refl refl notSet
  notNotSet = isPropDep→isSetDep'
                isSetIsPropDep
                (involPath² notnot)
                notSet refl refl notSet

  Code : Bℤ₂ → hSet ℓ-zero
  Code = Elim.rec
    (Bool , isSetBool)
    (λ i → notEq i , notSet i)
    (λ i j → λ where
      .fst → notNot² i j
      .snd → notNotSet i j)
    (isOfHLevelTypeOfHLevel 2)

  El : Bℤ₂ → Type₀
  El b = Code b .fst

module BINARY where
  open import Cubical.Data.FinSet.Binary.Large

  sem : Bℤ₂ → Binary _
  sem = Elim.rec Base Loop Loop² isGroupoidBinary

  loop? : Bool → base ≡ base
  loop? false = refl
  loop?  true = loop

  Loop²-coh : (a b c : Bool) → Type₀
  Loop²-coh false false false = Unit
  Loop²-coh false  true  true = Unit
  Loop²-coh  true false  true = Unit
  Loop²-coh  true  true false = Unit
  Loop²-coh     _     _     _ = ⊥

  rf : Bool ≡ Bool → Bool
  rf P = transport P false

  Loop²-coh-lemma₀
    : ∀(p q r : Bool)
    → r ⊕ p ≡ q
    → Loop²-coh p q r
  Loop²-coh-lemma₀ false false false sq = _
  Loop²-coh-lemma₀ false  true  true sq = _
  Loop²-coh-lemma₀  true false  true sq = _
  Loop²-coh-lemma₀  true  true false sq = _
  Loop²-coh-lemma₀ false  true false = false≢true
  Loop²-coh-lemma₀ false false  true = true≢false
  Loop²-coh-lemma₀  true false false = true≢false
  Loop²-coh-lemma₀  true  true  true = false≢true

  Loop²-coh-lemma
    : ∀(P Q R : Bool ≡ Bool)
    → Square P Q refl R
    → Loop²-coh (rf P) (rf Q) (rf R)
  Loop²-coh-lemma P Q R sq = Loop²-coh-lemma₀ p q r eqn
    where
    p = rf P
    q = rf Q
    r = rf R

    open BoolReflection

    cmp : P ∙ R ≡ Q
    cmp i j
      = hcomp (λ k → λ where
            (i = i0) → compPath-filler P R k j
            (i = i1) → Q j
            (j = i0) → Bool
            (j = i1) → R (i ∨ k))
          (sq i j)

    rcmp : ⊕-Path (r ⊕ p) ≡ ⊕-Path q
    rcmp = ⊕-Path (r ⊕ p)
             ≡[ i ]⟨ ⊕-comp p r (~ i) ⟩
           ⊕-Path p ∙ ⊕-Path r
             ≡[ i ]⟨ ⊕-complete P (~ i) ∙ ⊕-complete R (~ i) ⟩
           P ∙ R
             ≡⟨ cmp ⟩
           Q
             ≡⟨ ⊕-complete Q ⟩
           ⊕-Path q ∎
    open Iso
    eqn : r ⊕ p ≡ q
    eqn = transport (λ i →
              reflectIso .leftInv (r ⊕ p) i ≡ reflectIso .leftInv q i)
            (cong (reflectIso .inv) rcmp)

  loop²?
    : ∀ p q r → Loop²-coh p q r
    → Square (loop? p) (loop? q) refl (loop? r)
  loop²? false false false _ = refl
  loop²? false  true  true _ = λ i j → loop (i ∧ j)
  loop²?  true false  true _ = loop²
  loop²?  true  true false _ = refl

  module _ (B : Type₀) where
    based : (P : Bool ≃ B) → Bℤ₂
    based _ = base

    pull₀ : (P Q : Bool ≃ B) → Bool ≡ Bool
    pull₀ P Q i
      = hcomp (λ k → λ where
            (i = i0) → ua P (~ k)
            (i = i1) → ua Q (~ k))
          B

    pull₁ : (P Q : Bool ≃ B) → Square (ua P) (ua Q) (pull₀ P Q) refl
    pull₁ P Q i j
      = hcomp (λ k → λ where
            (i = i0) → ua P (~ k ∨ j)
            (i = i1) → ua Q (~ k ∨ j)
            (j = i1) → B)
          B

    pull₂
      : (P Q R : Bool ≃ B)
      → Square (pull₀ P Q) (pull₀ P R) refl (pull₀ Q R)
    pull₂ P Q R i j
      = hcomp (λ k → λ where
            (j = i0) → ua P (~ k)
            (i = i0) (j = i1) → ua Q (~ k)
            (i = i1) (j = i1) → ua R (~ k))
          B

    pull₃
      : (P Q R : Bool ≃ B)
      → Cube (pull₁ P Q) (pull₁ P R)
            (λ _ → ua P)  (pull₁ Q R)
            (pull₂ P Q R) (λ _ _ → B)
    pull₃ P Q R i j k
      = hcomp (λ τ → λ where
            (j = i0) → ua P (~ τ ∨ k)
            (i = i0) (j = i1) → ua Q (~ τ ∨ k)
            (i = i1) (j = i1) → ua R (~ τ ∨ k)
            (k = i1) → B)
          B

    looped : (P Q : Bool ≃ B) → based P ≡ based Q
    looped P Q = loop? b
      where
      b : Bool
      b = rf (pull₀ P Q)

    looped²
      : (P Q R : Bool ≃ B)
      → Square (looped P Q) (looped P R) refl (looped Q R)
    looped² P Q R = loop²? pq pr qr pqr
      where
      pq = rf (pull₀ P Q)
      pr = rf (pull₀ P R)
      qr = rf (pull₀ Q R)

      pqr : Loop²-coh pq pr qr
      pqr = Loop²-coh-lemma (pull₀ P Q) (pull₀ P R) (pull₀ Q R) (pull₂ P Q R)

  syn : Binary _ → Bℤ₂
  syn (B , tP) = rec→Gpd trunc (based B) 3k tP
    where
    open 3-Constant
    3k : 3-Constant (based B)
    3k .link = looped B
    3k .coh₁ = looped² B


{-# OPTIONS --rewriting --confluence-check #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

postulate
  A : Set
  a b : A
  f : A → A
  rew₁ : f a ≡ b
  rew₂ : f ≡ λ _ → a

{-# REWRITE rew₁ #-}
{-# REWRITE rew₂ #-}


------------------------------------------------------------------------------
-- Alter: An unguarded co-recursive function
------------------------------------------------------------------------------

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

module FOT.FOTC.UnguardedCorecursion.Alter.Alter where

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

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

postulate
  alter    : D
  alter-eq : alter ≡ true ∷ false ∷ alter
{-# ATP axiom alter-eq #-}

postulate
  not₀    : D
  not₀-eq : ∀ b → not₀ · b ≡ not b
{-# ATP axiom not₀-eq #-}

postulate
  alter' : D
  alter'-eq : alter' ≡ true ∷ map not₀ alter'
{-# ATP axiom alter'-eq #-}


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

module lib.Basics where

open import lib.Base public

open import lib.Equivalence public
open import lib.Function public
open import lib.Funext public
open import lib.NType public
open import lib.PathFunctor public
open import lib.PathGroupoid public
open import lib.PathOver public
open import lib.Relation public
open import lib.Univalence public


open import MJ.Types
import MJ.Classtable.Core as Core
import MJ.Classtable.Code as Code
import MJ.Syntax as Syntax

module MJ.Semantics.Objects.Flat {c}(Ct : Core.Classtable c)(ℂ : Code.Code Ct) where

open import Prelude

open import Level renaming (suc to lsuc; zero to lzero)
open import Data.Vec hiding (_++_; lookup; drop)
open import Data.Star
open import Data.List
open import Data.List.First.Properties
open import Data.List.Membership.Propositional
open import Data.List.Any.Properties
open import Data.List.All as All
open import Data.List.All.Properties.Extra
open import Data.List.Prefix
open import Data.List.Properties.Extra
open import Data.Maybe as Maybe
open import Data.Maybe.Relation.Unary.All as MayAll using ()
open import Data.String using (String)
open import Relation.Binary.PropositionalEquality

open import MJ.Semantics.Values Ct
open import MJ.Semantics.Objects Ct
open import MJ.Syntax Ct
open Code Ct
open Core c
open Classtable Ct
open import MJ.Classtable.Membership Ct

private

  collect : ∀ {cid}(chain : Σ ⊢ cid <: Object) ns → List (String × typing ns)
  collect (super {cid} ◅ ch) ns = Class.decls (Σ (cls cid)) ns ++ collect ch ns
  collect ε ns = Class.decls (Σ Object) ns

  {-
  We define collect members by delegation to collection of members over a particular
  inheritance chain.
  This makes the definition structurally recursive and is sound by the fact that
  inheritance chains are unique.
  -}
  collect-members : ∀ cid ns → List (String × typing ns)
  collect-members cid ns = collect (rooted cid) ns

  {-
  An Object is then simply represented by a list of values for all it's members.
  -}
  Obj : (World c) → (cid : _) → Set
  Obj W cid = All (λ d → Val W (proj₂ d)) (collect-members cid FIELD)

  weaken-obj : ∀ {W W'} cid → W' ⊒ W → Obj W cid → Obj W' cid
  weaken-obj cid ext O = All.map (weaken-val ext) O

  {-
  We can relate the flat Object structure with the hierarchical notion of membership
  through the definition of `collect`.
  This allows us to get and set members on Objects.
  -}
  {-# TERMINATING #-}
  getter : ∀ {W n a} cid → Obj W cid → IsMember cid FIELD n a → Val W a
  getter cid O q with rooted cid
  getter .Object O (.Object , ε , def) | ε = ∈-all (proj₁ (first⟶∈ def)) O
  getter .Object O (_ , () ◅ _ , _) | ε
  getter ._ O (._ , ε , def) | super {cid} ◅ z
    with split-++ (Class.decls (Σ (cls _)) FIELD) _ O
  ... | own , inherited = ∈-all (proj₁ (first⟶∈ def)) own
  getter ._ O (pid , super {cid} ◅ s , def) | super ◅ z
    with split-++ (Class.decls (Σ (cls _)) FIELD) _ O
  ... | own , inherited rewrite <:-unique z (rooted (Class.parent (Σ (cls cid)))) =
    getter _ inherited (pid , s , def)

  {-# TERMINATING #-}
  setter : ∀ {W f a} cid → Obj W cid → IsMember cid FIELD f a → Val W a → Obj W cid
  setter (cls cid) O q v with rooted (cls cid)
  setter (cls cid) O (._ , ε , def) v | super ◅ z with split-++ (Class.decls (Σ (cls _)) FIELD) _ O
  ... | own , inherited =
    (own All.[ proj₁ (first⟶∈ def) ]≔ v) ++-all inherited
  setter (cls cid) O (._ , super ◅ s , def) v | super ◅ z with split-++ (Class.decls (Σ (cls _)) FIELD) _ O
  ... | own , inherited rewrite <:-unique z (rooted (Class.parent (Σ (cls cid)))) =
    own ++-all setter _ inherited (_ , s , def) v
  setter Object O mem v = ⊥-elim (∉Object mem)

  {-
  A default object instance can be created for every class simply by tabulating `default`
  over the types of all fields of a class.
  -}
  defaultObject' : ∀ {W cid} → (ch : Σ ⊢ cid <: Object) → All (λ d → Val W (proj₂ d)) (collect ch FIELD)
  defaultObject' ε rewrite Σ-Object = []
  defaultObject' {cid = Object} (() ◅ _)
  defaultObject' {cid = cls x} (super ◅ z) =
    All.tabulate {xs = Class.decls (Σ (cls x)) FIELD} (λ{ {_ , ty} _ → default ty})
    ++-all
    defaultObject' z

{-
We collect these definitions under the abstract ObjEncoding interface for usage in the semantics
-}
encoding : ObjEncoding
encoding = record {
    Obj = Obj ;
    weaken-obj = λ cid ext O → weaken-obj cid ext O ;
    getter = getter ;
    setter = setter ;
    defaultObject = λ cid → defaultObject' (rooted cid)
  }


------------------------------------------------------------------------
-- A quotient inductive-inductive definition of the partiality monad
------------------------------------------------------------------------

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

module Partiality-monad.Inductive where

import Equality.Path as P
open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (⊥)

open import Bijection equality-with-J using (_↔_)
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J

open import Partiality-algebra as PA hiding (_∘_)
open import Partiality-algebra.Eliminators as PAE hiding (Arguments)
import Partiality-algebra.Properties

private
  variable
    a ℓ p q : Level
    A       : Type a

mutual

  infix 10 _⊥
  infix 4  _⊑_

  -- Originally the monad was postulated. After the release of Cubical
  -- Agda it was turned into a QIIT, but in order to not get any extra
  -- computation rules it was made abstract.

  abstract

    -- The partiality monad.

    data _⊥ (A : Type a) : Type a where
      never        : A ⊥
      now          : A → A ⊥
      ⨆            : Increasing-sequence A → A ⊥
      antisymmetry : x ⊑ y → y ⊑ x → x P.≡ y

      -- We have chosen to explicitly make the type set-truncated.
      -- However, this constructor is mostly unused: it is used to
      -- define partiality-algebra below (and the corresponding record
      -- field is in turn also mostly unused, see its documentation
      -- for details), and it is mentioned in the implementation of
      -- eliminators (also below).
      ⊥-is-set-unused : P.Is-set (A ⊥)

  -- Increasing sequences.

  Increasing-sequence : Type ℓ → Type ℓ
  Increasing-sequence A =
    Σ (ℕ → A ⊥) λ f → ∀ n → f n ⊑ f (suc n)

  -- Upper bounds.

  Is-upper-bound :
    {A : Type a} → Increasing-sequence A → A ⊥ → Type a
  Is-upper-bound s x = ∀ n → (s [ n ]) ⊑ x

  -- A projection function for Increasing-sequence.

  infix 30 _[_]

  _[_] : Increasing-sequence A → ℕ → A ⊥
  _[_] s n = proj₁ {A = _ → _ ⊥} s n

  private
    variable
      x y z : A ⊥

  abstract

    -- An ordering relation.

    data _⊑_ {A : Type a} : A ⊥ → A ⊥ → Type a where
      ⊑-refl            : ∀ x → x ⊑ x
      ⊑-trans           : x ⊑ y → y ⊑ z → x ⊑ z
      never⊑            : ∀ x → never ⊑ x
      upper-bound       : ∀ s → Is-upper-bound s (⨆ s)
      least-upper-bound : ∀ s ub → Is-upper-bound s ub → ⨆ s ⊑ ub
      ⊑-propositional   : P.Is-proposition (x ⊑ y)

-- A partiality algebra for the partiality monad.

partiality-algebra : ∀ {a} (A : Type a) → Partiality-algebra a a A
partiality-algebra A = record
  { T                       = A ⊥
  ; partiality-algebra-with = record
    { _⊑_               = _⊑_
    ; never             = never′
    ; now               = now′
    ; ⨆                 = ⨆′
    ; antisymmetry      = antisymmetry′
    ; T-is-set-unused   = T-is-set-unused′
    ; ⊑-refl            = ⊑-refl′
    ; ⊑-trans           = ⊑-trans′
    ; never⊑            = never⊑′
    ; upper-bound       = upper-bound′
    ; least-upper-bound = least-upper-bound′
    ; ⊑-propositional   = ⊑-propositional′
    }
  }
  where

  abstract

    never′ : A ⊥
    never′ = never

    now′ : A → A ⊥
    now′ = now

    ⨆′ : Increasing-sequence A → A ⊥
    ⨆′ = ⨆

    antisymmetry′ : x ⊑ y → y ⊑ x → x ≡ y
    antisymmetry′ = λ p q → _↔_.from ≡↔≡ (antisymmetry p q)

    T-is-set-unused′ : Is-set (A ⊥)
    T-is-set-unused′ =
                      $⟨ (λ {x y} → ⊥-is-set-unused {x = x} {y = y}) ⟩
      P.Is-set (A ⊥)  ↝⟨ _↔_.from (H-level↔H-level 2) ⟩□
      Is-set (A ⊥)    □

    ⊑-refl′ : (x : A ⊥) → x ⊑ x
    ⊑-refl′ = ⊑-refl

    ⊑-trans′ : x ⊑ y → y ⊑ z → x ⊑ z
    ⊑-trans′ = ⊑-trans

    never⊑′ : ∀ x → never′ ⊑ x
    never⊑′ = never⊑

    upper-bound′ : ∀ s → Is-upper-bound s (⨆′ s)
    upper-bound′ = upper-bound

    least-upper-bound′ : ∀ s ub → Is-upper-bound s ub → ⨆′ s ⊑ ub
    least-upper-bound′ = least-upper-bound

    ⊑-propositional′ : Is-proposition (x ⊑ y)
    ⊑-propositional′ {x = x} {y = y} =
                                $⟨ ⊑-propositional ⟩
      P.Is-proposition (x ⊑ y)  ↝⟨ _↔_.from (H-level↔H-level 1) ⟩□
      Is-proposition (x ⊑ y)    □

abstract

  -- The elimination principle.

  eliminators : Elimination-principle p q (partiality-algebra A)
  eliminators {A = A} args = record
    { ⊥-rec       = ⊥-rec
    ; ⊑-rec       = ⊑-rec
    ; ⊥-rec-never = refl
    ; ⊥-rec-now   = λ _ → refl
    ; ⊥-rec-⨆     = λ _ → refl
    }
    where
    module A = PAE.Arguments args

    mutual

      inc-rec : (s : Increasing-sequence A) → A.Inc A.P A.Q s
      inc-rec (s , inc) = (λ n → ⊥-rec (s   n))
                        , (λ n → ⊑-rec (inc n))

      ⊥-rec : (x : A ⊥) → A.P x
      ⊥-rec never                                     = A.pe
      ⊥-rec (now x)                                   = A.po x
      ⊥-rec (⨆ s)                                     = A.pl s (inc-rec s)
      ⊥-rec (antisymmetry {x = x} {y = y} p q i)      = subst≡→[]≡
                                                          {B = A.P}
                                                          {eq = antisymmetry p q}
                                                          (A.pa p q
                                                             (⊥-rec x) (⊥-rec y)
                                                             (⊑-rec p) (⊑-rec q))
                                                          i
      ⊥-rec (⊥-is-set-unused {x = x} {y = y} p q i j) = lemma i j
        where
        ⊥-is-set-unused′ : P.Is-set (A ⊥)
        ⊥-is-set-unused′ = ⊥-is-set-unused

        lemma :
          P.[ (λ i → P.[ (λ j → A.P (⊥-is-set-unused′ p q i j)) ]
                       ⊥-rec x ≡ ⊥-rec y) ]
            (λ i → ⊥-rec (p i)) ≡ (λ i → ⊥-rec (q i))
        lemma = P.heterogeneous-UIP
                  (λ x → _↔_.to (H-level↔H-level 2) (A.pp {x = x}))
                  (⊥-is-set-unused p q)
                  _ _

      ⊑-rec : (x⊑y : x ⊑ y) → A.Q (⊥-rec x) (⊥-rec y) x⊑y
      ⊑-rec (⊑-refl x)                              = A.qr x (⊥-rec x)
      ⊑-rec (⊑-trans {x = x} {y = y} {z = z} p q)   = A.qt p q
                                                        (⊥-rec x) (⊥-rec y) (⊥-rec z)
                                                        (⊑-rec p) (⊑-rec q)
      ⊑-rec (never⊑ x)                              = A.qe x (⊥-rec x)
      ⊑-rec (upper-bound s n)                       = A.qu s (inc-rec s) n
      ⊑-rec (least-upper-bound s ub is-ub)          = A.ql s ub is-ub
                                                        (inc-rec s) (⊥-rec ub)
                                                        (λ n → ⊑-rec {x = proj₁ s n}
                                                                     (is-ub n))
      ⊑-rec (⊑-propositional {x = x} {y = y} p q i) = lemma i
        where
        ⊑-propositional′ : P.Is-proposition (x ⊑ y)
        ⊑-propositional′ = ⊑-propositional

        lemma : P.[ (λ i → A.Q (⊥-rec x) (⊥-rec y)
                             (⊑-propositional′ p q i)) ]
                  ⊑-rec p ≡ ⊑-rec q
        lemma =
          P.heterogeneous-irrelevance
            (λ p → _↔_.to (H-level↔H-level 1)
                     (A.qp (⊥-rec x) (⊥-rec y) p))

module _ {A : Type a} where

  open Partiality-algebra (partiality-algebra A) public
    hiding (T; _⊑_; _[_]; Increasing-sequence; Is-upper-bound)
    renaming ( T-is-set to ⊥-is-set
             ; equality-characterisation-T to
               equality-characterisation-⊥
             )

  open Partiality-algebra.Properties (partiality-algebra A) public

-- The eliminators' arguments.

Arguments : ∀ {a} p q (A : Type a) → Type (a ⊔ lsuc (p ⊔ q))
Arguments p q A = PAE.Arguments p q (partiality-algebra A)

module _ (args : Arguments p q A) where
  open Eliminators (eliminators args) public

-- Initiality.

initial : Initial p q (partiality-algebra A)
initial = eliminators→initiality _ eliminators


useful-lemma : ∀ {a} {A : Set a} → A
useful-lemma = useful-lemma


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness #-}

open import Data.Empty
open import Data.Product
open import Data.List using ([]; _∷_; _∷ʳ_; _++_)

open import Relation.Nullary
open import Relation.Unary using (_∈_; _⊆_;_∉_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
import Relation.Binary.HeterogeneousEquality as Het

open import Common

module HasTrace {ℙ : Set} (message : Message ℙ)
  where

open import Trace message
open import SessionType message
open import Transitions message

_HasTrace_ : SessionType -> Trace -> Set
_HasTrace_ T φ = ∃[ S ] (Defined S × Transitions T φ S)

after : ∀{T φ} -> T HasTrace φ -> SessionType
after (S , _ , _) = S

-- data _HasTrace_ : SessionType -> Trace -> Set where
--   does : ∀{T φ S} (tr : Transitions T φ S) (def : Defined S) -> T Does φ

_HasTrace?_ : (T : SessionType) (φ : Trace) -> Dec (T HasTrace φ)
nil HasTrace? _ = no λ { (_ , () , refl)
                       ; (_ , _ , step () _) }
inp f HasTrace? [] = yes (_ , inp , refl)
inp f HasTrace? (I x ∷ φ) with x ∈? f
... | no nfx = no λ { (_ , def , step inp tr) → nfx (transitions+defined->defined tr def) }
... | yes fx with f x .force HasTrace? φ
... | yes (_ , def , tr) = yes (_ , def , step inp tr)
... | no ntφ = no λ { (_ , def , step inp tr) → ntφ (_ , def , tr) }
inp f HasTrace? (O x ∷ φ) = no λ { (_ , _ , step () _) }
out f HasTrace? [] = yes (_ , out , refl)
out f HasTrace? (I x ∷ φ) = no λ { (_ , _ , step () _) }
out f HasTrace? (O x ∷ φ) with x ∈? f
... | no nfx = no λ { (_ , _ , step (out fx) _) → nfx fx }
... | yes fx with f x .force HasTrace? φ
... | yes (_ , def , tr) = yes (_ , def , step (out fx) tr)
... | no ntφ = no λ { (_ , def , step (out fx) tr) → ntφ (_ , def , tr) }

has-trace->defined : ∀{T φ} -> T HasTrace φ -> Defined T
has-trace->defined (_ , tdef , tr) = transitions+defined->defined tr tdef

inp-has-trace : ∀{f x φ} -> f x .force HasTrace φ -> inp f HasTrace (I x ∷ φ)
inp-has-trace (_ , def , tr) = _ , def , step inp tr

inp-has-no-trace : ∀{f x φ} -> ¬ f x .force HasTrace φ -> ¬ inp f HasTrace (I x ∷ φ)
inp-has-no-trace nφ (_ , def , step inp tr) = nφ (_ , def , tr)

out-has-trace : ∀{f x φ} -> f x .force HasTrace φ -> out f HasTrace (O x ∷ φ)
out-has-trace (_ , def , tr) = _ , def , step (out (transitions+defined->defined tr def)) tr

out-has-no-trace : ∀{f x φ} -> ¬ f x .force HasTrace φ -> ¬ out f HasTrace (O x ∷ φ)
out-has-no-trace nφ (_ , def , step (out fx) tr) = nφ (_ , def , tr)

out-has-no-trace->undefined : ∀{f x} -> ¬ out f HasTrace (O x ∷ []) -> ¬ Defined (f x .force)
out-has-no-trace->undefined {f} {x} nt with x ∈? f
... | yes fx = ⊥-elim (nt (_ , fx , step (out fx) refl))
... | no nfx = nfx

unprefix-some : ∀{α φ ψ} -> (α ∷ ψ) ⊑ (α ∷ φ) -> ψ ⊑ φ
unprefix-some (some pre) = pre

⊑-has-trace : ∀{T φ ψ} -> ψ ⊑ φ -> T HasTrace φ -> T HasTrace ψ
⊑-has-trace none (_ , tdef , tr) = _ , transitions+defined->defined tr tdef , refl
⊑-has-trace (some pre) (_ , tdef , step t tr) =
  let _ , sdef , sr = ⊑-has-trace pre (_ , tdef , tr) in
  _ , sdef , step t sr

split-trace : ∀{T φ ψ} (tφ : T HasTrace φ) -> T HasTrace (φ ++ ψ) -> after tφ HasTrace ψ
split-trace (_ , tdef , refl) tφψ = tφψ
split-trace (_ , tdef , step inp tr) (_ , sdef , step inp sr) = split-trace (_ , tdef , tr) (_ , sdef , sr)
split-trace (_ , tdef , step (out _) tr) (_ , sdef , step (out _) sr) = split-trace (_ , tdef , tr) (_ , sdef , sr)

join-trace : ∀{T φ ψ} (tφ : T HasTrace φ) -> after tφ HasTrace ψ -> T HasTrace (φ ++ ψ)
join-trace (_ , _ , refl) tφ/ψ = tφ/ψ
join-trace (_ , tdef , step t tr) tφ/ψ =
  let (_ , sdef , sr) = join-trace (_ , tdef , tr) tφ/ψ in
  _ , sdef , step t sr

⊑-has-co-trace : ∀{T φ ψ} -> φ ⊑ ψ -> T HasTrace (co-trace ψ) -> T HasTrace (co-trace φ)
⊑-has-co-trace le tψ = ⊑-has-trace (⊑-co-trace le) tψ

⊑-tran-has-trace : ∀{T φ ψ χ} (pre1 : φ ⊑ ψ) (pre2 : ψ ⊑ χ) ->
  (tχ : T HasTrace χ) ->
  ⊑-has-trace pre1 (⊑-has-trace pre2 tχ) ≡ ⊑-has-trace (⊑-tran pre1 pre2) tχ
⊑-tran-has-trace none none tχ = refl
⊑-tran-has-trace none (some pre2) (fst , fst₁ , step t snd) = refl
⊑-tran-has-trace (some pre1) (some pre2) (_ , def , step _ tr) rewrite ⊑-tran-has-trace pre1 pre2 (_ , def , tr) = refl

⊑-has-trace-after : ∀{T φ} (tφ : T HasTrace φ) -> ⊑-has-trace (⊑-refl φ) tφ ≡ tφ
⊑-has-trace-after (_ , _ , refl) = refl
⊑-has-trace-after (_ , tdef , step inp tr) rewrite ⊑-has-trace-after (_ , tdef , tr) = refl
⊑-has-trace-after (_ , tdef , step (out _) tr) rewrite ⊑-has-trace-after (_ , tdef , tr) = refl

nil-has-no-trace : ∀{φ} -> ¬ nil HasTrace φ
nil-has-no-trace (_ , () , refl)
nil-has-no-trace (_ , _ , step () _)

end-has-empty-trace : ∀{φ T} -> End T -> T HasTrace φ -> φ ≡ []
end-has-empty-trace (inp U) (_ , _ , refl) = refl
end-has-empty-trace (inp U) (_ , def , step inp refl) = ⊥-elim (U _ def)
end-has-empty-trace (inp U) (_ , def , step inp (step t _)) = ⊥-elim (U _ (transition->defined t))
end-has-empty-trace (out U) (_ , _ , refl) = refl
end-has-empty-trace (out U) (_ , _ , step (out !x) _) = ⊥-elim (U _ !x)

has-trace-++ : ∀{T φ ψ} -> T HasTrace (φ ++ ψ) -> T HasTrace φ
has-trace-++ tφψ = ⊑-has-trace ⊑-++ tφψ

trace-coherence : ∀{T φ ψ₁ ψ₂ x y} -> T HasTrace (φ ++ I x ∷ ψ₁) -> T HasTrace (φ ++ O y ∷ ψ₂) -> ⊥
trace-coherence {_} {[]} (_ , _ , step inp _) (_ , _ , step () _)
trace-coherence {_} {I _ ∷ _} (_ , tdef , step inp tr) (_ , sdef , step inp sr) = trace-coherence (_ , tdef , tr) (_ , sdef , sr)
trace-coherence {_} {O _ ∷ _} (_ , tdef , step (out _) tr) (_ , sdef , step (out _) sr) = trace-coherence (_ , tdef , tr) (_ , sdef , sr)

defined->has-empty-trace : ∀{T} -> Defined T -> T HasTrace []
defined->has-empty-trace inp = _ , inp , refl
defined->has-empty-trace out = _ , out , refl

has-trace-double-negation : ∀{T φ} -> ¬ ¬ T HasTrace φ -> T HasTrace φ
has-trace-double-negation {T} {φ} p with T HasTrace? φ
... | yes tφ = tφ
... | no ntφ = ⊥-elim (p ntφ)

{- New -}
not-nil-has-trace : ∀{ϕ} → ¬ (nil HasTrace ϕ)
not-nil-has-trace (.(inp _) , inp , step () _)
not-nil-has-trace (.(out _) , out , step () _)

trace-after-in : ∀{f x ϕ} → (inp f) HasTrace (I x ∷ ϕ) → (f x .force) HasTrace ϕ
trace-after-in (_ , def , step inp red) = _ , def , red

trace-after-out : ∀{f x ϕ} → (out f) HasTrace (O x ∷ ϕ) → (f x .force) HasTrace ϕ
trace-after-out (_ , def , step (out _) red) = _ , def , red

inp-hastrace->defined : ∀{f x tr} → (inp f) HasTrace (I x ∷ tr) → x ∈ dom f
inp-hastrace->defined (_ , def , step inp refl) = def
inp-hastrace->defined (_ , def , step inp (step red _)) = transition->defined red

empty-inp-has-empty-trace : ∀{f ϕ} → EmptyContinuation f → (inp f) HasTrace ϕ → ϕ ≡ []
empty-inp-has-empty-trace e (_ , _ , refl) = refl
empty-inp-has-empty-trace {f} e (_ , _ , step (inp {x = x}) reds) with Defined? (f x .force)
empty-inp-has-empty-trace {f} e (_ , def , step (inp {x = _}) refl) | no ¬def = ⊥-elim (¬def def)
empty-inp-has-empty-trace {f} e (_ , _ , step (inp {x = _}) (step t _)) | no ¬def = ⊥-elim (¬def (transition->defined t))
... | yes def = ⊥-elim (e _ def)

empty-out-has-empty-trace : ∀{f ϕ} → EmptyContinuation f → (out f) HasTrace ϕ → ϕ ≡ []
empty-out-has-empty-trace e (_ , _ , refl) = refl
empty-out-has-empty-trace e (_ , _ , step (out def) _) = ⊥-elim (e _ def)


------------------------------------------------------------------------
-- Aczel's structure identity principle (for 1-categories), more or
-- less as found in "Homotopy Type Theory: Univalent Foundations of
-- Mathematics" (first edition)
------------------------------------------------------------------------

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

open import Equality

module Structure-identity-principle
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Bijection eq using (_↔_; Σ-≡,≡↔≡)
open import Category eq
open Derived-definitions-and-properties eq
open import Equality.Decidable-UIP eq
open import Equivalence eq hiding (id; _∘_; inverse; lift-equality)
open import Function-universe eq hiding (id) renaming (_∘_ to _⊚_)
open import H-level eq
open import H-level.Closure eq
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (id)

-- Standard notions of structure.

record Standard-notion-of-structure
         {c₁ c₂} ℓ₁ ℓ₂ (C : Precategory c₁ c₂) :
         Type (c₁ ⊔ c₂ ⊔ lsuc (ℓ₁ ⊔ ℓ₂)) where
  open Precategory C

  field
    P               : Obj → Type ℓ₁
    H               : ∀ {X Y} (p : P X) (q : P Y) → Hom X Y → Type ℓ₂
    H-prop          : ∀ {X Y} {p : P X} {q : P Y}
                      (f : Hom X Y) → Is-proposition (H p q f)
    H-id            : ∀ {X} {p : P X} → H p p id
    H-∘             : ∀ {X Y Z} {p : P X} {q : P Y} {r : P Z} {f g} →
                      H p q f → H q r g → H p r (g ∙ f)
    H-antisymmetric : ∀ {X} (p q : P X) →
                      H p q id → H q p id → p ≡ q

  -- P constructs sets. (The proof was suggested by Michael Shulman in
  -- a mailing list post.)

  P-set : ∀ A → Is-set (P A)
  P-set A = propositional-identity⇒set
    (λ p q → H p q id × H q p id)
    (λ _ _ → ×-closure 1 (H-prop id) (H-prop id))
    (λ _ → H-id , H-id)
    (λ p q → uncurry (H-antisymmetric p q))

  -- Two Str morphisms (see below) of equal type are equal if their
  -- first components are equal.

  lift-equality : {X Y : ∃ P} {f g : ∃ (H (proj₂ X) (proj₂ Y))} →
                  proj₁ f ≡ proj₁ g → f ≡ g
  lift-equality eq = Σ-≡,≡→≡ eq (H-prop _ _ _)

  -- A derived precategory.

  Str : Precategory (c₁ ⊔ ℓ₁) (c₂ ⊔ ℓ₂)
  Str = record { precategory =
    ∃ P ,
    (λ { (X , p) (Y , q) →
         ∃ (H p q) ,
         Σ-closure 2 Hom-is-set (λ f → mono₁ 1 (H-prop f)) }) ,
    (id , H-id) ,
    (λ { (f , hf) (g , hg) → f ∙ g , H-∘ hg hf }) ,
    lift-equality left-identity ,
    lift-equality right-identity ,
    lift-equality assoc }

  module Str = Precategory Str

  -- A rearrangement lemma.

  proj₁-≡→≅-¹ :
    ∀ {X Y} (X≡Y : X ≡ Y) →
    proj₁ (Str.≡→≅ X≡Y Str.¹) ≡
    elim (λ {X Y} _ → Hom X Y) (λ _ → id) (cong proj₁ X≡Y)
  proj₁-≡→≅-¹ {X , p} = elim¹
    (λ X≡Y → proj₁ (Str.≡→≅ X≡Y Str.¹) ≡
             elim (λ {X Y} _ → Hom X Y) (λ _ → id) (cong proj₁ X≡Y))
    (proj₁ (Str.≡→≅ (refl (X , p)) Str.¹)                               ≡⟨ cong (proj₁ ∘ Str._¹) $ elim-refl (λ {X Y} _ → X Str.≅ Y) _ ⟩
     proj₁ (Str.id {X = X , p})                                         ≡⟨⟩
     id {X = X}                                                         ≡⟨ sym $ elim-refl (λ {X Y} _ → Hom X Y) _ ⟩
     elim (λ {X Y} _ → Hom X Y) (λ _ → id) (refl X)                     ≡⟨ cong (elim (λ {X Y} _ → Hom X Y) _) $ sym $ cong-refl proj₁ ⟩∎
     elim (λ {X Y} _ → Hom X Y) (λ _ → id) (cong proj₁ (refl (X , p)))  ∎)

-- The structure identity principle states that the precategory Str is
-- a category (assuming extensionality).
--
-- The proof below is based on (but not quite identical to) the one in
-- "Homotopy Type Theory: Univalent Foundations of Mathematics" (first
-- edition).

abstract

  structure-identity-principle :
    ∀ {c₁ c₂ ℓ₁ ℓ₂} →
    Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂) →
    (C : Category c₁ c₂) →
    (S : Standard-notion-of-structure ℓ₁ ℓ₂ (Category.precategory C)) →
    ∀ {X Y} → Is-equivalence
                (Precategory.≡→≅ (Standard-notion-of-structure.Str S)
                                 {X} {Y})
  structure-identity-principle ext C S =
    Str.≡→≅-equivalence-lemma ≡≃≅ ≡≃≅-refl
    where
    open Standard-notion-of-structure S
    module C = Category C

    -- _≡_ is pointwise equivalent to Str._≅_.

    module ≅HH≃≅ where

      to : ∀ {X Y} {p : P X} {q : P Y} →
           (∃ λ (f : X C.≅ Y) → H p q (f C.¹) × H q p (f C.⁻¹)) →
           (X , p) Str.≅ (Y , q)
      to ((f , f⁻¹ , f∙f⁻¹ , f⁻¹∙f) , Hf , Hf⁻¹) =
        (f , Hf) , (f⁻¹ , Hf⁻¹) ,
        lift-equality f∙f⁻¹ ,
        lift-equality f⁻¹∙f

    ≅HH≃≅ : ∀ {X Y} {p : P X} {q : P Y} →
            (∃ λ (f : X C.≅ Y) → H p q (f C.¹) × H q p (f C.⁻¹)) ≃
            ((X , p) Str.≅ (Y , q))
    ≅HH≃≅ {X} {Y} {p} {q} = ↔⇒≃ (record
      { surjection = record
        { logical-equivalence = record
          { to   = ≅HH≃≅.to
          ; from = from
          }
        ; right-inverse-of = to∘from
        }
      ; left-inverse-of = from∘to
      })
      where
      from : (X , p) Str.≅ (Y , q) →
             ∃ λ (f : X C.≅ Y) → H p q (f C.¹) × H q p (f C.⁻¹)
      from ((f , Hf) , (f⁻¹ , Hf⁻¹) , f∙f⁻¹ , f⁻¹∙f) =
        (f , f⁻¹ , cong proj₁ f∙f⁻¹ , cong proj₁ f⁻¹∙f) , Hf , Hf⁻¹

      to∘from : ∀ p → ≅HH≃≅.to (from p) ≡ p
      to∘from ((f , Hf) , (f⁻¹ , Hf⁻¹) , f∙f⁻¹ , f⁻¹∙f) =
        cong₂ (λ f∙f⁻¹ f⁻¹∙f →
                 (f , Hf) , (f⁻¹ , Hf⁻¹) , f∙f⁻¹ , f⁻¹∙f)
              (Str.Hom-is-set _ _)
              (Str.Hom-is-set _ _)

      from∘to : ∀ p → from (≅HH≃≅.to p) ≡ p
      from∘to ((f , f⁻¹ , f∙f⁻¹ , f⁻¹∙f) , Hf , Hf⁻¹) =
        cong₂ (λ f∙f⁻¹ f⁻¹∙f → (f , f⁻¹ , f∙f⁻¹ , f⁻¹∙f) , Hf , Hf⁻¹)
              (C.Hom-is-set _ _)
              (C.Hom-is-set _ _)

    module ≡≡≃≅HH where

      to : ∀ {X Y} {p : P X} {q : P Y} →
           (X≡Y : X ≡ Y) → subst P X≡Y p ≡ q →
           H p q (C.≡→≅ X≡Y C.¹) × H q p (C.≡→≅ X≡Y C.⁻¹)
      to {X} {p = p} X≡Y p≡q = elim¹
        (λ X≡Y → ∀ {q} → subst P X≡Y p ≡ q →
                 H p q (C.≡→≅ X≡Y C.¹) × H q p (C.≡→≅ X≡Y C.⁻¹))
        (elim¹
           (λ {q} _ → H p q (C.≡→≅ (refl X) C.¹) ×
                      H q p (C.≡→≅ (refl X) C.⁻¹))
           ( subst (λ { (q , f) → H p q f })
                   (sym $ cong₂ _,_
                            (subst P (refl X) p  ≡⟨ subst-refl P _ ⟩∎
                             p                   ∎)
                            (C.≡→≅ (refl X) C.¹  ≡⟨ cong C._¹ C.≡→≅-refl ⟩∎
                             C.id                ∎))
                   H-id
           , subst (λ { (q , f) → H q p f })
                   (sym $ cong₂ _,_
                            (subst P (refl X) p  ≡⟨ subst-refl P _ ⟩∎
                             p                   ∎)
                            (C.≡→≅ (refl X) C.⁻¹  ≡⟨ cong C._⁻¹ C.≡→≅-refl ⟩∎
                             C.id                 ∎))
                   H-id
           ))
        X≡Y p≡q

      to-refl : ∀ {X} {p : P X} →
                subst (λ f → H p p (f C.¹) × H p p (f C.⁻¹))
                      C.≡→≅-refl
                      (to (refl X) (subst-refl P p)) ≡
                (H-id , H-id)
      to-refl = cong₂ _,_ (H-prop _ _ _) (H-prop _ _ _)

    ≡≡≃≅HH : ∀ {X Y} {p : P X} {q : P Y} →
             (∃ λ (eq : X ≡ Y) → subst P eq p ≡ q) ≃
             (∃ λ (f : X C.≅ Y) → H p q (f C.¹) × H q p (f C.⁻¹))
    ≡≡≃≅HH {X} {p = p} {q} =
      Σ-preserves C.≡≃≅ λ X≡Y →
        _↔_.to (⇔↔≃ ext (P-set _) (×-closure 1 (H-prop _) (H-prop _)))
               (record { to = ≡≡≃≅HH.to X≡Y ; from = from X≡Y })
      where
      from : ∀ X≡Y → H p q (C.≡→≅ X≡Y C.¹) × H q p (C.≡→≅ X≡Y C.⁻¹) →
             subst P X≡Y p ≡ q
      from X≡Y (H¹ , H⁻¹) = elim¹
        (λ {Y} X≡Y → ∀ {q} →
                     H p q (C.≡→≅ X≡Y C.¹) → H q p (C.≡→≅ X≡Y C.⁻¹) →
                     subst P X≡Y p ≡ q)
        (λ {q} H¹ H⁻¹ →
           subst P (refl X) p  ≡⟨ subst-refl P _ ⟩
           p                   ≡⟨ H-antisymmetric p q
                                    (subst (H p q) (cong C._¹  C.≡→≅-refl) H¹)
                                    (subst (H q p) (cong C._⁻¹ C.≡→≅-refl) H⁻¹) ⟩∎
           q                   ∎)
        X≡Y H¹ H⁻¹

    ≡≃≅ : ∀ {X Y} {p : P X} {q : P Y} →
          _≡_ {A = ∃ P} (X , p) (Y , q) ≃ ((X , p) Str.≅ (Y , q))
    ≡≃≅ = ≅HH≃≅ ⊚ ≡≡≃≅HH ⊚ ↔⇒≃ (inverse Σ-≡,≡↔≡)

    -- …and the proof maps reflexivity to the identity morphism.

    ≡≃≅-refl : ∀ {Xp} → _≃_.to ≡≃≅ (refl Xp) Str.¹ ≡ Str.id
    ≡≃≅-refl {X , p} = cong Str._¹ (
      ≅HH≃≅.to (_≃_.to ≡≡≃≅HH (Σ-≡,≡←≡ (refl (_,_ {B = P} X p))))      ≡⟨ cong (≅HH≃≅.to ∘ _≃_.to ≡≡≃≅HH) $ Σ-≡,≡←≡-refl {B = P} ⟩
      ≅HH≃≅.to (_≃_.to ≡≡≃≅HH (refl X , subst-refl P p))               ≡⟨⟩
      ≅HH≃≅.to (C.≡→≅ (refl X) , ≡≡≃≅HH.to (refl X) (subst-refl P p))  ≡⟨ cong ≅HH≃≅.to $ Σ-≡,≡→≡ C.≡→≅-refl ≡≡≃≅HH.to-refl ⟩
      ≅HH≃≅.to (C.id≅ , H-id , H-id)                                   ≡⟨ refl _ ⟩∎
      Str.id≅                                                          ∎)


module examplesPaperJFP.WxGraphicsLib where

open import SizedIO.Base
open import StateSizedIO.GUI.BaseStateDependent

open import Size

open import Data.Bool.Base
open import Data.List.Base

open import Function

open import NativeIO

open import StateSizedIO.GUI.WxBindingsFFI
open import StateSizedIO.GUI.VariableList

data GuiLev1Command : Set where
  makeFrame   :  GuiLev1Command
  makeButton  :  Frame  →  GuiLev1Command
  addButton   :  Frame  →  Button  →  GuiLev1Command
  drawBitmap  :  DC     →  Bitmap  →  Point → Bool → GuiLev1Command
  repaint     :  Frame  →  GuiLev1Command

GuiLev1Response : GuiLev1Command → Set
GuiLev1Response  makeFrame       = Frame
GuiLev1Response (makeButton _)   = Button
GuiLev1Response  _               = Unit

GuiLev1Interface : IOInterface
Command   GuiLev1Interface  =  GuiLev1Command
Response  GuiLev1Interface  =  GuiLev1Response

GuiLev2State : Set₁
GuiLev2State = VarList

data GuiLev2Command (s :  GuiLev2State) : Set₁ where
  level1C           :  GuiLev1Command → GuiLev2Command s
  createVar         :  {A : Set} → A → GuiLev2Command s
  setButtonHandler  :  Button
                       → List (prod s → IO GuiLev1Interface ∞ (prod s))
                       → GuiLev2Command s
  setOnPaint        :  Frame
                       → List (prod s → DC → Rect → IO GuiLev1Interface ∞ (prod s))
                       → GuiLev2Command s

GuiLev2Response : (s : GuiLev2State) → GuiLev2Command s → Set
GuiLev2Response  _ (level1C c)        =  GuiLev1Response c
GuiLev2Response  _ (createVar {A} a)  =  Var A
GuiLev2Response  _  _                 =  Unit

GuiLev2Next : (s : GuiLev2State) → (c : GuiLev2Command s)
              → GuiLev2Response s c
              → GuiLev2State
GuiLev2Next s (createVar {A} a)  var  =  addVar A var s
GuiLev2Next s _                   _   =  s

GuiLev2Interface : IOInterfaceˢ
Stateˢ     GuiLev2Interface  =  GuiLev2State
Commandˢ   GuiLev2Interface  =  GuiLev2Command
Responseˢ  GuiLev2Interface  =  GuiLev2Response
nextˢ      GuiLev2Interface  =  GuiLev2Next

translateLev1Local : (c : GuiLev1Command) → NativeIO (GuiLev1Response c)
translateLev1Local  makeFrame              =  nativeNewFrame "dummy title"
translateLev1Local (makeButton fra)        =  nativeMakeButton fra "dummy button label"
translateLev1Local (addButton fra bt)      =  nativeAddButton fra bt
translateLev1Local (drawBitmap dc bm p b)  =  nativeDrawBitmap dc bm p b
translateLev1Local (repaint fra)           =  nativeRepaint fra

translateLev1 : {A : Set} → IO GuiLev1Interface ∞ A → NativeIO A
translateLev1 = translateIO translateLev1Local

translateLev1List : {A : Set} → List (IO GuiLev1Interface ∞ A) → List (NativeIO A)
translateLev1List l = map translateLev1 l

translateLev2Local  :   (s : GuiLev2State)
                        → (c : GuiLev2Command s)
                        → NativeIO (GuiLev2Response s c)
translateLev2Local s (level1C c)        =  translateLev1Local c
translateLev2Local s (createVar {A} a)  =  nativeNewVar {A} a
translateLev2Local s (setButtonHandler bt proglist) =
  nativeSetButtonHandler bt
         (dispatchList s (map (λ prog → translateLev1 ∘ prog)  proglist))
translateLev2Local s (setOnPaint fra proglist) =
  nativeSetOnPaint fra (λ dc rect → dispatchList s
         (map (λ prog aa → translateLev1 (prog aa dc rect)) proglist))

translateLev2 : ∀ {A s} → IOˢ GuiLev2Interface ∞ (λ _ → A) s → NativeIO A
translateLev2 = translateIOˢ  translateLev2Local


open import Categories
open import Functors
open import RMonads

module RMonads.CatofRAdj.InitRAdj {a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                                  {J : Fun C D}(M : RMonad J) where

open import Library
open import Naturals hiding (Iso; module Iso)
open import RAdjunctions
open import RMonads.CatofRAdj M
open import Categories.Initial
open import RMonads.RKleisli M
open import RMonads.RKleisli.Functors M
open import RMonads.RKleisli.Adjunction M
open import RAdjunctions.RAdj2RMon

open Cat
open Fun
open RMonad M
open NatT
open RAdj

lemX : R KlAdj ○ L KlAdj ≅ TFun M
lemX = FunctorEq _ _ refl refl

KlObj : Obj CatofAdj
KlObj = record {
  E   = Kl;
  adj = KlAdj;
  law = lemX;
  ηlaw = refl;
  bindlaw = λ{X}{Y}{f} →
    cong bind (stripsubst (Hom D (OMap J X))
                          f
                          (fcong Y (cong OMap (sym lemX))))}
  where
        open Cat

open ObjAdj
open import Isomorphism
open Iso

lemZ : {F G G' : Fun C D} → G ≅ G' → {α : NatT F G}{β : NatT F G'} →
       α ≅ β →
       ∀{X} → cmp α {X} ≅ cmp β {X}
lemZ refl refl = refl

lemZ' : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}{F F' G G' : Fun C D} →
        F ≅ F' → G ≅ G' →
        {α : NatT F G}{β : NatT F' G'} → α ≅ β →
        ∀{X} → cmp α {X} ≅ cmp β {X}
lemZ' refl refl refl = refl

lemfid : ∀{e f}{E : Cat {e}{f}}(L : Fun C E)(R : Fun E D)
  (T : Fun C D)
  (p : T ≅ R ○ L)
  (η : ∀ {X} → Hom D (OMap J X) (OMap T X))
  (right : {X : Obj C}{Y : Obj E} →
           Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y) →
  (left : {X : Obj C}{Y : Obj E} →
          Hom E (OMap L X) Y → Hom D (OMap J X) (OMap R Y)) →
  (q : {X : Obj C}{Y : Obj E}(f : Hom E (OMap L X) Y) → right (left f) ≅ f) →
  (r : {X : Obj C} → left (iden E {OMap L X}) ≅ η {X}) →
  {X : Obj C} →
  right (subst (Hom D (OMap J X)) (fcong X (cong OMap p)) η)
  ≅
  iden E {OMap L X}
lemfid {E = E} L R .(R ○ L) refl η right left q r {X} =
  trans (cong right (sym r)) (q (iden E))

lemfcomp : ∀{e f}{E : Cat {e}{f}}(L : Fun C E)(R : Fun E D)(T : Fun C D)
  (p : T ≅ R ○ L)
  (bind : ∀{X Y} → Hom D (OMap J X) (OMap T Y) → Hom D (OMap T X) (OMap T Y)) →
  (right : {X : Obj C} {Y : Obj E} →
           Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y) →
  (q : {X Y : Obj C} {f : Hom D (OMap J X) (OMap T Y)} →
       HMap R (right (subst (Hom D (OMap J X)) (fcong Y (cong OMap p)) f))
       ≅
       bind f) →
  (r : {X X' : Obj C}{Y Y' : Obj E}
       (f : Hom C X' X)(g : Hom E Y Y')
       (h : Hom D (OMap J X) (OMap R Y)) →
       right (comp D (HMap R g) (comp D h (HMap J f)))
       ≅
       comp E g (comp E (right h) (HMap L f))) →
  ∀{X Y Z : Obj C}
  {f : Hom D (OMap J Y) (OMap T Z)}
  {g : Hom D (OMap J X) (OMap T Y)} →
  right (subst (Hom D (OMap J X)) (fcong Z (cong OMap p)) (comp D (bind f) g))
  ≅
  comp E (right (subst (Hom D (OMap J Y)) (fcong Z (cong OMap p)) f))
         (right (subst (Hom D (OMap J X)) (fcong Y (cong OMap p)) g))
lemfcomp {E = E} L R .(R ○ L) refl bind right q r {X}{Y}{Z}{f}{g} =
  trans (cong₂ (λ f g → right (comp D f g)) (sym (q {f = f})) (sym (idr D)))
        (trans (cong (λ h → right (comp D (HMap R (right f)) (comp D g h)))
                     (sym (fid J)))
               (trans (r (iden C) (right f) g)
                      (cong (comp E (right f))
                            (trans (cong (comp E (right g)) (fid L))
                                   (idr E)))))

lemLlaw : ∀{e f}{E : Cat {e}{f}}(J : Fun C D)(L : Fun C E)(R : Fun E D)(T : Fun C D)
          (p : T ≅ R ○ L)
          (η : ∀ {X} → Hom D (OMap J X) (OMap T X)) →
          (right : {X : Obj C} {Y : Obj E} →
                   Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y) →
          (left : {X : Obj C} {Y : Obj E} →
                  Hom E (OMap L X) Y → Hom D (OMap J X)  (OMap R Y)) →
          (q : {X : Obj C} {Y : Obj E} (f : Hom E (OMap L X) Y) →
               right (left f) ≅ f) →
          (r : {X : Obj C} → left (iden E {OMap L X}) ≅ η {X}) →
          (t : {X X' : Obj C}{Y Y' : Obj E}
                   (f : Hom C X' X)(g : Hom E Y Y')
                   (h : Hom D (OMap J X) (OMap R Y)) →
                   right (comp D (HMap R g) (comp D h (HMap J f)))
                   ≅
                   comp E g (comp E (right h) (HMap L f)) ) →
          {X Y : Obj C} (f : Hom C X Y) →
          right (subst (Hom D (OMap J X))
                       (fcong Y (cong OMap p))
                       (comp D η (HMap J f)))
          ≅
          HMap L f
lemLlaw {E = E} J L R .(R ○ L) refl η right left q r t {X}{Y} f =
  trans (cong (λ g → right (comp D g (HMap J f))) (sym r))
        (trans (cong right
                     (trans (sym (idl D))
                            (cong (λ g → comp D g (comp D (left (iden E))
                                                          (HMap J f)))
                                  (sym (fid R)))))
               (trans (trans (trans (t f (iden E) (left (iden E)))
                                    (idl E))
                             (cong (λ g → comp E g (HMap L f)) (q (iden E))))
                      (idl E)))

K' : ∀{e}{f}(A : Obj (CatofAdj {e}{f})) → Fun (E KlObj) (E A)
K' A = record {
    OMap  = OMap (L (adj A));
    HMap  = λ{X}{Y} f →
      right (adj A) (subst (Hom D (OMap J X))
                           (fcong Y (cong OMap (sym (ObjAdj.law A))))
                           f);
    fid   = lemfid
                   (L (adj A))
                   (R (adj A))
                   (TFun M)
                   (sym (law A))
                   η
                   (right (adj A))
                   (left (adj A))
                   (lawa (adj A))
                   (ObjAdj.ηlaw A);
    fcomp = lemfcomp
                     (L (adj A))
                     (R (adj A))
                     (TFun M)
                     (sym (law A))
                     bind
                     (right (adj A))
                     (bindlaw A)
                     (natright (adj A))}

Llaw' : ∀{e}{f}(A : Obj (CatofAdj {e}{f})) → K' A ○ L (adj KlObj) ≅ L (adj A)
Llaw' A = FunctorEq
   _
   _
   refl
   (iext λ _ → iext λ _ → ext $ lemLlaw J
     (L (adj A))
     (R (adj A))
     (TFun M)
     (sym (law A))
     η
     (right (adj A))
     (left (adj A))
     (lawa (adj A))
     (ηlaw A)
     (natright (adj A)))

Rlaw' : ∀{e}{f}(A : Obj (CatofAdj {e}{f})) → R (adj KlObj) ≅ R (adj A) ○ K' A
Rlaw' A = FunctorEq _ _ (cong OMap (sym (law A)))
                        (iext λ _ → iext λ _ → ext λ _ → sym (bindlaw A))

rightlaw' : ∀{e f}(A : Obj (CatofAdj {e}{f})) →
            {X : Obj C} {Y : Obj (E KlObj)}
            {f : Hom D (OMap J X) (OMap (R (adj KlObj)) Y)} →
            HMap (K' A) (right (adj KlObj) f) ≅
            right (adj A) (subst (Hom D (OMap J X)) (fcong Y (cong OMap (Rlaw' A))) f)
rightlaw' A {X}{Y}{f} = cong (right (adj A)) (trans (stripsubst (Hom D (OMap J X)) f (fcong Y (cong OMap (sym (law A))))) (sym (stripsubst (Hom D (OMap J X)) f (fcong Y (cong OMap (Rlaw' A))))) )

KlHom : {A : Obj CatofAdj} → Hom CatofAdj KlObj A
KlHom {A = A} = record {
  K        = K' A;
  Llaw     = Llaw' A;
  Rlaw     = Rlaw' A;
  rightlaw = rightlaw' A}

KlIsInit : Init CatofAdj KlObj
KlIsInit = record {
  i   = KlHom;
  law = λ {X} {V} → HomAdjEq
    _
    _
    ((FunctorEq _ _ (cong OMap (sym (HomAdj.Llaw V)))
             (iext λ A → iext λ B → ext λ f →
                trans
                (cong₂ (λ B₁ → right (adj X) {A} {B₁})
                 (sym (fcong B (cong OMap (HomAdj.Llaw V))))
                 (trans
                    (stripsubst (Hom D (OMap J A)) f
                     (fcong B (cong OMap (sym (law X)))))
                    (sym
                     (stripsubst (Hom D (OMap J A)) f
                      (fcong B (cong OMap (HomAdj.Rlaw V)))))))
                (sym (HomAdj.rightlaw V)))))}
-- -}