module Term (Gnd : Set)(U : Set)(El : U -> Set) where

open import Basics
open import Pr
open import Nom
import Kind
open module KindGUEl = Kind Gnd U El
import Loc
open module LocK = Loc Kind
import Cxt
open module CxtK = Cxt Kind

data Jud : Set where
  Term : Kind -> Jud
  Args : Kind -> Gnd -> Jud
  Head : Jud

data _[_]-_ : Loc -> Jud -> Kind -> Set where
  [_] : {C : Kind}{L : Loc}{Z : Gnd} ->
        L [ Args C Z ]- C  ->  L [ Term C ]- Ty Z
  fn : {C : Kind}{L : Loc}(A : U){K : El A -> Kind} ->
       ((x : El A) -> L [ Term C ]- K x) -> L [ Term C ]- Pi A K
  \\ : {C : Kind}{L : Loc}{S T : Kind} ->
       (L * S) [ Term C ]- T  ->  L [ Term C ]- (S |> T)
  _^_ : {C : Kind}{L : Loc}{Z : Gnd}{A : U}{K : El A -> Kind} ->
        (x : El A) -> L [ Args C Z ]- K x -> L [ Args C Z ]- Pi A K
  _&_ : {C : Kind}{L : Loc}{S T : Kind}{Z : Gnd} ->
        L [ Term C ]- S  ->  L [ Args C Z ]- T  ->  L [ Args C Z ]- (S |> T)
  nil : {C : Kind}{L : Loc}{Z : Gnd} -> L [ Args C Z ]- Ty Z
  _$_ : {C : Kind}{L : Loc}{T : Kind}{Z : Gnd} ->
        L [ Head ]- T  ->  L [ Args C Z ]- T  ->  L [ Term C ]- Ty Z
  ` : Nom -> {S : Kind}{L : Loc} -> L [ Head ]- S
  # : {L : Loc}{S : Kind} -> L ! S -> L [ Head ]- S

infixr 90 _^_ _&_

infix 40 _[_]-_

Good : Cxt -> {L : Loc}{j : Jud}{T : Kind} -> L [ j ]- T -> Pr
Good G [ c ]      = Good G c
Good G (fn A f)   = all (El A) \a -> Good G (f a)
Good G (\\ b)     = Good G b
Good G (a ^ ss)   = Good G ss
Good G (s & ss)   = Good G s /\ Good G ss
Good G nil        = tt
Good G (x $ ss)   = Good G x /\ Good G ss
Good G (` x {S})  = GooN G S x
Good G (# v)      = tt

data _[_/_]-_ (G : Cxt)(L : Loc)(j : Jud)(T : Kind) : Set where
  _-!_ : (t : L [ j ]- T) -> [| Good G t |] -> G [ L / j ]- T

gtm : {G : Cxt}{L : Loc}{j : Jud}{T : Kind} -> G [ L / j ]- T -> L [ j ]- T
gtm (t -! _) = t

good : {G : Cxt}{L : Loc}{j : Jud}{T : Kind}
       (t : G [ L / j ]- T) -> [| Good G (gtm t) |]
good (t -! g) = g

_[!_!]-_ : Cxt -> Kind -> Kind -> Set
G [! C !]- T = G [ EL / Term C ]- T

G[_] : {G : Cxt}{C : Kind}{L : Loc}{Z : Gnd} ->
       G [ L / Args C Z ]- C ->
     ----------------------------
       G [ L / Term C ]- Ty Z

G[ c -! cg ] = [ c ] -! cg

Gfn : {G : Cxt}{C : Kind}{L : Loc}(A : U){K : El A -> Kind} ->
      ((x : El A) -> G [ L / Term C ]- K x) ->
    -------------------------------------------
      G [ L / Term C ]- Pi A K

Gfn A f = fn A (gtm o f) -! (good o f)

G\\ : {G : Cxt}{C : Kind}{L : Loc}{S T : Kind} ->
      G [ L * S / Term C ]- T ->
    ------------------------------
      G [ L / Term C ]- (S |> T)

G\\ (b -! bg) = \\ b -! bg

_G^_ : {G : Cxt}{C : Kind}{L : Loc}{Z : Gnd}{A : U}{K : El A -> Kind} ->
       (x : El A) ->
       G [ L / Args C Z ]- K x ->
     ------------------------------
       G [ L / Args C Z ]- Pi A K

a G^ (s -! sg) = (a ^ s) -! sg

_G&_ : {G : Cxt}{C : Kind}{L : Loc}{S T : Kind}{Z : Gnd} ->
        G [ L / Term C ]- S  ->
        G [ L / Args C Z ]- T  ->
      ----------------------------------
        G [ L / Args C Z ]- (S |> T)

(r -! rg) G& (s -! sg) = (r & s) -! (rg , sg)

Gnil : {G : Cxt}{C : Kind}{L : Loc}{Z : Gnd} ->
      -----------------------------
        G [ L / Args C Z ]- Ty Z

Gnil = nil -! _

_G$_ : {G : Cxt}{C : Kind}{L : Loc}{T : Kind}{Z : Gnd} ->
        G [ L / Head ]- T  ->
        G [ L / Args C Z ]- T  ->
      -----------------------------
        G [ L / Term C ]- Ty Z

(h -! hg) G$ (s -! sg) = (h $ s) -! (hg , sg)

G` :   {G : Cxt}{S : Kind}{L : Loc} -> Nom :- GooN G S ->
     ------------------------------------------------------
        G [ L / Head ]- S

G` [ x / xg ] = ` x -! xg

G# : {G : Cxt}{L : Loc}{S : Kind} -> L ! S ->
     --------------------------
       G [ L / Head ]- S

G# v = # v -! _

infixr 90 _G^_ _G&_


-- | In this module we show that the substream relation is transitive.

open import Streams
open import Relation.Binary.PropositionalEquality as P
open import Data.Product
open import Function.Equivalence

mutual
  record F : Set where
    coinductive
    field out : Fμ

  data Fμ : Set where
    pres : F → Fμ
    drop : Fμ → Fμ

open F public

μfilter : ∀{A} → Fμ → Stream A → Stream A
filter : ∀{A} → F → Stream A → Stream A

filter x = μfilter (out x)

hd (μfilter (pres x) s) = hd s
tl (μfilter (pres x) s) = filter x (tl s)
μfilter (drop u) s = μfilter u (tl s)

comp : F → F → F
μcomp : Fμ → Fμ → Fμ

out (comp x y) = μcomp (out x) (out y)

μcomp (pres x) (pres y) = pres (comp x y)
μcomp (pres x) (drop v) = drop (μcomp (out x) v)
μcomp (drop u) v        = drop (μcomp u v)

_•_ : F → F → F
y • x = comp x y

_•μ_ : Fμ → Fμ → Fμ
v •μ u = μcomp u v

filter-comp : ∀{A} → ∀ x y (s : Stream A) →
              filter (y • x) s ~ filter y (filter x s)
μfilter-comp : ∀{A} → ∀ u v (s : Stream A) →
               μfilter (v •μ u) s ~ μfilter v (μfilter u s)

filter-comp x y s = μfilter-comp (out x) (out y) s

hd~(μfilter-comp (pres x) (pres y) s) = refl
tl~(μfilter-comp (pres x) (pres y) s) = filter-comp x y (tl s)
μfilter-comp (pres x) (drop v) s = μfilter-comp (out x) v (tl s)
-- The following cases are just the same, they need to be there for Agda to
-- reduce the definition of μcomp
μfilter-comp (drop u) (pres x) s = μfilter-comp u (pres x) (tl s)
μfilter-comp (drop u) (drop v) s = μfilter-comp u (drop v) (tl s)

_≤[_]_ : ∀{A} → Stream A → F → Stream A → Set
s ≤[ x ] t = s ~ filter x t

_≤μ[_]_ : ∀{A} → Stream A → Fμ → Stream A → Set
s ≤μ[ x ] t = s ~ μfilter x t

mutual
  record _≤_ {A : Set} (s t : Stream A) : Set where
    coinductive
    field out≤ : s ≤μ t

  data _≤μ_ {A : Set} (s t : Stream A) : Set where
    ma : hd s ≡ hd t → (tl s) ≤ (tl t) → s ≤μ t
    sk : s ≤μ (tl t) → s ≤μ t

open _≤_ public

witness : ∀{A} {s t : Stream A} → s ≤ t → F
xwitness : ∀{A} {s t : Stream A} → s ≤μ t → Fμ

out (witness p) = xwitness (out≤ p)

xwitness (ma _ t≤) = pres (witness t≤)
xwitness (sk u)    = drop (xwitness u)

impl₁ : ∀{A} {s t : Stream A} → (p : s ≤ t) → s ≤[ witness p ] t
ximpl₁ : ∀{A} {s t : Stream A} → (p : s ≤μ t) → s ≤μ[ xwitness p ] t

impl₁ {A} {s} {t} p = ximpl₁ (out≤ p)

hd~ (ximpl₁ (ma h≡ t≤)) = h≡
tl~ (ximpl₁ (ma h≡ t≤)) = impl₁ t≤
ximpl₁ (sk q) = ximpl₁ q

impl₂ : ∀{A} {s t : Stream A} (x : F) → s ≤[ x ] t → s ≤ t
ximpl₂ : ∀{A} {s t : Stream A} (u : Fμ) → s ≤μ[ u ] t → s ≤μ t

out≤ (impl₂ x p) = ximpl₂ (out x) p

ximpl₂ (pres x) p = ma (hd~ p) (impl₂ x (tl~ p))
ximpl₂ (drop u) p = sk (ximpl₂ u p)

≤⇔filter-≤ : ∀{A} (s t : Stream A) →
             s ≤ t ⇔ ∃ λ p → s ≤[ p ] t
≤⇔filter-≤ s t = equivalence (λ x → witness x , impl₁ x)
                             (λ {(x , p) → impl₂ x p})

filter-resp~ : ∀{A} {s t : Stream A} (x : F) →
               s ~ t → filter x s ~ filter x t
μfilter-resp~ : ∀{A} {s t : Stream A} (u : Fμ) →
                s ~ t → μfilter u s ~ μfilter u t

filter-resp~ x p = μfilter-resp~ (out x) p
hd~ (μfilter-resp~ (pres x) p) = hd~ p
tl~ (μfilter-resp~ (pres x) p) = filter-resp~ x (tl~ p)
μfilter-resp~ (drop u) p = μfilter-resp~ u (tl~ p)

{-
We prove transitivity of the witnessed substream relation by
r ~ filter x s
  ~ filter x (filter y t)
  ~ filter (comp x y) t

-}
≤-filter-trans : ∀{A} {r s t : Stream A} {x y} →
                 r ≤[ x ] s → s ≤[ y ] t → r ≤[ x • y ] t
≤-filter-trans {x = x} {y} p q =
  ~trans p (
    ~trans (filter-resp~ x q)
           (~sym (filter-comp y x _)))

≤-trans : ∀{A} {r s t : Stream A} →
          r ≤ s → s ≤ t → r ≤ t
≤-trans p q = impl₂ (witness p • witness q)
                    (≤-filter-trans {x = witness p}
                                    {y = witness q}
                                    (impl₁ p)
                                    (impl₁ q)
                    )

-- lem : ∀{A} {s t : Stream A} → hd s ≡ hd t → tl s ≤ tl t → t ≤μ tl s → tl t ≤μ tl s
-- lem s0≡t0 t'≤s' (ma t0≡s1 t'≤s'') with out≤ t'≤s'
-- lem s0≡t0 t'≤s' (ma t0≡s1 t'≤s'') | ma s1≡t1 s''≤t'' = ma (P.sym s1≡t1) {!!}
-- lem s0≡t0 t'≤s' (ma t0≡s1 t'≤s'') | sk p = {!!}
-- lem {s = s} s0≡t0 s'≤t' (sk p) = {!!}

-- ≤-antisym : ∀{A} {s t : Stream A} →
--             s ≤ t → t ≤ s → s ~ t
-- ≤μ-antisym : ∀{A} {s t : Stream A} →
--             s ≤μ t → t ≤μ s → s ~ t
-- ≤-antisym p q = ≤μ-antisym (out≤ p) (out≤ q)
-- hd~ (≤μ-antisym (ma hs≡ht ts≤tt) _) = hs≡ht
-- tl~ (≤μ-antisym (ma hs≡ht ts≤tt) (ma ht≡hs tt≤ts)) = ≤-antisym ts≤tt tt≤ts
-- tl~ (≤μ-antisym (ma hs≡ht ts≤tt) (sk q)) = ≤μ-antisym (out≤ ts≤tt) {!!}
-- ≤μ-antisym (sk p) q = {!!}

{-
------------------
--- Try to convince Agda that x = zip(ev(x), odd(x)) is well-defined.

even : ∀{A} → Stream A → Stream A
hd (even s) = hd s
tl (even s) = even (tl (tl s))

odd : ∀{A} → Stream A → Stream A
odd s = even (tl s)

zips : ∀{A} → Stream A → Stream A → Stream A
hd (zips s t) = hd s
tl (zips s t) = zips t (tl s)

open import Data.Nat

foo : Stream ℕ
hd foo = 0
tl foo = zips (even foo) (odd foo)

-- H : Stream ℕ → Stream ℕ → Stream ℕ
-- f : ℕ → Stream ℕ → Stream ℕ → Stream ℕ

-- H s t = f (hd t) s t

-- hd (f zero s t) = hd s
-- tl (f zero s t) = H s (tl t)
-- f (suc n) s t = f n (tl s) t
-}


data ⊤ : Set where tt : ⊤

postulate
  A : Set
  B : A → Set
  a : A
  b : B a
  G : ∀ x → B x → Set

postulate tt' : ⊤

poo : G a b
poo with tt | a
... | _ | _ = {!!}


{-# OPTIONS --without-K --safe #-}
-- verbatim dual of Categories.Category.Construction.Properties.Kleisli
module Categories.Category.Construction.Properties.CoKleisli where

open import Level
import Relation.Binary.PropositionalEquality as ≡

open import Categories.Adjoint
open import Categories.Adjoint.Properties
open import Categories.Category
open import Categories.Functor using (Functor; _∘F_)
open import Categories.Functor.Equivalence
open import Categories.Comonad
import Categories.Morphism.Reasoning as MR

open import Categories.Adjoint.Construction.CoKleisli
open import Categories.Category.Construction.CoKleisli

private
  variable
    o ℓ e : Level
    𝒞 𝒟 : Category o ℓ e

module _ {F : Functor 𝒞 𝒟} {G : Functor 𝒟 𝒞} (F⊣G : Adjoint F G) where
  private
    T : Comonad 𝒟
    T = adjoint⇒comonad F⊣G

    𝒟ₜ : Category _ _ _
    𝒟ₜ = CoKleisli T

    module 𝒞 = Category 𝒞
    module 𝒟 = Category 𝒟
    module 𝒟ₜ = Category 𝒟ₜ

    module T = Comonad T
    module F = Functor F
    module G = Functor G

    open Adjoint F⊣G

  -- Maclane's Comparison Functor
  ComparisonF : Functor 𝒟ₜ 𝒞
  ComparisonF = record
   { F₀ = λ X → G.F₀ X
   ; F₁ = λ {A} {B} f → 𝒞 [ (G.F₁ f) ∘ unit.η (G.F₀ A) ]
   ; identity = λ {A} → zag
   ; homomorphism = λ {X} {Y} {Z} {f} {g} → begin
      G.F₁ (g 𝒟.∘ F.F₁ (G.F₁ f) 𝒟.∘ F.F₁ (unit.η (G.F₀ X))) 𝒞.∘ unit.η (G.F₀ X)             ≈⟨ pushˡ G.homomorphism ⟩
      G.F₁ g 𝒞.∘ G.F₁ ((F.F₁ (G.F₁ f)) 𝒟.∘ F.F₁ (unit.η (G.F₀ X))) 𝒞.∘ unit.η (G.F₀ X)      ≈⟨ (refl⟩∘⟨ pushˡ G.homomorphism) ⟩
      G.F₁ g 𝒞.∘ G.F₁ (F.F₁ (G.F₁ f)) 𝒞.∘ G.F₁ (F.F₁ (unit.η (G.F₀ X))) 𝒞.∘ unit.η (G.F₀ X) ≈⟨ (refl⟩∘⟨ (refl⟩∘⟨ sym (unit.commute (unit.η (G.F₀ X))))) ⟩
      G.F₁ g 𝒞.∘ G.F₁ (F.F₁ (G.F₁ f)) 𝒞.∘ unit.η (G.F₀ (F.F₀ (G.F₀ X))) 𝒞.∘ unit.η (G.F₀ X) ≈⟨ (refl⟩∘⟨ pullˡ (sym (unit.commute (G.F₁ f)))) ⟩
      G.F₁ g 𝒞.∘ (unit.η (G.F₀ Y) 𝒞.∘ G.F₁ f) 𝒞.∘ unit.η (G.F₀ X)                           ≈⟨ MR.assoc²'' 𝒞 ⟩
      (G.F₁ g 𝒞.∘ unit.η (G.F₀ Y)) 𝒞.∘ G.F₁ f 𝒞.∘ unit.η (G.F₀ X)                           ∎
   ; F-resp-≈ = λ eq → 𝒞.∘-resp-≈ (G.F-resp-≈ eq) (Category.Equiv.refl 𝒞)
   }
   where
    open 𝒞.HomReasoning
    open 𝒞.Equiv
    open MR 𝒞

  private
    L = ComparisonF
    module L = Functor L
    module Gₜ = Functor (Forgetful T)
    module Fₜ = Functor (Cofree T)

  F∘L≡Forgetful : (F ∘F L) ≡F Forgetful T
  F∘L≡Forgetful = record
   { eq₀ = λ X → ≡.refl
   ; eq₁ = eq-1
   }
   where
   open 𝒟.HomReasoning
   open MR 𝒟
   eq-1 : {X Y : 𝒟.Obj} (f : F.F₀ (G.F₀ X) 𝒟.⇒ Y) → 𝒟.id 𝒟.∘ F.F₁ (G.F₁ f 𝒞.∘ unit.η (G.F₀ X)) 𝒟.≈ (F.F₁ (G.F₁ f) 𝒟.∘ F.F₁ (unit.η (G.F₀ X))) 𝒟.∘ 𝒟.id
   eq-1 {X} {Y} f = begin
    𝒟.id 𝒟.∘ F.F₁ (G.F₁ f 𝒞.∘ unit.η (G.F₀ X))          ≈⟨ id-comm-sym ⟩
    F.F₁ (G.F₁ f 𝒞.∘ unit.η (G.F₀ X)) 𝒟.∘ 𝒟.id          ≈⟨ (F.homomorphism ⟩∘⟨refl) ⟩
    (F.F₁ (G.F₁ f) 𝒟.∘ F.F₁ (unit.η (G.F₀ X))) 𝒟.∘ 𝒟.id ∎

  L∘Cofree≡G : (L ∘F Cofree T) ≡F G
  L∘Cofree≡G = record
   { eq₀ = λ X → ≡.refl
   ; eq₁ = eq-1
   }
   where
   open 𝒞.HomReasoning
   open MR 𝒞
   eq-1 : {X Y : 𝒟.Obj} (f : X 𝒟.⇒ Y) → 𝒞.id 𝒞.∘ G.F₁ (f 𝒟.∘ counit.η X) 𝒞.∘ unit.η (G.F₀ X) 𝒞.≈ G.F₁ f 𝒞.∘ 𝒞.id
   eq-1 {X} {Y} f = begin
    𝒞.id 𝒞.∘ G.F₁ (f 𝒟.∘ counit.η X) 𝒞.∘ unit.η (G.F₀ X)         ≈⟨ id-comm-sym ⟩
    (G.F₁ (f 𝒟.∘ counit.η X) 𝒞.∘ unit.η (G.F₀ X)) 𝒞.∘ 𝒞.id       ≈⟨ (pushˡ G.homomorphism ⟩∘⟨refl) ⟩
    (G.F₁ f 𝒞.∘ G.F₁ (counit.η X) 𝒞.∘ unit.η (G.F₀ X)) 𝒞.∘ 𝒞.id  ≈⟨ (elimʳ zag ⟩∘⟨refl) ⟩
    G.F₁ f 𝒞.∘ 𝒞.id                                              ∎


{-# OPTIONS --without-K #-}
open import Function
open import Data.Zero
open import Relation.Binary.PropositionalEquality.NP
open import Explore.Zero
import Explore.Universe.Type
import Explore.Universe
open import Function.Extensionality
open import Type.Identities
open import HoTT
open Equivalences

module Explore.Universe.Base
  (open Explore.Universe.Type {𝟘})
  (u : U) where

open Explore.Universe 𝟘

open FromKit 𝟘ⁱ (λ {{ua}}{{_}} → 𝟘ˢ-ok {{ua}}) 𝟘ˡ 𝟘ᶠ
             (λ {{ua}} → Σᵉ𝟘-ok {{ua}})
             Πᵉ𝟘-ok (λ {ℓ₀ ℓ₁} ℓᵣ → ⟦𝟘ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} {_≡_})
             (const 𝟙ᵁ) (λ {{ua}} {{fext}} v → equiv (λ _ ()) _ (λ f → λ= (λ())) (λ _ → refl))
             u public


module Data.Word64.Exts where

open import Agda.Builtin.Nat
open import Agda.Builtin.Word
open import Data.Nat
open import Data.Word

addWord : Word64 → Word64 → Word64
addWord a b = primWord64FromNat (primWord64ToNat a + primWord64ToNat b)

subWord : Word64 → Word64 → Word64
subWord a b = primWord64FromNat (primWord64ToNat a - primWord64ToNat b)


module lift-tests where

open import lib
open import cedille-types
open import convervsion
open import ctxt
open import lift
open import syntax-util
open import to-string

t0 = Lft posinfo-gen "X" (Parens posinfo-gen (mlam "x" (mlam "y" (mvar "y"))) posinfo-gen)
       (LiftArrow (LiftStar posinfo-gen) (LiftArrow (LiftStar posinfo-gen) (LiftStar posinfo-gen)))

t = TpApp (TpApp t0 (mall "X" (Tkk star) (TpArrow (mtpvar "X") (mtpvar "X")))) (mtpvar "False")

s = type-to-string t

s1 = type-to-string (hnf new-ctxt tt t)


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

module Data.Fin.Base where

open import Data.Maybe.Base
open import Data.Nat.Base using (ℕ; suc; zero)
open import Level
open import Data.Empty

Fin : ℕ → Type
Fin zero    = ⊥
Fin (suc n) = Maybe (Fin n)

pattern f0 = nothing
pattern fs n = just n


------------------------------------------------------------------------------
-- Axiomatic PA propositional equality
------------------------------------------------------------------------------

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

module PA.Axiomatic.Mendelson.Relation.Binary.PropositionalEqualityATP where

open import PA.Axiomatic.Mendelson.Base

------------------------------------------------------------------------------
-- Identity properties

postulate ≈-refl : ∀ {n} → n ≈ n
{-# ATP prove ≈-refl #-}

postulate ≈-sym : ∀ {m n} → m ≈ n → n ≈ m
{-# ATP prove ≈-sym #-}

postulate ≈-trans : ∀ {m n o} → m ≈ n → n ≈ o → m ≈ o
{-# ATP prove ≈-trans #-}


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

open import Cubical.Core.Everything
open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Data.Sum
open import Cubical.Data.Unit

module Coequalizers where

record Graph {ℓ ℓ' : Level} (E : Type ℓ) (V : Type ℓ') : Type (ℓ-max ℓ ℓ') where
  field
    π₀ : E → V
    π₁ : E → V

open Graph ⦃...⦄

data Coeq {ℓ ℓ' : Level} {V : Type ℓ} {E : Type ℓ'} (ev : Graph E V) :
          Type (ℓ-max ℓ ℓ')  where
  c[_] : V → (Coeq ev)
  quot : (e : E) → c[ (Graph.π₀ ev e) ] ≡ c[ (Graph.π₁ ev e) ]

_/_ : {ℓ ℓ' : Level} (V : Type ℓ) (E : Type ℓ') ⦃ ev : Graph E V ⦄ →
         Type (ℓ-max ℓ ℓ')
_/_ V E ⦃ ev ⦄ = Coeq ev

infix 25 _/_

module CoprodCoeq {ℓ ℓ' ℓ'' : Level} (E₀ : Type ℓ) (E₁ : Type ℓ') (V : Type ℓ'')
  ⦃ ev : Graph (E₀ ⊎ E₁) V ⦄ where
  instance
    evE₀ : Graph E₀ V
    evE₀ = record { π₀ = π₀ ∘ inl ; π₁ = π₁ ∘ inl }

    ev-snd : Graph E₁ (V / E₀)
    ev-snd = record { π₀ = c[_] ∘ π₀ ∘ inr ; π₁ = c[_] ∘ π₁ ∘ inr }

  coeq-coprod-equiv : V / (E₀ ⊎ E₁) ≃ (V / E₀) / E₁
  coeq-coprod-equiv = isoToEquiv (iso f g f-g g-f)
    where
      f : V / (E₀ ⊎ E₁) → (V / E₀) / E₁
      f c[ x ] = c[ c[ x ] ]
      f (quot (inl e) i) = c[ quot e i ]
      f (quot (inr e) i) = quot e i

      g : (V / E₀) / E₁ →  V / (E₀ ⊎ E₁)
      g c[ c[ x ] ] = c[ x ]
      g c[ quot e i ] = quot (inl e) i
      g (quot e i) = quot (inr e) i

      f-g : (z : (V / E₀) / E₁) → (f (g z) ≡ z)
      f-g c[ c[ x ] ] = refl
      f-g c[ quot e i ] = refl
      f-g (quot e i) = refl

      g-f : (z : V / (E₀ ⊎ E₁)) → (g (f z) ≡ z)
      g-f c[ x ] = refl
      g-f (quot (inl e) i) = refl
      g-f (quot (inr e) i) = refl

module TrivialExtension {ℓ ℓ' : Level} (V : Type ℓ) (v : V) where
  instance
    evt-l : Graph Unit (V ⊎ Unit)
    evt-l = record { π₀ = λ x → inl v ; π₁ = inr }

    evt-r : Graph Unit (Unit ⊎ V)
    evt-r = record { π₀ = inl ; π₁ = λ _ → inr v }

  te-equiv-l : V ≃ (V ⊎ Unit) / Unit
  te-equiv-l = isoToEquiv (iso (c[_] ∘ inl) g f-g (λ _ → refl))
    where
      g : (V ⊎ Unit) / Unit → V
      g c[ inl x ] = x
      g c[ inr x ] = v
      g (quot e i) = v

      f-g : (z : (V ⊎ Unit) / Unit) → c[ inl (g z) ] ≡ z
      f-g c[ inl x ] = refl
      f-g c[ inr x ] = quot x
      f-g (quot e i) j = quot e (i ∧ j)

  te-equiv-r : V ≃ (Unit ⊎ V) / Unit
  te-equiv-r = isoToEquiv (iso (c[_] ∘ inr) g f-g λ _ → refl)
    where
      g : (Unit ⊎ V) / Unit → V
      g c[ inl x ] = v
      g c[ inr x ] = x
      g (quot e i) = v

      f-g : (z : (Unit ⊎ V) / Unit) → c[ inr (g z) ] ≡ z
      f-g c[ inl x ] i = quot x (~ i)
      f-g c[ inr x ] = refl
      f-g (quot e i) j = quot e (i ∨ ~ j)


-- Andreas, 2018-06-15, issue #1086
-- Reported by Andrea
-- Fixed by Jesper in https://github.com/agda/agda/commit/242684bca62fabe43e125aefae7526be4b26a135

open import Common.Bool
open import Common.Equality

and : (a b : Bool) → Bool
and true  b = b
and false b = false

test : ∀ a b → and a b ≡ true → a ≡ true
test true true refl = refl

-- Should succeed.


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

module Data.List.Kleene where

open import Data.List.Kleene.Base public


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

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function using (_∘_; id)
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Logic using (_≡ₚ_)
open import Cubical.Functions.Embedding
open import Cubical.Data.Nat
open import Cubical.Data.NatPlusOne

open import Cubical.Algebra
open import Cubical.Algebra.Properties
open import Cubical.Algebra.Semigroup.Morphism
open import Cubical.Algebra.Magma.Properties using (isPropIsMagma)

open import Cubical.Relation.Binary
open import Cubical.Relation.Binary.Reasoning.Equality
open import Cubical.HITs.PropositionalTruncation

open import Cubical.Algebra.Semigroup.MorphismProperties public
  using (SemigroupPath; uaSemigroup; carac-uaSemigroup; Semigroup≡; caracSemigroup≡)

private
  variable
    ℓ ℓ′ : Level

isPropIsSemigroup : ∀ {S : Type ℓ} {_•_} → isProp (IsSemigroup S _•_)
isPropIsSemigroup {_} {_} {_•_} (issemigroup aMagma aAssoc) (issemigroup bMagma bAssoc) =
  cong₂ issemigroup (isPropIsMagma aMagma bMagma) (isPropAssociative (IsMagma.is-set aMagma) _•_ aAssoc bAssoc)

module SemigroupLemmas (S : Semigroup ℓ) where
  open Semigroup S

  ^-suc : ∀ x n → x ^ suc₊₁ n ≡ x ^ n • x
  ^-suc x one    = refl
  ^-suc x (2+ n) =
    x ^ suc₊₁ (2+ n)     ≡⟨⟩
    x ^ 1+ suc (suc n)   ≡⟨⟩
    x • (x • x ^ 1+ n)   ≡⟨⟩
    x • x ^ suc₊₁ (1+ n) ≡⟨ cong (x •_) (^-suc x (1+ n)) ⟩
    x • (x ^ 1+ n • x)   ≡˘⟨ assoc x (x ^ 1+ n) x ⟩
    x • x ^ 1+ n • x     ≡⟨⟩
    x ^ 2+ n • x         ∎

  ^-plus : ∀ x → Homomorphic₂ (x ^_) _+₊₁_ _•_
  ^-plus _ one _ = refl
  ^-plus x (2+ m) n =
    x ^ (1+ (suc m) +₊₁ n) ≡⟨⟩
    x • (x ^ (1+ m +₊₁ n)) ≡⟨ cong (x •_) (^-plus x (1+ m) n) ⟩
    x • (x ^ 1+ m • x ^ n) ≡˘⟨ assoc x (x ^ 1+ m) (x ^ n) ⟩
    x • x ^ 1+ m • x ^ n   ≡⟨⟩
    x ^ 2+ m • x ^ n       ∎

module Kernel {S : Semigroup ℓ} {T : Semigroup ℓ′} (hom : SemigroupHom S T) where
  private
    module S = Semigroup S
    module T = Semigroup T
  open SemigroupHom hom renaming (fun to f)

  Kernel′ : RawRel ⟨ S ⟩ ℓ′
  Kernel′ x y = f x ≡ f y

  isPropKernel : isPropValued Kernel′
  isPropKernel x y = T.is-set (f x) (f y)

  Kernel : Rel ⟨ S ⟩ ℓ′
  Kernel = fromRaw Kernel′ isPropKernel

  ker-reflexive : Reflexive Kernel
  ker-reflexive = refl

  ker-fromEq : FromEq Kernel
  ker-fromEq = rec (isPropKernel _ _) (cong f)

  ker-symmetric : Symmetric Kernel
  ker-symmetric = sym

  ker-transitive : Transitive Kernel
  ker-transitive = _∙_

  ker-isPreorder : IsPreorder Kernel
  ker-isPreorder = record
    { reflexive  = ker-reflexive
    ; transitive = ker-transitive
    }

  ker-isPartialEquivalence : IsPartialEquivalence Kernel
  ker-isPartialEquivalence = record
    { symmetric  = ker-symmetric
    ; transitive = ker-transitive
    }

  ker-isEquivalence : IsEquivalence Kernel
  ker-isEquivalence = record
    { isPartialEquivalence = ker-isPartialEquivalence
    ; reflexive            = ker-reflexive
    }

  ker⇒id→emb : Kernel ⇒ _≡ₚ_ → isEmbedding f
  ker⇒id→emb ker⇒id = injEmbedding S.is-set T.is-set (λ p → rec (S.is-set _ _) id (ker⇒id p))

  emb→ker⇒id : isEmbedding f → Kernel ⇒ _≡ₚ_
  emb→ker⇒id isemb {x} {y} = ∣_∣ ∘ invIsEq (isemb x y)


------------------------------------------------------------------------
-- A proof of univalence for an arbitrary "equality with J"
------------------------------------------------------------------------

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

import Equality.Path as P

module Equality.Path.Isomorphisms.Univalence
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

import Equality.Path.Univalence as PU
open import Prelude

open import Equivalence equality-with-J
open import Univalence-axiom equality-with-J
open import Equality.Path.Isomorphisms eq

private
  variable
    ℓ : Level

-- Univalence.

univ : Univalence ℓ
univ = _≃_.from Univalence≃Univalence PU.univ

-- A variant of univ that does not compute at compile-time.

abstract

  abstract-univ : Univalence ℓ
  abstract-univ = univ

-- Propositional extensionality.

prop-ext : Propositional-extensionality ℓ
prop-ext =
  _≃_.from
    (Propositional-extensionality-is-univalence-for-propositions ext)
    (λ _ _ → univ)


{-# OPTIONS --without-K #-}
module pointed where

open import pointed.core public
open import pointed.equality public


module Issue546 where

data I : Set where
  i : I

data ⊤ : Set where
  tt : ⊤

abstract
  P : I → Set
  P i = ⊤

Q : P i → Set
Q _ = ⊤

q : Q tt
q = tt

-- Q tt should be rejected.

-- This bug was introduced in Agda 2.3.0.


module NF.Sum where

open import NF
open import Data.Sum
open import Relation.Binary.PropositionalEquality

instance
  nfInj₁ : {A B : Set}{a : A}{{nfa : NF a}} -> NF {A ⊎ B} (inj₁ a)
  Sing.unpack (NF.!! (nfInj₁ {a = a})) = inj₁ (nf a)
  Sing.eq (NF.!! (nfInj₁ {{nfa}})) rewrite nf≡ {{nfa}} = refl

  {-# INLINE nfInj₁ #-}

  nfInj₂ : {A B : Set}{b : B}{{nfb : NF b}} -> NF {A ⊎ B} (inj₂ b)
  Sing.unpack (NF.!! (nfInj₂ {b = b})) = inj₂ (nf b)
  Sing.eq (NF.!! (nfInj₂ {{nfb}})) rewrite nf≡ {{nfb}} = refl

  {-# INLINE nfInj₂ #-}


{-# OPTIONS --cubical-compatible #-}
postulate
  A : Set
  B : A → Set

@0 T : Set
T = (@0 x : A) → B x

_ : Set₁
_ = (@0 A : Set) → @0 A → (@0 x : A) → Set

data D : Set₁ where
  @0 c : (@0 A : Set) → A → (x : A) → D


------------------------------------------------------------------------
-- The Agda standard library
--
-- A categorical view of Covec
------------------------------------------------------------------------

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

module Codata.Covec.Categorical where

open import Codata.Conat
open import Codata.Covec

open import Category.Functor
open import Category.Applicative

functor : ∀ {ℓ i n} → RawFunctor {ℓ} (λ A → Covec A n i)
functor = record { _<$>_ = map }

applicative : ∀ {ℓ i n} → RawApplicative {ℓ} (λ A → Covec A n i)
applicative = record
  { pure = replicate _
  ; _⊛_  = ap
  }


module tree-io-example where

open import io
open import list
open import maybe
open import string
open import tree
open import unit
open import nat-to-string

errmsg = "Run with a single (small) number as the command-line argument.\n"

processArgs : 𝕃 string → IO ⊤
processArgs (s :: []) with string-to-ℕ s
... | nothing = putStr errmsg
... | just n = putStr (𝕋-to-string ℕ-to-string (perfect-binary-tree n n)) >> putStr "\n"
processArgs _ = putStr errmsg

main : IO ⊤
main = getArgs >>= processArgs


{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae

module Decidable.Sets {a : _} (A : Set a) where

DecidableSet : Set a
DecidableSet = (a b : A) → ((a ≡ b) || ((a ≡ b) → False))


{-# OPTIONS --without-K #-}
module hott.level.closure.extra where

open import level
open import decidable
open import sum
open import level using (lsuc; ↑; lift)
open import equality.core
open import equality.calculus
open import function.core using (_∘_; const)
open import function.extensionality
open import function.isomorphism
open import sets.bool
open import sets.unit
open import sets.nat.core
-- open import sets.nat.ordering.leq.core
open import hott.level.core
open import hott.level.sets
open import hott.level.closure.core
open import hott.equivalence.core
  using (weak-equiv; _≈_)
open import hott.univalence
open import sets.empty

abstract
  -- Π preserves h-levels
  Π-level : ∀ {i j n} {X : Set i}{Y : X → Set j}
           → ((x : X) → h n (Y x))
           → h n ((x : X) → Y x)
  Π-level {n = 0} c = Π-contr c
  Π-level {n = suc n} {X = X}{Y} hn = λ f g →
    subst (h n) strong-funext (Π-level (λ x → hn x (f x) (g x)))

  -- Σ preserves h-levels
  Σ-level : ∀ {i j n} {X : Set i}{Y : X → Set j}
           → h n X → ((x : X) → h n (Y x))
           → h n (Σ X Y)
  Σ-level {n = 0}{X = X}{Y} (x₀ , cx) hy =
    (x₀ , proj₁ (hy x₀)) , λ { (x , y) → c x y }
    where
      c : (x : X)(y : Y x) → (x₀ , proj₁ (hy x₀)) ≡ (x , y)
      c x y = ap (λ x → (x , proj₁ (hy x))) (cx x)
            · ap (_,_ x) (proj₂ (hy x) y)
  Σ-level {n = suc n} hx hy = λ a b → iso-level Σ-split-iso
    (Σ-level (hx _ _) (λ p → hy (proj₁ b) _ _))

  -- × preserves h-levels
  ×-level : ∀ {i j n}{X : Set i}{Y : Set j}
           → h n X → h n Y → h n (X × Y)
  ×-level hx hy = Σ-level hx (λ _ → hy)

  -- ⊎ preserves h-levels
--  ⊎-level : ∀ {i j n}{X : Set i}{Y : Set j}
--           → 2 ≤ n → h n X → h n Y → h n (X ⊎ Y)
--  ⊎-level {i}{j}{n} {X}{Y} p hx hy = iso-level lem
--    (Σ-level (h! {p = decide p} bool-set) P-level)
--    where
--      P : Bool → Set (i ⊔ j)
--      P true = ↑ j X
--      P false = ↑ i Y
--
--      P-level : (b : Bool) → h n (P b)
--      P-level true = iso-level (lift-iso j X) hx
--      P-level false = iso-level (lift-iso i Y) hy
--
--      lem : Σ Bool P ≅ (X ⊎ Y)
--      lem = iso f g H K
--        where
--          f : (Σ Bool P) → (X ⊎ Y)
--          f (true , lift x) = inj₁ x
--          f (false , lift y) = inj₂ y
--
--          g : (X ⊎ Y) → (Σ Bool P)
--          g (inj₁ x) = (true , lift x)
--          g (inj₂ y) = (false , lift y)
--
--          H : (x : Σ Bool P) → g (f x) ≡ x
--          H (true , lift x) = refl
--          H (false , lift y) = refl
--
--          K : (x : X ⊎ Y) → f (g x) ≡ x
--          K (inj₁ x) = refl
--          K (inj₂ y) = refl

  Π-level-impl : ∀ {i j n} {X : Set i}{Y : X → Set j}
                → ((x : X) → h n (Y x))
                → h n ({x : X} → Y x)
  Π-level-impl {X = X}{Y} hY = iso-level impl-iso (Π-level hY)

  -- being contractible is a proposition
  contr-h1 : ∀ {i}(X : Set i) → h 1 (contr X)
  contr-h1 X = prop⇒h1 λ { (x₀ , c₀) (x₁ , c₁) →
      unapΣ (c₀ x₁ , contr⇒prop (lem (x₀ , c₀) x₁) _ _) }
    where
      lem : ∀ {i}{A : Set i} → contr A → (x : A) → contr ((x' : A) → x ≡ x')
      lem c x = Π-level (λ x' → h↑ c x x')

  -- being of h-level n is a proposition
  hn-h1 : ∀ {i} n (X : Set i) → h 1 (h n X)
  hn-h1 0 X = contr-h1 X
  hn-h1 (suc n) X = Π-level λ x → Π-level λ y → hn-h1 n (x ≡ y)

  -- being a weak equivalence is a proposition
  weak-equiv-h1 : ∀ {i j}{X : Set i}{Y : Set j}
                → (f : X → Y)
                → h 1 (weak-equiv f)
  weak-equiv-h1 f = Π-level λ y
                  → contr-h1 _

  ⊎-h1 : ∀ {i j}{A : Set i}{B : Set j}
       → h 1 A → h 1 B → ¬ (A × B)
       → h 1 (A ⊎ B)
  ⊎-h1 {A = A}{B = B} hA hB u = prop⇒h1 ⊎-prop
    where
      ⊎-prop : prop (A ⊎ B)
      ⊎-prop (inj₁ a) (inj₁ a') = ap inj₁ (h1⇒prop hA a a')
      ⊎-prop (inj₁ a) (inj₂ b') = ⊥-elim (u (a , b'))
      ⊎-prop (inj₂ b) (inj₁ a') = ⊥-elim (u (a' , b))
      ⊎-prop (inj₂ b) (inj₂ b') = ap inj₂ (h1⇒prop hB b b')

  inj-level : ∀ {i j n}{A : Set i}{B : Set j}
             → (f : A → B)
             → h (suc n) A → h n (injective f)
  inj-level f hA
    = Π-level-impl λ x
    → Π-level-impl λ x'
    → Π-level λ p
    → hA x x'

  ↣-level : ∀ {i j n}{A : Set i}{B : Set j}
           → h (suc n) A → h n B → h n (A ↣ B)
  ↣-level hA hB
    = Σ-level (Π-level λ _ → hB) λ f
    → inj-level f hA

  ¬-h1 : ∀ {i}{X : Set i} → h 1 (¬ X)
  ¬-h1 = Π-level λ _ → ⊥-prop


open import Proc

module Silence (param : Param) where

open import Basics
import Interp
import Hear

open Process param
open Interp param
open Hear param

NoSpeak : {a : U} -> Proc a -> Set
NoSpeak {a} p = (w : LT a)(q : Proc a) -> ¬ (p -! w !-> q)

silent-nospeak : {a : U}{p : Proc a} -> Silent p -> NoSpeak p
silent-nospeak silent-o          w  q  ()
silent-nospeak silent->          w  q  ()
silent-nospeak (silent-|| s1 s2) w  ._ (tx-!| h _) = silent-nospeak s1 _ _ h
silent-nospeak (silent-|| s1 s2) w  ._ (tx-|! _ h) = silent-nospeak s2 _ _ h
silent-nospeak (silent-def s)    w  q  (tx-def h)  = silent-nospeak s _ _ h
silent-nospeak (silent-/| s)     ._ ._ (tx-/| h)   = silent-nospeak s _ _ h

nospeak-silent : {a : U}{p : Proc a} -> Guard p -> NoSpeak p -> Silent p
nospeak-silent og           s = silent-o
nospeak-silent (>g f)       s = silent->
nospeak-silent (w !g p)     s = kill (s _ _ tx-!)
nospeak-silent (w ! p +g f) s = kill (s _ _ tx-+)
nospeak-silent (g1 ||g g2)  s =
    silent-|| (nospeak-silent g1 (inv1 g2 s))
              (nospeak-silent g2 (inv2 g1 s))
  where
    module Inv {a : U}{p1 p2 : Proc a} where
      inv1 : Guard p2 -> NoSpeak (p1 || p2) -> NoSpeak p1
      inv1 g2 h w p t = h _ _ (tx-!| t (sound g2))

      inv2 : Guard p1 -> NoSpeak (p1 || p2) -> NoSpeak p2
      inv2 g1 h w p t = h _ _ (tx-|! (sound g1) t)
    open Inv
nospeak-silent (φ /|g g)    s = silent-/| (nospeak-silent g (inv s))
  where
    inv : forall {p} -> NoSpeak (φ /| p) -> NoSpeak p
    inv h w p t = h _ _ (tx-/| t)
nospeak-silent (defg x g)   s = silent-def (nospeak-silent g (inv s))
  where
    inv : NoSpeak (def x) -> NoSpeak (env _ x)
    inv h w p t = h _ _ (tx-def t)


{-# OPTIONS --allow-unsolved-metas #-}
module Issue501 where

record ⊤ : Set where
  constructor tt

data _⊎_ (A : Set) (B : Set) : Set where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

[_,_] : ∀ {A : Set} {B : Set} {C : A ⊎ B → Set} →
        ((x : A) → C (inj₁ x)) → ((x : B) → C (inj₂ x)) →
        ((x : A ⊎ B) → C x)
[ f , g ] (inj₁ x) = f x
[ f , g ] (inj₂ y) = g y

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

Pow : Set → Set₁
Pow X = X → Set

-- Replacing /Pow I/ with /X → Set/ below makes the file load.

-- data _:=_ {I : Set}(A : Set)(i : I) : I → Set where
data _:=_ {I : Set}(A : Set)(i : I) : Pow I where
  ⟨_⟩ : (x : A) → (A := i) i

postulate
  S     : Set
  s     : S
  D     : Pow S → Pow S
  P     : Pow S
  m     : D P s
  _>>=_ : ∀ {A B s} → D A s → (∀ {s} → A s → D B s) → D B s

p : D P s
p = m >>= λ k → [ (λ { ⟨ x ⟩ → {!!} }) , {!!} ] {!!}


{-# OPTIONS --sized-types #-}
open import Relation.Binary.Core

module Heapsort.Impl1.Correctness.Permutation {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import BBHeap _≤_ hiding (forget ; flatten)
open import BBHeap.Heapify _≤_ tot≤ trans≤
open import BBHeap.Insert _≤_ tot≤ trans≤
open import BBHeap.Subtyping _≤_ trans≤
open import BHeap _≤_ hiding (forget) renaming (flatten to flatten')
open import BHeap.Order _≤_
open import BHeap.Order.Properties _≤_
open import BHeap.Properties _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.List
open import Data.Nat renaming (_≤_ to _≤ₙ_)
open import Data.Sum
open import Heapsort.Impl1 _≤_ tot≤ trans≤
open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A
open import List.Permutation.Base.Concatenation A
open import OList _≤_
open import Order.Total _≤_ tot≤
open import Relation.Binary

open DecTotalOrder decTotalOrder hiding (refl)

lemma-flatten-flatten' : {b : Bound}(h : BHeap b)(accₕ : Acc h) → forget (flatten h accₕ) ∼ flatten' h
lemma-flatten-flatten' lf _ = ∼[]
lemma-flatten-flatten' (nd b≤x l r) (acc rs) = ∼x /head /head (trans∼ (lemma-flatten-flatten' (merge tot≤ l r) (rs (merge tot≤ l r) (lemma-merge≤′ tot≤ b≤x l r))) (lemma-merge∼ tot≤ l r))

lemma-flatten'-flatten : {b : Bound}(h : BHeap b)(accₕ : Acc h) → (flatten' h) ∼ (forget (flatten h accₕ))
lemma-flatten'-flatten h tₕ = sym∼ (lemma-flatten-flatten' h tₕ)

lemma-subtyping≡ : {b b' : Bound}(b'≤b : LeB b' b)(h : BBHeap b) → (flatten' (relax (subtyping b'≤b h))) ≡ flatten' (relax h)
lemma-subtyping≡ b'≤b leaf = refl
lemma-subtyping≡ b'≤b (left {l = l} {r = r} b≤x l⋘r) rewrite lemma-subtyping≡ b≤x l | lemma-subtyping≡ b≤x r = refl
lemma-subtyping≡ b'≤b (right {l = l} {r = r} b≤x l⋙r) rewrite lemma-subtyping≡ b≤x l | lemma-subtyping≡ b≤x r = refl

lemma-insert∼ : {b : Bound}{x : A}(b≤x : LeB b (val x))(h : BBHeap b) → (x ∷ flatten' (relax h)) ∼ (flatten' (relax (insert b≤x h)))
lemma-insert∼ b≤x leaf = refl∼
lemma-insert∼ {x = x} b≤x (left {x = y} {l = l} {r = r} b≤y l⋘r)
    with tot≤ x y
... | inj₁ x≤y
    with lemma-insert⋘ (lexy refl≤) l⋘r
... | inj₁ lᵢ⋘r
           rewrite lemma-subtyping≡ {val y} {val x} (lexy x≤y) (insert {val y} {y} (lexy refl≤) l)
                     | lemma-subtyping≡ {val y} {val x} (lexy x≤y) r
                     = ∼x /head /head (lemma++∼r (lemma-insert∼ (lexy refl≤) l))
... | inj₂ lᵢ⋗r
           rewrite  lemma-subtyping≡ {val y} {val x} (lexy x≤y) (insert {val y} {y} (lexy refl≤) l)
                      | lemma-subtyping≡ {val y} {val x} (lexy x≤y) r
                      = ∼x /head /head (lemma++∼r (lemma-insert∼ (lexy refl≤) l))
lemma-insert∼ {x = x} b≤x (left {x = y} {l = l} {r = r} b≤y l⋘r) | inj₂ y≤x
    with lemma-insert⋘ (lexy y≤x) l⋘r
... | inj₁ lᵢ⋘r = ∼x (/tail /head) /head (lemma++∼r (lemma-insert∼ (lexy y≤x) l))
... | inj₂ lᵢ⋗r = ∼x (/tail /head) /head (lemma++∼r (lemma-insert∼ (lexy y≤x) l))
lemma-insert∼ {x = x} b≤x (right {x = y} {l = l} {r = r} b≤y l⋙r)
    with tot≤ x y
... | inj₁ x≤y
    with lemma-insert⋙ (lexy refl≤) l⋙r
... | inj₁ l⋙rᵢ
           rewrite lemma-subtyping≡ {val y} {val x} (lexy x≤y) (insert {val y} {y} (lexy refl≤) r)
                     | lemma-subtyping≡ {val y} {val x} (lexy x≤y) l
                     = ∼x /head /head (trans∼ (∼x /head (lemma++/ {xs = flatten' (relax l)}) refl∼) (lemma++∼l {xs = flatten' (relax l)} (lemma-insert∼ (lexy refl≤) r)))
... | inj₂ l≃rᵢ
           rewrite lemma-subtyping≡ {val y} {val x} (lexy x≤y) (insert {val y} {y} (lexy refl≤) r)
                     | lemma-subtyping≡ {val y} {val x} (lexy x≤y) l
                     = ∼x /head /head (trans∼ (∼x /head (lemma++/ {xs = flatten' (relax l)}) refl∼) (lemma++∼l {xs = flatten' (relax l)} (lemma-insert∼ (lexy refl≤) r)))
lemma-insert∼ {x = x} b≤x (right {x = y} {l = l} {r = r} b≤y l⋙r) | inj₂ y≤x
    with lemma-insert⋙ (lexy y≤x) l⋙r
... | inj₁ l⋙rᵢ = ∼x (/tail /head) /head (trans∼ (∼x /head (lemma++/ {xs = flatten' (relax l)}) refl∼) (lemma++∼l {xs = flatten' (relax l)} (lemma-insert∼ (lexy y≤x) r)))
... | inj₂ l≃rᵢ = ∼x (/tail /head) /head (trans∼ (∼x /head (lemma++/ {xs = flatten' (relax l)}) refl∼) (lemma++∼l {xs = flatten' (relax l)} (lemma-insert∼ (lexy y≤x) r)))

theorem-heapsort∼ : (xs : List A) → xs ∼ forget (heapsort xs)
theorem-heapsort∼ [] = ∼[]
theorem-heapsort∼ (x ∷ xs) = trans∼ (trans∼ (∼x /head /head (trans∼ (theorem-heapsort∼ xs) (lemma-flatten-flatten' h' accₕ'))) (lemma-insert∼ lebx h)) (lemma-flatten'-flatten (hᵢ) accₕᵢ)
              where h = heapify xs
                    h' = relax h
                    accₕ' = ≺-wf h'
                    hᵢ = relax (insert lebx h)
                    accₕᵢ = ≺-wf hᵢ


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Group.Notation where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Algebra.Group.Base

module GroupNotationG {ℓ : Level} ((_ , G) : Group {ℓ}) where
  0ᴳ = GroupStr.0g G
  _+ᴳ_ = GroupStr._+_ G
  -ᴳ_ = GroupStr.-_ G
  _-ᴳ_ = GroupStr._-_ G
  lIdᴳ = GroupStr.lid G
  rIdᴳ = GroupStr.rid G
  lCancelᴳ = GroupStr.invl G
  rCancelᴳ = GroupStr.invr G
  assocᴳ = GroupStr.assoc G
  setᴳ = GroupStr.is-set G

module GroupNotationᴴ {ℓ : Level} ((_ , G) : Group {ℓ}) where
  0ᴴ = GroupStr.0g G
  _+ᴴ_ = GroupStr._+_ G
  -ᴴ_ = GroupStr.-_ G
  _-ᴴ_ = GroupStr._-_ G
  lIdᴴ = GroupStr.lid G
  rIdᴴ = GroupStr.rid G
  lCancelᴴ = GroupStr.invl G
  rCancelᴴ = GroupStr.invr G
  assocᴴ = GroupStr.assoc G
  setᴴ = GroupStr.is-set G

module GroupNotation₀ {ℓ : Level} ((_ , G) : Group {ℓ}) where
  0₀ = GroupStr.0g G
  _+₀_ = GroupStr._+_ G
  -₀_ = GroupStr.-_ G
  _-₀_ = GroupStr._-_ G
  lId₀ = GroupStr.lid G
  rId₀ = GroupStr.rid G
  lCancel₀ = GroupStr.invl G
  rCancel₀ = GroupStr.invr G
  assoc₀ = GroupStr.assoc G
  set₀ = GroupStr.is-set G

module GroupNotation₁ {ℓ : Level} ((_ , G) : Group {ℓ}) where
  0₁ = GroupStr.0g G
  _+₁_ = GroupStr._+_ G
  -₁_ = GroupStr.-_ G
  _-₁_ = GroupStr._-_ G
  lId₁ = GroupStr.lid G
  rId₁ = GroupStr.rid G
  lCancel₁ = GroupStr.invl G
  rCancel₁ = GroupStr.invr G
  assoc₁ = GroupStr.assoc G
  set₁ = GroupStr.is-set G


-- Check that checking of left-hand sides are postponed properly
-- when the type of an argument that is matched on is a meta.

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

data X : Set where
  zero : X

easy : _ → Nat
easy (suc n) = n
easy zero    = zero

-- TODO: uncomment below once LHS postponing is actually implemented

-- hard : _ → Nat
-- hard zero    = zero
-- hard (suc n) = hard n

-- _$_ : {A B : Set} → (A → B) → A → B
-- f $ x = f x

-- plam : Nat
-- plam = (λ { zero → zero; (suc n) → n }) $ suc zero


------------------------------------------------------------------------
-- The Agda standard library
--
-- Correctness proofs for container combinators
------------------------------------------------------------------------

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

module Data.Container.Combinator.Properties where

open import Axiom.Extensionality.Propositional using (Extensionality)
open import Data.Container.Core
open import Data.Container.Combinator
open import Data.Container.Relation.Unary.Any
open import Data.Empty using (⊥-elim)
open import Data.Product as Prod using (∃; _,_; proj₁; proj₂; <_,_>; uncurry; curry)
open import Data.Sum as S using (inj₁; inj₂; [_,_]′; [_,_])
open import Function as F using (_∘′_)
open import Function.Inverse as Inv using (_↔_; inverse; module Inverse)
open import Level using (_⊔_; lower)
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≗_)

-- I have proved some of the correctness statements under the
-- assumption of functional extensionality. I could have reformulated
-- the statements using suitable setoids, but I could not be bothered.

module Identity where

  correct : ∀ {s p x} {X : Set x} → ⟦ id {s} {p} ⟧ X ↔ F.id X
  correct {X = X} = inverse to from (λ _ → P.refl) (λ _ → P.refl)
    where
    to : ⟦ id ⟧ X → F.id X
    to xs = proj₂ xs _

    from : F.id X → ⟦ id ⟧ X
    from x = (_ , λ _ → x)

module Constant (ext : ∀ {ℓ ℓ′} → Extensionality ℓ ℓ′) where

  correct : ∀ {x p y} (X : Set x) {Y : Set y} → ⟦ const {x} {p ⊔ y} X ⟧ Y ↔ F.const X Y
  correct {x} {y} X {Y} = inverse proj₁ from from∘to λ _ → P.refl

    where
    from : X → ⟦ const X ⟧ Y
    from = < F.id , F.const (⊥-elim ∘′ lower) >

    from∘to : (x : ⟦ const X ⟧ Y) → from (proj₁ x) ≡ x
    from∘to xs = P.cong (proj₁ xs ,_) (ext (λ x → ⊥-elim (lower x)))

module Composition {s₁ s₂ p₁ p₂} (C₁ : Container s₁ p₁) (C₂ : Container s₂ p₂) where

  correct : ∀ {x} {X : Set x} → ⟦ C₁ ∘ C₂ ⟧ X ↔ (⟦ C₁ ⟧ F.∘ ⟦ C₂ ⟧) X
  correct {X = X} = inverse to from (λ _ → P.refl) (λ _ → P.refl)
    where
    to : ⟦ C₁ ∘ C₂ ⟧ X → ⟦ C₁ ⟧ (⟦ C₂ ⟧ X)
    to ((s , f) , g) = (s , < f , curry (g ∘′ any) >)

    from : ⟦ C₁ ⟧ (⟦ C₂ ⟧ X) → ⟦ C₁ ∘ C₂ ⟧ X
    from (s , f) = ((s , proj₁ F.∘ f) , uncurry (proj₂ F.∘ f) ∘′ ◇.proof)

module Product (ext : ∀ {ℓ ℓ′} → Extensionality ℓ ℓ′)
       {s₁ s₂ p₁ p₂} (C₁ : Container s₁ p₁) (C₂ : Container s₂ p₂) where

  correct : ∀ {x} {X : Set x} →  ⟦ C₁ × C₂ ⟧ X ↔ (⟦ C₁ ⟧ X Prod.× ⟦ C₂ ⟧ X)
  correct {X = X} = inverse to from from∘to (λ _ → P.refl)
    where
    to : ⟦ C₁ × C₂ ⟧ X → ⟦ C₁ ⟧ X Prod.× ⟦ C₂ ⟧ X
    to ((s₁ , s₂) , f) = ((s₁ , f F.∘ inj₁) , (s₂ , f F.∘ inj₂))

    from : ⟦ C₁ ⟧ X Prod.× ⟦ C₂ ⟧ X → ⟦ C₁ × C₂ ⟧ X
    from ((s₁ , f₁) , (s₂ , f₂)) = ((s₁ , s₂) , [ f₁ , f₂ ]′)

    from∘to : from F.∘ to ≗ F.id
    from∘to (s , f) =
      P.cong (s ,_) (ext [ (λ _ → P.refl) , (λ _ → P.refl) ])

module IndexedProduct {i s p} {I : Set i} (Cᵢ : I → Container s p) where

  correct : ∀ {x} {X : Set x} → ⟦ Π I Cᵢ ⟧ X ↔ (∀ i → ⟦ Cᵢ i ⟧ X)
  correct {X = X} = inverse to from (λ _ → P.refl) (λ _ → P.refl)
    where
    to : ⟦ Π I Cᵢ ⟧ X → ∀ i → ⟦ Cᵢ i ⟧ X
    to (s , f) = λ i → (s i , λ p → f (i , p))

    from : (∀ i → ⟦ Cᵢ i ⟧ X) → ⟦ Π I Cᵢ ⟧ X
    from f = (proj₁ F.∘ f , uncurry (proj₂ F.∘ f))

module Sum {s₁ s₂ p} (C₁ : Container s₁ p) (C₂ : Container s₂ p) where

  correct : ∀ {x} {X : Set x} → ⟦ C₁ ⊎ C₂ ⟧ X ↔ (⟦ C₁ ⟧ X S.⊎ ⟦ C₂ ⟧ X)
  correct {X = X} = inverse to from from∘to to∘from
    where
    to : ⟦ C₁ ⊎ C₂ ⟧ X → ⟦ C₁ ⟧ X S.⊎ ⟦ C₂ ⟧ X
    to (inj₁ s₁ , f) = inj₁ (s₁ , f)
    to (inj₂ s₂ , f) = inj₂ (s₂ , f)

    from : ⟦ C₁ ⟧ X S.⊎ ⟦ C₂ ⟧ X → ⟦ C₁ ⊎ C₂ ⟧ X
    from = [ Prod.map inj₁ F.id , Prod.map inj₂ F.id ]′

    from∘to : from F.∘ to ≗ F.id
    from∘to (inj₁ s₁ , f) = P.refl
    from∘to (inj₂ s₂ , f) = P.refl

    to∘from : to F.∘ from ≗ F.id
    to∘from = [ (λ _ → P.refl) , (λ _ → P.refl) ]

module IndexedSum {i s p} {I : Set i} (C : I → Container s p) where

  correct : ∀ {x} {X : Set x} → ⟦ Σ I C ⟧ X ↔ (∃ λ i → ⟦ C i ⟧ X)
  correct {X = X} = inverse to from (λ _ → P.refl) (λ _ → P.refl)
    where
    to : ⟦ Σ I C ⟧ X → ∃ λ i → ⟦ C i ⟧ X
    to ((i , s) , f) = (i , (s , f))

    from : (∃ λ i → ⟦ C i ⟧ X) → ⟦ Σ I C ⟧ X
    from (i , (s , f)) = ((i , s) , f)

module ConstantExponentiation {i s p} {I : Set i} (C : Container s p) where

  correct : ∀ {x} {X : Set x} → ⟦ const[ I ]⟶ C ⟧ X ↔ (I → ⟦ C ⟧ X)
  correct = IndexedProduct.correct (F.const C)


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

open import HoTT
open import groups.SumOfSubIndicator
open import cohomology.Theory

{- It should be possible to prove lemmas for arbitrary universe levels,
   but this file is only used for [FinSkeleton], which is in the zeroth
   universe. -}

module cohomology.SubFinWedge (CT : CohomologyTheory lzero) (n : ℤ) where

open CohomologyTheory CT

{-
  [B-ac] and [B-dec] can actually be proved from [subfin],
  but maybe the user wants to supply a different [B-ac].

  Another good question is why the focus is on [B], not [A].
  Well, check the definition of [MinusPoint] and you will see why.
-}

module _ {I} {A B : Type₀} (p : Fin I → Coprod A B) (X : Ptd₀) where

  C-subfinite-additive : C n (⊙BigWedge (λ (_ : B) → X)) →ᴳ Πᴳ B (λ _ → C n X)
  C-subfinite-additive = C-additive n (λ (_ : B) → X)

  CEl-subfinite-additive : CEl n (⊙BigWedge (λ (_ : B) → X)) → Π B (λ _ → CEl n X)
  CEl-subfinite-additive = GroupHom.f C-subfinite-additive

  C-subfinite-additive-is-equiv : has-choice 0 B lzero → is-equiv CEl-subfinite-additive
  C-subfinite-additive-is-equiv = C-additive-is-equiv n (λ _ → X)

  C-subfinite-additive-iso : has-choice 0 B lzero
    → C n (⊙BigWedge (λ (_ : B) → X)) ≃ᴳ Πᴳ B (λ _ → C n X)
  C-subfinite-additive-iso = C-additive-iso n (λ (_ : B) → X)

  {- an explicit inverse function -}
  explicit-inverse-C-subfinite-additive : has-dec-eq B
    → Π B (λ _ → CEl n X) → CEl n (⊙BigWedge (λ (_ : B) → X))
  explicit-inverse-C-subfinite-additive B-dec f =
    Group.subsum-r (C n (⊙BigWedge (λ _ → X))) p (λ b → CEl-fmap n (⊙bwproj B-dec b) (f b))

module _ where

  {- this part is to prove the explicit inverse function is correct -}
  abstract
    private
      C-bwproj-bwin-≠ : {B : Type₀} (B-dec : has-dec-eq B) {X : Ptd₀}
        {b b' : B} (neq : b ≠ b') (g : CEl n X)
        → CEl-fmap n (⊙bwproj B-dec b ⊙∘ ⊙bwin {X = λ _ → X} b') g == Cident n X
      C-bwproj-bwin-≠ B-dec neq g =
        CEl-fmap-base-indep n (bwproj-bwin-≠ B-dec neq) g ∙ C-fmap-cst n g

      C-bwproj-bwin-diag : {B : Type₀} (B-dec : has-dec-eq B) {X : Ptd₀} (b : B) (g : CEl n X)
        → CEl-fmap n (⊙bwproj B-dec b ⊙∘ ⊙bwin {X = λ _ → X} b) g == g
      C-bwproj-bwin-diag B-dec b g =
        CEl-fmap-base-indep n (bwproj-bwin-diag B-dec b) g ∙ C-fmap-idf n g

      inverse-C-subfinite-additive-β' : ∀ {A B : Type₀} (B-dec : has-dec-eq B) {I}
        (p : Fin I ≃ Coprod A B) {X : Ptd₀}
        → ∀ f → GroupHom.f (C-subfinite-additive (–> p) X) (explicit-inverse-C-subfinite-additive (–> p) X B-dec f) ∼ f
      inverse-C-subfinite-additive-β' B-dec p {X} f b* =
        CEl-fmap n (⊙bwin b*) (Group.subsum-r (C n (⊙BigWedge (λ _ → X))) (–> p) (λ b → CEl-fmap n (⊙bwproj B-dec b) (f b)))
          =⟨ GroupHom.pres-subsum-r (C-fmap n (⊙bwin b*)) (–> p) (λ b → CEl-fmap n (⊙bwproj B-dec b) (f b)) ⟩
        Group.subsum-r (C n X) (–> p) (λ b → CEl-fmap n (⊙bwin b*) (CEl-fmap n (⊙bwproj B-dec b) (f b)))
          =⟨ ap (Group.subsum-r (C n X) (–> p)) (λ= λ b → ∘-CEl-fmap n (⊙bwin b*) (⊙bwproj B-dec b) (f b)) ⟩
        Group.subsum-r (C n X) (–> p) (λ b → CEl-fmap n (⊙bwproj B-dec b ⊙∘ ⊙bwin b*) (f b))
          =⟨ subsum-r-subindicator (C n X) p (λ b → CEl-fmap n (⊙bwproj B-dec b ⊙∘ ⊙bwin b*) (f b))
              b* (λ b≠b* → C-bwproj-bwin-≠ B-dec b≠b* _) ⟩
        CEl-fmap n (⊙bwproj B-dec b* ⊙∘ ⊙bwin b*) (f b*)
          =⟨ C-bwproj-bwin-diag B-dec b* (f b*) ⟩
        f b*
          =∎

    inverse-C-subfinite-additive-β : ∀ {A B : Type₀}
      (B-ac : has-choice 0 B lzero) (B-dec : has-dec-eq B) {I}
      (p : Fin I ≃ Coprod A B) {X : Ptd₀}
      → is-equiv.g (C-subfinite-additive-is-equiv (–> p) X B-ac)
      ∼ explicit-inverse-C-subfinite-additive (–> p) X B-dec
    inverse-C-subfinite-additive-β B-ac B-dec p {X} f =
      ! $ equiv-adj (GroupIso.f-equiv (C-subfinite-additive-iso (–> p) X B-ac)) $
        λ= $ inverse-C-subfinite-additive-β' B-dec p f

module _ (I : ℕ) (X : Ptd₀) where

  C-finite-additive : C n (⊙BigWedge (λ (_ : Fin I) → X)) →ᴳ Πᴳ (Fin I) (λ _ → C n X)
  C-finite-additive = C-subfinite-additive {A = Empty} inr X

  CEl-finite-additive : CEl n (⊙BigWedge (λ (_ : Fin I) → X)) → Π (Fin I) (λ _ → CEl n X)
  CEl-finite-additive = GroupHom.f C-finite-additive

  C-finite-additive-is-equiv : is-equiv CEl-finite-additive
  C-finite-additive-is-equiv = C-subfinite-additive-is-equiv {A = Empty} inr X (Fin-has-choice 0 lzero)

  C-finite-additive-iso : C n (⊙BigWedge (λ (_ : Fin I) → X)) ≃ᴳ Πᴳ (Fin I) (λ _ → C n X)
  C-finite-additive-iso = C-subfinite-additive-iso {A = Empty} inr X (Fin-has-choice 0 lzero)

  {- an explicit inverse function -}
  explicit-inverse-C-finite-additive : Π (Fin I) (λ _ → CEl n X) → CEl n (⊙BigWedge (λ (_ : Fin I) → X))
  explicit-inverse-C-finite-additive = explicit-inverse-C-subfinite-additive {A = Empty} inr X Fin-has-dec-eq

module _ where
  abstract
    inverse-C-finite-additive-β : ∀ {I : ℕ} {X : Ptd₀}
      → is-equiv.g (C-finite-additive-is-equiv I X)
      ∼ explicit-inverse-C-finite-additive I X
    inverse-C-finite-additive-β {I} {X} =
      inverse-C-subfinite-additive-β {A = Empty} {B = Fin I}
        (Fin-has-choice 0 lzero) Fin-has-dec-eq (⊔₁-Empty (Fin I) ⁻¹) {X}


{-# OPTIONS --safe #-}
module Cubical.Algebra.Algebra.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.Function
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Reflection.RecordEquiv

open import Cubical.Algebra.Module
open import Cubical.Algebra.Ring
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Group
open import Cubical.Algebra.Monoid

open Iso

private
  variable
    ℓ ℓ' ℓ'' ℓ''' : Level

record IsAlgebra (R : Ring ℓ) {A : Type ℓ'}
                 (0a 1a : A) (_+_ _·_ : A → A → A) (-_ : A → A)
                 (_⋆_ : ⟨ R ⟩ → A → A) : Type (ℓ-max ℓ ℓ') where

  constructor isalgebra

  open RingStr (snd R) using (1r) renaming (_+_ to _+r_; _·_ to _·r_)

  field
    isLeftModule : IsLeftModule R 0a _+_ -_ _⋆_
    ·-isMonoid  : IsMonoid 1a _·_
    dist        : (x y z : A) → (x · (y + z) ≡ (x · y) + (x · z))
                              × ((x + y) · z ≡ (x · z) + (y · z))
    ⋆-lassoc     : (r : ⟨ R ⟩) (x y : A) → (r ⋆ x) · y ≡ r ⋆ (x · y)
    ⋆-rassoc     : (r : ⟨ R ⟩) (x y : A) → r ⋆ (x · y) ≡ x · (r ⋆ y)

  open IsLeftModule isLeftModule public

  isRing : IsRing _ _ _ _ _
  isRing = isring (IsLeftModule.+-isAbGroup isLeftModule) ·-isMonoid dist
  open IsRing isRing public hiding (_-_; +Assoc; +Lid; +Linv; +Rid; +Rinv; +Comm)

unquoteDecl IsAlgebraIsoΣ = declareRecordIsoΣ IsAlgebraIsoΣ (quote IsAlgebra)

record AlgebraStr (R : Ring ℓ) (A : Type ℓ') : Type (ℓ-max ℓ ℓ') where

  constructor algebrastr

  field
    0a             : A
    1a             : A
    _+_            : A → A → A
    _·_            : A → A → A
    -_             : A → A
    _⋆_            : ⟨ R ⟩ → A → A
    isAlgebra      : IsAlgebra R 0a 1a _+_ _·_ -_ _⋆_

  open IsAlgebra isAlgebra public

Algebra : (R : Ring ℓ) → ∀ ℓ' → Type (ℓ-max ℓ (ℓ-suc ℓ'))
Algebra R ℓ' = Σ[ A ∈ Type ℓ' ] AlgebraStr R A

module commonExtractors {R : Ring ℓ} where

  Algebra→Module : (A : Algebra R ℓ') → LeftModule R ℓ'
  Algebra→Module (_ , algebrastr A _ _ _ _ _ (isalgebra isLeftModule _ _ _ _)) =
    _ , leftmodulestr A _ _ _ isLeftModule

  Algebra→Ring : (A : Algebra R ℓ') → Ring ℓ'
  Algebra→Ring (_ , str) = _ , ringstr _ _ _ _ _ (IsAlgebra.isRing (AlgebraStr.isAlgebra str))

  Algebra→AbGroup : (A : Algebra R ℓ') → AbGroup ℓ'
  Algebra→AbGroup A = LeftModule→AbGroup (Algebra→Module A)

  Algebra→Group : (A : Algebra R ℓ') → Group ℓ'
  Algebra→Group A = Ring→Group (Algebra→Ring A)

  Algebra→AddMonoid : (A : Algebra R ℓ') → Monoid ℓ'
  Algebra→AddMonoid A = Group→Monoid (Algebra→Group A)

  Algebra→MultMonoid : (A : Algebra R ℓ') → Monoid ℓ'
  Algebra→MultMonoid A = Ring→MultMonoid (Algebra→Ring A)

  isSetAlgebra : (A : Algebra R ℓ') → isSet ⟨ A ⟩
  isSetAlgebra A = isSetAbGroup (Algebra→AbGroup A)

  open RingStr (snd R) using (1r; ·Ldist+) renaming (_+_ to _+r_; _·_ to _·s_)

  makeIsAlgebra : {A : Type ℓ'} {0a 1a : A}
                  {_+_ _·_ : A → A → A} { -_ : A → A} {_⋆_ : ⟨ R ⟩ → A → A}
                  (isSet-A : isSet A)
                  (+-assoc :  (x y z : A) → x + (y + z) ≡ (x + y) + z)
                  (+-rid : (x : A) → x + 0a ≡ x)
                  (+-rinv : (x : A) → x + (- x) ≡ 0a)
                  (+-comm : (x y : A) → x + y ≡ y + x)
                  (·-assoc :  (x y z : A) → x · (y · z) ≡ (x · y) · z)
                  (·-rid : (x : A) → x · 1a ≡ x)
                  (·-lid : (x : A) → 1a · x ≡ x)
                  (·-rdist-+ : (x y z : A) → x · (y + z) ≡ (x · y) + (x · z))
                  (·-ldist-+ : (x y z : A) → (x + y) · z ≡ (x · z) + (y · z))
                  (⋆-assoc : (r s : ⟨ R ⟩) (x : A) → (r ·s s) ⋆ x ≡ r ⋆ (s ⋆ x))
                  (⋆-ldist : (r s : ⟨ R ⟩) (x : A) → (r +r s) ⋆ x ≡ (r ⋆ x) + (s ⋆ x))
                  (⋆-rdist : (r : ⟨ R ⟩) (x y : A) → r ⋆ (x + y) ≡ (r ⋆ x) + (r ⋆ y))
                  (⋆-lid   : (x : A) → 1r ⋆ x ≡ x)
                  (⋆-lassoc : (r : ⟨ R ⟩) (x y : A) → (r ⋆ x) · y ≡ r ⋆ (x · y))
                  (⋆-rassoc : (r : ⟨ R ⟩) (x y : A) → r ⋆ (x · y) ≡ x · (r ⋆ y))
                → IsAlgebra R 0a 1a _+_ _·_ -_ _⋆_
  makeIsAlgebra isSet-A
                +-assoc +-rid +-rinv +-comm
                ·-assoc ·-rid ·-lid ·-rdist-+ ·-ldist-+
                ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid ⋆-lassoc ⋆-rassoc =
                isalgebra
                  (makeIsLeftModule isSet-A
                                    +-assoc +-rid +-rinv +-comm
                                    ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid)
                  (makeIsMonoid isSet-A ·-assoc ·-rid ·-lid)
                  (λ x y z → ·-rdist-+ x y z , ·-ldist-+ x y z)
                  ⋆-lassoc ⋆-rassoc

open commonExtractors public

record IsAlgebraHom {R : Ring ℓ} {A : Type ℓ'} {B : Type ℓ''}
  (M : AlgebraStr R A) (f : A → B) (N : AlgebraStr R B)
  : Type (ℓ-max ℓ (ℓ-max ℓ' ℓ''))
  where

  -- Shorter qualified names
  private
    module M = AlgebraStr M
    module N = AlgebraStr N

  field
    pres0 : f M.0a ≡ N.0a
    pres1 : f M.1a ≡ N.1a
    pres+ : (x y : A) → f (x M.+ y) ≡ f x N.+ f y
    pres· : (x y : A) → f (x M.· y) ≡ f x N.· f y
    pres- : (x : A) → f (M.- x) ≡ N.- (f x)
    pres⋆ : (r : ⟨ R ⟩) (y : A) → f (r M.⋆ y) ≡ r N.⋆ f y

unquoteDecl IsAlgebraHomIsoΣ = declareRecordIsoΣ IsAlgebraHomIsoΣ (quote IsAlgebraHom)
open IsAlgebraHom

AlgebraHom : {R : Ring ℓ} (M : Algebra R ℓ') (N : Algebra R ℓ'') → Type (ℓ-max ℓ (ℓ-max ℓ' ℓ''))
AlgebraHom M N = Σ[ f ∈ (⟨ M ⟩ → ⟨ N ⟩) ] IsAlgebraHom (M .snd) f (N .snd)

IsAlgebraEquiv : {R : Ring ℓ} {A : Type ℓ'} {B : Type ℓ''}
  (M : AlgebraStr R A) (e : A ≃ B) (N : AlgebraStr R B)
  → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
IsAlgebraEquiv M e N = IsAlgebraHom M (e .fst) N

AlgebraEquiv : {R : Ring ℓ} (M : Algebra R ℓ') (N : Algebra R ℓ'') → Type (ℓ-max (ℓ-max ℓ ℓ') ℓ'')
AlgebraEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsAlgebraEquiv (M .snd) e (N .snd)

_$a_ : {R : Ring ℓ} {A : Algebra R ℓ'} {B : Algebra R ℓ''} → AlgebraHom A B → ⟨ A ⟩ → ⟨ B ⟩
f $a x = fst f x

AlgebraEquiv→AlgebraHom : {R : Ring ℓ} {A : Algebra R ℓ'} {B : Algebra R ℓ''}
                        → AlgebraEquiv A B → AlgebraHom A B
AlgebraEquiv→AlgebraHom (e , eIsHom) = e .fst , eIsHom

isPropIsAlgebra : (R : Ring ℓ) {A : Type ℓ'}
  (0a 1a : A)
  (_+_ _·_ : A → A → A)
  (-_ : A → A)
  (_⋆_ : ⟨ R ⟩ → A → A)
  → isProp (IsAlgebra R 0a 1a _+_ _·_ -_ _⋆_)
isPropIsAlgebra R _ _ _ _ _ _ = let open IsLeftModule in
  isOfHLevelRetractFromIso 1 IsAlgebraIsoΣ
    (isPropΣ
      (isPropIsLeftModule _ _ _ _ _)
      (λ mo → isProp×3 (isPropIsMonoid _ _)
                       (isPropΠ3 λ _ _ _ → isProp× (mo .is-set _ _) (mo .is-set _ _))
                       (isPropΠ3 λ _ _ _ → mo .is-set _ _)
                       (isPropΠ3 λ _ _ _ → mo .is-set _ _) ))

isPropIsAlgebraHom : (R : Ring ℓ) {A : Type ℓ'} {B : Type ℓ''}
                     (AS : AlgebraStr R A) (f : A → B) (BS : AlgebraStr R B)
                   → isProp (IsAlgebraHom AS f BS)
isPropIsAlgebraHom R AS f BS = isOfHLevelRetractFromIso 1 IsAlgebraHomIsoΣ
                               (isProp×5 (isSetAlgebra (_ , BS) _ _)
                                         (isSetAlgebra (_ , BS) _ _)
                                         (isPropΠ2 λ _ _ → isSetAlgebra (_ , BS) _ _)
                                         (isPropΠ2 λ _ _ → isSetAlgebra (_ , BS) _ _)
                                         (isPropΠ λ _ → isSetAlgebra (_ , BS) _ _)
                                         (isPropΠ2 λ _ _ → isSetAlgebra (_ , BS) _ _))

isSetAlgebraHom : {R : Ring ℓ} (M : Algebra R ℓ') (N : Algebra R ℓ'')
                → isSet (AlgebraHom M N)
isSetAlgebraHom _ N = isSetΣ (isSetΠ (λ _ → isSetAlgebra N))
                        λ _ → isProp→isSet (isPropIsAlgebraHom _ _ _ _)

isSetAlgebraEquiv : {R : Ring ℓ} (M N : Algebra R ℓ')
                  → isSet (AlgebraEquiv M N)
isSetAlgebraEquiv M N = isSetΣ (isOfHLevel≃ 2 (isSetAlgebra M) (isSetAlgebra N))
                          λ _ → isProp→isSet (isPropIsAlgebraHom _ _ _ _)

AlgebraHom≡ : {R : Ring ℓ} {A B : Algebra R ℓ'} {φ ψ : AlgebraHom A B} → fst φ ≡ fst ψ → φ ≡ ψ
AlgebraHom≡ = Σ≡Prop λ f → isPropIsAlgebraHom _ _ f _

𝒮ᴰ-Algebra : (R : Ring ℓ) → DUARel (𝒮-Univ ℓ') (AlgebraStr R) (ℓ-max ℓ ℓ')
𝒮ᴰ-Algebra R =
  𝒮ᴰ-Record (𝒮-Univ _) (IsAlgebraEquiv {R = R})
    (fields:
      data[ 0a ∣ nul ∣ pres0 ]
      data[ 1a ∣ nul ∣ pres1 ]
      data[ _+_ ∣ bin ∣ pres+ ]
      data[ _·_ ∣ bin ∣ pres· ]
      data[ -_ ∣ autoDUARel _ _ ∣ pres- ]
      data[ _⋆_ ∣ autoDUARel _ _ ∣ pres⋆ ]
      prop[ isAlgebra ∣ (λ _ _ → isPropIsAlgebra _ _ _ _ _ _ _) ])
  where
  open AlgebraStr

  -- faster with some sharing
  nul = autoDUARel (𝒮-Univ _) (λ A → A)
  bin = autoDUARel (𝒮-Univ _) (λ A → A → A → A)

AlgebraPath : {R : Ring ℓ} (A B : Algebra R ℓ') → (AlgebraEquiv A B) ≃ (A ≡ B)
AlgebraPath {R = R} = ∫ (𝒮ᴰ-Algebra R) .UARel.ua

uaAlgebra : {R : Ring ℓ} {A B : Algebra R ℓ'} → AlgebraEquiv A B → A ≡ B
uaAlgebra {A = A} {B = B} = equivFun (AlgebraPath A B)

isGroupoidAlgebra : {R : Ring ℓ} → isGroupoid (Algebra R ℓ')
isGroupoidAlgebra _ _ = isOfHLevelRespectEquiv 2 (AlgebraPath _ _) (isSetAlgebraEquiv _ _)

-- Smart constructor for ring homomorphisms
-- that infers the other equations from pres1, pres+, and pres·

module _  {R : Ring ℓ} {A : Algebra R ℓ'} {B : Algebra R ℓ''} {f : ⟨ A ⟩ → ⟨ B ⟩} where

  private
    module A = AlgebraStr (A .snd)
    module B = AlgebraStr (B .snd)

  module _
    (p1 : f A.1a ≡ B.1a)
    (p+ : (x y : ⟨ A ⟩) → f (x A.+ y) ≡ f x B.+ f y)
    (p· : (x y : ⟨ A ⟩) → f (x A.· y) ≡ f x B.· f y)
    (p⋆ : (r : ⟨ R ⟩) (x : ⟨ A ⟩) → f (r A.⋆ x) ≡ r B.⋆ f x)
    where

    open IsAlgebraHom
    private
      isGHom : IsGroupHom (Algebra→Group A .snd) f (Algebra→Group B .snd)
      isGHom = makeIsGroupHom p+

    makeIsAlgebraHom : IsAlgebraHom (A .snd) f (B .snd)
    makeIsAlgebraHom .pres0 = isGHom .IsGroupHom.pres1
    makeIsAlgebraHom .pres1 = p1
    makeIsAlgebraHom .pres+ = p+
    makeIsAlgebraHom .pres· = p·
    makeIsAlgebraHom .pres- = isGHom .IsGroupHom.presinv
    makeIsAlgebraHom .pres⋆ = p⋆


open import Oscar.Prelude

module Oscar.Class.[ExtensibleType] where

record [ExtensibleType]
    {𝔵} {𝔛 : Ø 𝔵}
    {𝔟} {𝔒₂ : 𝔛 → Ø 𝔟}
    {ℓ̇} (_↦_ : ∀ {x} → 𝔒₂ x → 𝔒₂ x → Ø ℓ̇)
    : Ø₀ where
  constructor ∁
  no-eta-equality


module Web.Semantic.DL.Signature where

infixr 4 _,_

-- a Signature is constructed from Concept Names and Role/Relation Names
data Signature : Set₁ where
  _,_ : (CN RN : Set) → Signature

-- concept name (maps to Sets)
CN : Signature → Set
CN (CN , RN) = CN

-- Role Names (or relation names)
RN : Signature → Set
RN (CN , RN) = RN


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

data ⊤ : Prop where
  tt : ⊤

data A : ⊤ → Set where
  a : (x : ⊤) → A x

f : A tt → ⊤
f (a x) = {!!}


module Punctaffy.Hypersnippet.Hyperstack where

open import Level using (Level; _⊔_)

open import Punctaffy.Hypersnippet.Dim using (DimSys; dimLte)

data DimList {n l : Level} : DimSys {n} {l} → Set (n ⊔ l) → Set (n ⊔ l) where
  makeDimList : {ds : DimSys} → {a : Set (n ⊔ l)} → (len : DimSys.Carrier ds) → ((i : DimSys.Carrier ds) → dimLte {n} {l} {ds} i len → a) → DimList ds a


open import Data.List renaming (_∷_ to _∷ₗ_ ; [_] to [_]ₗ)
open import Data.Maybe
open import Data.Product
open import Data.Sum

open import AEff
open import EffectAnnotations
open import Preservation
open import Renamings
open import Substitutions
open import Types

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary

module ProcessPreservation where

-- REDUCTION OF PROCESS TYPES

infix 10 _⇝_

data _⇝_ : {o o' : O} → PType o → PType o' → Set where

  id  : {X : VType}
        {o : O}
        {i : I} →
        ----------------------
        X ‼ o , i ⇝ X ‼ o , i

  act : {X : VType}
        {o o' o'' : O}
        {i i' i'' : I} →
        (ops : List Σₛ) →
        (op : Σₛ) →
        (o' , i') ≡ ops ↓↓ₑ (o , i) →
        (o'' , i'') ≡ ((ops ++ [ op ]ₗ) ↓↓ₑ (o , i)) →
        ----------------------------------------------
        (X ‼ o' , i') ⇝ (X ‼ o'' , i'')

  par : {o o' o'' o''' : O}
        {PP : PType o}
        {QQ : PType o'}
        {PP' : PType o''}
        {QQ' : PType o'''} →
        PP ⇝ PP' →
        QQ ⇝ QQ' →
        ----------------------
        (PP ∥ QQ) ⇝ (PP' ∥ QQ')

-- REDUCTION OF PROCESS TYPES IS REFLEXIVE

{- LEMMA 4.4 (1) -}

⇝-refl : {o : O} {PP : PType o} → PP ⇝ PP
⇝-refl {o} {X ‼ o , i} =
  id
⇝-refl {.(_ ∪ₒ _)} {PP ∥ QQ} =
  par ⇝-refl ⇝-refl

-- ACTION OF INTERRUPTS ON GENERAL PROCESS TYPES IS A REDUCTION

{- LEMMA 4.4 (2) -}

⇝-↓ₚ : {o : O}
       {PP : PType o}
       {op : Σₛ} →
       --------------
       PP ⇝ op ↓ₚ PP

⇝-↓ₚ {.o} {X ‼ o , i} {op} =
  act [] op refl refl
⇝-↓ₚ {.(_ ∪ₒ _)} {PP ∥ QQ} {op} =
  par ⇝-↓ₚ ⇝-↓ₚ

-- ACTION OF INTERRUPTS PRESERVES PROCESS TYPE REDUCTION

{- LEMMA 4.4 (3) -}

⇝-↓ₚ-cong : {o o' : O}
            {PP : PType o}
            {QQ : PType o'}
            {op : Σₛ} →
            PP ⇝ QQ →
            --------------------
            op ↓ₚ PP ⇝ op ↓ₚ QQ

⇝-↓ₚ-cong id =
  id
⇝-↓ₚ-cong {_} {_} {_} {_} {op} (act {_} {o} {o'} {o''} {i} {i'} {i''} ops op' p q) =
  act {o = o} {i = i} (op ∷ₗ ops) op' (cong (λ oi → op ↓ₑ oi) p) (cong (λ oi → op ↓ₑ oi) q)
⇝-↓ₚ-cong (par p q) =
  par (⇝-↓ₚ-cong p) (⇝-↓ₚ-cong q)

-- PROCESS TYPE REDUCTION INCREASES SIGNAL INDEX

{- LEMMA 4.4 (4) -}

inj-proj₁ : {X Y : Set} {xy xy' : X × Y} → xy ≡ xy' → proj₁ xy ≡ proj₁ xy'
inj-proj₁ refl = refl

⇝-⊑ₒ : {o o' : O}
       {PP : PType o}
       {QQ : PType o'} →
       PP ⇝ QQ →
       ------------------
       o ⊑ₒ o'

⇝-⊑ₒ id =
  ⊑ₒ-refl
⇝-⊑ₒ (act {_} {o} {o'} {o''} {i} ops op p q) with inj-proj₁ p | inj-proj₁ q
... | r | s =
  subst (λ o → o ⊑ₒ o'')
        (sym r)
        (subst (λ o'' → proj₁ (ops ↓↓ₑ (o , i)) ⊑ₒ o'')
               (sym s)
               (subst (λ v → proj₁ (ops ↓↓ₑ (o , i)) ⊑ₒ proj₁ v)
                      (sym (↓↓ₑ-act ops [ op ]ₗ))
                      (↓↓ₑ-⊑ₒ-act ops op)))
⇝-⊑ₒ (par p q) =
  ∪ₒ-fun (⇝-⊑ₒ p) (⇝-⊑ₒ q)

-- EVALUATION CONTEXTS FOR PROCESSES

infix 10 _⊢F⦂_

data _⊢F⦂_ (Γ : Ctx) : {o : O} → PType o → Set where

  [-]     : {o : O} →
            {PP : PType o} →
            --------------
            Γ ⊢F⦂ PP

  _∥ₗ_    : {o o' : O}
            {PP : PType o}
            {QQ : PType o'} →
            Γ ⊢F⦂ PP →
            Γ ⊢P⦂ QQ →
            ------------------
            Γ ⊢F⦂ (PP ∥ QQ)

  _∥ᵣ_    : {o o' : O}
            {PP : PType o}
            {QQ : PType o'} →
            Γ ⊢P⦂ PP →
            Γ ⊢F⦂ QQ →
            ------------------
            Γ ⊢F⦂ (PP ∥ QQ)

  ↑       : {o : O}
            {PP : PType o}  →
            (op : Σₛ) →
            op ∈ₒ o →
            Γ ⊢V⦂ ``(payload op) →
            Γ ⊢F⦂ PP →
            ----------------------
            Γ ⊢F⦂ PP

  ↓       : {o : O}
            {PP : PType o}
            (op : Σₛ) →
            Γ ⊢V⦂ ``(payload op) →
            Γ ⊢F⦂ PP →
            ----------------------
            Γ ⊢F⦂ op ↓ₚ PP

-- FINDING THE TYPE OF THE HOLE OF A WELL-TYPED PROCESS EVALUATION CONTEXT

hole-ty-f : {Γ : Ctx} {o : O} {PP : PType o} → Γ ⊢F⦂ PP → Σ[ o' ∈ O ] (PType o')
hole-ty-f {_} {o} {PP} [-] =
  o , PP
hole-ty-f (_∥ₗ_ {o} {o'} {PP} {QQ} F Q) =
  proj₁ (hole-ty-f F) , proj₂ (hole-ty-f F)
hole-ty-f (_∥ᵣ_ {o} {o'} {PP} {QQ} P F) =
  proj₁ (hole-ty-f F) , proj₂ (hole-ty-f F)
hole-ty-f (↑ op p V F) =
  proj₁ (hole-ty-f F) , proj₂ (hole-ty-f F)
hole-ty-f (↓ op V F) =
  proj₁ (hole-ty-f F) , proj₂ (hole-ty-f F)

-- FILLING A WELL-TYPED PROCESS EVALUATION CONTEXT

infix 30 _[_]f

_[_]f : {Γ : Ctx} {o : O} {PP : PType o} → (F : Γ ⊢F⦂ PP) → (P : Γ ⊢P⦂ proj₂ (hole-ty-f F)) → Γ ⊢P⦂ PP
[-] [ P ]f =
  P
(F ∥ₗ Q) [ P ]f =
  (F [ P ]f) ∥ Q
(Q ∥ᵣ F) [ P ]f =
  Q ∥ (F [ P ]f)
(↑ op p V F) [ P ]f =
  ↑ op p V (F [ P ]f)
(↓ op V F) [ P ]f =
  ↓ op V (F [ P ]f)

-- TYPES OF WELL-TYPED PROCESS EVALUATION CONTEXTS ALSO REDUCE

⇝-f-⇝ : {Γ : Ctx}
        {o o' : O}
        {PP : PType o}
        {QQ : PType o'} →
        (F : Γ ⊢F⦂ PP) →
        proj₂ (hole-ty-f F) ⇝ QQ →
        ------------------------------------------
        Σ[ o'' ∈ O ] Σ[ RR ∈ PType o'' ] (PP ⇝ RR)

⇝-f-⇝ {_} {_} {o'} {_} {QQ} [-] p =
  o' , QQ , p
⇝-f-⇝ (_∥ₗ_ {o} {o'} {PP} {QQ} F Q) p with ⇝-f-⇝ F p
... | o'' , RR , q =
  (o'' ∪ₒ o') , (RR ∥ QQ) , par q ⇝-refl
⇝-f-⇝ (_∥ᵣ_ {o} {o'} {PP} {QQ} P F) p with ⇝-f-⇝ F p
... | o'' , RR , q =
  (o ∪ₒ o'') , (PP ∥ RR) , par ⇝-refl q
⇝-f-⇝ (↑ op p V F) q with ⇝-f-⇝ F q
... | o'' , RR , r =
  o'' , RR , r
⇝-f-⇝ (↓ op V F) p with ⇝-f-⇝ F p
... | o'' , RR , q =
  proj₁ (op ↓ₚₚ RR) , (op ↓ₚ RR) , ⇝-↓ₚ-cong q

⇝-f-∈ₒ : {Γ : Ctx}
         {o o' : O}
         {PP : PType o}
         {QQ : PType o'}
         (F : Γ ⊢F⦂ PP) →
         (p : proj₂ (hole-ty-f F) ⇝ QQ) →
         --------------------------------
         o ⊑ₒ proj₁ (⇝-f-⇝ F p)

⇝-f-∈ₒ [-] p =
  ⇝-⊑ₒ p
⇝-f-∈ₒ (F ∥ₗ Q) p =
  ∪ₒ-fun (⇝-f-∈ₒ F p) ⊑ₒ-refl
⇝-f-∈ₒ (P ∥ᵣ F) p =
  ∪ₒ-fun ⊑ₒ-refl (⇝-f-∈ₒ F p)
⇝-f-∈ₒ (↑ op p V F) q =
  ⇝-f-∈ₒ F q
⇝-f-∈ₒ (↓ {o} {PP} op V F) p =
  ⇝-f-∈ₒ-aux (⇝-f-⇝ F p) refl

  where
    ⇝-f-∈ₒ-aux : (orp : Σ[ o'' ∈ O ] Σ[ RR ∈ PType o'' ] (PP ⇝ RR)) →
                 orp ≡ ⇝-f-⇝ F p →
                 ----------------------------------------------------
                 proj₁ (op ↓ₚₚ PP) ⊑ₒ proj₁ (op ↓ₚₚ proj₁ (proj₂ orp))

    ⇝-f-∈ₒ-aux (o'' , RR , r) q =
      ⇝-⊑ₒ (⇝-↓ₚ-cong r)

{- LEMMA 4.6 -}

⇝-f : {Γ : Ctx}
      {o o' : O}
      {PP : PType o}
      {QQ : PType o'} →
      (F : Γ ⊢F⦂ PP) →
      (p : proj₂ (hole-ty-f F) ⇝ QQ) →
      ---------------------------------
      Γ ⊢F⦂ (proj₁ (proj₂ (⇝-f-⇝ F p)))

⇝-f [-] p =
  [-]
⇝-f (F ∥ₗ Q) p with ⇝-f F p
... | q =
  q ∥ₗ Q
⇝-f (Q ∥ᵣ F) p with ⇝-f F p
... | q =
  Q ∥ᵣ q
⇝-f (↑ op p V F) q with ⇝-f F q
... | r =
  ↑ op (⇝-f-∈ₒ F q op p) V r
⇝-f (↓ op V F) p with ⇝-f F p
... | q =
  ↓ op V q

⇝-f-tyₒ : {Γ : Ctx}
          {o o' : O}
          {PP : PType o}
          {QQ : PType o'} →
          (F : Γ ⊢F⦂ PP) →
          (p : proj₂ (hole-ty-f F) ⇝ QQ) →
          --------------------------------
          o' ≡ proj₁ (hole-ty-f (⇝-f F p))

⇝-f-tyₒ [-] p =
  refl
⇝-f-tyₒ (F ∥ₗ Q) p =
  ⇝-f-tyₒ F p
⇝-f-tyₒ (P ∥ᵣ F) p =
  ⇝-f-tyₒ F p
⇝-f-tyₒ (↑ op p V F) q =
  ⇝-f-tyₒ F q
⇝-f-tyₒ (↓ op V F) p =
  ⇝-f-tyₒ F p

⇝-f-ty : {Γ : Ctx}
         {o o' : O}
         {PP : PType o}
         {QQ : PType o'} →
         (F : Γ ⊢F⦂ PP) →
         (p : proj₂ (hole-ty-f F) ⇝ QQ) →
         --------------------------------------
         subst (λ o → PType o) (⇝-f-tyₒ F p) QQ
         ≡
         proj₂ (hole-ty-f (⇝-f F p))

⇝-f-ty [-] p =
  refl
⇝-f-ty (F ∥ₗ Q) p =
  ⇝-f-ty F p
⇝-f-ty (P ∥ᵣ F) p =
  ⇝-f-ty F p
⇝-f-ty (↑ op p V F) q =
  ⇝-f-ty F q
⇝-f-ty (↓ op V F) p =
  ⇝-f-ty F p

-- AUXILIARY TWO-LEVEL INDEXED SUBSTITUTION

subst-i : {X : Set} {x x' : X} → (Y : X → Set) → {y : Y x} {y' : Y x'} →
          (Z : (x : X) → Y x → Set) → (p : x ≡ x') → subst Y p y ≡ y' → Z x y → Z x' y'
subst-i Y Z refl refl z = z

-- SMALL-STEP OPERATIONAL SEMANTICS FOR WELL-TYPED PROCESSES
-- (ADDITIONALLY SERVES AS THE PRESERVATION THEOREM)

{- THEOREM 4.7 -}

infix 10 _[_]↝_

data _[_]↝_ {Γ : Ctx} : {o o' : O} {PP : PType o} {QQ : PType o'} → Γ ⊢P⦂ PP → PP ⇝ QQ → Γ ⊢P⦂ QQ → Set where

  -- RUNNING INDIVIDUAL COMPUTATIONS

  run     : {X : VType}
            {o : O}
            {i : I}
            {M N : Γ ⊢M⦂ X ! (o , i)} →
            M ↝ N →
            ---------------------------
            (run M) [ id ]↝ (run N)

  -- BROADCAST RULES

  ↑-∥ₗ    : {o o' : O}
            {PP : PType o}
            {QQ : PType o'}
            {op : Σₛ} →
            (p : op ∈ₒ o) →
            (V : Γ ⊢V⦂ `` (payload op)) →
            (P : Γ ⊢P⦂ PP) →
            (Q : Γ ⊢P⦂ QQ) →
            ------------------------------------------
            ((↑ op p V P) ∥ Q)
            [ par ⇝-refl (⇝-↓ₚ {op = op}) ]↝
            ↑ op (∪ₒ-inl op p) V (P ∥ ↓ op V Q)

  ↑-∥ᵣ    : {o o' : O}
            {PP : PType o}
            {QQ : PType o'}
            {op : Σₛ} →
            (p : op ∈ₒ o') →
            (V : Γ ⊢V⦂ `` (payload op)) →
            (P : Γ ⊢P⦂ PP) →
            (Q : Γ ⊢P⦂ QQ) →
            ------------------------------------------
            (P ∥ (↑ op p V Q))
            [ par (⇝-↓ₚ {op = op}) ⇝-refl ]↝
            ↑ op (∪ₒ-inr op p) V (↓ op V P ∥ Q)

  -- INTERRUPT PROPAGATION RULES

  ↓-run   : {X : VType}
            {o : O}
            {i : I}
            {op : Σₛ} →
            (V : Γ ⊢V⦂ `` (payload op)) →
            (M : Γ ⊢M⦂ X ! (o , i)) →
            -----------------------------
            ↓ op V (run M)
            [ id ]↝
            run (↓ op V M)

  ↓-∥     : {o o' : O}
            {PP : PType o}
            {QQ : PType o'}
            {op : Σₛ}
            (V : Γ ⊢V⦂ `` (payload op)) →
            (P : Γ ⊢P⦂ PP) →
            (Q : Γ ⊢P⦂ QQ) →
            -----------------------------
            ↓ op V (P ∥ Q)
            [ ⇝-refl ]↝
            ((↓ op V P) ∥ (↓ op V Q))

  ↓-↑     : {o : O}
            {PP : PType o}
            {op : Σₛ}
            {op' : Σₛ} →
            (p : op' ∈ₒ o) →
            (V : Γ ⊢V⦂ ``(payload op)) →
            (W : Γ ⊢V⦂ ``(payload op')) →
            (P : Γ ⊢P⦂ PP) →
            -----------------------------------
            ↓ op V (↑ op' p W P)
            [ ⇝-refl ]↝
            ↑ op' (↓ₚₚ-⊑ₒ PP op' p) W (↓ op V P)

  -- SIGNAL HOISTING RULE

  ↑       : {X : VType}
            {o : O}
            {i : I} →
            {op : Σₛ} →
            (p : op ∈ₒ o) →
            (V : Γ ⊢V⦂ `` (payload op)) →
            (M : Γ ⊢M⦂ X ! (o , i)) →
            -----------------------------
            run (↑ op p V M)
            [ id ]↝
            ↑ op p V (run M)

  -- EVALUATION CONTEXT RULE

  context : {o o' : O}
            {PP : PType o}
            {QQ : PType o'}
            (F : Γ ⊢F⦂ PP) →
            {P : Γ ⊢P⦂ proj₂ (hole-ty-f F)}
            {Q : Γ ⊢P⦂ QQ}
            {r : proj₂ (hole-ty-f F) ⇝ QQ} →
            P [ r ]↝ Q →
            -----------------------------------------------------------------------------
            F [ P ]f
            [ proj₂ (proj₂ (⇝-f-⇝ F r)) ]↝
            (⇝-f F r) [ subst-i PType (λ o QQ → Γ ⊢P⦂ QQ) (⇝-f-tyₒ F r) (⇝-f-ty F r) Q ]f


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

module Agda.Builtin.Sigma where

open import Agda.Primitive

record Σ {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    fst : A
    snd : B fst

open Σ public

infixr 4 _,_

{-# BUILTIN SIGMA Σ #-}


open import Agda.Primitive

data Foo : Setω where
  foo : Foo

bar : Foo → Foo
bar foo = foo


--
-- Created by Dependently-Typed Lambda Calculus on 2019-05-15
-- records
-- Author: ice10
--

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

record List (A : Set) : Set where
  coinductive
  field
    head : A
    tail : List A
open List

-- | Bisimulation as equality
record _==_ (x : List A) (y : List A) : Set where
  coinductive
  field
    refl-head : head x ≡ head y
    refl-tail : tail x == tail y
open _==_


module Everything where
-- The development can almost entirely be type-checked using --safe,
-- We mark modules that use the TERMINATING pragma with (**)
-- And one module that uses --rewriting with (*).
-- These are the only modules that Agda does not accept ass --safe.

--  # First we summarize the library we use by Rouvoet et al '20, CPP.
--
--  Our work contributes various improvements to the library.
--  In particular, its generalization relations whose underlying
--  equivalence is not propositional equality.
--  But also various additions to the parts of the library
--  mentioned below.

-- Core defines what a proof-relevant ternary relation (Rel₃).
import Relation.Ternary.Core

-- Structures defines type classes for ternary relations.
-- A PRSA is a commutative monoid and should implement:
--   - IsPartialMonoid <: IsPartialSemigroup
--   - IsCommutative
import Relation.Ternary.Structures

-- The overloaded syntax of separation logic comes from:
import Relation.Ternary.Structures.Syntax

-- Resource aware versions of data types that we use are defined generically
-- in Relation.Ternary.Data:
import Relation.Ternary.Data.Bigstar             -- 'Star' in figure 5 of the paper
import Relation.Ternary.Data.Bigplus             -- 'Plus'
import Relation.Ternary.Data.ReflexiveTransitive -- 'IStar'

-- The computational structures from the library that we use in the paper
import Relation.Ternary.Functor
import Relation.Ternary.Monad

-- # We make the following additions to the library, that we describe in the paper.

-- A generic PRSA for list separation modulo permutations.
-- It is generic in the sense that it is parameterized in a PRSA on its elements.
-- We prove that it is a PRSA, with various additional properties that are
-- crucial for the model construction in the paper.
import Relation.Ternary.Construct.Bag
import Relation.Ternary.Construct.Bag.Properties

-- A generic PRSA Exchange, that generalizes the interface composition relation.
import Relation.Ternary.Construct.Exchange

-- Its construction is generic in 2 PRSAs that obey some properties.
-- These properties are formalized as type-classes on ternary relations
import Relation.Ternary.Structures.Positive
import Relation.Ternary.Structures.Crosssplit

-- We added the writer monad construction described in the paper.
import Relation.Ternary.Monad.Writer

-- # We then formalize the typed language CF, and typed bytecode,
-- and implement the typed compilation backend.

-- The model:
-- The bag separation implements the 'disjoint' and the 'overlapping' context
-- separation from the paper, depending on how you instantiate it.
-- The instantiation is done in the JVM model construction.
-- Here we also instantiate Exchange to obtain interface composition.
import JVM.Model

-- Syntax of bytecode
import JVM.Types
import JVM.Syntax.Instructions
import JVM.Syntax.Bytecode

-- The Compiler monad
import JVM.Compiler.Monad

-- The source language
import CF.Types
import CF.Syntax           -- co-contextual
import CF.Syntax.Hoisted   -- co-contextual without local variable introductions
import CF.Syntax.DeBruijn  -- contextual

import CF.Transform.Hoist               -- hoisting local variable declarations (**)
import CF.Transform.UnCo                -- contextualizing (**)
import CF.Transform.Compile.Expressions -- compiling expressions
import CF.Transform.Compile.Statements  -- compiling statements
import CF.Transform.Compile.ToJVM       -- typeclass for type translation
import JVM.Transform.Noooops            -- bytecode optimization that removes nops
import JVM.Transform.Assemble           -- bytecode translation to absolute jumps (*)
import JVM.Printer                      -- printer for co-contextual bytecode to Jasmin (not verified) (**)

-- Example compilations.
-- These can be run by first compiling them using `make examples`.
-- The output will be in _build/bin/
import CF.Examples.Ex1 -- (*,**)
import CF.Examples.Ex2 -- (*,**)


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

open import Categories.Category using (Category)
open import Categories.Category.Monoidal.Core using (Monoidal)

-- The tensor product of certain monoidal categories is a monoidal functor.

module Categories.Functor.Monoidal.Tensor {o ℓ e} {C : Category o ℓ e}
  {M : Monoidal C} where

open import Data.Product using (_,_)

open import Categories.Category.Product using (Product)
open import Categories.Category.Monoidal.Braided using (Braided)
open import Categories.Category.Monoidal.Symmetric using (Symmetric)
open import Categories.Category.Monoidal.Construction.Product hiding (⊗)
open import Categories.Category.Monoidal.Interchange
open import Categories.Category.Monoidal.Structure
open import Categories.Morphism using (module ≅)
open import Categories.Functor.Monoidal
import Categories.Functor.Monoidal.Braided as BMF
import Categories.Functor.Monoidal.Symmetric as SMF
open import Categories.NaturalTransformation.NaturalIsomorphism
   using (NaturalIsomorphism)

open NaturalIsomorphism
private
  C-monoidal : MonoidalCategory o ℓ e
  C-monoidal = record { U = C; monoidal = M }

  C×C          = Product C C
  C×C-monoidal = Product-MonoidalCategory C-monoidal C-monoidal

open MonoidalCategory C-monoidal

-- By definition, the tensor product ⊗ of a monoidal category C is a
-- binary functor ⊗ : C × C → C.  The product category C × C of a
-- monoidal category C is again monoidal.  Thus we may ask:
--
--   Is the functor ⊗ a monoidal functor, i.e. does it preserve the
--   monoidal structure in a suitable way (lax or strong)?
--
-- The answer is "yes", provided ⊗ comes equipped with a (coherent)
-- interchange map, aka a "four-middle interchange", which is the case
-- e.g. when C is braided.

module Lax (hasInterchange : HasInterchange M) where
  private module interchange = HasInterchange hasInterchange

  ⊗-isMonoidalFunctor : IsMonoidalFunctor C×C-monoidal C-monoidal ⊗
  ⊗-isMonoidalFunctor = record
    { ε             = unitorˡ.to
    ; ⊗-homo        = F⇒G interchange.naturalIso
    ; associativity = interchange.assoc
    ; unitaryˡ      = interchange.unitˡ
    ; unitaryʳ      = interchange.unitʳ
    }

  ⊗-MonoidalFunctor : MonoidalFunctor C×C-monoidal C-monoidal
  ⊗-MonoidalFunctor = record { F = ⊗ ; isMonoidal = ⊗-isMonoidalFunctor }

module LaxBraided (B : Braided M) where
  open Lax (BraidedInterchange.hasInterchange B) public

module LaxSymmetric (S : Symmetric M) where
  open SymmetricInterchange S
  open Lax hasInterchange public
  open SymmetricMonoidalCategory using ()
    renaming (braidedMonoidalCategory to bmc)
  private
    C-symmetric : SymmetricMonoidalCategory o ℓ e
    C-symmetric = record { symmetric = S }

    C×C-symmetric = Product-SymmetricMonoidalCategory C-symmetric C-symmetric

  open BMF.Lax (bmc C×C-symmetric) (bmc C-symmetric)
  open SMF.Lax C×C-symmetric C-symmetric

  ⊗-isBraidedMonoidalFunctor : IsBraidedMonoidalFunctor ⊗
  ⊗-isBraidedMonoidalFunctor = record
    { isMonoidal      = ⊗-isMonoidalFunctor
    ; braiding-compat = swapInner-braiding′
    }

  ⊗-SymmetricMonoidalFunctor : SymmetricMonoidalFunctor
  ⊗-SymmetricMonoidalFunctor = record
    { isBraidedMonoidal = ⊗-isBraidedMonoidalFunctor }

module Strong (hasInterchange : HasInterchange M) where
  private module interchange = HasInterchange hasInterchange

  ⊗-isMonoidalFunctor : IsStrongMonoidalFunctor C×C-monoidal C-monoidal ⊗
  ⊗-isMonoidalFunctor = record
    { ε             = ≅.sym C unitorˡ
    ; ⊗-homo        = interchange.naturalIso
    ; associativity = interchange.assoc
    ; unitaryˡ      = interchange.unitˡ
    ; unitaryʳ      = interchange.unitʳ
    }

  ⊗-MonoidalFunctor : StrongMonoidalFunctor C×C-monoidal C-monoidal
  ⊗-MonoidalFunctor = record { isStrongMonoidal = ⊗-isMonoidalFunctor }

-- TODO: implement the missing bits in Categories.Category.Monoidal.Interchange.

module StrongBraided (B : Braided M) where
  open Strong (BraidedInterchange.hasInterchange B) public

module StrongSymmetric (S : Symmetric M) where
  open SymmetricInterchange S
  open Strong hasInterchange public
  open SymmetricMonoidalCategory using ()
    renaming (braidedMonoidalCategory to bmc)
  private
    C-symmetric : SymmetricMonoidalCategory o ℓ e
    C-symmetric = record { symmetric = S }

    C×C-symmetric = Product-SymmetricMonoidalCategory C-symmetric C-symmetric

  open BMF.Strong (bmc C×C-symmetric) (bmc C-symmetric)
  open SMF.Strong C×C-symmetric C-symmetric

  ⊗-isBraidedMonoidalFunctor : IsBraidedMonoidalFunctor ⊗
  ⊗-isBraidedMonoidalFunctor = record
    { isStrongMonoidal = ⊗-isMonoidalFunctor
    ; braiding-compat  = swapInner-braiding′
    }

  ⊗-SymmetricMonoidalFunctor : SymmetricMonoidalFunctor
  ⊗-SymmetricMonoidalFunctor = record
    { isBraidedMonoidal = ⊗-isBraidedMonoidalFunctor }


module Common where

open import Agda.Builtin.Size public
  using (Size ; Size<_)
  renaming (ω to ∞)

open import Agda.Primitive public
  using ()
  renaming (_⊔_ to _⊔ᴸ_ ; lsuc to sucᴸ)

open import Data.Bool public
  using (true ; false)
  renaming (Bool to 𝔹 ; _∧_ to _∧ᴮ_ ; _∨_ to _∨ᴮ_ ; not to ¬ᴮ_ ; if_then_else_ to ifᴮ)

open import Data.Empty public
  using ()
  renaming (⊥ to 𝟘 ; ⊥-elim to elim𝟘)

open import Data.Fin public
  using (Fin ; zero ; suc)

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

open import Data.Nat public
  using (ℕ ; zero ; suc)
  renaming (_≟_ to _≟ᴺ_)

open import Data.Sum public
  using (_⊎_)
  renaming (inj₁ to ι₁ ; inj₂ to ι₂)

open import Data.Unit public
  using ()
  renaming (⊤ to 𝟙 ; tt to ∙)

open import Function public
  using (_∘_ ; _$_)
  renaming (id to I ; const to K ; _ˢ_ to S)

open import Relation.Binary.PropositionalEquality public
  using (_≡_ ; _≢_ ; refl ; trans ; sym ; cong ; subst)
  renaming (cong₂ to cong²)

open import Relation.Nullary public
  using (Dec ; yes ; no)
  renaming (¬_ to Not)

open import Relation.Nullary.Decidable public
  using ()
  renaming (map′ to mapDec)

open import Relation.Nullary.Negation public
  using ()
  renaming (contradiction to _↯_)

-- Abstract symbols, or atoms.

abstract
  Atom : Set
  Atom = ℕ

  _≟ᵅ_ : (P P′ : Atom) → Dec (P ≡ P′)
  _≟ᵅ_ = _≟ᴺ_

-- Products, with custom fixities.

infixl 5 _,_
record Σ {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ᴸ b) where
  constructor _,_
  field
    π₁ : A
    π₂ : B π₁

open Σ public

∃ : ∀ {a b} {A : Set a} → (A → Set b) → Set (a ⊔ᴸ b)
∃ = Σ _

infix 2 _×_
_×_ : ∀ {a b} (A : Set a) (B : Set b) → Set (a ⊔ᴸ b)
A × B = Σ A (λ _ → B)

-- Elimination for disjoint unions.

elim⊎ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
        → A ⊎ B → (A → C) → (B → C) → C
elim⊎ (ι₁ x) f g = f x
elim⊎ (ι₂ y) f g = g y

-- Double-argument K combinator.

K² : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
     → A → B → C → A
K² x _ _ = x

-- Triple-argument congruence.

cong³ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
        (f : A → B → C → D) {x x′ y y′ z z′}
        → x ≡ x′ → y ≡ y′ → z ≡ z′ → f x y z ≡ f x′ y′ z′
cong³ f refl refl refl = refl

-- Iteration and recursion for naturals.

itᴺ : ∀ {a} {A : Set a} → ℕ → (A → A) → A → A
itᴺ zero    f x = x
itᴺ (suc n) f x = f (itᴺ n f x)

recᴺ : ∀ {a} {A : Set a} → ℕ → (ℕ → A → A) → A → A
recᴺ zero    f x = x
recᴺ (suc n) f x = f n (recᴺ n f x)

-- Iteration and recursion for lists.

itᴸ : ∀ {a b} {A : Set a} {B : Set b} → List A → (A → B → B) → B → B
itᴸ []       f x = x
itᴸ (k ∷ ks) f x = f k (itᴸ ks f x)

recᴸ : ∀ {a b} {A : Set a} {B : Set b} → List A → (A → List A → B → B) → B → B
recᴸ []       f x = x
recᴸ (k ∷ ks) f x = f k ks (recᴸ ks f x)

-- Composition, supremum, and infimum for relations.

module _ {W : Set} where
  _⨾_ : (W → W → Set) → (W → W → Set) → (W → W → Set)
  _R_ ⨾ _Q_ = λ w w′ → ∃ (λ v → w R v × v Q w′)

  _⊔_ : (W → W → Set) → (W → W → Set) → (W → W → Set)
  _R_ ⊔ _Q_ = λ w w′ → ∃ (λ v → w R v × w′ Q v)

  _⊓_ : (W → W → Set) → (W → W → Set) → (W → W → Set)
  _R_ ⊓ _Q_ = λ w w′ → ∃ (λ v → v R w × v Q w′)


------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.PropertiesATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality.Type
open import FOTC.Data.List
open import FOTC.Data.Stream

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Stream predicate is also a pre-fixed point of the functional
-- StreamF, i.e.
--
-- StreamF Stream ≤ Stream (see FOTC.Data.Stream.Type).

-- See Issue https://github.com/asr/apia/issues/81 .
Stream-inA : D → Set
Stream-inA xs = ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs'
{-# ATP definition Stream-inA #-}

Stream-in : ∀ {xs} →
            ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs' →
            Stream xs
Stream-in h = Stream-coind Stream-inA h' h
  where
  postulate h' : ∀ {xs} → Stream-inA xs →
                 ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream-inA xs'
  {-# ATP prove h' #-}

-- See Issue https://github.com/asr/apia/issues/81 .
zeros-StreamA : D → Set
zeros-StreamA xs = xs ≡ zeros
{-# ATP definition zeros-StreamA #-}

zeros-Stream : Stream zeros
zeros-Stream = Stream-coind zeros-StreamA h refl
  where
  postulate h : ∀ {xs} → zeros-StreamA xs →
                ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ zeros-StreamA xs'
  {-# ATP prove h #-}

-- See Issue https://github.com/asr/apia/issues/81 .
ones-StreamA : D → Set
ones-StreamA xs = xs ≡ ones
{-# ATP definition ones-StreamA #-}

ones-Stream : Stream ones
ones-Stream = Stream-coind ones-StreamA h refl
  where
  postulate h : ∀ {xs} → ones-StreamA xs →
                ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ ones-StreamA xs'
  {-# ATP prove h #-}

postulate ∷-Stream : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
{-# ATP prove ∷-Stream #-}

-- Adapted from (Sander 1992, p. 59).

-- See Issue https://github.com/asr/apia/issues/81 .
streamLengthR : D → D → Set
streamLengthR m n = ∃[ xs ] Stream xs ∧ m ≡ length xs ∧ n ≡ ∞
{-# ATP definition streamLengthR #-}

streamLength : ∀ {xs} → Stream xs → length xs ≈ ∞
streamLength {xs} Sxs = ≈-coind streamLengthR h₁ h₂
  where
  postulate
    h₁ : ∀ {m n} → streamLengthR m n →
         m ≡ zero ∧ n ≡ zero
           ∨ (∃[ m' ] ∃[ n' ] m ≡ succ₁ m' ∧ n ≡ succ₁ n' ∧ streamLengthR m' n')
  {-# ATP prove h₁ #-}

  postulate h₂ : streamLengthR (length xs) ∞
  {-# ATP prove h₂ #-}

------------------------------------------------------------------------------
-- References
--
-- Sander, Herbert P. (1992). A Logic of Functional Programs with an
-- Application to Concurrency. PhD thesis. Department of Computer
-- Sciences: Chalmers University of Technology and University of
-- Gothenburg.


------------------------------------------------------------------------
-- Simple recognisers
------------------------------------------------------------------------

open import Relation.Binary
open import Relation.Binary.PropositionalEquality hiding ([_])

-- The recognisers are parametrised on the alphabet.

module TotalRecognisers.Simple
         (Tok : Set)
         (_≟_ : Decidable (_≡_ {A = Tok}))
         -- The tokens must come with decidable equality.
         where

open import Algebra
open import Codata.Musical.Notation
open import Data.Bool hiding (_≟_)
import Data.Bool.Properties as Bool
private
  module BoolCS = CommutativeSemiring Bool.∧-∨-commutativeSemiring
open import Function
open import Data.List
open import Data.Product
open import Relation.Nullary

------------------------------------------------------------------------
-- Recogniser combinators

infixl 10 _·_
infixl  5 _∣_

mutual

  -- The index is true if the corresponding language contains the
  -- empty string (is nullable).

  data P : Bool → Set where
    fail  : P false
    empty : P true
    tok   : Tok → P false
    _∣_   : ∀ {n₁ n₂} → P n₁ →            P n₂ → P (n₁ ∨ n₂)
    _·_   : ∀ {n₁ n₂} → P n₁ → ∞⟨ not n₁ ⟩P n₂ → P (n₁ ∧ n₂)

  -- Coinductive if the index is true.

  ∞⟨_⟩P : Bool → Bool → Set
  ∞⟨ true  ⟩P n = ∞ (P n)
  ∞⟨ false ⟩P n =    P n

------------------------------------------------------------------------
-- Conditional coinduction helpers

delayed? : ∀ {b n} → ∞⟨ b ⟩P n → Bool
delayed? {b = b} _ = b

♭? : ∀ {b n} → ∞⟨ b ⟩P n → P n
♭? {true}  x = ♭ x
♭? {false} x =   x

♯? : ∀ {b n} → P n → ∞⟨ b ⟩P n
♯? {true}  x = ♯ x
♯? {false} x =   x

-- A lemma.

♭?♯? : ∀ b {n} {p : P n} → ♭? {b} (♯? p) ≡ p
♭?♯? true  = refl
♭?♯? false = refl

------------------------------------------------------------------------
-- Semantics

-- The semantics is defined inductively: s ∈ p iff the string s is
-- contained in the language defined by p.

infix 4 _∈_

data _∈_ : ∀ {n} → List Tok → P n → Set where
  empty   : [] ∈ empty
  tok     : ∀ {t} → [ t ] ∈ tok t
  ∣-left  : ∀ {s n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} →
            s ∈ p₁ → s ∈ p₁ ∣ p₂
  ∣-right : ∀ {s n₁ n₂} {p₁ : P n₁} {p₂ : P n₂} →
            s ∈ p₂ → s ∈ p₁ ∣ p₂
  _·_     : ∀ {s₁ s₂ n₁ n₂} {p₁ : P n₁} {p₂ : ∞⟨ not n₁ ⟩P n₂} →
            s₁ ∈ p₁ → s₂ ∈ ♭? p₂ → s₁ ++ s₂ ∈ p₁ · p₂

-- A lemma.

cast : ∀ {n} {p p′ : P n} {s} → p ≡ p′ → s ∈ p → s ∈ p′
cast refl s∈ = s∈

------------------------------------------------------------------------
-- Nullability

-- The nullability index is correct.

⇒ : ∀ {n} {p : P n} → [] ∈ p → n ≡ true
⇒ pr = ⇒′ pr refl
  where
  ⇒′ : ∀ {n s} {p : P n} → s ∈ p → s ≡ [] → n ≡ true
  ⇒′ empty                   refl = refl
  ⇒′ tok                     ()
  ⇒′ (∣-left            pr₁) refl with ⇒ pr₁
  ⇒′ (∣-left            pr₁) refl | refl = refl
  ⇒′ (∣-right           pr₂) refl with ⇒ pr₂
  ⇒′ (∣-right {n₁ = n₁} pr₂) refl | refl = proj₂ BoolCS.zero n₁
  ⇒′ (_·_ {[]}    pr₁ pr₂)   refl = cong₂ _∧_ (⇒ pr₁) (⇒ pr₂)
  ⇒′ (_·_ {_ ∷ _} pr₁ pr₂)   ()

⇐ : ∀ {n} (p : P n) → n ≡ true → [] ∈ p
⇐ fail                         ()
⇐ empty                        refl = empty
⇐ (tok t)                      ()
⇐ (_∣_ {true}           p₁ p₂) refl = ∣-left            (⇐ p₁ refl)
⇐ (_∣_ {false} {true}   p₁ p₂) refl = ∣-right {p₁ = p₁} (⇐ p₂ refl)
⇐ (_∣_ {false} {false}  p₁ p₂) ()
⇐ (_·_ {true}  p₁ p₂)          refl = ⇐ p₁ refl · ⇐ p₂ refl
⇐ (_·_ {false} p₁ p₂)          ()

-- We can decide if the empty string belongs to a given language.

nullable? : ∀ {n} (p : P n) → Dec ([] ∈ p)
nullable? {true}  p = yes (⇐ p refl)
nullable? {false} p = no helper
  where
  helper : ¬ [] ∈ p
  helper []∈p with ⇒ []∈p
  ... | ()

------------------------------------------------------------------------
-- Derivative

-- D-nullable and D are placed in a mutual block to ensure that the
-- underscores in the definition of D-nullable can be solved by
-- constraints introduced in the body of D. The functions are not
-- actually mutually recursive.

mutual

  -- The index of the derivative. The right-hand sides (excluding
  -- t′ ≟ t and delayed? p₂) are inferable, but included here so that
  -- they can easily be inspected.

  D-nullable : ∀ {n} → Tok → P n → Bool
  D-nullable t fail      = false
  D-nullable t empty     = false
  D-nullable t (tok t′)  with t′ ≟ t
  D-nullable t (tok t′)  | yes t′≡t = true
  D-nullable t (tok t′)  | no  t′≢t = false
  D-nullable t (p₁ ∣ p₂) = D-nullable t p₁ ∨ D-nullable t p₂
  D-nullable t (p₁ · p₂) with delayed? p₂
  D-nullable t (p₁ · p₂) | true  = D-nullable t p₁ ∧ _
  D-nullable t (p₁ · p₂) | false = D-nullable t p₁ ∧ _ ∨ D-nullable t p₂

  -- D t p is the "derivative" of p with respect to t. It is specified
  -- by the equivalence s ∈ D t p ⇔ t ∷ s ∈ p (proved below).

  D : ∀ {n} (t : Tok) (p : P n) → P (D-nullable t p)
  D t fail      = fail
  D t empty     = fail
  D t (tok t′)  with t′ ≟ t
  D t (tok t′)  | yes t′≡t = empty
  D t (tok t′)  | no  t′≢t = fail
  D t (p₁ ∣ p₂) = D t p₁ ∣ D t p₂
  D t (p₁ · p₂) with delayed? p₂
  D t (p₁ · p₂) | true  = D t p₁ · ♯? (♭ p₂)
  D t (p₁ · p₂) | false = D t p₁ · ♯?    p₂ ∣ D t p₂

-- D is correct.

D-sound : ∀ {s n} {t} {p : P n} → s ∈ D t p → t ∷ s ∈ p
D-sound s∈ = D-sound′ _ _ s∈
  where
  D-sound′ : ∀ {s n} t (p : P n) → s ∈ D t p → t ∷ s ∈ p
  D-sound′ t fail                ()
  D-sound′ t empty               ()
  D-sound′ t (tok t′)            _                   with t′ ≟ t
  D-sound′ t (tok .t)            empty               | yes refl = tok
  D-sound′ t (tok t′)            ()                  | no  t′≢t
  D-sound′ t (p₁ ∣ p₂)           (∣-left  ∈₁)        = ∣-left            (D-sound′ t p₁ ∈₁)
  D-sound′ t (p₁ ∣ p₂)           (∣-right ∈₂)        = ∣-right {p₁ = p₁} (D-sound′ t p₂ ∈₂)
  D-sound′ t (_·_ {true}  p₁ p₂) (∣-left  (∈₁ · ∈₂)) = D-sound′ t p₁ ∈₁ · cast (♭?♯? (not (D-nullable t p₁))) ∈₂
  D-sound′ t (_·_ {true}  p₁ p₂) (∣-right ∈₂)        = ⇐ p₁ refl · D-sound′ t p₂ ∈₂
  D-sound′ t (_·_ {false} p₁ p₂) (∈₁ · ∈₂)           = D-sound′ t p₁ ∈₁ · cast (♭?♯? (not (D-nullable t p₁))) ∈₂

D-complete : ∀ {s n} {t} {p : P n} → t ∷ s ∈ p → s ∈ D t p
D-complete {t = t} t∷s∈ = D-complete′ _ t∷s∈ refl
  where
  D-complete′ : ∀ {s s′ n} (p : P n) → s′ ∈ p → s′ ≡ t ∷ s → s ∈ D t p
  D-complete′         fail     ()  refl
  D-complete′         empty    ()  refl
  D-complete′         (tok t′) _   refl with t′ ≟ t
  D-complete′         (tok .t) tok refl | yes refl = empty
  D-complete′ {[]}    (tok .t) tok refl | no  t′≢t with t′≢t refl
  D-complete′ {[]}    (tok .t) tok refl | no  t′≢t | ()
  D-complete′ (p₁ ∣ p₂)           (∣-left  ∈₁)         refl = ∣-left                    (D-complete ∈₁)
  D-complete′ (p₁ ∣ p₂)           (∣-right ∈₂)         refl = ∣-right {p₁ = D t p₁}     (D-complete ∈₂)
  D-complete′ (_·_ {true}  p₁ p₂) (_·_ {[]}     ∈₁ ∈₂) refl = ∣-right {p₁ = D t p₁ · _} (D-complete ∈₂)
  D-complete′ (_·_ {true}  p₁ p₂) (_·_ {._ ∷ _} ∈₁ ∈₂) refl = ∣-left (D-complete ∈₁ · cast (sym (♭?♯? (not (D-nullable t p₁)))) ∈₂)
  D-complete′ (_·_ {false} p₁ p₂) (_·_ {[]}     ∈₁ ∈₂) refl with ⇒ ∈₁
  D-complete′ (_·_ {false} p₁ p₂) (_·_ {[]}     ∈₁ ∈₂) refl | ()
  D-complete′ (_·_ {false} p₁ p₂) (_·_ {._ ∷ _} ∈₁ ∈₂) refl = D-complete ∈₁ · cast (sym (♭?♯? (not (D-nullable t p₁)))) ∈₂

------------------------------------------------------------------------
-- _∈_ is decidable

-- _∈?_ runs a recogniser. Note that the result is yes or no plus a
-- /proof/ verifying that the answer is correct.

infix 4 _∈?_

_∈?_ : ∀ {n} (s : List Tok) (p : P n) → Dec (s ∈ p)
[]    ∈? p = nullable? p
t ∷ s ∈? p with s ∈? D t p
t ∷ s ∈? p | yes s∈Dtp = yes (D-sound s∈Dtp)
t ∷ s ∈? p | no  s∉Dtp = no  (s∉Dtp ∘ D-complete)