{-# OPTIONS --cubical --no-import-sorts --allow-unsolved-metas #-}

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

module Number.Base where

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)

open import Cubical.Data.Nat renaming (ℕ to Nat)
open import Cubical.Data.Unit.Base -- Unit
open import Cubical.Data.Empty -- ⊥

open import Number.Postulates
open import Number.Bundles

data NumberKind : Type where
  isNat     : NumberKind
  isInt     : NumberKind
  isRat     : NumberKind
  isReal    : NumberKind
  isComplex : NumberKind

-- NumberKindEnumeration
NLE : NumberKind → Nat
NLE isNat     = 0
NLE isInt     = 1
NLE isRat     = 2
NLE isReal    = 3
NLE isComplex = 4

-- inverse of NumberKindEnumeration
NLE⁻¹ : Nat → NumberKind
NLE⁻¹ 0 = isNat
NLE⁻¹ 1 = isInt
NLE⁻¹ 2 = isRat
NLE⁻¹ 3 = isReal
NLE⁻¹ 4 = isComplex
NLE⁻¹ x = isComplex -- doesn't matter

-- proof of inversity
NLE⁻¹-isRetraction : ∀ x → NLE⁻¹ (NLE x) ≡ x
NLE⁻¹-isRetraction isNat     = refl
NLE⁻¹-isRetraction isInt     = refl
NLE⁻¹-isRetraction isRat     = refl
NLE⁻¹-isRetraction isReal    = refl
NLE⁻¹-isRetraction isComplex = refl

-- order lifted from Nat
open import Enumeration NLE NLE⁻¹ NLE⁻¹-isRetraction using () renaming
  ( _≤'_ to _≤ₙₗ_
  ; min' to minₙₗ
  ; max' to maxₙₗ
  ; max-implies-≤' to max-implies-≤ₙₗ₂
  ) public

data PositivityKindOrderedRing : Type where
  anyPositivityᵒʳ : PositivityKindOrderedRing
  isNonzeroᵒʳ     : PositivityKindOrderedRing
  isNonnegativeᵒʳ : PositivityKindOrderedRing
  isPositiveᵒʳ    : PositivityKindOrderedRing
  isNegativeᵒʳ    : PositivityKindOrderedRing
  isNonpositiveᵒʳ : PositivityKindOrderedRing

data PositivityKindField : Type where
  anyPositivityᶠ : PositivityKindField
  isNonzeroᶠ     : PositivityKindField

PositivityKindType : NumberKind → Type
PositivityKindType isNat     = PositivityKindOrderedRing
PositivityKindType isInt     = PositivityKindOrderedRing
PositivityKindType isRat     = PositivityKindOrderedRing
PositivityKindType isReal    = PositivityKindOrderedRing
PositivityKindType isComplex = PositivityKindField

NumberProp = Σ NumberKind PositivityKindType

module PatternsType where
  -- ordered ring patterns
  pattern X   = anyPositivityᵒʳ
  pattern X⁺⁻ = isNonzeroᵒʳ
  pattern X₀⁺ = isNonnegativeᵒʳ
  pattern X⁺  = isPositiveᵒʳ
  pattern X⁻  = isNegativeᵒʳ
  pattern X₀⁻ = isNonpositiveᵒʳ
  -- field patterns (overlapping)
  pattern X   = anyPositivityᶠ
  pattern X⁺⁻ = isNonzeroᶠ

module PatternsProp where
  -- ordered ring patterns
  pattern ⁇x⁇ = anyPositivityᵒʳ
  pattern x#0 = isNonzeroᵒʳ
  pattern 0≤x = isNonnegativeᵒʳ
  pattern 0<x = isPositiveᵒʳ
  pattern x<0 = isNegativeᵒʳ
  pattern x≤0 = isNonpositiveᵒʳ
  -- field patterns (overlapping)
  pattern ⁇x⁇ = anyPositivityᶠ
  pattern x#0 = isNonzeroᶠ

open PatternsProp

coerce-PositivityKind-OR2F : PositivityKindOrderedRing → PositivityKindField
coerce-PositivityKind-OR2F ⁇x⁇ = ⁇x⁇
coerce-PositivityKind-OR2F x#0 = x#0
coerce-PositivityKind-OR2F 0≤x = ⁇x⁇
coerce-PositivityKind-OR2F 0<x = x#0
coerce-PositivityKind-OR2F x<0 = x#0
coerce-PositivityKind-OR2F x≤0 = ⁇x⁇

coerce-PositivityKind-F2OR : PositivityKindField → PositivityKindOrderedRing
coerce-PositivityKind-F2OR ⁇x⁇ = ⁇x⁇
coerce-PositivityKind-F2OR x#0 = x#0

coerce-PositivityKind-OR2 : PositivityKindOrderedRing → (to : NumberKind) → PositivityKindType to
coerce-PositivityKind-OR2 pl isNat     = pl
coerce-PositivityKind-OR2 pl isInt     = pl
coerce-PositivityKind-OR2 pl isRat     = pl
coerce-PositivityKind-OR2 pl isReal    = pl
coerce-PositivityKind-OR2 pl isComplex = coerce-PositivityKind-OR2F pl

coerce-PositivityKind-F2 : PositivityKindField → (to : NumberKind) → PositivityKindType to
coerce-PositivityKind-F2 pl isNat     = coerce-PositivityKind-F2OR pl
coerce-PositivityKind-F2 pl isInt     = coerce-PositivityKind-F2OR pl
coerce-PositivityKind-F2 pl isRat     = coerce-PositivityKind-F2OR pl
coerce-PositivityKind-F2 pl isReal    = coerce-PositivityKind-F2OR pl
coerce-PositivityKind-F2 pl isComplex = pl

coerce-PositivityKind : (from to : NumberKind) → PositivityKindType from → PositivityKindType to
coerce-PositivityKind isNat     to x = coerce-PositivityKind-OR2 x to
coerce-PositivityKind isInt     to x = coerce-PositivityKind-OR2 x to
coerce-PositivityKind isRat     to x = coerce-PositivityKind-OR2 x to
coerce-PositivityKind isReal    to x = coerce-PositivityKind-OR2 x to
coerce-PositivityKind isComplex to x = coerce-PositivityKind-F2  x to

-- NumberKind interpretation

NumberKindLevel : NumberKind → Level
NumberKindLevel isNat     = ℕℓ
NumberKindLevel isInt     = ℤℓ
NumberKindLevel isRat     = ℚℓ
NumberKindLevel isReal    = ℝℓ
NumberKindLevel isComplex = ℂℓ

NumberKindProplevel : NumberKind → Level
NumberKindProplevel isNat     = ℕℓ'
NumberKindProplevel isInt     = ℤℓ'
NumberKindProplevel isRat     = ℚℓ'
NumberKindProplevel isReal    = ℝℓ'
NumberKindProplevel isComplex = ℂℓ'

NumberKindInterpretation : (x : NumberKind) → Type (NumberKindLevel x)
NumberKindInterpretation isNat     = let open ℕ* in ℕ
NumberKindInterpretation isInt     = let open ℤ* in ℤ
NumberKindInterpretation isRat     = let open ℚ* in ℚ
NumberKindInterpretation isReal    = let open ℝ* in ℝ
NumberKindInterpretation isComplex = let open ℂ* in ℂ

-- PositivityKind interpretation

PositivityKindInterpretation : (nl : NumberKind) → PositivityKindType nl → (x : NumberKindInterpretation nl) → Type (NumberKindProplevel nl)
PositivityKindInterpretation isNat     ⁇x⁇ x =               Unit
PositivityKindInterpretation isNat     x#0 x = let open ℕ in  x # 0f
PositivityKindInterpretation isNat     0≤x x = let open ℕ in 0f ≤  x
PositivityKindInterpretation isNat     0<x x = let open ℕ in 0f <  x
PositivityKindInterpretation isNat     x≤0 x = let open ℕ in  x ≤ 0f
PositivityKindInterpretation isNat     x<0 x =               ⊥
PositivityKindInterpretation isInt     ⁇x⁇ x =               Lift Unit
PositivityKindInterpretation isInt     x#0 x = let open ℤ in  x # 0f
PositivityKindInterpretation isInt     0≤x x = let open ℤ in 0f ≤  x
PositivityKindInterpretation isInt     0<x x = let open ℤ in 0f <  x
PositivityKindInterpretation isInt     x≤0 x = let open ℤ in  x ≤ 0f
PositivityKindInterpretation isInt     x<0 x = let open ℤ in  x < 0f
PositivityKindInterpretation isRat     ⁇x⁇ x =               Lift Unit
PositivityKindInterpretation isRat     x#0 x = let open ℚ in  x # 0f
PositivityKindInterpretation isRat     0≤x x = let open ℚ in 0f ≤  x
PositivityKindInterpretation isRat     0<x x = let open ℚ in 0f <  x
PositivityKindInterpretation isRat     x≤0 x = let open ℚ in  x ≤ 0f
PositivityKindInterpretation isRat     x<0 x = let open ℚ in  x < 0f
PositivityKindInterpretation isReal    ⁇x⁇ x =               Lift Unit
PositivityKindInterpretation isReal    x#0 x = let open ℝ in  x # 0f
PositivityKindInterpretation isReal    0≤x x = let open ℝ in 0f ≤  x
PositivityKindInterpretation isReal    0<x x = let open ℝ in 0f <  x
PositivityKindInterpretation isReal    x≤0 x = let open ℝ in  x ≤ 0f
PositivityKindInterpretation isReal    x<0 x = let open ℝ in  x < 0f
PositivityKindInterpretation isComplex ⁇x⁇ x =               Lift Unit
PositivityKindInterpretation isComplex x#0 x = let open ℂ in  x # 0f

NumberLevel : NumberKind → Level
NumberLevel l = ℓ-max (NumberKindLevel l) (NumberKindProplevel l)

-- NumberProp interpretation
NumberInterpretation : ((l , p) : NumberProp) → Type (NumberLevel l)
NumberInterpretation (level , positivity) = Σ (NumberKindInterpretation level) (PositivityKindInterpretation level positivity)

-- generic number type
data Number (p : NumberProp) : Type (NumberLevel (fst p)) where
  _,,_ : (x :  NumberKindInterpretation (fst p))
       → (PositivityKindInterpretation (fst p) (snd p) x)
       → Number p

num : ∀{(l , p) : NumberProp} → Number (l , p) → NumberKindInterpretation l
num (p ,, q) = p

prp : ∀{pp@(l , p) : NumberProp} → (x : Number pp) → PositivityKindInterpretation l p (num x)
prp (p ,, q) = q

pop : ∀{p : NumberProp} → Number p → NumberInterpretation p
pop (x ,, p) = x , p

open PatternsType

{- NOTE: overlapping patterns makes this possible:

_ : NumberProp'
_ = isRat , X⁺⁻

_ : NumberProp'
_ = isComplex , X⁺⁻

-}


agda --compile Ackermann.agda
./Ackermann


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Semigroup.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Reflection.StrictEquiv

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Record

open Iso

private
  variable
    ℓ : Level

-- Semigroups as a record, inspired by the Agda standard library:
--
--  https://github.com/agda/agda-stdlib/blob/master/src/Algebra/Bundles.agda#L48
--  https://github.com/agda/agda-stdlib/blob/master/src/Algebra/Structures.agda#L50
--
-- Note that as we are using Path for all equations the IsMagma record
-- would only contain isSet A if we had it.
record IsSemigroup {A : Type ℓ} (_·_ : A → A → A) : Type ℓ where

  constructor issemigroup

  field
    is-set : isSet A
    assoc  : (x y z : A) → x · (y · z) ≡ (x · y) · z

record SemigroupStr (A : Type ℓ) : Type (ℓ-suc ℓ) where

  constructor semigroupstr

  field
    _·_         : A → A → A
    isSemigroup : IsSemigroup _·_

  infixl 7 _·_

  open IsSemigroup isSemigroup public

Semigroup : Type (ℓ-suc ℓ)
Semigroup = TypeWithStr _ SemigroupStr

semigroup : (A : Type ℓ) (_·_ : A → A → A) (h : IsSemigroup _·_) → Semigroup
semigroup A _·_ h = A , semigroupstr _·_ h

record SemigroupEquiv (M N : Semigroup {ℓ}) (e : ⟨ M ⟩ ≃ ⟨ N ⟩) : Type ℓ where

  constructor semigroupequiv

  -- Shorter qualified names
  private
    module M = SemigroupStr (snd M)
    module N = SemigroupStr (snd N)

  field
    isHom : (x y : ⟨ M ⟩) → equivFun e (x M.· y) ≡ equivFun e x N.· equivFun e y

open SemigroupStr
open IsSemigroup
open SemigroupEquiv

-- Develop some theory about Semigroups using various general results
-- that are stated using Σ-types. For this we define Semigroup as a
-- nested Σ-type, prove that it's equivalent to the above record
-- definition and then transport results along this equivalence.
module SemigroupΣTheory {ℓ} where

  RawSemigroupStructure : Type ℓ → Type ℓ
  RawSemigroupStructure X = X → X → X

  RawSemigroupEquivStr = AutoEquivStr RawSemigroupStructure

  rawSemigroupUnivalentStr : UnivalentStr _ RawSemigroupEquivStr
  rawSemigroupUnivalentStr = autoUnivalentStr RawSemigroupStructure

  SemigroupAxioms : (A : Type ℓ) → RawSemigroupStructure A → Type ℓ
  SemigroupAxioms A _·_ = isSet A
                        × ((x y z : A) → x · (y · z) ≡ (x · y) · z)

  SemigroupStructure : Type ℓ → Type ℓ
  SemigroupStructure = AxiomsStructure RawSemigroupStructure SemigroupAxioms

  SemigroupΣ : Type (ℓ-suc ℓ)
  SemigroupΣ = TypeWithStr ℓ SemigroupStructure

  isPropSemigroupAxioms : (A : Type ℓ) (_·_ : RawSemigroupStructure A)
                        → isProp (SemigroupAxioms A _·_)
  isPropSemigroupAxioms _ _ = isPropΣ isPropIsSet λ isSetA → isPropΠ3 λ _ _ _ → isSetA _ _

  SemigroupEquivStr : StrEquiv SemigroupStructure ℓ
  SemigroupEquivStr = AxiomsEquivStr RawSemigroupEquivStr SemigroupAxioms

  SemigroupAxiomsIsoIsSemigroup : {A : Type ℓ} (_·_ : RawSemigroupStructure A)
                                → Iso (SemigroupAxioms A _·_) (IsSemigroup _·_)
  fun (SemigroupAxiomsIsoIsSemigroup s) (x , y)           = issemigroup x y
  inv (SemigroupAxiomsIsoIsSemigroup s) M                 = is-set M , assoc M
  rightInv (SemigroupAxiomsIsoIsSemigroup s) _            = refl
  leftInv (SemigroupAxiomsIsoIsSemigroup s) _             = refl

  SemigroupAxioms≡IsSemigroup : {A : Type ℓ} (_·_ : RawSemigroupStructure A)
                              → SemigroupAxioms _ _·_ ≡ IsSemigroup _·_
  SemigroupAxioms≡IsSemigroup s = isoToPath (SemigroupAxiomsIsoIsSemigroup s)

  Semigroup→SemigroupΣ : Semigroup → SemigroupΣ
  Semigroup→SemigroupΣ (A , semigroupstr _·_ isSemigroup) =
    A , _·_ , SemigroupAxiomsIsoIsSemigroup _ .inv isSemigroup

  SemigroupΣ→Semigroup : SemigroupΣ → Semigroup
  SemigroupΣ→Semigroup (A , _·_ , isSemigroupΣ) =
    semigroup A _·_ (SemigroupAxiomsIsoIsSemigroup _ .fun isSemigroupΣ)

  SemigroupIsoSemigroupΣ : Iso Semigroup SemigroupΣ
  SemigroupIsoSemigroupΣ =
    iso Semigroup→SemigroupΣ SemigroupΣ→Semigroup (λ _ → refl) (λ _ → refl)

  semigroupUnivalentStr : UnivalentStr SemigroupStructure SemigroupEquivStr
  semigroupUnivalentStr = axiomsUnivalentStr _ isPropSemigroupAxioms rawSemigroupUnivalentStr

  SemigroupΣPath : (M N : SemigroupΣ) → (M ≃[ SemigroupEquivStr ] N) ≃ (M ≡ N)
  SemigroupΣPath = SIP semigroupUnivalentStr

  SemigroupEquivΣ : (M N : Semigroup) → Type ℓ
  SemigroupEquivΣ M N = Semigroup→SemigroupΣ M ≃[ SemigroupEquivStr ] Semigroup→SemigroupΣ N

  SemigroupIsoΣPath : {M N : Semigroup} → Iso (Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] SemigroupEquiv M N e) (SemigroupEquivΣ M N)
  fun SemigroupIsoΣPath (e , x) = e , isHom x
  inv SemigroupIsoΣPath (e , h) = e , semigroupequiv h
  rightInv SemigroupIsoΣPath _  = refl
  leftInv SemigroupIsoΣPath _   = refl

  SemigroupPath : (M N : Semigroup) → (Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] SemigroupEquiv M N e) ≃ (M ≡ N)
  SemigroupPath M N =
    Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] SemigroupEquiv M N e ≃⟨ strictIsoToEquiv SemigroupIsoΣPath ⟩
    SemigroupEquivΣ M N ≃⟨ SemigroupΣPath _ _ ⟩
    Semigroup→SemigroupΣ M ≡ Semigroup→SemigroupΣ N ≃⟨ isoToEquiv (invIso (congIso SemigroupIsoSemigroupΣ)) ⟩
    M ≡ N ■

-- We now extract the important results from the above module

isPropIsSemigroup : {A : Type ℓ} (_·_ : A → A → A) → isProp (IsSemigroup _·_)
isPropIsSemigroup _·_ =
  subst isProp (SemigroupΣTheory.SemigroupAxioms≡IsSemigroup _·_)
        (SemigroupΣTheory.isPropSemigroupAxioms _ _·_)

SemigroupPath : (M N : Semigroup {ℓ}) → (Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] SemigroupEquiv M N e) ≃ (M ≡ N)
SemigroupPath {ℓ = ℓ} =
  SIP
    (autoUnivalentRecord
      (autoRecordSpec (SemigroupStr {ℓ}) SemigroupEquiv
        (fields:
          data[ _·_ ∣ isHom ]
          prop[ isSemigroup ∣ (λ _ → isPropIsSemigroup _) ]))
      _ _)


open import Agda.Builtin.Equality
open import Agda.Builtin.Nat

data ⊥ : Set where

data Zero : Set where
  zero : Zero

data One : Set where
  suc : Zero → One

data _≤_ : One → Zero → Set where

_≤?_ : ∀ m n → m ≤ n → ⊥
suc m ≤? zero = λ ()

thm : (f : suc zero ≤ zero → ⊥) → suc zero ≤? zero ≡ f
thm f = refl
  -- (λ ()) zero x != f x of type ⊥
  --        ^^^^


module FRP.JS.Size where

postulate
  Size : Set
  ↑_   : Size → Size
  ∞    : Size

{-# BUILTIN SIZE    Size #-}
{-# BUILTIN SIZESUC ↑_   #-}
{-# BUILTIN SIZEINF ∞    #-}
{-# COMPILED_JS     ↑_ function(x) { return null; } #-}
{-# COMPILED_JS     ∞  null #-}


module Categories.Normalise where

-- Experiments on using computation to simplify equalities

open import Level
open import Function renaming (id to idᶠ; _∘_ to _©_)
open import Data.Product
open import Categories.Support.PropositionalEquality

open import Categories.Category
import Categories.Morphisms as Mor

open import Relation.Binary hiding (_⇒_)

--open import Categories.Object.Coproduct
open import Categories.Object.BinaryCoproducts

open import Categories.Square

-- Normalizing with β and η rules for coproducts, through Yoneda
module +Reasoning {o ℓ e} (C : Category o ℓ e) (bincoprod : BinCoproducts C) where

  private module C = Category C
  open C using (Obj; _≡_; _⇒_; module Equiv)
  open Equiv
  open BinCoproducts C bincoprod
--  open BinaryCoproducts C (Bin→Binary C bincoprod) hiding ([_,_]; i₁; i₂; universal; commute₁; commute₂)

  data Ty : Set o where
    ↑_ : Obj -> Ty
    _⊎_ : Ty -> Ty -> Ty

  T : Ty -> Obj
  T (↑ x) = x
  T (t ⊎ t₁) = T t + T t₁

  data Term : Ty → Ty → Set (o ⊔ ℓ) where
    #id : ∀ {A} → Term A A
    #i₁ : ∀ {A B} → Term A (A ⊎ B)
    #i₂ : ∀ {A B} → Term B (A ⊎ B)
    #[_,_] : ∀ {A B C} → Term A C → Term B C → Term (A ⊎ B) C
    _#∘_ : ∀ {A B C} → Term B C → Term A B → Term A C
    `_` : ∀ {A B} → T A ⇒ T B → Term A B

  ↑↑ : ∀ {A B} -> A C.⇒ B -> Term (↑ A) (↑ B)
  ↑↑ {A} {B} f = `_` {↑ A} {↑ B} f

  _#⧻_ : ∀ {A B C D} → (Term A B) → (Term C D) → (Term (A ⊎ C) (B ⊎ D))
  f #⧻ g = #[ #i₁ #∘ f , #i₂ #∘ g ]

  #left : ∀ {A B C} → (Term A B) → (Term (A ⊎ C) (B ⊎ C))
  #left f = f #⧻ #id

  #right : ∀ {A C D} → (Term C D) → (Term (A ⊎ C) (A ⊎ D))
  #right g = #id #⧻ g

  eval : ∀ {A B} → Term A B → T A ⇒ T B
  eval #id = C.id
  eval #i₁ = i₁
  eval #i₂ = i₂
  eval #[ t , t₁ ] = [ (eval t) , (eval t₁) ]
  eval (t #∘ t₁)   = eval t C.∘ eval t₁
  eval ` x `       = x

  module Internal where

    _⇛_ : Ty → Ty → Set _
    _⇛_ (↑ x) t = x ⇒ T t
    _⇛_ (s ⊎ s₁) t = (s ⇛ t) × (s₁ ⇛ t)

    ⇛→⇒ : ∀ {A B} → A ⇛ B → T A ⇒ T B
    ⇛→⇒ {↑ O} f = f
    ⇛→⇒ {A ⊎ A₁} (f , g) = [ ⇛→⇒ {A} f , ⇛→⇒ {A₁} g ]

    _<∘_ : ∀ {A B C} → T B ⇒ T C → A ⇛ B → A ⇛ C
    _<∘_ {↑ x} f g = f C.∘ g
    _<∘_ {A ⊎ A₁} f (g₁ , g₂) = (_<∘_ {A} f g₁) , (_<∘_  {A₁} f  g₂)

    .<∘-comm : ∀ {A B C} (f : T B ⇒ T C) (g : A ⇛ B) → f C.∘ (⇛→⇒ {A} g) C.≡ ⇛→⇒ {A} (_<∘_ {A} {B} {C} f g)
    <∘-comm {↑ x} f g = refl
    <∘-comm {A ⊎ A₁} f g = trans ∘[] ([]-cong₂ (<∘-comm f (proj₁ g)) (<∘-comm f (proj₂ g)))

    mutual
     j₁ : ∀ {A B} → A ⇛ (A ⊎ B)
     j₁ {↑ x}    = i₁
     j₁ {A ⊎ A₁} = _<∘_ {A} i₁ (j₁ {A} {A₁}) , _<∘_ {A₁} i₁ (j₂ {A₁} {A})
     j₂ : ∀ {B A} → B ⇛ (A ⊎ B)
     j₂ {↑ x}    = i₂
     j₂ {B ⊎ B₁} = _<∘_ {B} i₂ (j₁ {B} {B₁}) , _<∘_ {B₁} i₂ (j₂ {B₁} {B})

     id : ∀ {A} → A ⇛ A
     id {↑ x}    = C.id
     id {A ⊎ A₁} = j₁ {A} {A₁} , j₂ {A₁} {A}

    ⇒→⇛ : ∀ {A B} → T A ⇒ T B → A ⇛ B
    ⇒→⇛ {↑ x} f = f
    ⇒→⇛ {A ⊎ A₁} f = _<∘_ {A} f (j₁ {A} {A₁}) , _<∘_ {A₁} f (j₂ {A₁} {A})

    mutual
     .j₁≡i₁ : ∀ {A B} → ⇛→⇒ {A} (j₁ {A} {B}) C.≡ i₁
     j₁≡i₁ {↑ x} = refl
     j₁≡i₁ {A ⊎ A₁} = universal (trans (C.∘-resp-≡ʳ (sym (j₁≡i₁ {A} {A₁}))) (<∘-comm {A} i₁ (j₁ {A} {A₁})))
                                (trans (C.∘-resp-≡ʳ (sym (j₂≡i₂ {A₁} {A}))) (<∘-comm {A₁} i₁ (j₂ {A₁} {A})))

     .j₂≡i₂ : ∀ {B A} → ⇛→⇒ {B} (j₂ {B} {A}) C.≡ i₂
     j₂≡i₂ {↑ x} = refl
     j₂≡i₂ {A ⊎ A₁} = universal (trans (C.∘-resp-≡ʳ (sym (j₁≡i₁ {A} {A₁}))) (<∘-comm {A} i₂ (j₁ {A} {A₁})))
                                (trans (C.∘-resp-≡ʳ (sym (j₂≡i₂ {A₁} {A})))
                                   (<∘-comm {A₁} i₂ (j₂ {A₁} {A})))

    .iso₁-⇒⇛ : ∀ {A B} → (f : T A ⇒ T B) → ⇛→⇒ {A} {B} (⇒→⇛ {A} {B} f) ≡ f
    iso₁-⇒⇛ {↑ x} f = refl
    iso₁-⇒⇛ {A ⊎ A₁} {B} f = universal (trans (C.∘-resp-≡ʳ (sym j₁≡i₁)) (<∘-comm {A} {A ⊎ A₁} {B} f (j₁ {A})))
                                       (trans (C.∘-resp-≡ʳ (sym j₂≡i₂)) (<∘-comm {A₁} {A ⊎ A₁} {B} f (j₂ {A₁})))

    .id≡id : ∀ A → ⇛→⇒ {A} (id {A}) ≡ C.id
    id≡id (↑ x) = refl
    id≡id (A ⊎ A₁) = universal (trans C.identityˡ (sym j₁≡i₁)) (trans C.identityˡ (sym j₂≡i₂))

    _∘_ : ∀ {A B C} → B ⇛ C → A ⇛ B → A ⇛ C
    _∘_ {↑ x} {B} f g = ⇛→⇒ {B} f C.∘ g
    _∘_ {A ⊎ A₁} f (g₁ , g₂) = (_∘_ {A} f g₁) , (_∘_ {A₁} f g₂)

    .∘-comm : ∀ {A B C} (f : B ⇛ C) (g : A ⇛ B) → (⇛→⇒ {B} f) C.∘ (⇛→⇒ {A} g) C.≡ ⇛→⇒ {A} (_∘_ {A} {B} {C} f g)
    ∘-comm {↑ x} f g = refl
    ∘-comm {A ⊎ A₁} f g = trans ∘[] ([]-cong₂ (∘-comm f (proj₁ g)) (∘-comm f (proj₂ g)))

    -- An η-expanded version of C
    Cη : Category _ _ _
    Cη = record
      { Obj = Ty
      ; _⇒_ = _⇛_
      ; _≡_ = λ {A} f g → ⇛→⇒ {A} f ≡ ⇛→⇒ {A} g
      ; _∘_ = λ {A} {B} {C} → _∘_ {A} {B} {C}
      ; id = λ {X} → id {X}
      ; assoc = λ {A} {B} {C} {D} {f} {g} {h} →
                     trans (sym (∘-comm {A} {B} {D} (h ∘ g) f))
                    (trans (C.∘-resp-≡ˡ (sym (∘-comm {B} {C} {D} h g)))
                    (trans C.assoc
                    (trans (C.∘-resp-≡ʳ (∘-comm {A} {B} {C} g f))
                           (∘-comm {A} {C} {D} h (g ∘ f)))))
      ; identityˡ = λ {A} {B} {f} → trans (sym (∘-comm {A} {B} {B} id f))
                                   (trans (C.∘-resp-≡ˡ (id≡id B)) C.identityˡ)
      ; identityʳ = λ {A} {B} {f} →
                      trans (sym (∘-comm {A} {A} {B} f id))
                     (trans (C.∘-resp-≡ʳ (id≡id A)) C.identityʳ)
      ; equiv = record
        { refl = refl
        ; sym = sym
        ; trans = trans
        }
      ; ∘-resp-≡ = λ {A} {B} {C} {f} {h} {g} {i} f≡h g≡i →
            trans (sym (∘-comm {A} {B} {C} f g)) (trans (C.∘-resp-≡ f≡h g≡i) (∘-comm {A} {B} {C} h i))
      }

    module Cη = Category Cη

    -- We need the opposite category for Yon because i₁ and i₂ simplify when precomposed.
    -- Using Eda seems to undo the simplifications instead.
    open Yon-Eda (Category.op Cη)

    Yon-i₁ : ∀ {A B} → Yon (A ⊎ B) A
    Yon-i₁ {A} {B} = record
                     { arr = j₁ {A} {B}
                     ; fun = proj₁
                     ; ok = λ {W} f → trans (trans (sym commute₁) (C.∘-resp-≡ʳ (sym (j₁≡i₁ {A} {B})))) (∘-comm {A} {A ⊎ B} {W} f (j₁ {A} {B}))
                     }

    Yon-i₂ : ∀ {A B} → Yon (A ⊎ B) B
    Yon-i₂ {A} {B} = record
                     { arr = j₂ {B} {A}
                     ; fun = proj₂
                     ; ok = λ {W} f →
                                trans (trans (sym commute₂) (C.∘-resp-≡ʳ (sym (j₂≡i₂ {B} {A}))))
                                (∘-comm {B} {A ⊎ B} {W} f (j₂ {B} {A}))
                     }

    Yon-[_,_] : ∀ {A B C} → Yon C A → Yon C B → Yon C (A ⊎ B)
    Yon-[_,_] f g = record
                    { arr = (Yon.arr f) , (Yon.arr g)
                    ; fun = λ f₁ → (Yon.fun f f₁) , (Yon.fun g f₁)
                    ; ok = λ f₁ → []-cong₂ (Yon.ok f f₁) (Yon.ok g f₁)
                    }

    eeval : ∀ {A B} → Term A B → Yon B A
    eeval #id = Yon-id
    eeval #i₁ = Yon-i₁
    eeval #i₂ = Yon-i₂
    eeval #[ t , t₁ ] = Yon-[ (eeval t) , (eeval t₁) ]
    eeval (t #∘ t₁) = Yon-compose (eeval t₁) (eeval t)
    eeval {A} ` f ` = Yon-inject (⇒→⇛ {A} f)

    yeeval : ∀ {A B} → Term A B → T A ⇒ T B
    yeeval {A} {B} t = ⇛→⇒ {A} (Yon.arr (eeval t))

    .yeeval≡eval : ∀ {A B} → (f : Term A B) → yeeval f ≡ eval f
    yeeval≡eval     #id = id≡id _
    yeeval≡eval {A} #i₁ = j₁≡i₁ {A}
    yeeval≡eval {A} #i₂ = j₂≡i₂ {A}
    yeeval≡eval   ` x ` = iso₁-⇒⇛ x
    yeeval≡eval #[ f , f₁ ] = []-cong₂ (yeeval≡eval f) (yeeval≡eval f₁)
    yeeval≡eval (f #∘ f₁) = trans
                          (trans (Yon.ok (eeval f₁) (Yon.arr (eeval f)))
                                 (sym (∘-comm (Yon.arr (eeval f)) (Yon.arr (eeval f₁)))))
                          (C.∘-resp-≡ (yeeval≡eval f) (yeeval≡eval f₁))

    +reasoning : NormReasoning C o (ℓ ⊔ o)
    +reasoning = record
                 { U = Ty
                 ; T = T
                 ; _#⇒_ = Term
                 ; eval = eval
                 ; norm = yeeval
                 ; norm≡eval = yeeval≡eval }

  open NormReasoning Internal.+reasoning public hiding (T; eval)


module AlonzoPrelude where
  open import RTN public
  import RTP  -- magic module - Run Time Primitives

  Int : Set
  Int = RTP.Int

  Float : Set
  Float = RTP.Float

  String : Set
  String = RTP.String

  Char : Set
  Char = RTP.Char

  data True : Set where
    tt : True

{-
  record True : Set where

  tt : True
  tt = record{}
-}
  data False : Set where

  elim-False : {A : Set} -> False -> A
  elim-False ()

  -- _∘_ : {A,B,C:Set} -> (B -> C) -> (A -> B) -> A -> C
  -- f ∘ g = \x -> f (g x)

  id : {A : Set} -> A -> A
  id x = x

  infixr 90 _○_
  _○_ : {A B C : Set} -> (B -> C) -> (A -> B) -> A -> C
  (f ○ g) x = f (g x)

  infixr 0 _$_
  _$_ : {A B : Set} -> (A -> B) -> A -> B
  f $ x = f x

  flip : {A B C : Set} -> (A -> B -> C) -> B -> A -> C
  flip f x y = f y x

  const : {A B : Set} -> A -> B -> A
  const x _ = x

  typeOf : {A : Set} -> A -> Set
  typeOf {A} _ = A

  data _×_ (A B : Set) : Set where
    <_,_> : A -> B -> A × B

  fst : {A B : Set} -> A × B -> A
  fst < x , y > = x

  snd : {A B : Set} -> A × B -> B
  snd < x , y > = y

{-
  infixr 10 _::_
  data List (A:Set) : Set where
    nil  : List A
    _::_ : A -> List A -> List A

  [_] : {A:Set} -> A -> List A
  [ x ] = x :: nil
-}
  {-# BUILTIN INTEGER Int    #-}
--  {-# BUILTIN STRING  String #-}
--   {-# BUILTIN FLOAT   Float  #-}
  {-# BUILTIN CHAR    Char   #-}


{-# OPTIONS --cubical --no-import-sorts --safe --experimental-lossy-unification #-}

module Cubical.Algebra.Group.EilenbergMacLane1 where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.GroupoidLaws renaming (assoc to ∙assoc)
open import Cubical.Foundations.Path
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Data.Unit
open import Cubical.Data.Sigma
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Truncation as Trunc renaming (rec to trRec; elim to trElim)
open import Cubical.HITs.EilenbergMacLane1

private
  variable ℓ : Level

module _ (Ĝ : Group ℓ) where
  private
    G = fst Ĝ
  open GroupStr (snd Ĝ)

  emloop-id : emloop 1g ≡ refl
  emloop-id =
    emloop 1g                                 ≡⟨ rUnit (emloop 1g) ⟩
    emloop 1g ∙ refl                          ≡⟨ cong (emloop 1g ∙_) (rCancel (emloop 1g) ⁻¹) ⟩
    emloop 1g ∙ (emloop 1g ∙ (emloop 1g) ⁻¹)  ≡⟨ ∙assoc _ _ _ ⟩
    (emloop 1g ∙ emloop 1g) ∙ (emloop 1g) ⁻¹  ≡⟨ cong (_∙ emloop 1g ⁻¹)
                                                   ((emloop-comp Ĝ 1g 1g) ⁻¹) ⟩
    emloop (1g · 1g) ∙ (emloop 1g) ⁻¹         ≡⟨ cong (λ g → emloop {Group = Ĝ} g
                                                             ∙ (emloop 1g) ⁻¹)
                                                      (rid 1g) ⟩
    emloop 1g ∙ (emloop 1g) ⁻¹                ≡⟨ rCancel (emloop 1g) ⟩
    refl ∎

  emloop-inv : (g : G) → emloop (inv g) ≡ (emloop g) ⁻¹
  emloop-inv g =
    emloop (inv g)                              ≡⟨ rUnit (emloop (inv g)) ⟩
    emloop (inv g) ∙ refl                       ≡⟨ cong (emloop (inv g) ∙_)
                                                      (rCancel (emloop g) ⁻¹) ⟩
    emloop (inv g) ∙ (emloop g ∙ (emloop g) ⁻¹) ≡⟨ ∙assoc _ _ _ ⟩
    (emloop (inv g) ∙ emloop g) ∙ (emloop g) ⁻¹ ≡⟨ cong (_∙ emloop g ⁻¹)
                                                      ((emloop-comp Ĝ (inv g) g) ⁻¹) ⟩
    emloop (inv g · g) ∙ (emloop g) ⁻¹          ≡⟨ cong (λ h → emloop {Group = Ĝ} h
                                                            ∙ (emloop g) ⁻¹)
                                                      (invl g) ⟩
    emloop 1g ∙ (emloop g) ⁻¹                 ≡⟨ cong (_∙ (emloop g) ⁻¹) emloop-id ⟩
    refl ∙ (emloop g) ⁻¹                      ≡⟨ (lUnit ((emloop g) ⁻¹)) ⁻¹ ⟩
    (emloop g) ⁻¹ ∎

  isGroupoidEM₁ : isGroupoid (EM₁ Ĝ)
  isGroupoidEM₁ = emsquash

  isConnectedEM₁ : isConnected 2 (EM₁ Ĝ)
  isConnectedEM₁ = ∣ embase ∣ , h
    where
      h : (y : hLevelTrunc 2 (EM₁ Ĝ)) → ∣ embase ∣ ≡ y
      h = trElim (λ y → isOfHLevelSuc 1 (isOfHLevelTrunc 2 ∣ embase ∣ y))
            (elimProp Ĝ (λ x → isOfHLevelTrunc 2 ∣ embase ∣ ∣ x ∣) refl)

  {- since we write composition in diagrammatic order,
     and function composition in the other order,
     we need right multiplication here -}
  rightEquiv : (g : G) → G ≃ G
  rightEquiv g = isoToEquiv isom
    where
    isom : Iso G G
    isom .Iso.fun = _· g
    isom .Iso.inv = _· inv g
    isom .Iso.rightInv h =
      (h · inv g) · g ≡⟨ (assoc h (inv g) g) ⁻¹ ⟩
        h · inv g · g ≡⟨ cong (h ·_) (invl g) ⟩
             h · 1g ≡⟨ rid h ⟩ h ∎
    isom .Iso.leftInv h =
      (h · g) · inv g ≡⟨ (assoc h g (inv g)) ⁻¹ ⟩
        h · g · inv g ≡⟨ cong (h ·_) (invr g) ⟩
             h · 1g ≡⟨ rid h ⟩ h ∎

  compRightEquiv : (g h : G)
    → compEquiv (rightEquiv g) (rightEquiv h) ≡ rightEquiv (g · h)
  compRightEquiv g h = equivEq (funExt (λ x → (assoc x g h) ⁻¹))

  CodesSet : EM₁ Ĝ → hSet ℓ
  CodesSet = rec Ĝ (isOfHLevelTypeOfHLevel 2) (G , is-set) RE REComp
    where
      RE : (g : G) → Path (hSet ℓ) (G , is-set) (G , is-set)
      RE g = Σ≡Prop (λ X → isPropIsOfHLevel {A = X} 2) (ua (rightEquiv g))

      lemma₁ : (g h : G) → Square
        (ua (rightEquiv g)) (ua (rightEquiv (g · h)))
        refl (ua (rightEquiv h))
      lemma₁ g h = invEq
                   (Square≃doubleComp (ua (rightEquiv g)) (ua (rightEquiv (g · h)))
                     refl (ua (rightEquiv h)))
                   (ua (rightEquiv g) ∙ ua (rightEquiv h)
                       ≡⟨ (uaCompEquiv (rightEquiv g) (rightEquiv h)) ⁻¹ ⟩
                    ua (compEquiv (rightEquiv g) (rightEquiv h))
                       ≡⟨ cong ua (compRightEquiv g h) ⟩
                    ua (rightEquiv (g · h)) ∎)

      lemma₂ : {A₀₀ A₀₁ : hSet ℓ} (p₀₋ : A₀₀ ≡ A₀₁)
               {A₁₀ A₁₁ : hSet ℓ} (p₁₋ : A₁₀ ≡ A₁₁)
               (p₋₀ : A₀₀ ≡ A₁₀) (p₋₁ : A₀₁ ≡ A₁₁)
               (s : Square (cong fst p₀₋) (cong fst p₁₋) (cong fst p₋₀) (cong fst p₋₁))
               → Square p₀₋ p₁₋ p₋₀ p₋₁
      fst (lemma₂ p₀₋ p₁₋ p₋₀ p₋₁ s i j) = s i j
      snd (lemma₂ p₀₋ p₁₋ p₋₀ p₋₁ s i j) =
        isSet→SquareP {A = (λ i j → isSet (s i j))}
          (λ i j → isProp→isSet (isPropIsOfHLevel 2))
          (cong snd p₀₋) (cong snd p₁₋) (cong snd p₋₀) (cong snd p₋₁) i j

      REComp : (g h : G) → Square (RE g) (RE (g · h)) refl (RE h)
      REComp g h = lemma₂ (RE g) (RE (g · h)) refl (RE h) (lemma₁ g h)
  Codes : EM₁ Ĝ → Type ℓ
  Codes x = CodesSet x .fst

  encode : (x : EM₁ Ĝ) → embase ≡ x → Codes x
  encode x p = subst Codes p 1g

  decode : (x : EM₁ Ĝ) → Codes x → embase ≡ x
  decode = elimSet Ĝ (λ x → isOfHLevelΠ 2 (λ c → isGroupoidEM₁ (embase) x))
    emloop λ g → ua→ λ h → emcomp h g

  decode-encode : (x : EM₁ Ĝ) (p : embase ≡ x) → decode x (encode x p) ≡ p
  decode-encode x p = J (λ y q → decode y (encode y q) ≡ q)
    (emloop (transport refl 1g) ≡⟨ cong emloop (transportRefl 1g) ⟩
     emloop 1g ≡⟨ emloop-id ⟩ refl ∎) p

  encode-decode : (x : EM₁ Ĝ) (c : Codes x) → encode x (decode x c) ≡ c
  encode-decode = elimProp Ĝ (λ x → isOfHLevelΠ 1 (λ c → CodesSet x .snd _ _))
    λ g → encode embase (decode embase g) ≡⟨ refl ⟩
          encode embase (emloop g) ≡⟨ refl ⟩
          transport (ua (rightEquiv g)) 1g ≡⟨ uaβ (rightEquiv g) 1g ⟩
          1g · g ≡⟨ lid g ⟩
          g ∎

  ΩEM₁Iso : Iso (Path (EM₁ Ĝ) embase embase) G
  Iso.fun ΩEM₁Iso = encode embase
  Iso.inv ΩEM₁Iso = emloop
  Iso.rightInv ΩEM₁Iso = encode-decode embase
  Iso.leftInv ΩEM₁Iso = decode-encode embase

  ΩEM₁≡ : (Path (EM₁ Ĝ) embase embase) ≡ G
  ΩEM₁≡ = isoToPath ΩEM₁Iso


module _ where

postulate
  A : Set
  _,_ : A → A → A

module M where
  module Mx (x : A) where
    module M where
      module My (y : A) where
        f : A
        f = x , y

postulate
  a b c : A

module M′  = M
module Ma  = M′.Mx.M a
module Mab = Ma.My b

g : A
g =  Mab.f

-- Original bug report --

record I (A : Set) : Set where
  field
    i : A → A
  record R (A : Set) : Set where
    field
      f : A → A
  open R public

module C (A : Set) where
  I₀ : I A
  I₀ = record { i = λ x → x }

  open I I₀

  r : (B : Set) → R B
  r B = record { f = λ x → x }

  g1 : (B : Set) → B → B
  g1 B = f′
    where
      open R (r B) renaming (f to f′)


-- Haskell-like do-notation.
module Syntax.Do where

open import Functional
import      Lvl
open import Syntax.Idiom
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable A B : Type{ℓ}
private variable F : Type{ℓ₁} → Type{ℓ₂}

record DoNotation (F : Type{ℓ₁} → Type{ℓ₂}) : Type{Lvl.𝐒(ℓ₁) Lvl.⊔ ℓ₂} where
  constructor intro
  field
    return : A → F(A)
    _>>=_  : F(A) → (A → F(B)) → F(B)

  module HaskellNames where
    _=<<_ : ∀{A B} → (A → F(B)) → F(A) → F(B)
    _=<<_ = swap(_>>=_)

    _>>_ : ∀{A B} → F(A) → F(B) → F(B)
    f >> g = f >>= const g

    _>=>_ : ∀{A B C : Type} → (A → F(B)) → (B → F(C)) → (A → F(C))
    (f >=> g)(A) = f(A) >>= g

    _<=<_ : ∀{A B C : Type} → (B → F(C)) → (A → F(B)) → (A → F(C))
    _<=<_ = swap(_>=>_)

  idiomBrackets : IdiomBrackets(F)
  IdiomBrackets.pure  idiomBrackets = return
  IdiomBrackets._<*>_ idiomBrackets Ff Fa = do
    f <- Ff
    a <- Fa
    return(f(a))

open DoNotation ⦃ … ⦄ using (return ; _>>=_) public


import SOAS.Families.Core

-- Combinators for context maps
module SOAS.ContextMaps.Combinators {T : Set}
  (open SOAS.Families.Core {T})
  (𝒳 : Familyₛ) where

open import SOAS.Common
open import SOAS.Context {T}
open import SOAS.Sorting
open import SOAS.Variable
open import SOAS.Families.Isomorphism
open import SOAS.Families.BCCC

private
  variable
    Γ Γ′ Δ Δ′ Θ : Ctx
    α β τ : T

-- Sub from the empty context
empty : ∅ ~[ 𝒳 ]↝ Δ
empty ()

-- Combine two maps into the same context by concatenating the domain
copair : Γ ~[ 𝒳 ]↝ Θ → Δ ~[ 𝒳 ]↝ Θ → (Γ ∔ Δ) ~[ 𝒳 ]↝ Θ
copair {∅} σ ς v = ς v
copair {α ∙ Γ} σ ς new = σ new
copair {α ∙ Γ} σ ς (old v) = copair {Γ} (σ ∘ old) ς v

copair≈₁ : {σ₁ σ₂ : Γ ~[ 𝒳 ]↝ Θ}(ς : Δ ~[ 𝒳 ]↝ Θ){v : ℐ α (Γ ∔ Δ)}
         → ({τ : T}(v : ℐ τ Γ) → σ₁ v ≡ σ₂ v)
         → copair σ₁ ς v ≡ copair σ₂ ς v
copair≈₁ ς {v} p = cong (λ - → copair (λ {τ} → - {τ}) ς v) (dext (λ y → p y))
copair≈₂ : (σ : Γ ~[ 𝒳 ]↝ Θ){ς₁ ς₂ : Δ ~[ 𝒳 ]↝ Θ}{v : ℐ α (Γ ∔ Δ)}
         → ({τ : T}(v : ℐ τ Δ) → ς₁ v ≡ ς₂ v)
         → copair σ ς₁ v ≡ copair σ ς₂ v
copair≈₂ σ {v = v} p = cong (λ - → copair σ (λ {τ} → - {τ}) v) (dext (λ y → p y))

-- Split a map from a combined context into two maps
split : (Γ ∔ Δ) ~[ 𝒳 ]↝ Θ → Γ ~[ 𝒳 ]↝ Θ × Δ ~[ 𝒳 ]↝ Θ
split {∅} σ = (λ ()) , σ
split {α ∙ Γ} σ with split {Γ} (σ ∘ old)
... | ς₁ , ς₂ = (λ{ new → σ new ; (old v) → ς₁ v}) , ς₂

-- Expand the codomain of a renaming
expandʳ : ({Γ} Δ : Ctx) → Γ ↝ Γ ∔ Δ
expandʳ {α ∙ Γ} Δ new = new
expandʳ {α ∙ Γ} Δ (old v) = old (expandʳ Δ v)

expandˡ : (Γ {Δ} : Ctx) → Δ ↝ Γ ∔ Δ
expandˡ ∅ v = v
expandˡ (α ∙ Γ) v = old (expandˡ Γ v)

-- Special cases of the above, when one of the contexts is a singleton
-- and the map from the singleton context is isomorphic to a term

-- Add a term to a context map
add : 𝒳 α Δ → Γ ~[ 𝒳 ]↝ Δ → (α ∙ Γ) ~[ 𝒳 ]↝ Δ
add t σ new = t
add t σ (old v) = σ v

-- Consider a term as a context map from the singleton context
asMap : 𝒳 α Γ → ⌊ α ⌋ ~[ 𝒳 ]↝ Γ
asMap t new = t

-- Separate a compound context map into a term and a residual map
detach : (τ ∙ Γ) ~[ 𝒳 ]↝ Δ → 𝒳 τ Δ × (Γ ~[ 𝒳 ]↝ Δ)
detach {_}{∅} σ = σ new , (λ ())
detach {_}{(α ∙ Γ)} σ = σ new , σ ∘ old

add[new][old] : (σ : τ ∙ Γ ~[ 𝒳 ]↝ Δ)(v : ℐ α (τ ∙ Γ))
             → add (σ new) (σ ∘ old) v ≡ σ v
add[new][old] σ new = refl
add[new][old] σ (old v) = refl

-- Remove a term from a compound context map
remove : (τ ∙ Γ) ~[ 𝒳 ]↝ Δ → Γ ~[ 𝒳 ]↝ Δ
remove {_} {∅} σ = λ ()
remove {_} {α ∙ Γ} σ = σ ∘ old

-- Add and remove are inverses
add∘remove : (σ : (τ ∙ Γ) ~[ 𝒳 ]↝ Δ) (v : ℐ α (τ ∙ Γ))
           → add (σ new) (remove σ) v
           ≡ σ v
add∘remove σ new = refl
add∘remove σ (old new) = refl
add∘remove σ (old (old v)) = refl

remove∘add : (σ : Γ ~[ 𝒳 ]↝ Δ) (t : 𝒳 τ Δ)(v : ℐ α Γ)
           → remove (add t σ) v
           ≡ σ v
remove∘add σ t new = refl
remove∘add σ t (old v) = refl


postulate
  X A : Set

module Foo {{x : X}} where

  postulate
    B C : Set
    foo : A → B → C → Set

module Bar {{x : X}} where
  open Foo

  postulate
    -- The following fails to infer the instance argument if we do not either:
    --   * apply {{x}} explicitly to foo
    --   * apply {{x}} explicitly when opening module Foo
    --   * define fail1 in module Foo
    fail1 : ∀ {a b b' c c'} → foo a b c → foo a b' c'

    -- However, the following works
    work1 : ∀ {a b c} → foo a b c → foo a b c
    work2 : ∀ {a a' b c} → foo a b c → foo a' b c
    work3 : ∀ {a b b' c} → foo a b c → foo a b' c
    work4 : ∀ {a a' b b' c} → foo a b c → foo a' b' c
    work5 : ∀ {a b c c'} → foo a b c → foo a b c'
    work6 : ∀ {a a' b c c'} → foo a b c → foo a' b c'
    work7 : ∀ {a a' b b' c c'} → foo a b c → foo a' b' c'

data Nat : Set where
  suc : Nat → Nat
  instance
    zero : Nat

instance
  one = suc zero

data IsSuc : Nat → Set where
  isSuc : ∀{n} → IsSuc (suc n)

postulate
  F : {{x : Nat}} (p : IsSuc x) → Set

test = F isSuc  -- yellow, but should not be


-- Quotient category
{-# OPTIONS --safe #-}

module Cubical.Categories.Constructions.Quotient where

open import Cubical.Categories.Category.Base
open import Cubical.Categories.Functor.Base
open import Cubical.Categories.Limits.Terminal
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.HITs.SetQuotients renaming ([_] to ⟦_⟧)

private
  variable
    ℓ ℓ' ℓq : Level

module _ (C : Category ℓ ℓ') where
  open Category C

  module _ (_~_ : {x y : ob} (f g : Hom[ x , y ] ) → Type ℓq)
           (~refl : {x y : ob} (f : Hom[ x , y ] ) → f ~ f)
           (~cong : {x y z : ob}
                    (f f' : Hom[ x , y ]) → f ~ f'
                  → (g g' : Hom[ y , z ]) → g ~ g'
                  → (f ⋆ g) ~ (f' ⋆ g')) where

    private
      Hom[_,_]/~ = λ (x y : ob) → Hom[ x , y ] / _~_

      module _ {x y z : ob} where
        _⋆/~_ : Hom[ x , y ]/~ → Hom[ y , z ]/~ → Hom[ x , z ]/~
        _⋆/~_ = rec2 squash/ (λ f g → ⟦ f ⋆ g ⟧)
                    (λ f f' g f~f' → eq/ _ _ (~cong _ _ f~f' _ _ (~refl _)))
                    (λ f g g' g~g' → eq/ _ _ (~cong _ _ (~refl _) _ _ g~g'))

    module _ {x y : ob} where
      ⋆/~IdL : (f : Hom[ x , y ]/~) → (⟦ id ⟧ ⋆/~ f) ≡ f
      ⋆/~IdL = elimProp (λ _ → squash/ _ _) (λ _ → cong ⟦_⟧ (⋆IdL _))

      ⋆/~IdR : (f : Hom[ x , y ]/~) → (f ⋆/~ ⟦ id ⟧) ≡ f
      ⋆/~IdR = elimProp (λ _ → squash/ _ _) (λ _ → cong ⟦_⟧ (⋆IdR _))

    module _ {x y z w : ob} where
      ⋆/~Assoc : (f : Hom[ x , y ]/~)
                (g : Hom[ y , z ]/~)
                (h : Hom[ z , w ]/~)
        → ((f ⋆/~ g) ⋆/~ h) ≡ (f ⋆/~ (g ⋆/~ h))

      ⋆/~Assoc = elimProp3 (λ _ _ _ → squash/ _ _) (λ _ _ _ → cong ⟦_⟧ (⋆Assoc _ _ _))

    open Category
    QuotientCategory : Category ℓ (ℓ-max ℓ' ℓq)
    QuotientCategory .ob = ob C
    QuotientCategory .Hom[_,_] x y = (C [ x , y ]) / _~_
    QuotientCategory .id = ⟦ id C ⟧
    QuotientCategory ._⋆_ = _⋆/~_
    QuotientCategory .⋆IdL = ⋆/~IdL
    QuotientCategory .⋆IdR = ⋆/~IdR
    QuotientCategory .⋆Assoc = ⋆/~Assoc
    QuotientCategory .isSetHom = squash/

    private
      C/~ = QuotientCategory

    -- Quotient map
    open Functor
    QuoFunctor : Functor C C/~
    QuoFunctor .F-ob x = x
    QuoFunctor .F-hom = ⟦_⟧
    QuoFunctor .F-id = refl
    QuoFunctor .F-seq f g = refl

    -- Quotients preserve initial / terminal objects
    isInitial/~ : {z : ob C} → isInitial C z → isInitial C/~ z
    isInitial/~ zInit x = ⟦ zInit x .fst ⟧ , elimProp (λ _ → squash/ _ _)
        λ f → eq/ _ _ (subst (_~ f) (sym (zInit x .snd f)) (~refl _))

    isFinal/~ : {z : ob C} → isFinal C z → isFinal C/~ z
    isFinal/~ zFinal x = ⟦ zFinal x .fst ⟧ , elimProp (λ _ → squash/ _ _)
        λ f → eq/ _ _ (subst (_~ f) (sym (zFinal x .snd f)) (~refl _))


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

open import Everything

module Test.Test1 where

  test-functor-transextensionality : ∀
    {𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂}
    ⦃ functor : Functor 𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂ ⦄
    (open Functor functor)
    → {!Transextensionality!.type _∼₁_ _∼̇₁_!}
  test-functor-transextensionality = transextensionality
  -- test-functor-transextensionality ⦃ functor ⦄ = let open Functor ⦃ … ⦄ in transextensionality1


{-# OPTIONS --safe #-}
module Cubical.HITs.Ints.IsoInt where

open import Cubical.HITs.Ints.IsoInt.Base public


-- This variant of the code is due to Ulf Norell.

open import Agda.Builtin.Size

data ⊥ : Set where

mutual

  data Unit (i : Size) : Set where
    c : Unit′ i → Unit i

  data Unit₁ (i : Size) : Set where
    c₁ : ⊥ → Unit i → Unit₁ i

  record Unit′ (i : Size) : Set where
    coinductive
    field
      force : {j : Size< i} → Unit₁ j

open Unit′ public

tail : Unit ∞ → Unit₁ ∞
tail (c x) = force x

u : (∀ {i} → Unit′ i → Unit i) →
    ∀ {i} → Unit₁ i
u cons = tail (cons λ { .force → u cons })

bad : Unit₁ ∞
bad = u c

refute : Unit₁ ∞ → ⊥
refute (c₁ () _)

loop : ⊥
loop = refute bad


------------------------------------------------------------------------
-- Breadth-first labelling of trees
------------------------------------------------------------------------

module BreadthFirst where

open import Codata.Musical.Notation
open import Codata.Musical.Colist using ([]; _∷_; concat)
open import Function
open import Data.Unit
open import Data.List.NonEmpty using (_⁺++⁺_)
open import Relation.Binary.PropositionalEquality as PropEq
  using () renaming (refl to ≡-refl)

open import BreadthFirst.Universe
open import BreadthFirst.Programs
open import BreadthFirst.Lemmas
open import Tree using (Tree; leaf; node; map)
open import Stream using (Stream; _≺_)

------------------------------------------------------------------------
-- Breadth-first labelling

label′ : ∀ {A B} → Tree A → Stream B →
         ElP (tree ⌈ B ⌉ ⊗ stream ⌈ Stream B ⌉)
label′ t ls = lab t (↓ (⌈ ls ⌉ ≺ ♯ snd (label′ t ls)))

label : ∀ {A B} → Tree A → Stream B → Tree B
label t ls = ⟦ fst (label′ t ls) ⟧

------------------------------------------------------------------------
-- Breadth-first labelling preserves the shape of the tree

shape-preserved′ : ∀ {A B} (t : Tree A)
                   (lss : ElP (stream ⌈ Stream B ⌉)) →
                   Eq (tree ⌈ ⊤ ⌉) (map (const tt) ⟦ fst (lab t lss) ⟧)
                                   (map (const tt) t)
shape-preserved′ leaf         lss = leaf
shape-preserved′ (node l _ r) lss with whnf lss
... | ⌈ x ≺ ls ⌉ ≺ lss′ =
  node (♯ shape-preserved′ (♭ l) (♭ lss′)) ⌈ ≡-refl ⌉
       (♯ shape-preserved′ (♭ r) (snd (lab (♭ l) (♭ lss′))))

shape-preserved : ∀ {A B} (t : Tree A) (ls : Stream B) →
                  Eq (tree ⌈ ⊤ ⌉) (map (const tt) (label t ls))
                                  (map (const tt) t)
shape-preserved t ls = shape-preserved′ t (↓ (⌈ ls ⌉ ≺ _))

------------------------------------------------------------------------
-- Breadth-first labelling uses the right labels

invariant : ∀ {A B} (t : Tree A) lss →
            EqP (stream (stream ⌈ B ⌉))
                ⟦ lss ⟧
                (zipWith _⁺++∞_ ⟦ flatten ⟦ fst (lab t lss) ⟧ ⟧
                                ⟦ snd (lab t lss) ⟧)
invariant leaf         lss = ⟦ lss ⟧ ∎
invariant (node l _ r) lss with whnf lss
... | ⌈ x ≺ ls ⌉ ≺ lss′ =
  (⌈ ≡-refl ⌉ ≺ ♯ refl (♭ ls)) ≺ ♯ (
    ⟦ ♭ lss′ ⟧                                     ≊⟨ invariant (♭ l) (♭ lss′) ⟩
    zipWith _⁺++∞_ ⟦ flatten ⟦ fst l′ ⟧ ⟧
                   ⟦ snd l′ ⟧                      ≊⟨ zipWith-cong ⁺++∞-cong
                                                        (⟦ flatten ⟦ fst l′ ⟧ ⟧ ∎)
                                                        (invariant (♭ r) (snd l′)) ⟩
    zipWith _⁺++∞_
      ⟦ flatten ⟦ fst l′ ⟧ ⟧
      (zipWith _⁺++∞_ ⟦ flatten ⟦ fst r′ ⟧ ⟧
                      ⟦ snd r′ ⟧)                  ≈⟨ zip-++-assoc (flatten ⟦ fst l′ ⟧)
                                                                   (flatten ⟦ fst r′ ⟧)
                                                                   ⟦ snd r′ ⟧ ⟩
    zipWith _⁺++∞_
      ⟦ longZipWith _⁺++⁺_ (flatten ⟦ fst l′ ⟧)
                           (flatten ⟦ fst r′ ⟧) ⟧
      ⟦ snd r′ ⟧                                   ∎)
  where
  l′ = lab (♭ l) (♭ lss′)
  r′ = lab (♭ r) (snd l′)

prefix-lemma : ∀ {a} xs xss yss →
               Eq (stream (stream a))
                  (xs ≺ ♯ xss) (zipWith _⁺++∞_ yss xss) →
               PrefixOfP a (concat yss) xs
prefix-lemma xs xss         []         _            = []
prefix-lemma xs (xs′ ≺ xss) (ys ∷ yss) (xs≈ ≺ xss≈) =
  concat (ys ∷ yss)      ≋⟨ concat-lemma ys yss ⟩
  ys ⁺++ concat (♭ yss)  ⊑⟨ ⁺++-mono ys (♯ prefix-lemma xs′ (♭ xss) (♭ yss) ⟦ lemma ⟧≈) ⟩
  ys ⁺++∞ xs′            ≈⟨ sym xs≈ ⟩
  xs                     ∎
  where
  lemma =
    xs′ ≺ _ {- ♯ ♭ xss -}           ≈⟨ refl xs′ ≺ ♯ refl (♭ xss) ⟩
    xs′ ≺ xss                       ≈⟨ ♭ xss≈ ⟩
    zipWith _⁺++∞_ (♭ yss) (♭ xss)  ∎

is-prefix : ∀ {A B} (t : Tree A) (ls : Stream B) →
            PrefixOf ⌈ B ⌉ (concat ⟦ flatten (label t ls) ⟧) ls
is-prefix {B = B} t ls =
  ⟦ prefix-lemma ls ⟦ snd l ⟧ ⟦ flatten ⟦ fst l ⟧ ⟧
      ⟦ ls ≺ _ {- ♯ ⟦ snd l ⟧ -}                        ≈⟨ refl ls ≺ ♯ refl ⟦ snd l ⟧ ⟩
        ⟦ ↓ (⌈ ls ⌉ ≺ _) ⟧                              ≊⟨ invariant t (↓ ⌈ ls ⌉ ≺ _) ⟩
        zipWith _⁺++∞_ ⟦ flatten ⟦ fst l ⟧ ⟧ ⟦ snd l ⟧  ∎ ⟧≈ ⟧⊑
  where l = label′ t ls


open import Common.Prelude
open import Common.Reflect

id : {A : Set} → A → A
id x = x

idTerm : Term
idTerm = lam visible (def (quote id) (arg₁ ∷ arg₂ ∷ []))
  where
    arg₁ = arg (arginfo hidden relevant) (def (quote Nat) [])
    arg₂ = arg (arginfo visible relevant) (var 0 [])

-- Should fail since idTerm "λ z → id {Nat} z"
id₂ : {A : Set} → A → A
id₂ = unquote idTerm


{-# OPTIONS --overlapping-instances #-}

module Sort where

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

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

open import Data.Variant using (Variants; inj; `_)

-- instance search methods

open import Data.List.Membership.Propositional.Instances
  using (⦃here⦄; ⦃there⦄)
open import Data.List.Relation.Binary.Subset.Propositional.Instances
  using (⦃[]⊆xs⦄; ⦃x∈ys-xs⊆ys⇒x∷xs⊆ys⦄; ⦅_⊆_⦆)
open import Data.Union.Relation.Binary.Subtype.Instances
  using (⦃refl⦄; ⦃generalize⦄; ⦃function⦄; ⌊_⌋)

-- ----------------------------------------------------------------------
-- Example (Injections)

data Sort : Set where
  term type : Sort

_ : Variants Sort (term ∷ [])
_ = ` term

_-Bounds : List Sort → Set
𝒮 -Bounds = Variants Sort 𝒮 → ℕ

Index : {𝒮 : List Sort} → Variants Sort 𝒮 → (𝒮 -Bounds) → Set
Index 𝓈 Γ = Fin (Γ 𝓈)

term-sorts : List Sort
term-sorts = term ∷ type ∷ []

infix 9 #_
data Term : term-sorts -Bounds → Set where
  #_ : ∀ {Γ} → Index (` term) Γ → Term Γ

-- ----------------------------------------------------------------------
-- Example (Subtyping)

type-sorts : List Sort
type-sorts = type ∷ []

infix 9 ~_

data Type : type-sorts -Bounds → Set where
  ~_ : ∀ {Γ} → Index (` type) Γ → Type Γ

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

_ : ⦅ type-sorts ⊆ term-sorts ⦆
_ = it

_ : term-sorts -Bounds → Set
_ = ⌊ Type ⌋

infixl 7 _[_]

data Term′ : term-sorts -Bounds → Set where
  #_ : ∀ {Γ} → Index (` term) Γ → Term′ Γ
  _[_] : ∀ {Γ} → Term′ Γ → ⌊ Type ⌋ Γ → Term′ Γ


------------------------------------------------------------------------
-- The Agda standard library
--
-- Fancy display functions for List-based tables
------------------------------------------------------------------------

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

module Text.Tabular.List where

open import Data.String using (String)
open import Data.List.Base
import Data.Nat.Properties as ℕₚ
open import Data.Product using (-,_; proj₂)
open import Data.Vec.Base as Vec using (Vec)
open import Data.Vec.Bounded.Base as Vec≤ using (Vec≤)
open import Function.Base

open import Text.Tabular.Base
import Text.Tabular.Vec as Show

display : TabularConfig → List Alignment → List (List String) → List String
display c a rows = Show.display c alignment rectangle where

  alignment : Vec Alignment _
  alignment = Vec≤.padRight Left
            $ Vec≤.≤-cast (ℕₚ.m⊓n≤m _ _)
            $ Vec≤.take _ (Vec≤.fromList a)

  rectangle : Vec (Vec String _) _
  rectangle = Vec.fromList
            $ map (Vec≤.padRight "")
            $ proj₂
            $ Vec≤.rectangle
            $ map (λ row → -, Vec≤.fromList row) rows


module PiQ.Opsem where
open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Sum
open import Data.Product
open import Data.Maybe
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Function using (_∘_)
open import Base
open import PiQ.Syntax

infix  1  _↦_

-- Base combinators
base : ∀ {A B} (c : A ↔ B) → Set
base unite₊l = ⊤
base uniti₊l = ⊤
base swap₊ = ⊤
base assocl₊ = ⊤
base assocr₊ = ⊤
base unite⋆l = ⊤
base uniti⋆l = ⊤
base swap⋆ = ⊤
base assocl⋆ = ⊤
base assocr⋆ = ⊤
base absorbr = ⊤
base factorzl = ⊤
base dist = ⊤
base factor = ⊤
base _ = ⊥

-- Dual combinators
dual : ∀ {A B} (c : A ↔ B) → Set
dual (ηₓ _) = ⊤
dual (εₓ _) = ⊤
dual η₊ = ⊤
dual ε₊ = ⊤
dual _ = ⊥

base-is-prop : ∀ {A B} (c : A ↔ B) → is-prop (base c)
base-is-prop unite₊l tt tt = refl
base-is-prop uniti₊l tt tt = refl
base-is-prop swap₊ tt tt = refl
base-is-prop assocl₊ tt tt = refl
base-is-prop assocr₊ tt tt = refl
base-is-prop unite⋆l tt tt = refl
base-is-prop uniti⋆l tt tt = refl
base-is-prop swap⋆ tt tt = refl
base-is-prop assocl⋆ tt tt = refl
base-is-prop assocr⋆ tt tt = refl
base-is-prop absorbr tt tt = refl
base-is-prop factorzl tt tt = refl
base-is-prop dist tt tt = refl
base-is-prop factor tt tt = refl

-- Evaluator for base combinators
δ : ∀ {A B} (c : A ↔ B) {_ : base c} → ⟦ A ⟧ → ⟦ B ⟧
δ unite₊l (inj₂ v) = v
δ uniti₊l v = inj₂ v
δ swap₊ (inj₁ x) = inj₂ x
δ swap₊ (inj₂ y) = inj₁ y
δ assocl₊ (inj₁ v) = inj₁ (inj₁ v)
δ assocl₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v)
δ assocl₊ (inj₂ (inj₂ v)) = inj₂ v
δ assocr₊ (inj₁ (inj₁ v)) = inj₁ v
δ assocr₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v)
δ assocr₊ (inj₂ v) = inj₂ (inj₂ v)
δ unite⋆l (tt , v) = v
δ uniti⋆l v = (tt , v)
δ swap⋆ (x , y) = (y , x)
δ assocl⋆ (v₁ , (v₂ , v₃)) = ((v₁ , v₂) , v₃)
δ assocr⋆ ((v₁ , v₂) , v₃) = (v₁ , (v₂ , v₃))
δ absorbr ()
δ factorzl ()
δ dist (inj₁ v₁ , v₃) = inj₁ (v₁ , v₃)
δ dist (inj₂ v₂ , v₃) = inj₂ (v₂ , v₃)
δ factor (inj₁ (v₁ , v₃)) = (inj₁ v₁ , v₃)
δ factor (inj₂ (v₂ , v₃)) = (inj₂ v₂ , v₃)

-- Decidable equality of PiQ values
_≟_ : {t : 𝕌} → Decidable (_≡_ {A = ⟦ t ⟧})
_≟_ {𝟙} tt tt = yes refl
_≟_ {t₁ +ᵤ t₂} (inj₁ x) (inj₁ y) with x ≟ y
... | yes refl = yes refl
... | no  x≠y  = no  (x≠y ∘ λ {refl → refl})
_≟_ {t₁ +ᵤ t₂} (inj₁ x) (inj₂ y) = no (λ ())
_≟_ {t₁ +ᵤ t₂} (inj₂ x) (inj₁ y) = no (λ ())
_≟_ {t₁ +ᵤ t₂} (inj₂ x) (inj₂ y) with x ≟ y
... | yes refl = yes refl
... | no  x≠y  = no  (x≠y ∘ λ {refl → refl})
_≟_ {t₁ ×ᵤ t₂} (x₁ , x₂) (y₁ , y₂) with x₁ ≟ y₁ | x₂ ≟ y₂
... | yes refl | yes refl = yes refl
... | yes refl | no x₂≠y₂ = no  (x₂≠y₂ ∘ cong proj₂)
... | no x₁≠y₁ | yes refl = no  (x₁≠y₁ ∘ cong proj₁)
... | no x₁≠y₁ | no x₂≠y₂ = no  (x₁≠y₁ ∘ cong proj₁)
_≟_ {𝟙/ t} ↻ ↻ = yes refl
_≟_ { - t} (- v₁) (- v₂) with v₁ ≟ v₂
... | yes refl = yes refl
... | no  neq  = no (λ {refl → neq refl})

-- Context
data Context : {A B : 𝕌} → Set where
  ☐ : ∀ {A B} → Context {A} {B}
  ☐⨾_•_ : ∀ {A B C} → (c₂ : B ↔ C) → Context {A} {C} → Context {A} {B}
  _⨾☐•_ : ∀ {A B C} → (c₁ : A ↔ B) → Context {A} {C} → Context {B} {C}
  ☐⊕_•_ : ∀ {A B C D} → (c₂ : C ↔ D) → Context {A +ᵤ C} {B +ᵤ D} → Context {A} {B}
  _⊕☐•_ : ∀ {A B C D} → (c₁ : A ↔ B) → Context {A +ᵤ C} {B +ᵤ D} → Context {C} {D}
  ☐⊗[_,_]•_ : ∀ {A B C D} → (c₂ : C ↔ D) → ⟦ C ⟧ → Context {A ×ᵤ C} {B ×ᵤ D} → Context {A} {B}
  [_,_]⊗☐•_ : ∀ {A B C D} → (c₁ : A ↔ B) → ⟦ B ⟧ → Context {A ×ᵤ C} {B ×ᵤ D} → Context {C} {D}

-- Machine state
data State : Set where
  ⟨_∣_∣_⟩▷ : ∀ {A B} → (c : A ↔ B) → ⟦ A ⟧ → Context {A} {B} → State
  ［_∣_∣_］▷ : ∀ {A B} → (c : A ↔ B) → ⟦ B ⟧ → Context {A} {B} → State
  ⟨_∣_∣_⟩◁ : ∀ {A B} → (c : A ↔ B) → ⟦ A ⟧ → Context {A} {B} → State
  ［_∣_∣_］◁ : ∀ {A B} → (c : A ↔ B) → ⟦ B ⟧ → Context {A} {B} → State
  ⊠ : State

-- Reduction relation
data _↦_ : State → State → Set where
  ↦⃗₁  : ∀ {A B} {c : A ↔ B} {b : base c} {v : ⟦ A ⟧} {κ : Context}
       → ⟨ c ∣ v ∣ κ ⟩▷ ↦ ［ c ∣ δ c {b} v ∣ κ ］▷
  ↦⃗₂  : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ⟨ id↔ ∣ v ∣ κ ⟩▷ ↦ ［ id↔ ∣ v ∣ κ ］▷
  ↦⃗₃  : ∀ {A B C} {c₁ : A ↔ B} {c₂ : B ↔ C} {v : ⟦ A ⟧} {κ : Context}
       → ⟨ c₁ ⨾ c₂ ∣ v ∣ κ ⟩▷ ↦ ⟨ c₁ ∣ v ∣ ☐⨾ c₂ • κ ⟩▷
  ↦⃗₄  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ A ⟧} {κ : Context}
       → ⟨ c₁ ⊕ c₂ ∣ inj₁ x ∣ κ ⟩▷ ↦ ⟨ c₁ ∣ x ∣ ☐⊕ c₂ • κ ⟩▷
  ↦⃗₅  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {y : ⟦ C ⟧} {κ : Context}
       → ⟨ c₁ ⊕ c₂ ∣ inj₂ y ∣ κ ⟩▷ ↦ ⟨ c₂ ∣ y ∣ c₁ ⊕☐• κ ⟩▷
  ↦⃗₆  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ A ⟧} {y : ⟦ C ⟧} {κ : Context}
       → ⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ κ ⟩▷ ↦ ⟨ c₁ ∣ x ∣ ☐⊗[ c₂ , y ]• κ ⟩▷
  ↦⃗₇  : ∀ {A B C} {c₁ : A ↔ B} {c₂ : B ↔ C} {v : ⟦ B ⟧} {κ : Context}
       → ［ c₁ ∣ v ∣ ☐⨾ c₂ • κ ］▷ ↦ ⟨ c₂ ∣ v ∣ (c₁ ⨾☐• κ) ⟩▷
  ↦⃗₈  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ B ⟧} {y : ⟦ C ⟧} {κ : Context}
       → ［ c₁ ∣ x ∣ ☐⊗[ c₂ , y ]• κ ］▷ ↦ ⟨ c₂ ∣ y ∣ [ c₁ , x ]⊗☐• κ ⟩▷
  ↦⃗₉  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ B ⟧} {y : ⟦ D ⟧} {κ : Context}
       → ［ c₂ ∣ y ∣ [ c₁ , x ]⊗☐• κ ］▷ ↦ ［ c₁ ⊗ c₂ ∣ (x , y) ∣ κ ］▷
  ↦⃗₁₀ : ∀ {A B C} {c₁ : A ↔ B} {c₂ : B ↔ C} {v : ⟦ C ⟧} {κ : Context}
       → ［ c₂ ∣ v ∣ (c₁ ⨾☐• κ) ］▷ ↦ ［ c₁ ⨾ c₂ ∣ v ∣ κ ］▷
  ↦⃗₁₁ : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ B ⟧} {κ : Context}
       → ［ c₁ ∣ x ∣ ☐⊕ c₂ • κ ］▷ ↦ ［ c₁ ⊕ c₂ ∣ inj₁ x ∣ κ ］▷
  ↦⃗₁₂ : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {y : ⟦ D ⟧} {κ : Context}
       → ［ c₂ ∣ y ∣ c₁ ⊕☐• κ ］▷ ↦ ［ c₁ ⊕ c₂ ∣ inj₂ y ∣ κ ］▷
  ↦⃖₁  : ∀ {A B} {c : A ↔ B} {b : base c} {v : ⟦ A ⟧} {κ : Context}
      → ［ c ∣ δ c {b} v ∣ κ ］◁ ↦ ⟨ c ∣ v ∣ κ ⟩◁
  ↦⃖₂  : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ［ id↔ ∣ v ∣ κ ］◁ ↦ ⟨ id↔ ∣ v ∣ κ ⟩◁
  ↦⃖₃  : ∀ {A B C} {c₁ : A ↔ B} {c₂ : B ↔ C} {v : ⟦ A ⟧} {κ : Context}
      → ⟨ c₁ ∣ v ∣ ☐⨾ c₂ • κ ⟩◁ ↦ ⟨ c₁ ⨾ c₂ ∣ v ∣ κ ⟩◁
  ↦⃖₄  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ A ⟧} {κ : Context}
      → ⟨ c₁ ∣ x ∣ ☐⊕ c₂ • κ ⟩◁ ↦ ⟨ c₁ ⊕ c₂ ∣ inj₁ x ∣ κ ⟩◁
  ↦⃖₅  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {y : ⟦ C ⟧} {κ : Context}
      → ⟨ c₂ ∣ y ∣ c₁ ⊕☐• κ ⟩◁ ↦ ⟨ c₁ ⊕ c₂ ∣ inj₂ y ∣ κ ⟩◁
  ↦⃖₆  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ A ⟧} {y : ⟦ C ⟧} {κ : Context}
      → ⟨ c₁ ∣ x ∣ ☐⊗[ c₂ , y ]• κ ⟩◁ ↦ ⟨ c₁ ⊗ c₂ ∣ (x , y) ∣ κ ⟩◁
  ↦⃖₇  : ∀ {A B C} {c₁ : A ↔ B} {c₂ : B ↔ C} {v : ⟦ B ⟧} {κ : Context}
      → ⟨ c₂ ∣ v ∣ (c₁ ⨾☐• κ) ⟩◁ ↦ ［ c₁ ∣ v ∣ ☐⨾ c₂ • κ ］◁
  ↦⃖₈  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ B ⟧} {y : ⟦ C ⟧} {κ : Context}
      → ⟨ c₂ ∣ y ∣ [ c₁ , x ]⊗☐• κ ⟩◁ ↦ ［ c₁ ∣ x ∣ ☐⊗[ c₂ , y ]• κ ］◁
  ↦⃖₉  : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ B ⟧} {y : ⟦ D ⟧} {κ : Context}
      → ［ c₁ ⊗ c₂ ∣ (x , y) ∣ κ ］◁ ↦ ［ c₂ ∣ y ∣ [ c₁ , x ]⊗☐• κ ］◁
  ↦⃖₁₀ : ∀ {A B C} {c₁ : A ↔ B} {c₂ : B ↔ C} {v : ⟦ C ⟧} {κ : Context}
      → ［ c₁ ⨾ c₂ ∣ v ∣ κ ］◁ ↦ ［ c₂ ∣ v ∣ (c₁ ⨾☐• κ) ］◁
  ↦⃖₁₁ : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {x : ⟦ B ⟧} {κ : Context}
      → ［ c₁ ⊕ c₂ ∣ inj₁ x ∣ κ ］◁ ↦ ［ c₁ ∣ x ∣ ☐⊕ c₂ • κ ］◁
  ↦⃖₁₂ : ∀ {A B C D} {c₁ : A ↔ B} {c₂ : C ↔ D} {y : ⟦ D ⟧} {κ : Context}
      → ［ c₁ ⊕ c₂ ∣ inj₂ y ∣ κ ］◁ ↦ ［ c₂ ∣ y ∣ c₁ ⊕☐• κ ］◁
  ↦η₊₁ : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ［ η₊ ∣ inj₁ v ∣ κ ］◁ ↦ ［ η₊ ∣ inj₂ (- v) ∣ κ ］▷
  ↦η₊₂ : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ［ η₊ ∣ inj₂ (- v) ∣ κ ］◁ ↦ ［ η₊ ∣ inj₁ v ∣ κ ］▷
  ↦ε₊₁ : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ⟨ ε₊ ∣ inj₁ v ∣ κ ⟩▷ ↦ ⟨ ε₊ ∣ inj₂ (- v) ∣ κ ⟩◁
  ↦ε₊₂ : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ⟨ ε₊ ∣ inj₂ (- v) ∣ κ ⟩▷ ↦ ⟨ ε₊ ∣ inj₁ v ∣ κ ⟩◁
  ↦⃗ηₓ  : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ⟨ ηₓ v ∣ tt ∣ κ ⟩▷ ↦ ［ ηₓ v ∣ (v , ↻) ∣ κ ］▷
  ↦⃖ηₓ₁ : ∀ {A} {v v' : ⟦ A ⟧} {κ : Context} {eq  : v ≡ v'} → ［ ηₓ v ∣ (v' , ↻) ∣ κ ］◁ ↦ ⟨ ηₓ v ∣ tt ∣ κ ⟩◁
  ↦⃖ηₓ₂ : ∀ {A} {v v' : ⟦ A ⟧} {κ : Context} {neq : v ≢ v'} → ［ ηₓ v ∣ (v' , ↻) ∣ κ ］◁ ↦ ⊠
  ↦⃗εₓ₁ : ∀ {A} {v v' : ⟦ A ⟧} {κ : Context} {eq  : v ≡ v'} → ⟨ εₓ v ∣ (v' , ↻) ∣ κ ⟩▷ ↦ ［ εₓ v ∣ tt ∣ κ ］▷
  ↦⃗εₓ₂ : ∀ {A} {v v' : ⟦ A ⟧} {κ : Context} {neq : v ≢ v'} → ⟨ εₓ v ∣ (v' , ↻) ∣ κ ⟩▷ ↦ ⊠
  ↦⃖εₓ  : ∀ {A} {v : ⟦ A ⟧} {κ : Context} → ［ εₓ v ∣ tt ∣ κ ］◁ ↦ ⟨ εₓ v ∣ (v , ↻) ∣ κ ⟩◁


-- Andreas, 2016-02-09, issue reported by Anton Setzer
-- {-# OPTIONS -v tc.conv.infer:30 -v tc.deftype:30 #-}

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

data ⊥ : Set where

data MaybeSet : Set₁ where
  nothing : MaybeSet
  just : Set → MaybeSet

-- not injective
FromJust : MaybeSet → Set
FromJust nothing = ⊥
FromJust (just A) = A

R0 : ⊥ → Set
R0 ()

data C1 (A :  Set) : Set where
  c1 : ⊥ → C1 A

-- R1 is projection-like
R1 : (A : Set) → C1 A → Set
R1 A (c1 c) = R0 c
-- R1 A (c1 ()) -- no int. err.

record Iface  : Set₁ where
  field
    Command   : Set
    Response  : Command → Set

I1 : (A : Set) → Iface
Iface.Command   (I1 A) = C1 A
Iface.Response  (I1 A) = R1 A
-- Iface.Response  (I1 A) (c1 c) = R0 c -- no int.err.
-- I1 A = record { Command = C1 A; Response = R1 A } -- no. int. err

postulate
  IO : Iface → Set

data C2 (s : MaybeSet) : Set₁ where
  c2  : (FromJust s → IO (I1 (FromJust s))) → C2 s

data IOˢ : MaybeSet → Set₁ where
  do : {s : MaybeSet} (c : C2 s) → IOˢ s

postulate
  bla : Set → ⊥ → IO (I1  ⊥)

test : IOˢ nothing
test = do (c2 (bla {!!}))


module nodcap.NF.Axiom where

open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺
open import Data.List as L using (List; []; _∷_; _++_)
open import Function using (_$_)
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)
open import Data.Environment
open import nodcap.Base
open import nodcap.NF.Typing

{-# TERMINATING #-}
-- Theorem:
--   Identity expansion.
--
-- Problematic calls:
--   * in the recursive calls under ⅋n and ⊗n, it is the
--     size of the resource index which is decreasing, not
--     the size of the type itself.
ax : {A : Type} → ⊢ⁿᶠ A ∷ A ^ ∷ []
ax { 𝟏 }
  = exch (bbl [])
  $ wait halt
ax { ⊥ }
  = wait halt
ax { 𝟎 }
  = exch (bbl [])
  $ loop
ax { ⊤ }
  = loop
ax { A ⊗ B }
  = exch (bbl [])
  $ recv
  $ exch (bwd [] (_ ∷ _ ∷ []))
  $ send ax ax
ax { A ⅋ B }
  = recv
  $ exch (bwd [] (_ ∷ _ ∷ []))
  $ send
  ( exch (bbl []) ax )
  ( exch (bbl []) ax )
ax { A ⊕ B }
  = exch (bbl [])
  $ case
  ( exch (bbl [])
  $ sel₁ ax
  )
  ( exch (bbl [])
  $ sel₂ ax
  )
ax { A & B }
  = case
  ( exch (bbl [])
  $ sel₁
  $ exch (bbl []) ax
  )
  ( exch (bbl [])
  $ sel₂
  $ exch (bbl []) ax
  )
ax { ![ suc zero ] A }
  = mk!₁
  $ exch (bbl [])
  $ mk?₁
  $ exch (bbl []) ax
ax { ![ suc (suc n) ] A }
  = exch (bbl [])
  $ cont {m = 1} {n = suc n}
  $ exch (bwd [] (_ ∷ _ ∷ []))
  $ pool {m = 1} {n = suc n}
  ( ax )
  ( ax )
ax { ?[ suc zero ] A }
  = mk?₁
  $ exch (bbl [])
  $ mk!₁
  $ exch (bbl []) ax
ax { ?[ suc (suc n) ] A }
  = cont {m = 1} {n = suc n}
  $ exch (bwd [] (_ ∷ _ ∷ []))
  $ pool {m = 1} {n = suc n}
  ( exch (bbl []) ax )
  ( exch (bbl []) ax )


module DualCoinductive where

open import Data.Nat hiding (compare)
open import Data.Nat.Properties
open import Data.Fin hiding (_+_)
open import Function
open import Relation.Binary.PropositionalEquality hiding (Extensionality)
open import Agda.Builtin.Equality.Rewrite
open import Direction

-- variables

variable
  n m : ℕ

-- session types coinductively

module COI where
  mutual
    data Type : Set where
      TUnit TInt : Type
      TPair : Type → Type → Type
      TChan : SType → Type

    data STypeF (S : Set) : Set where
      transmit : (d : Dir) (t : Type) (s : S) → STypeF S
      choice : (d : Dir) (m : ℕ) (alt : Fin m → S) → STypeF S
      end : STypeF S

    record SType : Set where
      coinductive
      constructor delay
      field force : STypeF SType

  open SType

  variable
    t t₁ t₂ t₃ t₁' t₂' t₃' : Type
    s s₁ s₂ s₃ : SType
    s' s₁' s₂' s₃' : STypeF SType

  -- type equivalence
  data EquivT (R : SType → SType → Set) : Type → Type → Set where
    eq-unit : EquivT R TUnit TUnit
    eq-int  : EquivT R TInt TInt
    eq-pair : EquivT R t₁ t₁' → EquivT R t₂ t₂' → EquivT R (TPair t₁ t₂) (TPair t₁' t₂')
    eq-chan : R s₁ s₂ → EquivT R (TChan s₁) (TChan s₂)

  -- session type equivalence
  data EquivF (R : SType → SType → Set) : STypeF SType → STypeF SType → Set where
    eq-transmit : (d : Dir) → EquivT R t₁ t₂ → R s₁ s₂ → EquivF R (transmit d t₁ s₁) (transmit d t₂ s₂)
    eq-choice : ∀ {alt alt'} → (d : Dir) → ((i : Fin m) → R (alt i) (alt' i)) → EquivF R (choice d m alt) (choice d m alt')
    eq-end : EquivF R end end

  record Equiv (s₁ : SType) (s₂ : SType) : Set where
    coinductive
    field force : EquivF Equiv (force s₁) (force s₂)

  open Equiv

  _≈_ = Equiv
  _≈'_ = EquivF Equiv
  _≈ᵗ_ = EquivT Equiv

  -- reflexivity
  ≈ᵗ-refl : t ≈ᵗ t
  ≈-refl : s ≈ s
  ≈'-refl : s' ≈' s'

  force (≈-refl {s}) = ≈'-refl

  ≈'-refl {transmit d t s} = eq-transmit d ≈ᵗ-refl ≈-refl
  ≈'-refl {choice d m alt} = eq-choice d λ i → ≈-refl
  ≈'-refl {end} = eq-end

  ≈ᵗ-refl {TUnit} = eq-unit
  ≈ᵗ-refl {TInt} = eq-int
  ≈ᵗ-refl {TPair t t₁} = eq-pair ≈ᵗ-refl ≈ᵗ-refl
  ≈ᵗ-refl {TChan x} = eq-chan ≈-refl

  -- symmetry
  ≈-symm : s₁ ≈ s₂ → s₂ ≈ s₁
  ≈'-symm : s₁' ≈' s₂' → s₂' ≈' s₁'
  ≈ᵗ-symm : t₁ ≈ᵗ t₂ → t₂ ≈ᵗ t₁

  force (≈-symm s₁≈s₂) = ≈'-symm (force s₁≈s₂)

  ≈'-symm (eq-transmit d x x₁) = eq-transmit d (≈ᵗ-symm x) (≈-symm x₁)
  ≈'-symm (eq-choice d x) = eq-choice d (λ i → ≈-symm (x i))
  ≈'-symm eq-end = eq-end

  ≈ᵗ-symm eq-unit = eq-unit
  ≈ᵗ-symm eq-int = eq-int
  ≈ᵗ-symm (eq-pair t₁≈t₂ t₁≈t₃) = eq-pair (≈ᵗ-symm t₁≈t₂) (≈ᵗ-symm t₁≈t₃)
  ≈ᵗ-symm (eq-chan x) = eq-chan (≈-symm x)

  -- transitivity
  ≈-trans : s₁ ≈ s₂ → s₂ ≈ s₃ → s₁ ≈ s₃
  ≈'-trans : s₁' ≈' s₂' → s₂' ≈' s₃' → s₁' ≈' s₃'
  ≈ᵗ-trans : t₁ ≈ᵗ t₂ → t₂ ≈ᵗ t₃ → t₁ ≈ᵗ t₃

  force (≈-trans s₁≈s₂ s₂≈s₃) = ≈'-trans (force s₁≈s₂) (force s₂≈s₃)

  ≈'-trans (eq-transmit d tt₁ ss₁) (eq-transmit .d tt₂ ss₂) = eq-transmit d (≈ᵗ-trans tt₁ tt₂) (≈-trans ss₁ ss₂)
  ≈'-trans (eq-choice d x) (eq-choice .d x₁) = eq-choice d (λ i → ≈-trans (x i) (x₁ i))
  ≈'-trans eq-end eq-end = eq-end

  ≈ᵗ-trans eq-unit eq-unit = eq-unit
  ≈ᵗ-trans eq-int eq-int = eq-int
  ≈ᵗ-trans (eq-pair t₁≈ᵗt₂ t₁≈ᵗt₃) (eq-pair t₂≈ᵗt₃ t₂≈ᵗt₄) = eq-pair (≈ᵗ-trans t₁≈ᵗt₂ t₂≈ᵗt₃) (≈ᵗ-trans t₁≈ᵗt₃ t₂≈ᵗt₄)
  ≈ᵗ-trans (eq-chan ss₁) (eq-chan ss₂) = eq-chan (≈-trans ss₁ ss₂)

  ----------------------------------------------------------------------
  -- relational duality
  data DualD : Dir → Dir → Set where
    dual-sr : DualD SND RCV
    dual-rs : DualD RCV SND

  -- session type duality
  data DualF (R : SType → SType → Set) : STypeF SType → STypeF SType → Set where
    dual-transmit : DualD d₁ d₂ → t₁ ≈ᵗ t₂ → R s₁ s₂ → DualF R (transmit d₁ t₁ s₁) (transmit d₂ t₂ s₂)
    dual-choice : ∀ {alt alt'} → DualD d₁ d₂ → ((i : Fin m) → R (alt i) (alt' i)) → DualF R (choice d₁ m alt) (choice d₂ m alt')
    dual-end : DualF R end end

  record Dual (s₁ : SType) (s₂ : SType) : Set where
    coinductive
    field force : DualF Dual (force s₁) (force s₂)

  -- open Dual

  _⊥_ = Dual
  _⊥'_ = DualF Dual
  -- _≈ᵗ_ = EquivT Equiv

  -- symmetric

  DualD-symm : DualD d₁ d₂ → DualD d₂ d₁
  DualD-symm dual-sr = dual-rs
  DualD-symm dual-rs = dual-sr

  ⊥-symm : s₁ ⊥ s₂ → s₂ ⊥ s₁
  ⊥'-symm : s₁' ⊥' s₂' → s₂' ⊥' s₁'

  Dual.force (⊥-symm s₁⊥s₂) = ⊥'-symm (Dual.force s₁⊥s₂)

  ⊥'-symm (dual-transmit x x₁ x₂) = dual-transmit (DualD-symm x) (≈ᵗ-symm x₁) (⊥-symm x₂)
  ⊥'-symm (dual-choice x x₁) = dual-choice (DualD-symm x) (⊥-symm ∘ x₁)
  ⊥'-symm dual-end = dual-end

  -- involutory
  DualD-inv : DualD d₁ d₂ → DualD d₂ d₃ → d₁ ≡ d₃
  DualD-inv dual-sr dual-rs = refl
  DualD-inv dual-rs dual-sr = refl

  ⊥-inv : s₁ ⊥ s₂ → s₂ ⊥ s₃ → s₁ ≈ s₃
  ⊥'-inv : s₁' ⊥' s₂' → s₂' ⊥' s₃' → s₁' ≈' s₃'

  force (⊥-inv s₁⊥s₂ s₂⊥s₃) = ⊥'-inv (Dual.force s₁⊥s₂) (Dual.force s₂⊥s₃)

  ⊥'-inv (dual-transmit dd₁ tt₁ ss₁) (dual-transmit dd₂ tt₂ ss₂) rewrite DualD-inv dd₁ dd₂ = eq-transmit _ (≈ᵗ-trans tt₁ tt₂) (⊥-inv ss₁ ss₂)
  ⊥'-inv (dual-choice dd₁ ss₁) (dual-choice dd₂ ss₂) rewrite DualD-inv dd₁ dd₂ = eq-choice _ (λ i → ⊥-inv (ss₁ i) (ss₂ i))
  ⊥'-inv dual-end dual-end = eq-end

  ----------------------------------------------------------------------
  -- duality
  dual : SType → SType
  dualF : STypeF SType → STypeF SType

  force (dual s) = dualF (force s)

  dualF (transmit d t s) = transmit (dual-dir d) t (dual s)
  dualF (choice d m alt) = choice (dual-dir d) m (dual ∘ alt)
  dualF end = end

  -- properties

  dual-involution : ∀ s → s ≈ dual (dual s)
  dual-involutionF : ∀ s' → s' ≈' dualF (dualF s')

  force (dual-involution s) = dual-involutionF (force s)

  dual-involutionF (transmit d t s)
    rewrite dual-dir-inv d = eq-transmit d ≈ᵗ-refl (dual-involution s)
  dual-involutionF (choice d m alt)
    rewrite dual-dir-inv d = eq-choice d (dual-involution ∘ alt)
  dual-involutionF end = eq-end

  -----------------------------------------------------------------------
  -- relational duality vs functional duality

  -- soundness

  dual-soundD : DualD d (dual-dir d)
  dual-soundD {SND} = dual-sr
  dual-soundD {RCV} = dual-rs

  dual-soundS : s ⊥ dual s
  dual-soundF : s' ⊥' dualF s'

  Dual.force dual-soundS = dual-soundF

  dual-soundF {transmit d t s} = dual-transmit dual-soundD ≈ᵗ-refl dual-soundS
  dual-soundF {choice d m alt} = dual-choice dual-soundD (λ i → dual-soundS)
  dual-soundF {end} = dual-end

  -- completeness

  dual-completeD : DualD d₁ d₂ → d₁ ≡ dual-dir d₂
  dual-completeD dual-sr = refl
  dual-completeD dual-rs = refl

  dual-completeS : s₁ ⊥ s₂ → s₁ ≈ dual s₂
  dual-completeF : s₁' ⊥' s₂' → s₁' ≈' dualF s₂'

  force (dual-completeS s₁⊥s₂) = dual-completeF (Dual.force s₁⊥s₂)

  dual-completeF (dual-transmit dd tt ss) rewrite dual-completeD dd = eq-transmit _ tt (dual-completeS ss)
  dual-completeF (dual-choice dd x₁) rewrite dual-completeD dd = eq-choice _ (λ i → dual-completeS (x₁ i))
  dual-completeF dual-end = eq-end


{-# OPTIONS --safe #-}
module Cubical.Categories.Monad.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Categories.Category
open import Cubical.Categories.Functor renaming (𝟙⟨_⟩ to funcId)
open import Cubical.Categories.NaturalTransformation.Base
open import Cubical.Categories.NaturalTransformation.Properties
open import Cubical.Categories.Functors.HomFunctor

private
  variable
    ℓ ℓ' : Level

module _ {C : Category ℓ ℓ'} (M : Functor C C) where
  open Category C
  open Functor
  open NatTrans

  IsPointed : Type (ℓ-max ℓ ℓ')
  IsPointed = NatTrans (funcId C) M

  record IsMonad : Type (ℓ-max ℓ ℓ') where
    field
      η : IsPointed
      μ : NatTrans (funcComp M M) M
      idl-μ : PathP (λ i → NatTrans (F-rUnit {F = M} i) M) (compTrans μ (η ∘ˡ M)) (idTrans M)
      idr-μ : PathP (λ i → NatTrans (F-lUnit {F = M} i) M) (compTrans μ (M ∘ʳ η)) (idTrans M)
      assoc-μ : PathP (λ i → NatTrans (F-assoc {F = M} {G = M} {H = M} i) M)
        (compTrans μ (M ∘ʳ μ))
        (compTrans μ (μ ∘ˡ M))

    -- bind : Hom[-,M-] -> Hom[M-,M-]
    bind : NatTrans (funcComp (HomFunctor C) ((funcId C ^opF) ×F M)) (funcComp (HomFunctor C) ((M ^opF) ×F M))
    N-ob bind (x , y) f = N-ob μ y ∘ F-hom M f
    N-hom bind {x , y} {x' , y'} (f , h) = funExt λ g →
      (F-hom M ((f ⋆ g) ⋆ F-hom M h) ⋆ N-ob μ y')
        ≡⟨ cong (_⋆ N-ob μ y') (F-seq M (f ⋆ g) (F-hom M h)) ⟩
      ((F-hom M (f ⋆ g) ⋆ F-hom M (F-hom M h)) ⋆ N-ob μ y')
        ≡⟨ ⋆Assoc (F-hom M (f ⋆ g)) (F-hom M (F-hom M h)) (N-ob μ y') ⟩
      (F-hom M (f ⋆ g) ⋆ (F-hom M (F-hom M h) ⋆ N-ob μ y'))
        ≡⟨ cong (F-hom M (f ⋆ g) ⋆_) (N-hom μ h) ⟩
      (F-hom M (f ⋆ g) ⋆ (N-ob μ y ⋆ F-hom M h))
        ≡⟨ sym (⋆Assoc (F-hom M (f ⋆ g)) (N-ob μ y) (F-hom M h)) ⟩
      ((F-hom M (f ⋆ g) ⋆ N-ob μ y) ⋆ F-hom M h)
        ≡⟨ cong (_⋆ F-hom M h) (cong (_⋆ N-ob μ y) (F-seq M f g)) ⟩
      (((F-hom M f ⋆ F-hom M g) ⋆ N-ob μ y) ⋆ F-hom M h)
        ≡⟨ cong (_⋆ F-hom M h) (⋆Assoc (F-hom M f) (F-hom M g) (N-ob μ y)) ⟩
      ((M .F-hom f ⋆ (F-hom M g ⋆ N-ob μ y)) ⋆ F-hom M h) ∎

  -- Define comonads as monads on the opposite category?

module _ (C : Category ℓ ℓ') where
  Monad : Type (ℓ-max ℓ ℓ')
  Monad = Σ[ M ∈ Functor C C ] IsMonad M

module _ {C : Category ℓ ℓ'} (monadM monadN : Monad C) (ν : NatTrans (fst monadM) (fst monadN)) where

  private
    M N : Functor C C
    M = fst monadM
    N = fst monadN
    module M = IsMonad (snd monadM)
    module N = IsMonad (snd monadN)

  record IsMonadHom : Type (ℓ-max ℓ ℓ') where
    constructor proveMonadHom
    field
      N-η : compTrans ν M.η ≡ N.η
      N-μ : compTrans ν M.μ ≡ compTrans N.μ (whiskerTrans ν ν)
  open IsMonadHom

  isProp-IsMonadHom : isProp (IsMonadHom)
  N-η (isProp-IsMonadHom (proveMonadHom N-η1 N-μ1) (proveMonadHom N-η2 N-μ2) i) = isSetNatTrans _ _ N-η1 N-η2 i
  N-μ (isProp-IsMonadHom (proveMonadHom N-η1 N-μ1) (proveMonadHom N-η2 N-μ2) i) = isSetNatTrans _ _ N-μ1 N-μ2 i

module _ {C : Category ℓ ℓ'} (monadM monadN : Monad C) where
  MonadHom : Type (ℓ-max ℓ ℓ')
  MonadHom = Σ[ ν ∈ NatTrans (fst monadM) (fst monadN) ] IsMonadHom monadM monadN ν


open import MJ.Types
open import MJ.Classtable

module MJ.Syntax {c}(Σ : Classtable c) where

open import MJ.Syntax.Typed Σ public


module Languages.FILL.Syntax where

open import level
open import bool
open import nat
open import unit
open import empty
open import list
open import eq
open import sum

open import Utils.HaskellTypes
open import Utils.HaskellFunctions
open import Languages.FILL.TypeSyntax

True : Set
True = ⊤{lzero}

False : Set
False = ⊥{lzero}

Name : Set
Name = ℕ

name-in : ∀{A : Set} → (A → A → 𝔹) → A → 𝕃 A → Set
name-in eq x ctx with list-member eq x ctx
name-in _ x ctx | tt = True
name-in _ x ctx | ff = False

-- Bound Variable Labels:
data VLabel : Set where
  LPV : VLabel         -- Let-Bound Left Pattern Variable
  RPV : VLabel         -- Let-Bound Right Pattern Variable
  BV  : VLabel         -- λ-Bound Variable

_vl-eq_ : VLabel → VLabel → 𝔹
LPV vl-eq LPV = tt
RPV vl-eq RPV = tt
BV vl-eq BV = tt
_ vl-eq _ = ff

data Pattern : Set where
  PTriv : Pattern
  PTensor : String → String → Pattern
  PPar : String → String → Pattern

data Term : Set where
  Triv : Term
  Void : Term
  FVar : String → Term
  BVar : Name → String → VLabel → Term
  Let : Term → Type → Pattern → Term → Term
  Lam : String → Type → Term → Term
  App : Term → Term → Term
  Tensor : Term → Term → Term
  Par : Term → Term → Term

open-t : Name → VLabel → Term → Term → Term
open-t x l u (BVar y ys l') with x =ℕ y | l vl-eq l'
... | tt | tt = u
... | _  | _  = BVar y ys l'
open-t x BV u (Let t₁ y z t₂) = Let (open-t x BV u t₁) y z (open-t x BV u t₂)
open-t x l u (Let t₁ a p t₂) = Let (open-t (suc x) l u t₁) a p (open-t (suc x) l u t₂)
open-t x BV u (Lam ys a t) = Lam ys a (open-t (suc x) BV u t)
open-t x l u (Lam ys a t) = Lam ys a (open-t x l u t)
open-t x l u (App t₁ t₂) = App (open-t x l u t₁) (open-t x l u t₂)
open-t x l u (Tensor t₁ t₂) = Tensor (open-t x l u t₁) (open-t x l u t₂)
open-t x l u (Par t₁ t₂) = Par (open-t x l u t₁) (open-t x l u t₂)
open-t _ _ _ t = t

close-t : Name → String → VLabel → String → Term → Term
close-t x xs l y (FVar z) with y str-eq z
... | tt = BVar x xs l
... | ff = FVar z
close-t x xs l y (Let t₁ ty p t₂) = Let (close-t x xs l y t₁) ty p (close-t x xs l y t₂)
close-t x xs l y (Lam ys a t) = Lam ys a (close-t x xs l y t)
close-t x xs l y (App t₁ t₂) = App (close-t x xs l y t₁) (close-t x xs l y t₂)
close-t x xs l y (Tensor t₁ t₂) = Tensor (close-t x xs l y t₁) (close-t x xs l y t₂)
close-t x xs l y (Par t₁ t₂) = Par (close-t x xs l y t₁) (close-t x xs l y t₂)
close-t _ _ _ _ t = t

data LC : Term → Set where
  Triv : LC Triv
  Void : LC Void
  FVar : ∀{x : String} → LC (FVar x)
  Lam : ∀{ns : 𝕃 String}{t : Term}{a : Type}{y : String}
      → LC t
      → (∀{x : String}
           → (name-in _str-eq_ x ns → False)
           → LC (open-t 0 BV (FVar x) t))
      → LC (Lam y a t)
  LetTriv : ∀{t₁ : Term}{a : Type}{t₂ : Term}
      → LC t₁
      → LC t₂
      → LC (Let t₁ a PTriv t₂)
  LetTensor : ∀{ns : 𝕃 String}{t₁ : Term}{a : Type}{t₂ : Term}{s₁ s₂ : String}
      → LC t₁
      → LC t₂
      → (∀{x y : String}
           → (name-in _str-eq_ x ns → False)
           → (name-in _str-eq_ y ns → False)
           → LC (open-t 0 LPV (FVar x) (open-t 0 RPV (FVar y) t₂)))
      → LC (Let t₁ a (PTensor s₁ s₂) t₂)
  LetPar : ∀{ns : 𝕃 String}{t₁ : Term}{a : Type}{t₂ : Term}{s₁ s₂ : String}
      → LC t₁
      → LC t₂
      → (∀{x y : String}
           → (name-in _str-eq_ x ns → False)
           → (name-in _str-eq_ y ns → False)
           → LC (open-t 0 LPV (FVar x) (open-t 0 RPV (FVar y) t₂)))
      → LC (Let t₁ a (PPar s₁ s₂) t₂)
  App : ∀{t₁ t₂ : Term}
      → LC t₁
      → LC t₂
      → LC (App t₁ t₂)
  Tensor : ∀{t₁ t₂ : Term}
      → LC t₁
      → LC t₂
      → LC (Tensor t₁ t₂)
  Par : ∀{t₁ t₂ : Term}
      → LC t₁
      → LC t₂
      → LC (Par t₁ t₂)


module Prelude.String where

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

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

unpackString = primStringToList
packString   = primStringFromList

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

infixr 5 _&_
_&_ = primStringAppend

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

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

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

-- Eq --

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

-- Ord --

instance
  OrdString : Ord String
  OrdString = OrdBy unpackString-inj

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

-- Overloaded literals --

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

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

-- Monoid --

instance
  open import Prelude.Monoid
  MonoidString : Monoid String
  mempty {{MonoidString}} = ""
  _<>_   {{MonoidString}} = primStringAppend


------------------------------------------------------------------------
-- The Agda standard library
--
-- Conversion of < to ≤, along with a number of properties
------------------------------------------------------------------------

-- Possible TODO: Prove that a conversion ≤ → < → ≤ returns a
-- relation equivalent to the original one (and similarly for
-- < → ≤ → <).

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

open import Relation.Binary

module Relation.Binary.Construct.StrictToNonStrict
  {a ℓ₁ ℓ₂} {A : Set a}
  (_≈_ : Rel A ℓ₁) (_<_ : Rel A ℓ₂)
  where

open import Relation.Nullary
open import Relation.Binary.Consequences
open import Function
open import Data.Product
open import Data.Sum
open import Data.Empty

------------------------------------------------------------------------
-- Conversion

-- _<_ can be turned into _≤_ as follows:

_≤_ : Rel A _
x ≤ y = (x < y) ⊎ (x ≈ y)

------------------------------------------------------------------------
-- The converted relations have certain properties
-- (if the original relations have certain other properties)

<⇒≤ : _<_ ⇒ _≤_
<⇒≤ = inj₁

reflexive : _≈_ ⇒ _≤_
reflexive = inj₂

antisym : IsEquivalence _≈_ → Transitive _<_ → Irreflexive _≈_ _<_ →
          Antisymmetric _≈_ _≤_
antisym eq trans irrefl = as
  where
  module Eq = IsEquivalence eq

  as : Antisymmetric _≈_ _≤_
  as (inj₂ x≈y) _          = x≈y
  as (inj₁ _)   (inj₂ y≈x) = Eq.sym y≈x
  as (inj₁ x<y) (inj₁ y<x) =
    ⊥-elim (trans∧irr⟶asym {_≈_ = _≈_} Eq.refl trans irrefl x<y y<x)

trans : IsEquivalence _≈_ → _<_ Respects₂ _≈_ → Transitive _<_ →
        Transitive _≤_
trans eq (respʳ , respˡ) <-trans = tr
  where
  module Eq = IsEquivalence eq

  tr : Transitive _≤_
  tr (inj₁ x<y) (inj₁ y<z) = inj₁ $ <-trans x<y y<z
  tr (inj₁ x<y) (inj₂ y≈z) = inj₁ $ respʳ y≈z x<y
  tr (inj₂ x≈y) (inj₁ y<z) = inj₁ $ respˡ (Eq.sym x≈y) y<z
  tr (inj₂ x≈y) (inj₂ y≈z) = inj₂ $ Eq.trans x≈y y≈z

<-≤-trans : Transitive _<_ → _<_ Respectsʳ _≈_ → Trans _<_ _≤_ _<_
<-≤-trans trans respʳ x<y (inj₁ y<z) = trans x<y y<z
<-≤-trans trans respʳ x<y (inj₂ y≈z) = respʳ y≈z x<y

≤-<-trans : Symmetric _≈_ → Transitive _<_ → _<_ Respectsˡ _≈_ → Trans _≤_ _<_ _<_
≤-<-trans sym trans respˡ (inj₁ x<y) y<z = trans x<y y<z
≤-<-trans sym trans respˡ (inj₂ x≈y) y<z = respˡ (sym x≈y) y<z

≤-respʳ-≈ : Transitive _≈_ → _<_ Respectsʳ _≈_ → _≤_ Respectsʳ _≈_
≤-respʳ-≈ trans respʳ y'≈y (inj₁ x<y') = inj₁ (respʳ y'≈y x<y')
≤-respʳ-≈ trans respʳ y'≈y (inj₂ x≈y') = inj₂ (trans x≈y' y'≈y)

≤-respˡ-≈ : Symmetric _≈_ → Transitive _≈_ → _<_ Respectsˡ _≈_ → _≤_ Respectsˡ _≈_
≤-respˡ-≈ sym trans respˡ x'≈x (inj₁ x'<y) = inj₁ (respˡ x'≈x x'<y)
≤-respˡ-≈ sym trans respˡ x'≈x (inj₂ x'≈y) = inj₂ (trans (sym x'≈x) x'≈y)

≤-resp-≈ : IsEquivalence _≈_ → _<_ Respects₂ _≈_ → _≤_ Respects₂ _≈_
≤-resp-≈ eq (respʳ , respˡ) = ≤-respʳ-≈ Eq.trans respʳ , ≤-respˡ-≈ Eq.sym Eq.trans respˡ
  where module Eq = IsEquivalence eq

total : Trichotomous _≈_ _<_ → Total _≤_
total <-tri x y with <-tri x y
... | tri< x<y x≉y x≯y = inj₁ (inj₁ x<y)
... | tri≈ x≮y x≈y x≯y = inj₁ (inj₂ x≈y)
... | tri> x≮y x≉y x>y = inj₂ (inj₁ x>y)

decidable : Decidable _≈_ → Decidable _<_ → Decidable _≤_
decidable ≈-dec <-dec x y with ≈-dec x y | <-dec x y
... | yes x≈y | _       = yes (inj₂ x≈y)
... | no  x≉y | yes x<y = yes (inj₁ x<y)
... | no  x≉y | no  x≮y = no [ x≮y , x≉y ]′

decidable' : Trichotomous _≈_ _<_ → Decidable _≤_
decidable' compare x y with compare x y
... | tri< x<y _   _ = yes (inj₁ x<y)
... | tri≈ _   x≈y _ = yes (inj₂ x≈y)
... | tri> x≮y x≉y _ = no [ x≮y , x≉y ]′

------------------------------------------------------------------------
-- Converting structures

isPreorder₁ : IsPreorder _≈_ _<_ → IsPreorder _≈_ _≤_
isPreorder₁ PO = record
  { isEquivalence = S.isEquivalence
  ; reflexive     = reflexive
  ; trans         = trans S.isEquivalence S.∼-resp-≈ S.trans
  }
  where module S = IsPreorder PO

isPreorder₂ : IsStrictPartialOrder _≈_ _<_ → IsPreorder _≈_ _≤_
isPreorder₂ SPO = record
  { isEquivalence = S.isEquivalence
  ; reflexive     = reflexive
  ; trans         = trans S.isEquivalence S.<-resp-≈ S.trans
  }
  where module S = IsStrictPartialOrder SPO

isPartialOrder : IsStrictPartialOrder _≈_ _<_ → IsPartialOrder _≈_ _≤_
isPartialOrder SPO = record
  { isPreorder = isPreorder₂ SPO
  ; antisym    = antisym S.isEquivalence S.trans S.irrefl
  }
  where module S = IsStrictPartialOrder SPO

isTotalOrder : IsStrictTotalOrder _≈_ _<_ → IsTotalOrder _≈_ _≤_
isTotalOrder STO = record
  { isPartialOrder = isPartialOrder S.isStrictPartialOrder
  ; total          = total S.compare
  }
  where module S = IsStrictTotalOrder STO

isDecTotalOrder : IsStrictTotalOrder _≈_ _<_ → IsDecTotalOrder _≈_ _≤_
isDecTotalOrder STO = record
  { isTotalOrder = isTotalOrder STO
  ; _≟_          = S._≟_
  ; _≤?_         = decidable' S.compare
  }
  where module S = IsStrictTotalOrder STO


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

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Concrete.System.Parameters
import LibraBFT.Concrete.Properties.VotesOnce as VO
import LibraBFT.Concrete.Properties.LockedRound as LR

open import LibraBFT.Yasm.Properties ConcSysParms

-- This module collects in one place the obligations an
-- implementation must meet in order to enjoy the properties
-- proved in Abstract.Properties.

module LibraBFT.Concrete.Obligations where

  record ImplObligations : Set₁ where
    field
      -- Structural obligations:
      sps-cor : StepPeerState-AllValidParts

      -- Semantic obligations:
      --
      -- VotesOnce:
      vo₁ : VO.ImplObligation₁
      vo₂ : VO.ImplObligation₂

      -- LockedRound:
      lr₁ : LR.ImplObligation₁


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

open import HoTT
open import homotopy.HSpace renaming (HSpaceStructure to HSS)
open import homotopy.Freudenthal
open import homotopy.IterSuspensionStable
open import homotopy.Pi2HSusp
open import homotopy.EM1HSpace

module homotopy.EilenbergMacLane where

-- EM(G,n) when G is π₁(A,a₀)
module EMImplicit {i} (A : Type i) (cA : is-connected 0 A)
  (gA : has-level 1 A) (A-H : HSS A) where

  private
    a₀ = HSS.e A-H
    X = ⊙[ A , a₀ ]

  ⊙EM : (n : ℕ) → Ptd i
  ⊙EM O = ⊙Ω X
  ⊙EM (S n) = ⊙Trunc ⟨ S n ⟩ (⊙Susp^ n X)

  module _ (n : ℕ) where
    EM = fst (⊙EM n)
    embase = snd (⊙EM n)

  EM-level : (n : ℕ) → has-level ⟨ n ⟩ (fst (⊙EM n))
  EM-level O = gA a₀ a₀
  EM-level (S n) = Trunc-level

  EM-conn : (n : ℕ) → is-connected ⟨ n ⟩ (EM (S n))
  EM-conn n = Trunc-preserves-conn ⟨ S n ⟩
                  (transport (λ t → is-connected t (fst (⊙Susp^ n X)))
                    (+2+0 ⟨ n ⟩₋₂) (⊙Susp^-conn n cA))

  {-
  π (S k) (EM (S n)) (embase (S n)) == π k (EM n) (embase n)
  where k > 0 and n = S (S n')
  -}
  module Stable (k n : ℕ) (indexing : S k ≤ S (S n))
    where

    private
      SSn : ℕ
      SSn = S (S n)

      lte : ⟨ S k ⟩ ≤T ⟨ SSn ⟩
      lte = ⟨⟩-monotone-≤ $ indexing

      Skle : S k ≤ (S n) *2
      Skle = ≤-trans indexing (lemma n)
        where lemma : (n' : ℕ) → S (S n') ≤ (S n') *2
              lemma O = inl idp
              lemma (S n') = ≤-trans (≤-ap-S (lemma n')) (inr ltS)

    private
      module SS = Susp^StableSucc X cA k (S n) Skle

    abstract
      stable : πS (S k) (⊙EM (S SSn))
             == πS k (⊙EM SSn)
      stable =
        πS (S k) (⊙EM (S SSn))
          =⟨ πS-below-trunc _ _ _ (≤T-ap-S lte) ⟩
        πS (S k) (⊙Susp^ SSn X)
          =⟨ SS.stable ⟩
        πS k (⊙Susp^ (S n) X)
          =⟨ ! (πS-below-trunc _ _ _ lte) ⟩
        πS k (⊙EM SSn) ∎

  module BelowDiagonal where

    π₁ : (n : ℕ) → πS 0 (⊙EM (S (S n))) == Lift-Unit-group
    π₁ n =
      contr-is-0ᴳ (πS 0 (⊙EM (S (S n))))
        (connected-at-level-is-contr
          (raise-level-≤T (≤T-ap-S (≤T-ap-S (-2≤T ⟨ n ⟩₋₂)))
                          (Trunc-level {n = 0}))
          (Trunc-preserves-conn 0 (path-conn (EM-conn (S n)))))

    -- some clutter here arises from the definition of <;
    -- any simple way to avoid this?
    πS-below : (k n : ℕ) → (S k < n)
      → πS k (⊙EM n) == Lift-Unit-group
    πS-below 0 .2 ltS = π₁ 0
    πS-below 0 .3 (ltSR ltS) = π₁ 1
    πS-below 0 (S (S n)) (ltSR (ltSR _)) = π₁ n
    πS-below (S k) ._ ltS =
      Stable.stable k k (inr ltS)
      ∙ πS-below k _ ltS
    πS-below (S k) ._ (ltSR ltS) =
      Stable.stable k (S k) (inr (ltSR ltS))
      ∙ πS-below k _ (ltSR ltS)
    πS-below (S k) ._ (ltSR (ltSR ltS)) =
      Stable.stable k (S (S k)) (inr (ltSR (ltSR ltS)))
      ∙ πS-below k _ (ltSR (ltSR ltS))
    πS-below (S k) (S (S (S n))) (ltSR (ltSR (ltSR lt))) =
      Stable.stable k n
        (inr (<-cancel-S (ltSR (ltSR (ltSR lt)))))
      ∙ πS-below k _ (<-cancel-S (ltSR (ltSR (ltSR lt))))

  module OnDiagonal where

    π₁ : πS 0 (⊙EM 1) == πS 0 X
    π₁ = πS-below-trunc 0 1 X ≤T-refl

    private
      module Π₂ = Pi2HSusp A gA cA A-H

    π₂ : πS 1 (⊙EM 2) == πS 0 X
    π₂ =
      πS-below-trunc 1 2 (⊙Susp X) ≤T-refl
      ∙ Π₂.π₂-Suspension

    πS-diag : (n : ℕ) → πS n (⊙EM (S n)) == πS 0 X
    πS-diag 0 = π₁
    πS-diag 1 = π₂
    πS-diag (S (S n)) =
      Stable.stable (S n) n ≤-refl
      ∙ πS-diag (S n)

  module AboveDiagonal where

    πS-above : (k n : ℕ) → (n < S k)
      → πS k (⊙EM n) == Lift-Unit-group
    πS-above k n lt =
      contr-is-0ᴳ (πS k (⊙EM n))
        (inhab-prop-is-contr
          [ idp^ (S k) ]
          (Trunc-preserves-level 0 (Ω^-level-in -1 (S k) _
            (raise-level-≤T (lemma lt) (EM-level n)))))
      where lemma : {k n : ℕ} → n < k → ⟨ n ⟩ ≤T (⟨ k ⟩₋₂ +2+ -1)
            lemma ltS = inl (! (+2+-comm _ -1))
            lemma (ltSR lt) = ≤T-trans (lemma lt) (inr ltS)

  module Spectrum where

    private
      module Π₂ = Pi2HSusp A gA cA A-H

    spectrum0 : ⊙Ω (⊙EM 1) == ⊙EM 0
    spectrum0 =
      ⊙Ω (⊙EM 1)
        =⟨ ⊙ua (⊙≃-in (Trunc=-equiv _ _) idp) ⟩
      ⊙Trunc 0 (⊙Ω X)
        =⟨ ⊙ua (⊙≃-in (unTrunc-equiv _ (gA a₀ a₀)) idp) ⟩
      ⊙Ω X ∎

    spectrum1 : ⊙Ω (⊙EM 2) == ⊙EM 1
    spectrum1 =
      ⊙Ω (⊙EM 2)
        =⟨ ⊙ua (⊙≃-in (Trunc=-equiv _ _) idp) ⟩
      ⊙Trunc 1 (⊙Ω (⊙Susp X))
        =⟨ Π₂.⊙main-lemma ⟩
      X
        =⟨ ! (⊙ua (⊙≃-in (unTrunc-equiv _ gA) idp)) ⟩
      ⊙EM 1 ∎

    private
      sconn : (n : ℕ) → is-connected ⟨ S n ⟩ (fst (⊙Susp^ (S n) X))
      sconn n = transport (λ t → is-connected t (fst (⊙Susp^ (S n) X)))
                          (+2+0 ⟨ n ⟩₋₁) (⊙Susp^-conn (S n) cA)

      kle : (n : ℕ) → ⟨ S (S n) ⟩ ≤T ⟨ n ⟩ +2+ ⟨ n ⟩
      kle O = inl idp
      kle (S n) = ≤T-trans (≤T-ap-S (kle n))
                   (≤T-trans (inl (! (+2+-βr ⟨ n ⟩ ⟨ n ⟩)))
                               (inr ltS))

      module FS (n : ℕ) =
        FreudenthalEquiv ⟨ n ⟩₋₁ ⟨ S (S n) ⟩ (kle n)
          (fst (⊙Susp^ (S n) X)) (snd (⊙Susp^ (S n) X)) (sconn n)

    spectrumSS : (n : ℕ)
      → ⊙Ω (⊙EM (S (S (S n)))) == ⊙EM (S (S n))
    spectrumSS n =
      ⊙Ω (⊙EM (S (S (S n))))
        =⟨ ⊙ua (⊙≃-in (Trunc=-equiv _ _) idp) ⟩
      ⊙Trunc ⟨ S (S n) ⟩ (⊙Ω (⊙Susp^ (S (S n)) X))
        =⟨ ! (FS.⊙path n) ⟩
      ⊙EM (S (S n)) ∎

    abstract
      spectrum : (n : ℕ) → ⊙Ω (⊙EM (S n)) == ⊙EM n
      spectrum 0 = spectrum0
      spectrum 1 = spectrum1
      spectrum (S (S n)) = spectrumSS n

module EMExplicit {i} (G : Group i) (G-abelian : is-abelian G) where
  module K₁ = EM₁ G
  module HSpace = EM₁HSpace G G-abelian
  open EMImplicit K₁.EM₁ K₁.EM₁-conn K₁.emlevel HSpace.H-EM₁ public

  open BelowDiagonal public using (πS-below)

  πS-diag : (n : ℕ) → πS n (⊙EM (S n)) == G
  πS-diag n = OnDiagonal.πS-diag n ∙ K₁.π₁.π₁-iso

  open AboveDiagonal public using (πS-above)
  open Spectrum public using (spectrum)


Id₁ Id₂ Id₃ : {A B : Set} → (A → B) → A → B
Id₁ F = F
Id₂ = Id₁
Id₃ = Id₁

syntax Id₁ (λ X → B) = ƛ X ⟶ B
syntax Id₂ (λ X → B) = X ↦ B
syntax Id₃ (λ X → B) = X ↦ B •

postulate
  A : Set
  a : A

module One where

  example₀ : (A → A) → A
  example₀ = ƛ _ ⟶ a

  example₁ : A → A
  example₁ = ƛ !_! ⟶ (!_!)

  example₂ : A → A
  example₂ = ƛ !_!_ ⟶ (!_!_)

  example₃ : A → A
  example₃ = ƛ _!_! ⟶ (_!_!)

  example₄ : A → A
  example₄ = ƛ _!_!_!_ ⟶ (_!_!_!_)

  example₅ : (A → A) → (A → A)
  example₅ = ƛ !_! ⟶ λ a → ! a !

  example₆ : (A → A → A) → (A → A → A)
  example₆ = ƛ !_!_ ⟶ λ a b → ! a ! b

  example₇ : (A → A → A) → (A → A → A)
  example₇ = ƛ _!_! ⟶ λ a b → a ! b !

  example₈ : (A → A → A → A → A) → (A → A → A → A → A)
  example₈ = ƛ _!_!_!_ ⟶ λ a b c → a !_! b ! c

  example₉ : (A → A) → A
  example₉ = ƛ !_! ⟶ (! a !)

  example₁₀ : (A → A → A) → A
  example₁₀ = ƛ !_!_ ⟶ (! a ! a)

  example₁₁ : (A → A → A) → A
  example₁₁ = ƛ _!_! ⟶ (a ! a !)

  example₁₂ : (A → A → A → A → A) → (A → A)
  example₁₂ = ƛ _!_!_!_ ⟶ (a ! a !_! a)

module Two where

  example₀ : (A → A) → A
  example₀ = _ ↦ a

  example₁ : A → A
  example₁ = !_! ↦ (!_!)

  example₂ : A → A
  example₂ = !_!_ ↦ (!_!_)

  example₃ : A → A
  example₃ = _!_! ↦ (_!_!)

  example₄ : A → A
  example₄ = _!_!_!_ ↦ (_!_!_!_)

  example₅ : (A → A) → (A → A)
  example₅ = !_! ↦ λ a → ! a !

  example₆ : (A → A → A) → (A → A → A)
  example₆ = !_!_ ↦ λ a b → ! a ! b

  example₇ : (A → A → A) → (A → A → A)
  example₇ = _!_! ↦ λ a b → a ! b !

  example₈ : (A → A → A → A → A) → (A → A → A → A → A)
  example₈ = _!_!_!_ ↦ λ a b c → a !_! b ! c

  example₉ : (A → A) → A
  example₉ = !_! ↦ (! a !)

  example₁₀ : (A → A → A) → A
  example₁₀ = !_!_ ↦ (! a ! a)

  example₁₁ : (A → A → A) → A
  example₁₁ = _!_! ↦ (a ! a !)

  example₁₂ : (A → A → A → A → A) → (A → A)
  example₁₂ = _!_!_!_ ↦ (a ! a !_! a)

module Three where

  example₀ : (A → A) → A
  example₀ = _ ↦ a •

  example₁ : A → A
  example₁ = !_! ↦ (!_!) •

  example₂ : A → A
  example₂ = !_!_ ↦ (!_!_) •

  example₃ : A → A
  example₃ = _!_! ↦ (_!_!) •

  example₄ : A → A
  example₄ = _!_!_!_ ↦ (_!_!_!_) •

  example₅ : (A → A) → (A → A)
  example₅ = !_! ↦ (λ a → ! a !) •

  example₆ : (A → A → A) → (A → A → A)
  example₆ = !_!_ ↦ (λ a b → ! a ! b) •

  example₇ : (A → A → A) → (A → A → A)
  example₇ = _!_! ↦ (λ a b → a ! b !) •

  example₈ : (A → A → A → A → A) → (A → A → A → A → A)
  example₈ = _!_!_!_ ↦ (λ a b c → a !_! b ! c) •

  example₉ : (A → A) → A
  example₉ = !_! ↦ (! a !) •

  example₁₀ : (A → A → A) → A
  example₁₀ = !_!_ ↦ (! a ! a) •

  example₁₁ : (A → A → A) → A
  example₁₁ = _!_! ↦ (a ! a !) •

  example₁₂ : (A → A → A → A → A) → (A → A)
  example₁₂ = _!_!_!_ ↦ (a ! a !_! a) •


-- Andreas, 2016-08-01, issue #2125, qualified names in pragmas

{-# OPTIONS --rewriting #-}

import Common.Equality as Eq

{-# BUILTIN REWRITE Eq._≡_ #-} -- qualified name, should be accepted

postulate
  A : Set
  a b : A

module M where
  open Eq
  postulate
    rule : a ≡ b

{-# REWRITE M.rule #-}  -- qualified name, should be accepted

-- ERROR WAS: in the name M.rule, the part M.rule is not valid
-- NOW: works


module Lawvere where

open import Library
open import Data.Sum
open import Categories
open import Categories.Sets
open import Categories.Initial
open import Categories.PushOuts
open import Categories.Products hiding (_×_)
open import Categories.CoProducts
open import Categories.Terminal

open import Functors
open import Functors.Fin

record Lawvere {a}{b} : Set (lsuc (a ⊔ b)) where
  constructor lawvere
  field T  : Cat {a}{b}
        L  : Fun (Nats Op) T
        L0 : Term T (Fun.OMap L zero)
        LP : ∀ m n → Prod T (Fun.OMap L m) (Fun.OMap L n)

-- it's not the identity, it switches some implicit in fid and fcomp I think
FunOp : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}} →
        Fun C D → Fun (C Op) (D Op)
FunOp (functor OMap HMap fid fcomp) = functor OMap HMap fid fcomp

LSet : Lawvere
LSet = lawvere
  (Sets Op)
  (FunOp FinF)
  (term (λ ()) (ext λ ()))
  λ m n → prod
    (Fin m ⊎ Fin n)
    inj₁
    inj₂
    [_,_]′
    refl
    refl
    λ p q → ext (λ{ (inj₁ a) -> fcong a p; (inj₂ b) -> fcong b q})

open import RMonads
open import RMonads.RKleisli
open import RMonads.RKleisli.Functors

lem : RMonad FinF → Lawvere {lzero}{lzero}
lem M = lawvere
  (Kl M Op)
  (FunOp (RKlL M) )
  (term (λ ()) (ext λ ()))
  λ m n → prod
    (m + n)
    (η ∘ extend)
    (η ∘ lift m)
    (case m)
    (ext λ i → trans (fcong (extend i) law2) (lem1 m _ _ i))
    (ext λ i → trans (fcong (lift m i) law2) (lem2 m _ _ i))
    λ {o} {f} {g} {h} p q → ext (lem3
      m
      f
      g
      h
      (trans (ext λ i → sym (fcong (extend i) law2)) p)
      (trans (ext λ i → sym (fcong (lift m i) law2)) q))
    where open RMonad M

lem-1 : Lawvere {lzero}{lzero} → RMonad FinF
lem-1 LT = rmonad
  (λ n → Cat.Hom (Lawvere.T LT) (Fun.OMap (Lawvere.L LT) 1) (Fun.OMap (Lawvere.L LT) n))
  {!!}
  {!!}
  {!!}
  {!!}
  {!!}

open import Categories.Products

record Model {a}{b}{c}{d} (Law : Lawvere {a}{b}) : Set (lsuc (a ⊔ b ⊔ c ⊔ d))
  where
  open Lawvere Law
  field C : Cat {c}{d}
        F : Fun T C
        F0 : Term C (Fun.OMap F (Fun.OMap L zero))
        FP : ∀ m n → Prod C (Fun.OMap F (Fun.OMap L m))
                            (Fun.OMap F (Fun.OMap L n))
open import RMonads.REM
open import RMonads.CatofRAdj.InitRAdj
open import RMonads.CatofRAdj.TermRAdjObj
open import RMonads.REM.Functors

model : (T : RMonad FinF) → Model (lem T)
model T = record {
  C  = EM T Op ;
  F  = FunOp (K' T (EMObj T));
  F0 = term (λ{alg} → ralgmorph (RAlg.astr alg {0} (λ ()))
                               (λ {n}{f} →
                                 sym $ RAlg.alaw2 alg {n}{zero}{f}{λ ()} ))
           (λ{alg}{f} → RAlgMorphEq T (ext (λ t → trans
             (trans (cong (λ f₁ → RAlg.astr alg f₁ t) (ext (λ ())))
                    (sym (fcong t (RAlgMorph.ahom f {0}{RMonad.η T}))))
             (cong (RAlgMorph.amor f) (fcong t (RMonad.law1 T))))));
  FP = λ m n → prod
    (Fun.OMap (REML FinF T) (m + n) )
    (Fun.HMap (REML FinF T) extend)
    (Fun.HMap (REML FinF T) (lift m))
    (λ{alg} f g → ralgmorph
      (RAlg.astr alg
                 (case m (RAlgMorph.amor f ∘ RMonad.η T)
                         (RAlgMorph.amor g ∘ RMonad.η T)))
      (sym (RAlg.alaw2 alg)))
    (λ {alg}{f}{g} → RAlgMorphEq T (trans
      (sym (RAlg.alaw2 alg))
      (trans (cong (RAlg.astr alg)
                   (ext λ i → trans (fcong (extend i) (sym (RAlg.alaw1 alg)))
                                    (lem1 m _ _ i)))
             (trans (sym (RAlgMorph.ahom f))
                    (ext λ i → cong (RAlgMorph.amor f)
                                    (fcong i (RMonad.law1 T)))))))
    (λ {alg}{f}{g} → RAlgMorphEq T (trans
      (sym (RAlg.alaw2 alg))
      (trans (cong (RAlg.astr alg)
                   (ext λ i → trans (fcong (lift m i) (sym (RAlg.alaw1 alg)))
                                    (lem2 m _ _ i)))
             (trans (sym (RAlgMorph.ahom g))
                    (ext λ i → cong (RAlgMorph.amor g)
                                    (fcong i (RMonad.law1 T)))))))
    λ{alg}{f}{g}{h} p q → RAlgMorphEq T (trans
      (trans (ext λ i → cong (RAlgMorph.amor h)
                             (sym (fcong i (RMonad.law1 T))))
             (RAlgMorph.ahom h))
      (cong (RAlg.astr alg) (ext (lem3
        m
        (RAlgMorph.amor f ∘ RMonad.η T)
        (RAlgMorph.amor g ∘ RMonad.η T)
        (RAlgMorph.amor h ∘ RMonad.η T)
        (ext λ i → trans
          (cong (RAlgMorph.amor h) (sym (fcong i (RMonad.law2 T))))
          (fcong (RMonad.η T i) (cong RAlgMorph.amor p)))
        (ext λ i → trans
          (cong (RAlgMorph.amor h) (sym (fcong i (RMonad.law2 T))))
          (fcong (RMonad.η T i) (cong RAlgMorph.amor q)))))))}


------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

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

module FOTC.Program.Mirror.PropertiesATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesATP using ( reverse-[x]≡[x] )
open import FOTC.Program.Mirror.Forest.PropertiesATP
open import FOTC.Program.Mirror.Forest.TotalityATP
open import FOTC.Program.Mirror.Mirror
open import FOTC.Program.Mirror.Tree.TotalityATP
open import FOTC.Program.Mirror.Type

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

mirror-involutive : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
helper            : ∀ {ts} → Forest ts →
                    reverse (map mirror (reverse (map mirror ts))) ≡ ts

mirror-involutive (tree d fnil) = prf
  where postulate prf : mirror · (mirror · node d []) ≡ node d []
        {-# ATP prove prf #-}

mirror-involutive (tree d (fcons {t} {ts} Tt Fts)) = prf
  where postulate prf : mirror · (mirror · node d (t ∷ ts)) ≡ node d (t ∷ ts)
        {-# ATP prove prf helper #-}

helper fnil = prf
  where postulate prf : reverse (map mirror (reverse (map mirror []))) ≡ []
        {-# ATP prove prf #-}

helper (fcons {t} {ts} Tt Fts) =
  prf (map-++ mirror
              mirror-Tree
              (reverse-Forest (map-Forest mirror mirror-Tree Fts))
              (mirror · t ∷ []))
      (mirror-involutive Tt)
      (helper Fts)
  where
  postulate
    -- We help the ATPs proving the first hypothesis.
    prf : (map mirror (reverse (map mirror ts) ++ (mirror · t ∷ [])) ≡
          map mirror
              (reverse (map mirror ts)) ++ (map mirror (mirror · t ∷ []))) →
          mirror · (mirror · t) ≡ t →
          reverse (map mirror (reverse (map mirror ts))) ≡ ts →
          reverse (map mirror (reverse (map mirror (t ∷ ts)))) ≡ t ∷ ts
  {-# ATP prove prf reverse-∷ mirror-Tree map-Forest reverse-++
                    reverse-Forest reverse-[x]≡[x] #-}


{-# OPTIONS --rewriting --prop #-}

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

postulate
  P : Prop
  p : P
  f : P -> P

  g : {A : Set} -> P -> A -> A
  eq : ∀{A} {x : A} -> g p x ≡ x

{-# REWRITE eq #-}

module _ {A : Set} {x : A} {y : P} where

  foo : g p x ≡ x
  foo = refl

  bar : g (f y) x ≡ x
  bar = refl


module Builtin.Coinduction where

open import Agda.Builtin.Coinduction public


module Bee2.Crypto.Defs where

open import Data.ByteString
open import Data.ByteVec
open import Agda.Builtin.Nat renaming (Nat to ℕ)

{-# FOREIGN GHC import qualified Bee2.Defs    #-}
postulate
  SizeT : Set
  SizeFromℕ : ℕ → SizeT
{-# COMPILE GHC SizeT = type (Bee2.Defs.Size) #-}
{-# COMPILE GHC SizeFromℕ =
    ( Prelude.fromIntegral ) #-}

Hash = ByteVec {Strict} 32

data SecurityLevel : Set where
  l128 l192 l256 : SecurityLevel


variable
  ℓ : _
  A : Set ℓ


------------------------------------------------------------------------------
-- Fair properties
------------------------------------------------------------------------------

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

module FOTC.Program.ABP.Fair.PropertiesATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the Fair
-- predicate is also a pre-fixed point of the functional FairF, i.e.
--
-- FairF Fair ≤ Fair (see FOTC.Program.ABP.Fair).

-- See Issue https://github.com/asr/apia/issues/81 .
Fair-inA : D → Set
Fair-inA os = ∃[ ft ] ∃[ os' ] F*T ft ∧ os ≡ ft ++ os' ∧ Fair os'
{-# ATP definition Fair-inA #-}

Fair-in : ∀ {os} → ∃[ ft ] ∃[ os' ] F*T ft ∧ os ≡ ft ++ os' ∧ Fair os' →
          Fair os
Fair-in h = Fair-coind Fair-inA h' h
  where
  postulate
    h' : ∀ {os} → Fair-inA os →
         ∃[ ft ] ∃[ os' ] F*T ft ∧ os ≡ ft ++ os' ∧ Fair-inA os'
  {-# ATP prove h' #-}

head-tail-Fair : ∀ {os} → Fair os → os ≡ T ∷ tail₁ os ∨ os ≡ F ∷ tail₁ os
head-tail-Fair {os} Fos with Fair-out Fos
... | (.(T ∷ []) , os' , f*tnil , h , Fos') = prf
  where
  postulate prf : os ≡ T ∷ tail₁ os ∨ os ≡ F ∷ tail₁ os
  {-# ATP prove prf #-}

... | (.(F ∷ ft) , os' , f*tcons {ft} FTft , h , Fos') = prf
  where
  postulate prf : os ≡ T ∷ tail₁ os ∨ os ≡ F ∷ tail₁ os
  {-# ATP prove prf #-}

tail-Fair : ∀ {os} → Fair os → Fair (tail₁ os)
tail-Fair {os} Fos with Fair-out Fos
... | .(T ∷ []) , os' , f*tnil , h , Fos' = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf #-}
... | .(F ∷ ft) , os' , f*tcons {ft} FTft , h , Fos' = prf
  where
  postulate prf : Fair (tail₁ os)
  {-# ATP prove prf Fair-in #-}