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

module Utils where

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

variable
  ℓ ℓ' ℓ'' : Level

module Test where
  import Algebra.Properties.BooleanAlgebra

  open import Algebra.Bundles

  module _ (B : BooleanAlgebra ℓ ℓ') where
    open BooleanAlgebra B
    open import Algebra.Definitions _≈_

    ∨-complementˡ : LeftInverse ⊤ ¬_ _∨_
    ∨-complementˡ = {! comm+invʳ⇒invˡ ∨-comm ∨-complementʳ !}

    ∨-complement : Inverse ⊤ ¬_ _∨_
    ∨-complement = {! ∨-complementˡ , ∨-complementʳ !}

    ∧-complementˡ : LeftInverse ⊥ ¬_ _∧_
    ∧-complementˡ = {! comm+invʳ⇒invˡ ∧-comm ∧-complementʳ !}

    ∧-complement : Inverse ⊥ ¬_ _∧_
    ∧-complement = {! ∧-complementˡ , ∧-complementʳ !}

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
-- open import Cubical.Structures.CommRing
-- open import Cubical.Relation.Nullary.Base -- ¬_
-- open import Cubical.Relation.Binary.Base
-- open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
-- open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`
-- -- open import Cubical.Structures.Poset
-- open import Cubical.Foundations.Function
-- open import Function.Base using (_∋_)
-- open import Function.Base using (it) -- instance search

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Logic
-- open import Algebra.Definitions
-- open import Cubical.Data.Empty
open import Cubical.HITs.PropositionalTruncation

import Cubical.Data.Empty as ⊥
open import Cubical.Data.Unit.Base

⊥↑ : ∀{ℓ} → hProp ℓ
⊥↑ = Lift ⊥.⊥ , λ ()

⊤↑ : ∀{ℓ} → hProp ℓ
⊤↑ = Lift Unit , isOfHLevelLift 1 (λ _ _ _ → tt)

-- _ = {! ⇔toPath!}

⊔-complementˡ :  ∀ x → ¬ x ⊔ x ≡ ⊤↑ -- LeftInverse _≡_ ⊤ ¬_ _⊔_
⊔-complementˡ = {! comm+invʳ⇒invˡ ⊔-comm ⊔-complementʳ !}

-- ⊔-complementʳ : ∀ x → x ⊔ ¬ x ≡ ∥ [ ⊤ ] ∥ₚ
-- ⊔-complementʳ : ∀(x : hProp ℓ) → x ⊔ ¬ x ≡ ((hProp ℓ) ∋ ⊤)
⊔-complementʳ : ∀(x : hProp ℓ) → x ⊔ ¬ x ≡ ⊤↑
⊔-complementʳ x =  λ i → {! ⊔-comm x (¬ x) i !}

⊔-complement : (∀ x → ¬ x ⊔ x ≡ ⊤↑) × (∀ x → x ⊔ ¬ x ≡ ⊤↑) -- Inverse _≡_ ⊤ ¬_ _⊔_
⊔-complement = ⊔-complementˡ , {! ⊔-complementʳ !}

-- agda deduces
--         Σ Type (λ A → (x y : A) → x ≡ y)
-- hProp normalizes to
--    λ ℓ → Σ (Type ℓ) (λ A → (x y : A) → x ≡ y)
--
⊓-complementˡ :  ∀ x → ¬ x ⊓ x ≡ ⊥ -- LeftInverse _≡_ ⊥ ¬_ _⊓_
⊓-complementˡ = {! isProp!} -- comm+invʳ⇒invˡ ⊓-comm ⊓-complementʳ

⊓-complementʳ :  ∀ x → x ⊓ ¬ x ≡ ⊥
⊓-complementʳ = {!!}

⊓-complement : (∀ x → ¬ x ⊓ x ≡ ⊥) × (∀ x → x ⊓ ¬ x ≡ ⊥) -- Inverse _≡_ ⊥ ¬_ _⊓_
⊓-complement = ⊓-complementˡ , ⊓-complementʳ

⊓-⊔-distribʳ : (P : hProp ℓ) (Q : hProp ℓ')(R : hProp ℓ'')
  → (Q ⊔ R) ⊓ P ≡ (Q ⊓ P) ⊔ (R ⊓ P)
⊓-⊔-distribʳ P Q R = (
  (Q ⊔ R) ⊓ P       ≡⟨ ⊓-comm _ _ ⟩
   P ⊓ (Q ⊔ R)      ≡⟨ ⊓-⊔-distribˡ P Q R ⟩
  (P ⊓ Q) ⊔ (P ⊓ R) ≡⟨ ( λ i → ⊓-comm P Q i ⊔ ⊓-comm P R i) ⟩
  (Q ⊓ P) ⊔ (R ⊓ P) ∎)

_ : isProp ≡ (λ(A : Type ℓ) → (x y : A) → x ≡ y)
_ = refl

-- `sq` stands for "squashed" and |_| is the constructor for ∥_∥
--
--   data ∥_∥ {ℓ} (A : Type ℓ) : Type ℓ where
--     ∣_∣ : A → ∥ A ∥
--     squash : ∀ (x y : ∥ A ∥) → x ≡ y
--
-- (see https://ice1000.org/2018/12-06-CubicalAgda.html#propositional-truncation )
-- we also have
--
--   hProp    ℓ  = Σ[ A ∈ Type ℓ ]  (∀( x  y : A)    → x ≡ y)
--   isContr {ℓ} = λ( A : Type ℓ ) → Σ[ x ∈ A ] (∀ y → x ≡ y)
--   isProp  {ℓ} = λ( A : Type ℓ ) → ∀( x  y : A)    → x ≡ y
--
-- and in `Cubical.Foundations.Id` we have
--
--   postulate
--     Id : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ
--   _≡_ : ∀ {ℓ} {A : Type ℓ} → A → A → Type ℓ
--   _≡_ = Id
--
-- which is imported in `Cubical.Foundations.Everything`, but _≡_ is hidden in favour of the _≡_ from `Agda.Builtin.Cubical.Path`:
--
--   _≡_ : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ
--   _≡_ {A = A} = PathP (λ i → A)
--
-- we have conversion functions between `Id` and `PathP`

-- recall from https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html
--
--   is-center                X c = (x   : X) → c ≡ x
--   is-singleton             X   = Σ  c ꞉ X , is-center X c
--   is-subsingleton          X   = (x y : X) → x ≡ y
--   𝟘-is-subsingleton            : is-subsingleton 𝟘
--   singletons-are-subsingletons : (X : 𝓤 ̇ ) → is-singleton X → is-subsingleton X
--   𝟙-is-subsingleton            : is-subsingleton 𝟙
--
-- now,
--   see https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#axiomatic-approach
--   see https://ice1000.org/2018/12-06-CubicalAgda.html#propositional-truncation
--     However I would not only use recPropTrunc explicitly as we can just use pattern-matching to define functions out of HITs.
--   see https://cstheory.stackexchange.com/questions/30542/squash-type-vs-propositional-truncation-type
--     Squash types correspond to judgmental truncation, not propositional truncation.
--     In a type theory without a type for judgmental equality, there's non much of a way to make use of an inhabitant of a squash type;
--     there's no way to write an eliminator into any type except another squash type.
--     Relatedly, having squash types, as presented in the book you linked, makes typechecking undecidable;
--     having propositional truncation types does not result in this drawback.
--   there is https://github.com/agda/cubical/pull/136
--     Elimination of propositional truncation to higher types

import Cubical.Foundations.Id
import Cubical.HITs.PropositionalTruncation.Properties -- look here for examples

∥∥-isProp : {A : Type ℓ} → ∀ (x y : ∥ A ∥) → x ≡ y
∥∥-isProp {ℓ = ℓ} {A = A} x y = (squash x y)

_ = propTruncIsProp

propTruncIsProp' : {A : Type ℓ} → isProp ∥ A ∥
propTruncIsProp' x y = squash x y

{-

t0 : {A : Type ℓ} → (x y : ∥ A ∥) → x ≡ y -- isProp (∥ A ∥)
t0 x ∣ y ∣ = squash x ∣ y ∣
-- Goal: ∥ A ∥
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ t0 x y₀ j
-- i = i1 ⊢ t0 x y₁ j
-- j = i0 ⊢ x
-- j = i1 ⊢ squash y₀ y₁ i
t0 x (squash y₀ y₁ i) j = {! t0  !}

-}

{-
-- Goal: ∣ x ∣ ≡ ∣ y ∣
t0 ∣ x ∣ ∣ y ∣ = squash ∣ x ∣ ∣ y ∣

-- Goal: ∣ x ∣ ≡ squash y₀ y₁ i
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ t0 ∣ x ∣ y₀
-- i = i1 ⊢ t0 ∣ x ∣ y₁
t0 ∣ x ∣ (squash y₀ y₁ i) = squash ∣ x ∣ (squash y₀ y₁ i) -- {! squash ∣ x ∣ (squash y₀ y₁ i)!} -- {! λ j → squash ∣ x ∣ (squash y₁ y₂ j) {!  !}  !}
t0 (squash x₁ x₂ i) ∣ y ∣ = squash (squash x₁ x₂ i) ∣ y ∣
t0 (squash x₁ x₂ i) (squash y₁ y₂ j) = squash (squash x₁ x₂ i) (squash y₁ y₂ j)
-}

-- Definition 2.4.3. The propositional truncation of a type X
--   is a proposition ∥ X ∥
--   together with a truncation map |_| : X → ∥ X ∥
--   such that for any other proposition Q, given a map g : X → Q, we obtain a map h : ∥ X ∥ → Q.
--
-- Remark 2.4.4. The uniqueness of the obtained map ∥ X ∥ → Q follows from the fact that Q is a proposition, and function extensionality
--
-- The propositional truncation ∥ X ∥ of a type X is a proposition. We may say, quite simply,
-- that we have a constructor sq which is a proof that the type ∥ X ∥ is a squashed to be a propo-
-- sition: it takes two elements of ∥ X ∥ and gives a proof that they are identical, i.e. squashed
-- together.

-- Definition 2.4.7.
-- We refer to types that are propositions as properties.
-- We refer to types that potentially have several witnesses as structure.

{-
module _ {ℓ} (X Y : Type ℓ) (g : X → Y) where

  f : ∥ X ∥ → Y
  f ∣ x ∣ = g x
  f (squash x₀ x₁ i) = {!  !}
-}

-- well, that might not work at all
-- ⊓-unliftˡ : {P : hProp ℓ} {Q : hProp ℓ'}

import Cubical.HITs.PropositionalTruncation.Properties

-- _ : (P : hProp P.ℓ) (Q : hProp Q.ℓ) (R : hProp R.ℓ) → (hProp P.ℓ → hProp Q.ℓ → hProp R.ℓ) → h
-- _ = ?

--_ = _≡ₚ_

⊓-identityˡ-↑ : (P : hProp ℓ) → ⊤↑ {ℓ} ⊓ P ≡ P
⊓-identityˡ-↑ _ = ⇔toPath snd  λ x → lift tt , x

-- \ is \\
-- ↑ is \u

private
  lemma : ∀ x y → x ⊓ y ≡ ⊥ → x ⊔ y ≡ ⊤ → ¬ x ≡ y
  lemma x y x⊓y=⊥ x⊔y=⊤ = (
    ¬ x                    ≡⟨ sym (⊓-identityʳ _) ⟩
    ¬ x ⊓ ⊤                ≡⟨ (λ i → ¬ x ⊓ x⊔y=⊤ (~ i) ) ⟩
    ¬ x ⊓ (x ⊔ y)          ≡⟨ ⊓-⊔-distribˡ (¬ x) x y  ⟩
    (¬ x ⊓ x) ⊔ (¬ x ⊓ y)  ≡⟨ (λ i → ⊓-complementˡ x i ⊔ (¬ x ⊓ y)) ⟩
    ⊥ ⊔ (¬ x ⊓ y)          ≡⟨ (λ i → x⊓y=⊥ (~ i) ⊔ (¬ x ⊓ y)) ⟩
    (x ⊓ y) ⊔ (¬ x ⊓ y)    ≡⟨  sym (⊓-⊔-distribʳ y x (¬ x)) ⟩
    (x ⊔ ¬ x) ⊓ y          ≡⟨ (λ i → (⊔-complementʳ x) i ⊓ y ) ⟩
    ⊤↑ ⊓ y                 ≡⟨ ⊓-identityˡ-↑ _ ⟩
    y                      ∎)

data Prop2Type (P : Prop ℓ) : Type (ℓ-suc ℓ) where
  inₚ : (p : P) → Prop2Type P

Prop-to-hProp : Prop ℓ → hProp (ℓ-suc ℓ)
Prop-to-hProp P = Prop2Type P ,  λ{ (inₚ x) (inₚ y) → refl }


------------------------------------------------------------------------------
-- Proving properties without using pattern matching on refl
------------------------------------------------------------------------------

{-# OPTIONS --no-pattern-matching      #-}
{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}

module FOT.PA.Inductive2Mendelson.NoPatternMatchingOnRefl where

open import PA.Inductive.Base

------------------------------------------------------------------------------
-- From PA.Inductive2Mendelson

S₁ :  ∀ {m n o} → m ≡ n → m ≡ o → n ≡ o
S₁ h₁ h₂ = trans (sym h₁) h₂

S₂ : ∀ {m n} → m ≡ n → succ m ≡ succ n
S₂ {m} h = subst (λ t → succ m ≡ succ t) h refl

-- 20 May 2013. Requires the predecessor function.
-- S₄ : ∀ {m n} → succ m ≡ succ n → m ≡ n


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors where all elements satisfy a given property
------------------------------------------------------------------------

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

module Data.Vec.Relation.Unary.All where

open import Data.Nat.Base using (zero; suc)
open import Data.Fin.Base using (Fin; zero; suc)
open import Data.Product as Prod using (_×_; _,_; uncurry; <_,_>)
open import Data.Vec.Base as Vec using (Vec; []; _∷_)
open import Function using (_∘_)
open import Level using (Level; _⊔_)
open import Relation.Nullary hiding (Irrelevant)
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Unary
open import Relation.Binary.PropositionalEquality as P using (subst)

private
  variable
    a b c p q r : Level
    A : Set a
    B : Set b
    C : Set c

------------------------------------------------------------------------
-- All P xs means that all elements in xs satisfy P.

infixr 5 _∷_

data All {a} {A : Set a} (P : Pred A p) : ∀ {n} → Vec A n → Set (p ⊔ a) where
  []  : All P []
  _∷_ : ∀ {n x} {xs : Vec A n} (px : P x) (pxs : All P xs) → All P (x ∷ xs)

------------------------------------------------------------------------
-- Operations on All

module _ {P : Pred A p} where

  head : ∀ {n x} {xs : Vec A n} → All P (x ∷ xs) → P x
  head (px ∷ pxs) = px

  tail : ∀ {n x} {xs : Vec A n} → All P (x ∷ xs) → All P xs
  tail (px ∷ pxs) = pxs

  uncons : ∀ {n x} {xs : Vec A n} → All P (x ∷ xs) → P x × All P xs
  uncons = < head , tail >

  lookup : ∀ {n} {xs : Vec A n} (i : Fin n) →
           All P xs → P (Vec.lookup xs i)
  lookup zero    (px ∷ pxs) = px
  lookup (suc i) (px ∷ pxs) = lookup i pxs

  tabulate : ∀ {n xs} → (∀ i → P (Vec.lookup xs i)) → All P {n} xs
  tabulate {xs = []}    pxs = []
  tabulate {xs = _ ∷ _} pxs = pxs zero ∷ tabulate (pxs ∘ suc)

module _ {P : Pred A p} {Q : Pred A q} where

  map : ∀ {n} → P ⊆ Q → All P {n} ⊆ All Q {n}
  map g []         = []
  map g (px ∷ pxs) = g px ∷ map g pxs

  zip : ∀ {n} → All P ∩ All Q ⊆ All (P ∩ Q) {n}
  zip ([] , [])             = []
  zip (px ∷ pxs , qx ∷ qxs) = (px , qx) ∷ zip (pxs , qxs)

  unzip : ∀ {n} → All (P ∩ Q) {n} ⊆ All P ∩ All Q
  unzip []           = [] , []
  unzip (pqx ∷ pqxs) = Prod.zip _∷_ _∷_ pqx (unzip pqxs)

module _ {P : Pred A p} {Q : Pred B q} {R : Pred C r} where

  zipWith : ∀ {_⊕_ : A → B → C} →
            (∀ {x y} → P x → Q y → R (x ⊕ y)) →
            ∀ {n xs ys} → All P {n} xs → All Q {n} ys →
            All R {n} (Vec.zipWith _⊕_ xs ys)
  zipWith _⊕_ {xs = []}     {[]}     []         []         = []
  zipWith _⊕_ {xs = x ∷ xs} {y ∷ ys} (px ∷ pxs) (qy ∷ qys) =
    px ⊕ qy ∷ zipWith _⊕_ pxs qys

------------------------------------------------------------------------
-- Properties of predicates preserved by All

module _ {P : Pred A p} where

  all : ∀ {n} → Decidable P → Decidable (All P {n})
  all P? []       = yes []
  all P? (x ∷ xs) = Dec.map′ (uncurry _∷_) uncons (P? x ×-dec all P? xs)

  universal : Universal P → ∀ {n} → Universal (All P {n})
  universal u []       = []
  universal u (x ∷ xs) = u x ∷ universal u xs

  irrelevant : Irrelevant P → ∀ {n} → Irrelevant (All P {n})
  irrelevant irr []           []           = P.refl
  irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) =
    P.cong₂ _∷_ (irr px₁ px₂) (irrelevant irr pxs₁ pxs₂)

  satisfiable : Satisfiable P → ∀ {n} → Satisfiable (All P {n})
  satisfiable (x , p) {zero}  = [] , []
  satisfiable (x , p) {suc n} = Prod.map (x ∷_) (p ∷_) (satisfiable (x , p))


module Luau.Heap where

open import Agda.Builtin.Equality using (_≡_)
open import FFI.Data.Maybe using (Maybe; just)
open import FFI.Data.Vector using (Vector; length; snoc; empty)
open import Luau.Addr using (Addr)
open import Luau.Var using (Var)
open import Luau.Syntax using (Block; Expr; nil; addr; function⟨_⟩_end)

data HeapValue : Set where
  function_⟨_⟩_end : Var → Var → Block → HeapValue

Heap = Vector HeapValue

data _≡_⊕_↦_ : Heap → Heap → Addr → HeapValue → Set where

  defn : ∀ {H val} →

    -----------------------------------
    (snoc H val) ≡ H ⊕ (length H) ↦ val

lookup : Heap → Addr → Maybe HeapValue
lookup = FFI.Data.Vector.lookup

emp : Heap
emp = empty

data AllocResult (H : Heap) (V : HeapValue) : Set where
  ok : ∀ a H′ → (H′ ≡ H ⊕ a ↦ V) → AllocResult H V

alloc : ∀ H V → AllocResult H V
alloc H V = ok (length H) (snoc H V) defn

next : Heap → Addr
next = length

allocated : Heap → HeapValue → Heap
allocated = snoc

-- next-emp : (length empty ≡ 0)
next-emp = FFI.Data.Vector.length-empty

-- lookup-next : ∀ V H → (lookup (allocated H V) (next H) ≡ just V)
lookup-next = FFI.Data.Vector.lookup-snoc

-- lookup-next-emp : ∀ V → (lookup (allocated emp V) 0 ≡ just V)
lookup-next-emp = FFI.Data.Vector.lookup-snoc-empty


module RMonads.SpecialCase where

open import Categories
open import Functors
open import Naturals hiding (Iso)
open import Monads
open import RMonads

leftM : ∀{a}{b}{C : Cat {a}{b}} → Monad C → RMonad (IdF C)
leftM M = record {
  T    = T;
  η    = η;
  bind = bind;
  law1 = law1;
  law2 = law2;
  law3 = law3}
  where open Monad M

rightM : ∀{a b}{C : Cat {a}{b}} → RMonad (IdF C) → Monad C
rightM {C = C} M = record {
  T    = T;
  η    = η;
  bind = bind;
  law1 = law1;
  law2 = law2;
  law3 = law3} where open RMonad M

open import Relation.Binary.HeterogeneousEquality
open import Isomorphism

isoM : ∀{a b}{C : Cat {a}{b}} → Iso (RMonad (IdF C)) (Monad C)
isoM = record {fun = rightM; inv = leftM; law1 = λ {(monad _ _ _ _ _ _) → refl}; law2 = λ {(rmonad _ _ _ _ _ _) → refl}}

open import Monads.MonadMorphs
open import RMonads.RMonadMorphs

leftMM : ∀{a b}{C : Cat {a}{b}}{M M' : Monad C} → MonadMorph M M' →
         RMonadMorph (leftM M) (leftM M')
leftMM MM = record {
  morph   = morph;
  lawη    = lawη;
  lawbind = lawbind} where open MonadMorph MM

rightMM : ∀{a b}{C : Cat {a}{b}}{M M' : RMonad (IdF C)} → RMonadMorph M M' →
          MonadMorph (rightM M) (rightM M')
rightMM MM = record {
  morph   = morph;
  lawη    = lawη;
  lawbind = lawbind} where open RMonadMorph MM

isoMM : ∀{a b}{C : Cat {a}{b}}{M M' : Monad C} →
        Iso (RMonadMorph (leftM M) (leftM M')) (MonadMorph M M')
isoMM {M = monad _ _ _ _ _ _}{M' = monad _ _ _ _ _ _} = record {
 fun  = rightMM;
 inv  = leftMM;
 law1 = λ {(monadmorph _ _ _) → refl};
 law2 = λ {(rmonadmorph _ _ _) → refl}}

open import Adjunctions
open import RAdjunctions

leftA : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}} → Adj C D → RAdj (IdF C) D
leftA {C}{D} A = record{
  L        = L;
  R        = R;
  left     = left;
  right    = right;
  lawa     = lawa;
  lawb     = lawb;
  natleft  = natleft;
  natright = natright} where open Adj A

rightA : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}} → RAdj (IdF C) D → Adj C D
rightA {C = C}{D = D} A = record{
  L        = L;
  R        = R;
  left     = left;
  right    = right;
  lawa     = lawa;
  lawb     = lawb;
  natleft  = natleft;
  natright = natright} where open RAdj A

isoA : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}} →
       Iso (RAdj (IdF C) D) (Adj C D)
isoA = record {
  fun = rightA;
  inv = leftA;
  law1 = λ {(adjunction _ _ _ _ _ _ _ _) → refl};
  law2 = λ {(radjunction _ _ _ _ _ _ _ _) → refl}}


module Forcing where

open import Common.IO
open import Common.Unit
open import Lib.Vec
open import Common.Nat

len : {A : Set}{n : Nat} → Vec A n → Nat
len {A} .{zero}  []             = zero
len {A} .{suc n} (_∷_ {n} x xs) = suc n

len2 : {A : Set}{n : Nat} → Vec A n → Nat
len2 [] = 0
len2 (_∷_ {n} x xs) = suc (len2 {n = n} xs)

len3 : {A : Set}{n : Nat} → Vec A n → Nat
len3 {n = zero}  []              = zero
len3 {n = suc n} (_∷_ .{n} x xs) = suc n

len4 : {A : Set}{n : Nat} → Vec A n → Nat
len4 []                 = zero
len4 (_∷_ {zero}  x xs) = suc zero
len4 (_∷_ {suc n} x xs) = suc (suc n)

main : IO Unit
main =
    printNat (len  l1) ,,
    printNat (len  l2) ,,
    printNat (len  l3) ,,

    printNat (len2 l1) ,,
    printNat (len2 l2) ,,
    printNat (len2 l3) ,,

    printNat (len3 l1) ,,
    printNat (len3 l2) ,,
    printNat (len3 l3) ,,

    printNat (len4 l1) ,,
    printNat (len4 l2) ,,
    printNat (len4 l3) ,,

    return unit
  where l1 = "a" ∷ ("b" ∷ ("c" ∷ []))
        l2 = 1 ∷ (2 ∷ (3 ∷ (4 ∷ (5 ∷ []))))
        l3 : Vec Nat zero
        l3 = []


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

open import HoTT

module homotopy.PathSetIsInitalCover {i} (X : Ptd i)
    -- and an arbitrary covering
    {k} (⊙cov : ⊙Cover X k) where

  open Cover

  private
    univ-cover = path-set-cover X
    module ⊙cov = ⊙Cover ⊙cov

  -- Weak initiality by transport.
  quotient-cover : CoverHom univ-cover ⊙cov.cov
  quotient-cover _ p = cover-trace ⊙cov.cov ⊙cov.pt p

  -- Strong initiality by path induction.
  module Uniqueness
    (cover-hom : CoverHom univ-cover ⊙cov.cov)
    (pres-pt : cover-hom (pt X) idp₀ == ⊙cov.pt)
    where

    private
      lemma₁ : ∀ a p → cover-hom a [ p ] == quotient-cover a [ p ]
      lemma₁ ._ idp = pres-pt

      lemma₂ : ∀ a p → cover-hom a p == quotient-cover a p
      lemma₂ a = Trunc-elim
        (λ p → =-preserves-set (⊙cov.Fiber-level a))
        (lemma₁ a)

    theorem : cover-hom == quotient-cover
    theorem = λ= λ a → λ= $ lemma₂ a


open import Prelude

module Implicits.Resolution.Termination.SizeMeasures where

open import Induction.WellFounded
open import Induction.Nat
open import Data.Product hiding (map)
open import Data.Nat.Base using (_<′_)
open import Data.Fin hiding (_+_; _≤_; _<_; _≤?_)
open import Data.List hiding (map)
open import Data.List.All
open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Data.Nat hiding (_<_)
open import Data.Nat.Properties

-- a strict sizemeasure for types
||_|| : ∀ {ν} → Type ν → ℕ
|| simpl (tc x) || = 1
|| simpl (tvar n) || = 1
|| simpl (a →' b) || = 1 + || a || + || b ||
|| a ⇒ b || = 1 + || a || + || b ||
|| ∀' a || = 1 + || a ||

-- size of the head of a type
h||_|| : ∀ {ν} → Type ν → ℕ
h|| a || = || proj₂ (a ◁) ||

-- type measure on metatypes
m||_|| : ∀ {m ν} → MetaType m ν → ℕ
m|| simpl (tc x) || = 1
m|| simpl (tvar n) || = 1
m|| simpl (mvar n) || = 1
m|| simpl (a →' b) || = suc (m|| a || + m|| b ||)
m|| a ⇒ b || = 1 + (m|| a || + m|| b ||)
m|| ∀' a || = 1 + m|| a ||

-- We package Type with it's deBruijn counter because
-- we need to express orderings such as a sρ< ∀' a
-- where the number of free variables varies.
-- We could express that as ∀ {ν μ} → Type ν → Type μ → Set,
-- but Well-founded _sρ<_ unifies ν and μ,
-- such that the well-founded proof would be too narrow
_hρ≤_ : (a b : ∃ Type) → Set
(_ , a) hρ≤ (_ , b) = h|| a || ≤ h|| b ||

_hρ<_ : (a b : ∃ Type) → Set
(_ , a) hρ< (_ , b) = h|| a || < h|| b ||

_hρ<?_ : ∀ {ν μ} → (a : Type ν) → (b : Type μ) → Dec ((ν , a) hρ< (μ , b))
a hρ<? b with h|| a || | h|| b ||
a hρ<? b | y | z = (suc y) ≤? z

_ρ<_ : ∃ Type → ∃ Type → Set
(_ , a) ρ< (_ , b) = || a || < || b ||

_ρ<?_ : (a b : ∃ Type) → Dec (a ρ< b)
(_ , a) ρ<? (_ , b) with || a || | || b ||
(_ , a) ρ<? (_ , b) | y | z = (suc y) ≤? z

_m<_ : ∃₂ MetaType → ∃₂ MetaType → Set
(_ , _ , a) m< (_ , _ , b) = m|| a || < m|| b ||

_occ[_]<_ : ∀ {ν μ} (a : Type ν) (x : ℕ) (b : Type μ) → Set
a occ[ x ]< b = (occ x (proj₂ (a ◁))) ≤ (occ x (proj₂ (b ◁)))

-- oliveira's termination condition on types
data ⊢term {ν} : (Type ν) → Set where
  term-simp : ∀ {τ} → ⊢term (simpl τ)
  term-tabs : ∀ {a} → ⊢term a → ⊢term (∀' a)
  term-iabs : ∀ {a b} → ⊢term a → ⊢term b → (, a) hρ< (, b) →
              All (λ x → a occ[ toℕ x ]< b) (fvars a ++ fvars b) →
              ⊢term (a ⇒ b)


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

open import Level

module Categories.Category.Instance.One where

open import Data.Unit using (⊤; tt)

open import Categories.Category
open import Categories.Functor
open import Categories.Category.Instance.Cats
import Categories.Object.Terminal as Term

module _ {o ℓ e : Level} where
  open Term (Cats o ℓ e)

  One : Category o ℓ e
  One = record
    { Obj       = Lift o ⊤
    ; _⇒_       = λ _ _ → Lift ℓ ⊤
    ; _≈_       = λ _ _ → Lift e ⊤
    }

  One-⊤ : Terminal
  One-⊤ = record { ⊤ = One ; ! = record { F₀ = λ _ → lift tt } }

-- not only is One terminal, it can be shifted anywhere else. Stronger veersion of !
shift : {o ℓ e : Level} (o′ ℓ′ e′ : Level) → Functor (One {o} {ℓ} {e}) (One {o′} {ℓ′} {e′})
shift o′ ℓ′ e′ = _ -- so obvious, Agda can fill it all in automatically!

One0 : Category 0ℓ 0ℓ 0ℓ
One0 = One {0ℓ} {0ℓ} {0ℓ}


{-
  Verified Red-Black Trees
        Toon Nolten

  Based on Chris Okasaki's "Red-Black Trees in a Functional Setting"
  where he uses red-black trees to implement sets.

  Invariants
  ----------

  1. No red node has a red parent
  2. Every Path from the root to an empty node contains the same number of
     black nodes.
    (Empty nodes are considered black)
-}
module RedBlackTree where

open import Data.Bool using (Bool; true; false) renaming (T to So; not to ¬)
_⇒_ : ∀{ℓ₁ ℓ₂} → Set ℓ₁ → Set ℓ₂ → Set _
P ⇒ T = {{p : P}} → T
infixr 3 _⇒_

if_then_else_ : ∀{ℓ}{A : Set ℓ} b → (So b ⇒ A) → (So (¬ b) ⇒ A) → A
if true  then t else f = t
if false then t else f = f

open import Data.Nat hiding (_<_; _≤_; _≟_; compare)
  renaming (decTotalOrder to ℕ-DTO)
open import Level hiding (suc)
open import Relation.Binary hiding (_⇒_)

open import Data.Sum using (_⊎_) renaming (inj₁ to h+0; inj₂ to h+1)
open import Data.Product using (Σ; Σ-syntax; _,_; proj₁; proj₂)

module RBTree {a ℓ}(order : StrictTotalOrder a ℓ ℓ) where

  open module sto = StrictTotalOrder order
  A = Carrier

  pattern LT = tri< _ _ _
  pattern EQ = tri≈ _ _ _
  pattern GT = tri> _ _ _
  _≤_ = compare

  data Color : Set where
    R B : Color

  _=ᶜ_ : Color → Color → Bool
  R =ᶜ R = true
  B =ᶜ B = true
  _ =ᶜ _ = false

  Height = ℕ

  data Tree : Color → Height → Set a where
    E : Tree B 0
    R : ∀{h} → Tree B h → A → Tree B h → Tree R h
    B : ∀{cl cr h} → Tree cl h → A → Tree cr h → Tree B (suc h)

  data IRTree : Height → Set a where
    IRl : ∀{h} → Tree R h → A → Tree B h → IRTree h
    IRr : ∀{h} → Tree B h → A → Tree R h → IRTree h

  data OutOfBalance : Height → Set a where
    _◂_◂_ : ∀{c h} → IRTree h → A → Tree c h → OutOfBalance h
    _▸_▸_ : ∀{c h} → Tree c h → A → IRTree h → OutOfBalance h

  data Treeish : Color → Height → Set a where
    RB : ∀{c h} → Tree c h → Treeish c h
    IR : ∀{h} → IRTree h → Treeish R h

  -- Insertion

  balance : ∀{h} → OutOfBalance h → Tree R (suc h)
  balance (IRl (R a x b) y c ◂ z ◂ d) = R (B a x b) y (B c z d)
  balance (IRr a x (R b y c) ◂ z ◂ d) = R (B a x b) y (B c z d)
  balance (a ▸ x ▸ IRl (R b y c) z d) = R (B a x b) y (B c z d)
  balance (a ▸ x ▸ IRr b y (R c z d)) = R (B a x b) y (B c z d)

  blacken : ∀{c h} → (Treeish c h)
            → (if c =ᶜ B then Tree B h else Tree B (suc h))
  blacken (RB E) = E
  blacken (RB (R l b r)) = (B l b r)
  blacken (RB (B l b r)) = (B l b r)
  blacken (IR (IRl l b r)) = (B l b r)
  blacken (IR (IRr l b r)) = (B l b r)

  ins : ∀{c h} → (a : A) → (t : Tree c h)
        → Σ[ c' ∈ Color ] (if c =ᶜ B then (Tree c' h) else (Treeish c' h))
  ins a E = R , R E a E
  --
  ins a (R _ b _) with a ≤ b
  ins a (R l _ _) | LT with ins a l
  ins _ (R _ b r) | LT | R , t = R , IR (IRl t b r)
  ins _ (R _ b r) | LT | B , t = R , (RB (R t b r))
  ins _ (R l b r) | EQ = R , RB (R l b r)
  ins a (R _ _ r) | GT with ins a r
  ins _ (R l b _) | GT | R , t = R , (IR (IRr l b t))
  ins _ (R l b _) | GT | B , t = R , (RB (R l b t))
  --
  ins a (B _ b _) with a ≤ b
  ins a (B l _ _) | LT with ins a l
  ins _ (B {R} _ b r) | LT | c , RB t = B , B t b r
  ins _ (B {R} _ b r) | LT | .R , IR t = R , balance (t ◂ b ◂ r)
  ins _ (B {B} _ b r) | LT | c , t = B , B t b r
  ins _ (B l b r) | EQ = B , B l b r
  ins a (B _ _ r) | GT with ins a r
  ins _ (B {cr = R} l b _) | GT | c , RB t = B , B l b t
  ins _ (B {cr = R} l b _) | GT | .R , IR t = R , balance (l ▸ b ▸ t)
  ins _ (B {cr = B} l b _) | GT | c , t = B , B l b t

  insert : ∀{c h} → (a : A) → (t : Tree c h)
           → Tree B h ⊎ Tree B (suc h)
  insert {R} a t with ins a t
  ... | R , t' = h+1 (blacken t')
  ... | B , t' = h+0 (blacken t')
  insert {B} a t with ins a t
  ... | R , t' = h+1 (blacken (RB t'))
  ... | B , t' = h+0 (blacken (RB t'))

  -- Simple Set Operations
  set : ∀{c h} → Set _
  set {c}{h} = Tree c h

  empty : set
  empty = E

  member : ∀{c h} → (a : A) → set {c}{h} → Bool
  member a E = false
  member a (R l b r) with a ≤ b
  ... | LT = member a l
  ... | EQ = true
  ... | GT = member a r
  member a (B l b r) with a ≤ b
  ... | LT = member a l
  ... | EQ = true
  ... | GT = member a r

-- Usage example

open import Relation.Binary.Properties.DecTotalOrder ℕ-DTO
ℕ-STO : StrictTotalOrder _ _ _
ℕ-STO = strictTotalOrder

open module rbtree = RBTree ℕ-STO

t0 : Tree B 2
t0 = B (R (B E 1 E) 2 (B (R E 3 E) 5 (R E 7 E)))
       8
       (B E 9 (R E 10 E))

t1 : Tree B 3
t1 = B (B (B E 1 E) 2 (B E 3 E))
       4
       (B (B E 5 (R E 7 E)) 8 (B E 9 (R E 10 E)))

t2 : Tree B 3
t2 = B (B (B E 1 E) 2 (B E 3 E))
       4
       (B (R (B E 5 E) 6 (B E 7 E)) 8 (B E 9 (R E 10 E)))

open import Relation.Binary.PropositionalEquality
t1≡t0+4 : h+1 t1 ≡ insert 4 t0
t1≡t0+4 = refl

t2≡t1+6 : h+0 t2 ≡ insert 6 t1
t2≡t1+6 = refl


module Proofs where

open import Agda.Builtin.Equality
open import Relation.Binary.PropositionalEquality.Core
open import Data.Nat

open ≡-Reasoning

open import Classes

data Vec : ℕ → Set → Set where
  Nil  : ∀ {a} → Vec 0 a
  Cons : ∀ {n A} → (a : A) → Vec n A → Vec (suc n) A

cons-cong : ∀ {n A} {a c : A} {b d : Vec n A} → a ≡ c → b ≡ d → Cons a b ≡ Cons c d
cons-cong {_} {_} {a} {c} {b} {d} p q = begin
  Cons a b ≡⟨ cong (λ x → Cons a x) q ⟩
  Cons a d ≡⟨ cong (λ x → Cons x d) p ⟩
  Cons c d ∎

instance
  VecF : {n : ℕ} → Functor (Vec n)
  VecF = record {
    fmap = fmap' ;
    F-id = id' ;
    F-∘ = comp' }
    where
      fmap' : ∀ {n A B} → (A → B) → Vec n A → Vec n B
      fmap' f Nil = Nil
      fmap' f (Cons a v) = Cons (f a) (fmap' f v)

      id' : ∀ {n A} → (a : Vec n A) → fmap' id a ≡ a
      id' Nil = refl
      id' (Cons a v) = cong (λ w → Cons a w) (id' v)

      comp' : ∀ {n A B C} → (g : B → C) (f : A → B) (a : Vec n A) → fmap' (g ∘ f) a ≡ (fmap' g ∘ fmap' f) a
      comp' g f Nil = refl
      comp' g f (Cons a v) = cons-cong refl (comp' g f v)

full : ∀ {A} → A → (n : ℕ) → Vec n A
full x zero = Nil
full x (suc n) = Cons x (full x n)

zipWith : ∀ {n A B C} → (A → B → C) → Vec n A → Vec n B → Vec n C
zipWith _ Nil Nil = Nil
zipWith f (Cons a v) (Cons b w) = Cons (f a b) (zipWith f v w)

instance
  VecA : {n : ℕ} → Applicative (Vec n)
  VecA {n} = record
           { pure = λ x → full x n
           ; _<*>_ = ap'
           ; A-id = id'
           ; A-∘ = comp'
           ; A-hom = hom'
           ; A-ic = ic'
           }
    where
      ap' : ∀ {n A B} (v : Vec n (A → B)) (w : Vec n A) → Vec n B
      ap' Nil Nil = Nil
      ap' (Cons a v) (Cons b w) = Cons (a b) (ap' v w)

      id' : ∀ {n A} (v : Vec n A) → ap' (full id n) v ≡ v
      id' Nil = refl
      id' (Cons a v) = cons-cong refl (id' v)

      comp' : ∀ {n A B C} → (u : Vec n (B → C)) (v : Vec n (A → B)) (w : Vec n A)
              → ap' (ap' (ap' (full _∘_ n) u) v) w ≡ ap' u (ap' v w)
      comp' Nil Nil Nil = refl
      comp' (Cons a u) (Cons b v) (Cons c w) = cons-cong refl (comp' u v w)

      hom' : ∀ {n A B} (f : A → B) (x : A) → ap' (full f n) (full x n) ≡ full (f x) n
      hom' {zero} f x = refl
      hom' {suc n} f x = cons-cong refl (hom' {n} f x)

      ic' : ∀ {n A B} (u : Vec n (A → B)) (y : A) → ap' u (full y n) ≡ ap' (full (_$ y) n) u
      ic' Nil y = refl
      ic' (Cons a u) y = cons-cong refl (ic' u y)

tail : ∀ {n A} → Vec (suc n) A → Vec n A
tail (Cons x v) = v

diag : ∀ {n A} → Vec n (Vec n A) → Vec n A
diag Nil = Nil
diag (Cons (Cons a w) v) = Cons a (diag (fmap tail v))

fmap-pure : ∀ {A B F} {{aF : Applicative F}} (f : A → B) (x : A)
            → fmap f (Applicative.pure aF x) ≡ Applicative.pure aF (f x)
fmap-pure f x = begin
  fmap f (pure x) ≡⟨ sym (appFun f (pure x)) ⟩
  pure f <*> pure x ≡⟨ A-hom f x ⟩
  pure (f x) ∎

diag-full : ∀ {A} (n : ℕ) (v : Vec n A) → diag (full v n) ≡ v
diag-full _ Nil = refl
diag-full (suc n) (Cons a v) = cons-cong refl (begin
  diag (fmap tail (full (Cons a v) n)) ≡⟨ cong diag (fmap-pure tail (Cons a v)) ⟩
  diag (full v n) ≡⟨ diag-full n v ⟩
  v ∎)

instance
  VecM : {n : ℕ} → Monad (Vec n)
  VecM = record { _>>=_ = bind' ;
                  left-1 = left' ;
                  right-1 = {!!} ;
                  assoc = {!!} }

    where
      bind' : ∀ {n A B} → Vec n A → (A → Vec n B) → Vec n B
      bind' v f = diag (fmap f v)

      left' : ∀ {n A B} (a : A) (k : A → Vec n B) → bind' (pure a) k ≡ k a
      left' {n} a k = begin
          diag (fmap k (full a n)) ≡⟨ cong diag (fmap-pure k a) ⟩
          diag (full (k a) n) ≡⟨ diag-full n (k a) ⟩
          k a ∎

      right' : ∀ {n A} (m : Vec n A) → bind' m pure ≡ m
      right' Nil = refl
      right' (Cons a m) = begin
        bind' (Cons a m) pure ≡⟨ refl ⟩
        diag (fmap pure (Cons a m)) ≡⟨ cons-cong refl {!!} ⟩ -- :(
        Cons a m ∎


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

open import Cubical.Foundations.Prelude
open import Cubical.Data.Sigma
open import Cubical.Data.Prod renaming (_×_ to _×'_)
open import Cubical.Data.Int renaming (_+_ to _+Int_ ; _-_ to _-Int_)
open import Cubical.Data.Unit

open import Cubical.Algebra.Monoid hiding (⟨_⟩)
open import Cubical.Algebra.Semigroup hiding (⟨_⟩)
open import Cubical.Foundations.HLevels

private
  variable
    ℓ : Level

record IsGroup {G : Type ℓ}
               (0g : G) (_+_ : G → G → G) (-_ : G → G) : Type ℓ where

  no-eta-equality
  constructor isgroup

  field
    isMonoid  : IsMonoid 0g _+_
    inverse   : (x : G) → (x + (- x) ≡ 0g) × ((- x) + x ≡ 0g)

  open IsMonoid isMonoid public

  infixl 6 _-_

  _-_ : G → G → G
  x - y = x + (- y)

  invl : (x : G) → (- x) + x ≡ 0g
  invl x = inverse x .snd

  invr : (x : G) → x + (- x) ≡ 0g
  invr x = inverse x .fst

η-isGroup : {G : Type ℓ} {0g 0g' : G} {_+_ _+'_  : G → G → G} { -_ -'_  : G → G}
         → 0g ≡ 0g'
         → _+_ ≡ _+'_
         → -_ ≡ -'_
         → IsGroup 0g _+_ -_ ≡ IsGroup 0g' _+'_ -'_
η-isGroup id1 id2 id3 i = IsGroup (id1 i) (id2 i) (id3 i)

record Group : Type (ℓ-suc ℓ) where
  no-eta-equality
  constructor group
  field
    Carrier : Type ℓ
    0g      : Carrier
    _+_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    isGroup : IsGroup 0g _+_ -_

  infix  8 -_
  infixr 7 _+_

  open IsGroup isGroup public

Group₀ : Type₁
Group₀ = Group {ℓ-zero}

-- Extractor for the carrier type
⟨_⟩ : Group → Type ℓ
⟨_⟩ = Group.Carrier

isSetGroup : (G : Group {ℓ}) → isSet ⟨ G ⟩
isSetGroup G = Group.isGroup G .IsGroup.isMonoid .IsMonoid.isSemigroup .IsSemigroup.is-set

makeIsGroup : {G : Type ℓ} {0g : G} {_+_ : G → G → G} { -_ : G → G}
              (is-setG : isSet G)
              (assoc : (x y z : G) → x + (y + z) ≡ (x + y) + z)
              (rid : (x : G) → x + 0g ≡ x)
              (lid : (x : G) → 0g + x ≡ x)
              (rinv : (x : G) → x + (- x) ≡ 0g)
              (linv : (x : G) → (- x) + x ≡ 0g)
            → IsGroup 0g _+_ -_
IsGroup.isMonoid (makeIsGroup is-setG assoc rid lid rinv linv) = makeIsMonoid is-setG assoc rid lid
IsGroup.inverse (makeIsGroup is-setG assoc rid lid rinv linv) = λ x → rinv x , linv x

makeGroup : {G : Type ℓ} (0g : G) (_+_ : G → G → G) (-_ : G → G)
            (is-setG : isSet G)
            (assoc : (x y z : G) → x + (y + z) ≡ (x + y) + z)
            (rid : (x : G) → x + 0g ≡ x)
            (lid : (x : G) → 0g + x ≡ x)
            (rinv : (x : G) → x + (- x) ≡ 0g)
            (linv : (x : G) → (- x) + x ≡ 0g)
          → Group
Group.Carrier (makeGroup 0g _+_ -_ is-setG assoc rid lid rinv linv) = _
Group.0g (makeGroup 0g _+_ -_ is-setG assoc rid lid rinv linv) = 0g
Group._+_ (makeGroup 0g _+_ -_ is-setG assoc rid lid rinv linv) = _+_
Group.- makeGroup 0g _+_ -_ is-setG assoc rid lid rinv linv = -_
Group.isGroup (makeGroup 0g _+_ -_ is-setG assoc rid lid rinv linv) = makeIsGroup is-setG assoc rid lid rinv linv

makeGroup-right : ∀ {ℓ} {A : Type ℓ}
  → (id : A)
  → (comp : A → A → A)
  → (inv : A → A)
  → (set : isSet A)
  → (assoc : ∀ a b c → comp a (comp b c) ≡ comp (comp a b) c)
  → (rUnit : ∀ a → comp a id ≡ a)
  → (rCancel : ∀ a → comp a (inv a) ≡ id)
  → Group
makeGroup-right {A = A} id comp inv set assoc rUnit rCancel =
  makeGroup id comp inv set assoc rUnit lUnit rCancel lCancel
  where
    _⨀_ = comp
    abstract
      lCancel : ∀ a → comp (inv a) a ≡ id
      lCancel a =
        inv a ⨀ a
          ≡⟨ sym (rUnit (comp (inv a) a))  ⟩
        (inv a ⨀ a) ⨀ id
          ≡⟨ cong (comp (comp (inv a) a)) (sym (rCancel (inv a))) ⟩
        (inv a ⨀ a) ⨀ (inv a ⨀ (inv (inv a)))
          ≡⟨ assoc _ _ _ ⟩
        ((inv a ⨀ a) ⨀ (inv a)) ⨀ (inv (inv a))
          ≡⟨ cong (λ □ → □ ⨀ _) (sym (assoc _ _ _)) ⟩
        (inv a ⨀ (a ⨀ inv a)) ⨀ (inv (inv a))
          ≡⟨ cong (λ □ → (inv a ⨀ □) ⨀ (inv (inv a))) (rCancel a) ⟩
        (inv a ⨀ id) ⨀ (inv (inv a))
          ≡⟨ cong (λ □ → □ ⨀ (inv (inv a))) (rUnit (inv a)) ⟩
        inv a ⨀ (inv (inv a))
          ≡⟨ rCancel (inv a) ⟩
        id
          ∎

      lUnit : ∀ a → comp id a ≡ a
      lUnit a =
        id ⨀ a
          ≡⟨ cong (λ b → comp b a) (sym (rCancel a)) ⟩
        (a ⨀ inv a) ⨀ a
          ≡⟨ sym (assoc _ _ _) ⟩
        a ⨀ (inv a ⨀ a)
          ≡⟨ cong (comp a) (lCancel a) ⟩
        a ⨀ id
          ≡⟨ rUnit a ⟩
        a
          ∎

makeGroup-left : ∀ {ℓ} {A : Type ℓ}
  → (id : A)
  → (comp : A → A → A)
  → (inv : A → A)
  → (set : isSet A)
  → (assoc : ∀ a b c → comp a (comp b c) ≡ comp (comp a b) c)
  → (lUnit : ∀ a → comp id a ≡ a)
  → (lCancel : ∀ a → comp (inv a) a ≡ id)
  → Group
makeGroup-left {A = A} id comp inv set assoc lUnit lCancel =
  makeGroup id comp inv set assoc rUnit lUnit rCancel lCancel
  where
    abstract
      rCancel : ∀ a → comp a (inv a) ≡ id
      rCancel a =
        comp a (inv a)
          ≡⟨ sym (lUnit (comp a (inv a)))  ⟩
        comp id (comp a (inv a))
          ≡⟨ cong (λ b → comp b (comp a (inv a))) (sym (lCancel (inv a))) ⟩
        comp (comp (inv (inv a)) (inv a)) (comp a (inv a))
          ≡⟨ sym (assoc (inv (inv a)) (inv a) (comp a (inv a))) ⟩
        comp (inv (inv a)) (comp (inv a) (comp a (inv a)))
          ≡⟨ cong (comp (inv (inv a))) (assoc (inv a) a (inv a)) ⟩
        comp (inv (inv a)) (comp (comp (inv a) a) (inv a))
          ≡⟨ cong (λ b → comp (inv (inv a)) (comp b (inv a))) (lCancel a) ⟩
        comp (inv (inv a)) (comp id (inv a))
          ≡⟨ cong (comp (inv (inv a))) (lUnit (inv a)) ⟩
        comp (inv (inv a)) (inv a)
          ≡⟨ lCancel (inv a) ⟩
        id
          ∎

      rUnit : ∀ a → comp a id ≡ a
      rUnit a =
        comp a id
          ≡⟨ cong (comp a) (sym (lCancel a)) ⟩
        comp a (comp (inv a) a)
          ≡⟨ assoc a (inv a) a ⟩
        comp (comp a (inv a)) a
          ≡⟨ cong (λ b → comp b a) (rCancel a) ⟩
        comp id a
          ≡⟨ lUnit a ⟩
        a
          ∎

open Group
open IsGroup

η-Group : {G H : Group {ℓ}}
       → (p : ⟨ G ⟩ ≡ ⟨ H ⟩)
       → (q : PathP (λ i → p i) (0g G) (0g H))
       → (r : PathP (λ i → (p i) → (p i) → (p i)) (_+_ G) (_+_ H))
       → (s : PathP (λ i → p i → p i) (-_ G) (-_ H))
       → PathP (λ i → IsGroup (q i) (r i) (s i)) (isGroup G) (isGroup H)
       → G ≡ H
Carrier (η-Group p _ _ _ _ i) = p i
0g (η-Group _ q _ _ _ i) = q i
_+_ (η-Group _ _ r _ _ i) = r i
- η-Group _ _ _ s t i = s i
isGroup (η-Group _ _ _ _ t i) = t i

isSetCarrier : ∀ {ℓ} → (G : Group {ℓ}) → isSet ⟨ G ⟩
isSetCarrier G = IsSemigroup.is-set (IsMonoid.isSemigroup (isMonoid G))

open IsMonoid
open IsSemigroup
dirProd : ∀ {ℓ ℓ'} → Group {ℓ} → Group {ℓ'} → Group
Carrier (dirProd A B) = Carrier A × Carrier B
0g (dirProd A B) = (0g A) , (0g B)
_+_ (dirProd A B) a b = (_+_ A (fst a) (fst b)) , _+_ B (snd a) (snd b)
-_ (dirProd A B) a = (-_ A (fst a)) , (-_ B (snd a))
is-set (isSemigroup (isMonoid (isGroup (dirProd A B)))) =
  isOfHLevelΣ 2 (isSetCarrier A) λ _ → isSetCarrier B
assoc (isSemigroup (isMonoid (isGroup (dirProd A B)))) x y z i =
  assoc (isGroup A) (fst x) (fst y) (fst z) i , assoc (isGroup B) (snd x) (snd y) (snd z) i
identity (isMonoid (isGroup (dirProd A B))) x =
   (λ i → IsGroup.rid (isGroup A) (fst x) i , IsGroup.rid (isGroup B) (snd x) i)
 , λ i → IsGroup.lid (isGroup A) (fst x) i , IsGroup.lid (isGroup B) (snd x) i
inverse (isGroup (dirProd A B)) x =
    (λ i → (fst (inverse (isGroup A) (fst x)) i) , (fst (inverse (isGroup B) (snd x)) i))
  , λ i → (snd (inverse (isGroup A) (fst x)) i) , (snd (inverse (isGroup B) (snd x)) i)

trivialGroup : Group₀
Carrier trivialGroup = Unit
0g trivialGroup = _
_+_ trivialGroup _ _ = _
-_ trivialGroup _ = _
is-set (isSemigroup (isMonoid (isGroup trivialGroup))) = isSetUnit
assoc (isSemigroup (isMonoid (isGroup trivialGroup))) _ _ _ = refl
identity (isMonoid (isGroup trivialGroup)) _ = refl , refl
inverse (isGroup trivialGroup) _ = refl , refl

intGroup : Group₀
Carrier intGroup = Int
0g intGroup = 0
_+_ intGroup = _+Int_
- intGroup = 0 -Int_
is-set (isSemigroup (isMonoid (isGroup intGroup))) = isSetInt
assoc (isSemigroup (isMonoid (isGroup intGroup))) = +-assoc
identity (isMonoid (isGroup intGroup)) x = refl , (+-comm (pos 0) x)
inverse (isGroup intGroup) x = +-comm x (pos 0 -Int x) ∙ minusPlus x 0 , (minusPlus x 0)


{-# OPTIONS --without-K --safe #-}
module Categories.Yoneda where

-- Yoneda Lemma.  In total, provides:
-- * the Yoneda Embedding (called embed here) from any Category C into Presheaves C
--   Worth noticing that there is no 'locally small' condition here; however, if one looks at
--   the levels involved, there is indeed a raise from that of C to that of Presheaves C.
-- * The traditional Yoneda lemma (yoneda-inverse) which says that for any object a of C, and
--   any Presheaf F over C (where our presheaves are over Setoids), then
--   Hom[ Presheaves C] (Functor.F₀ embed a , F) ≅ Functor.F₀ F a
--   as Setoids. In addition, Yoneda (yoneda) also says that this isomorphism is natural in a and F.
open import Level
open import Function.Base using (_$_)
open import Function.Bundles using (Inverse)
open import Function.Equality using (Π; _⟨$⟩_; cong)
open import Relation.Binary.Bundles using (module Setoid)
import Relation.Binary.Reasoning.Setoid as SetoidR
open import Data.Product using (_,_; Σ)

open import Categories.Category using (Category; _[_,_])
open import Categories.Category.Product using (πʳ; πˡ; _※_)
open import Categories.Category.Construction.Presheaves using (Presheaves)
open import Categories.Category.Construction.Functors using (eval)
open import Categories.Category.Instance.Setoids using (Setoids)
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.Functor.Hom using (module Hom; Hom[_][-,_]; Hom[_][-,-])
open import Categories.Functor.Bifunctor using (Bifunctor)
open import Categories.Functor.Presheaf using (Presheaf)
open import Categories.Functor.Construction.LiftSetoids using (LiftSetoids)
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper) renaming (id to idN)
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)

import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR
import Categories.NaturalTransformation.Hom as NT-Hom

private
  variable
    o ℓ e : Level

module Yoneda (C : Category o ℓ e) where
  open Category C hiding (op) -- uses lots
  open HomReasoning using (_○_; ⟺)
  open MR C using (id-comm)
  open NaturalTransformation using (η; commute)
  open NT-Hom C using (Hom[A,C]⇒Hom[B,C])
  private
    module CE = Category.Equiv C using (refl)
    module C = Category C using (op)

  -- The Yoneda embedding functor
  embed : Functor C (Presheaves C)
  embed = record
    { F₀           = Hom[ C ][-,_]
    ; F₁           = Hom[A,C]⇒Hom[B,C] -- A⇒B induces a NatTrans on the Homs.
    ; identity     = identityˡ ○_
    ; homomorphism = λ h₁≈h₂ → ∘-resp-≈ʳ h₁≈h₂ ○ assoc
    ; F-resp-≈     = λ f≈g h≈i → ∘-resp-≈ f≈g h≈i
    }

  -- Using the adjunction between product and product, we get a kind of contravariant Bifunctor
  yoneda-inverse : (a : Obj) (F : Presheaf C (Setoids ℓ e)) →
    Inverse (Category.hom-setoid (Presheaves C) {Functor.F₀ embed a} {F}) (Functor.F₀ F a)
  yoneda-inverse a F = record
    { f = λ nat → η nat a ⟨$⟩ id
    ; f⁻¹ = λ x → ntHelper record
        { η       = λ X → record
          { _⟨$⟩_ = λ X⇒a → F.₁ X⇒a ⟨$⟩ x
          ; cong  = λ i≈j → F.F-resp-≈ i≈j SE.refl
          }
        ; commute = λ {X} {Y} Y⇒X {f} {g} f≈g →
          let module SR = SetoidR (F.₀ Y) in
          SR.begin
             F.₁ (id ∘ f ∘ Y⇒X) ⟨$⟩ x   SR.≈⟨ F.F-resp-≈ (identityˡ ○ ∘-resp-≈ˡ f≈g) (SE.refl {x}) ⟩
             F.₁ (g ∘ Y⇒X) ⟨$⟩ x        SR.≈⟨ F.homomorphism SE.refl ⟩
             F.₁ Y⇒X ⟨$⟩ (F.₁ g ⟨$⟩ x)
           SR.∎
        }
    ; cong₁ = λ i≈j → i≈j CE.refl
    ; cong₂ = λ i≈j y≈z → F.F-resp-≈ y≈z i≈j
    ; inverse = (λ Fa → F.identity SE.refl) , λ nat {x} {z} z≈y →
        let module S     = Setoid (F.₀ x) in
        S.trans (S.sym (commute nat z CE.refl))
                (cong (η nat x) (identityˡ ○ identityˡ ○ z≈y))
    }
    where
    module F = Functor F using (₀; ₁; F-resp-≈; homomorphism; identity)
    module SE = Setoid (F.₀ a) using (refl)

  private
    -- in this bifunctor, a presheaf from Presheaves C goes from C to Setoids ℓ e,
    -- but the over Setoids has higher level than the hom setoids.
    Nat[Hom[C][-,c],F] : Bifunctor (Presheaves C) (Category.op C) (Setoids _ _)
    Nat[Hom[C][-,c],F] = Hom[ Presheaves C ][-,-] ∘F (Functor.op embed ∘F πʳ ※ πˡ)

    -- in this bifunctor, it needs to go from Presheaves which maps C to Setoids ℓ e,
    -- so the universe level needs to be lifted.
    FC : Bifunctor (Presheaves C) (Category.op C) (Setoids _ _)
    FC = LiftSetoids (o ⊔ ℓ ⊔ e) (o ⊔ ℓ) ∘F eval {C = Category.op C} {D = Setoids ℓ e}

    module yoneda-inverse {a} {F} = Inverse (yoneda-inverse a F)

  -- the two bifunctors above are naturally isomorphic.
  -- it is easy to show yoneda-inverse first then to yoneda.
  yoneda : NaturalIsomorphism Nat[Hom[C][-,c],F] FC
  yoneda = record
    { F⇒G = ntHelper record
      { η       = λ where
        (F , A) → record
          { _⟨$⟩_ = λ α → lift (yoneda-inverse.f α)
          ; cong  = λ i≈j → lift (i≈j CE.refl)
          }
      ; commute = λ where
        {_} {G , B} (α , f) {β} {γ} β≈γ → lift $ cong (η α B) (helper f β γ β≈γ)
      }
    ; F⇐G = ntHelper record
      { η       = λ (F , A) → record
          { _⟨$⟩_ = λ x → yoneda-inverse.f⁻¹ (lower x)
          ; cong  = λ i≈j y≈z → Functor.F-resp-≈ F y≈z (lower i≈j)
          }
      ; commute = λ (α , f) eq eq′ → helper′ α f (lower eq) eq′
      }
    ; iso = λ (F , A) → record
        { isoˡ = λ {α β} i≈j {X} y≈z →
          Setoid.trans (Functor.F₀ F X) ( yoneda-inverse.inverseʳ α {x = X} y≈z) (i≈j CE.refl)
        ; isoʳ = λ eq → lift (Setoid.trans (Functor.F₀ F A) ( yoneda-inverse.inverseˡ {F = F} _) (lower eq))
        }
    }
    where helper : {F : Functor C.op (Setoids ℓ e)}
                   {A B : Obj} (f : B ⇒ A)
                   (β γ : NaturalTransformation Hom[ C ][-, A ] F) →
                   Setoid._≈_ (Functor.F₀ Nat[Hom[C][-,c],F] (F , A)) β γ →
                   Setoid._≈_ (Functor.F₀ F B) (η β B ⟨$⟩ f ∘ id) (Functor.F₁ F f ⟨$⟩ (η γ A ⟨$⟩ id))
          helper {F} {A} {B} f β γ β≈γ = S.begin
            η β B ⟨$⟩ f ∘ id          S.≈⟨ cong (η β B) (id-comm ○ (⟺ identityˡ)) ⟩
            η β B ⟨$⟩ id ∘ id ∘ f     S.≈⟨ commute β f CE.refl ⟩
            F.₁ f ⟨$⟩ (η β A ⟨$⟩ id) S.≈⟨ cong (F.₁ f) (β≈γ CE.refl) ⟩
            F.₁ f ⟨$⟩ (η γ A ⟨$⟩ id) S.∎
            where
            module F = Functor F using (₀;₁)
            module S = SetoidR (F.₀ B)

          helper′ : ∀ {F G : Functor (Category.op C) (Setoids ℓ e)}
                      {A B Z : Obj}
                      {h i : Z ⇒ B}
                      {X Y : Setoid.Carrier (Functor.F₀ F A)}
                      (α : NaturalTransformation F G)
                      (f : B ⇒ A) →
                      Setoid._≈_ (Functor.F₀ F A) X Y →
                      h ≈ i →
                      Setoid._≈_ (Functor.F₀ G Z) (Functor.F₁ G h ⟨$⟩ (η α B ⟨$⟩ (Functor.F₁ F f ⟨$⟩ X)))
                                          (η α Z ⟨$⟩ (Functor.F₁ F (f ∘ i) ⟨$⟩ Y))
          helper′ {F} {G} {A} {B} {Z} {h} {i} {X} {Y} α f eq eq′ = S.begin
            G.₁ h ⟨$⟩ (η α B ⟨$⟩ (F.₁ f ⟨$⟩ X)) S.≈˘⟨ commute α h (S′.sym (cong (F.₁ f) eq)) ⟩
            η α Z ⟨$⟩ (F.₁ h ⟨$⟩ (F.₁ f ⟨$⟩ Y)) S.≈⟨ cong (η α Z) (F.F-resp-≈ eq′ S′.refl) ⟩
            η α Z ⟨$⟩ (F.₁ i ⟨$⟩ (F.₁ f ⟨$⟩ Y)) S.≈˘⟨ cong (η α Z) (F.homomorphism (Setoid.refl (F.₀ A))) ⟩
            η α Z ⟨$⟩ (F.₁ (f ∘ i) ⟨$⟩ Y)        S.∎
            where
              module F = Functor F using (₀; ₁; homomorphism; F-resp-≈)
              module G = Functor G using (₀; ₁)
              module S = SetoidR (G.₀ Z)
              module S′ = Setoid (F.₀ B) using (refl; sym)

  module yoneda = NaturalIsomorphism yoneda


{-# OPTIONS --safe #-}
module Cubical.Categories.Instances.Semilattice where

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.Semilattice

open import Cubical.Categories.Category
open import Cubical.Categories.Instances.Poset

open Category

module _ {ℓ} (L : Semilattice ℓ) where
  open JoinSemilattice L

  JoinSemilatticeCategory : Category ℓ ℓ
  JoinSemilatticeCategory = PosetCategory IndPoset

module _ {ℓ} (L : Semilattice ℓ) where
  open MeetSemilattice L

  MeetSemilatticeCategory : Category ℓ ℓ
  MeetSemilatticeCategory = PosetCategory IndPoset


module Cats.Category.Constructions.Exponential where

open import Level

open import Cats.Category.Base
open import Cats.Category.Constructions.Product as Product using
  (HasBinaryProducts)
open import Cats.Util.Conv

import Cats.Category.Constructions.Unique as Unique

module Build {lo la l≈}
  (Cat : Category lo la l≈)
  {{hasBinaryProducts : HasBinaryProducts Cat}}
  where

  open Category Cat
  open ≈-Reasoning
  open Unique.Build Cat
  open HasBinaryProducts hasBinaryProducts

  record Exp (B C : Obj) : Set (lo ⊔ la ⊔ l≈) where
    field
      Cᴮ : Obj
      eval : Cᴮ × B ⇒ C
      curry′ : ∀ {A} (f : A × B ⇒ C)
        → ∃![ f̃ ∈ A ⇒ Cᴮ ] (eval ∘ ⟨ f̃ × id ⟩ ≈ f)

    curry : ∀ {A} → A × B ⇒ C → A ⇒ Cᴮ
    curry f = curry′ f ⃗

    eval-curry : ∀ {A} {f : A × B ⇒ C}
      → eval ∘ ⟨ curry f × id ⟩ ≈ f
    eval-curry {f = f} = ∃!′.prop (curry′ f)

    curry-unique : ∀ {A} {f : A × B ⇒ C} {g}
      → eval ∘ ⟨ g × id ⟩ ≈ f
      → curry f ≈ g
    curry-unique {f = f} = ∃!′.unique (curry′ f)

    uncurry : ∀ {A} → A ⇒ Cᴮ → A × B ⇒ C
    uncurry f = eval ∘ ⟨ f × id ⟩

    curry∘uncurry : ∀ {A} {f : A ⇒ Cᴮ}
      → curry (uncurry f) ≈ f
    curry∘uncurry = curry-unique ≈.refl

    uncurry∘curry : ∀ {A} {f : A × B ⇒ C}
      → uncurry (curry f) ≈ f
    uncurry∘curry = eval-curry

  instance HasObj-Exp : ∀ {B C} → HasObj (Exp B C) lo la l≈
  HasObj-Exp = record { Cat = Cat ; _ᴼ = Exp.Cᴮ }

  open Exp public

  curry∘curry : ∀ {A B C Y Z} (Cᴮ : Exp B C) (Yᶻ : Exp Y Z)
    → {f : Cᴮ ᴼ × Y ⇒ Z} {g : A × B ⇒ C}
    → curry Yᶻ f ∘ curry Cᴮ g ≈ curry Yᶻ (f ∘ ⟨ curry Cᴮ g × id ⟩)
  curry∘curry Cᴮ Yᶻ {f} {g} = ≈.sym (curry-unique Yᶻ (
      begin
        eval Yᶻ ∘ ⟨ curry Yᶻ f ∘ curry Cᴮ g × id ⟩
      ≈⟨ ∘-resp-r (⟨×⟩-resp ≈.refl (≈.sym id-l)) ⟩
        eval Yᶻ ∘ ⟨ curry Yᶻ f ∘ curry Cᴮ g × id ∘ id ⟩
      ≈⟨ ∘-resp-r (≈.sym ⟨×⟩-∘) ⟩
        eval Yᶻ ∘ ⟨ curry Yᶻ f × id ⟩ ∘ ⟨ curry Cᴮ g × id ⟩
      ≈⟨ unassoc ⟩
        (eval Yᶻ ∘ ⟨ curry Yᶻ f × id ⟩) ∘ ⟨ curry Cᴮ g × id ⟩
      ≈⟨ ∘-resp-l (eval-curry Yᶻ) ⟩
        f ∘ ⟨ curry Cᴮ g × id ⟩
      ∎
    ))

record HasExponentials {lo la l≈}
  (Cat : Category lo la l≈)
  : Set (lo ⊔ la ⊔ l≈)
  where
  private open module Bld = Build Cat using (Exp)
  open Category Cat
  open Unique.Build Cat

  infixr 1 _↝′_ _↝_

  field
    {{hasBinaryProducts}} : HasBinaryProducts Cat
    _↝′_ : ∀ B C → Exp B C

  open HasBinaryProducts hasBinaryProducts

  _↝_ : Obj → Obj → Obj
  B ↝ C = (B ↝′ C) ᴼ

  eval : ∀ {B C} → (B ↝ C) × B ⇒ C
  eval {B} {C} = Bld.eval (B ↝′ C)

  curry : ∀ {A B C} → A × B ⇒ C → A ⇒ B ↝ C
  curry {B = B} {C} f = Bld.curry (B ↝′ C) f

  uncurry : ∀ {A B C} → A ⇒ B ↝ C → A × B ⇒ C
  uncurry {B = B} {C} = Bld.uncurry (B ↝′ C)

  eval-curry : ∀ {A B C} {f : A × B ⇒ C}
    → eval ∘ ⟨ curry f × id ⟩ ≈ f
  eval-curry {B = B} {C} = Bld.eval-curry (B ↝′ C)

  curry∘uncurry : ∀ {A B C} {f : A ⇒ B ↝ C}
    → curry (uncurry f) ≈ f
  curry∘uncurry {B = B} {C} = Bld.curry∘uncurry (B ↝′ C)

  uncurry∘curry : ∀ {A B C} {f : A × B ⇒ C}
    → uncurry (curry f) ≈ f
  uncurry∘curry {B = B} {C} = Bld.uncurry∘curry (B ↝′ C)

  curry∘curry : ∀ {A B C Y Z}
    → {f : (B ↝ C) × Y ⇒ Z} {g : A × B ⇒ C}
    → curry f ∘ curry g ≈ curry (f ∘ ⟨ curry g × id ⟩)
  curry∘curry {B = B} {C} {Y} {Z} = Bld.curry∘curry (B ↝′ C) (Y ↝′ Z)


module Issue533 where

data Empty : Set where

empty : {A B : Set} → (B → Empty) → B → A
empty f x with f x
... | ()

fail : ∀ {A : Set} → Empty → A
fail {A} = empty absurd
  where
    absurd : _ → Empty
    absurd ()
-- should check (due to postponed emptyness constraint, see issue 479)


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

open import Categories.Category

module Categories.Functor.Core where

open import Level
open import Categories.Support.EqReasoning

record Functor {o ℓ e o′ ℓ′ e′} (C : Category o ℓ e) (D : Category o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  eta-equality
  private module C = Category C
  private module D = Category D

  field
    F₀ : C.Obj → D.Obj
    {F₁} : ∀ {A B} → C [ A , B ] → D [ F₀ A , F₀ B ]

    .{identity} : ∀ {A} → D [ F₁ (C.id {A}) ≡ D.id ]
    .{homomorphism} : ∀ {X Y Z} {f : C [ X , Y ]} {g : C [ Y , Z ]}
                  → D [ F₁ (C [ g ∘ f ]) ≡ D [ F₁ g ∘ F₁ f ] ]
    .{F-resp-≡} : ∀ {A B} {F G : C [ A , B ]} → C [ F ≡ G ] → D [ F₁ F ≡ F₁ G ]

  op : Functor C.op D.op
  op = record
    { F₀ = F₀
    ; F₁ = F₁
    ; identity = identity
    ; homomorphism = homomorphism
    ; F-resp-≡ = F-resp-≡
    }

Endofunctor : ∀ {o ℓ e} → Category o ℓ e → Set _
Endofunctor C = Functor C C

Contravariant : ∀ {o ℓ e o′ ℓ′ e′} (C : Category o ℓ e) (D : Category o′ ℓ′ e′) → Set _
Contravariant C D = Functor C.op D
  where module C = Category C

id : ∀ {o ℓ e} {C : Category o ℓ e} → Endofunctor C
id {C = C} = record
  { F₀ = λ x → x
  ; F₁ = λ x → x
  ; identity = refl
  ; homomorphism = refl
  ; F-resp-≡ = λ x → x
  }
  where open Category.Equiv C

infixr 9 _∘_

_∘_ : ∀ {o ℓ e} {o′ ℓ′ e′} {o′′ ℓ′′ e′′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {E : Category o′′ ℓ′′ e′′}
    → Functor D E → Functor C D → Functor C E
_∘_ {C = C} {D = D} {E = E} F G = record
  { F₀ = λ x → F₀ (G₀ x)
  ; F₁ = λ f → F₁ (G₁ f)
  ; identity = identity′
  ; homomorphism = homomorphism′
  ; F-resp-≡ = ∘-resp-≡′
  }
  where
  module C = Category C
  module D = Category D
  module E = Category E
  module F = Functor F
  module G = Functor G
  open F
  open G renaming (F₀ to G₀; F₁ to G₁; F-resp-≡ to G-resp-≡)

  .identity′ : ∀ {A} → E [ F₁ (G₁ (C.id {A})) ≡ E.id ]
  identity′ = begin
                F₁ (G₁ C.id)
              ≈⟨ F-resp-≡ G.identity ⟩
                F₁ D.id
              ≈⟨ F.identity ⟩
                E.id
              ∎
    where
    open SetoidReasoning E.hom-setoid

  .homomorphism′ : ∀ {X Y Z} {f : C [ X , Y ]} {g : C [ Y , Z ]}
                 → E [ F₁ (G₁ (C [ g ∘ f ])) ≡ E [ F₁ (G₁ g) ∘ F₁ (G₁ f) ] ]
  homomorphism′ {f = f} {g = g} = begin
                                    F₁ (G₁ (C [ g ∘ f ]))
                                  ≈⟨ F-resp-≡ G.homomorphism ⟩
                                    F₁ (D [ G₁ g ∘ G₁ f ])
                                  ≈⟨ F.homomorphism ⟩
                                    (E [ F₁ (G₁ g) ∘ F₁ (G₁ f) ])
                                  ∎
    where
    open SetoidReasoning E.hom-setoid

  .∘-resp-≡′ : ∀ {A B} {F G : C [ A , B ]}
            → C [ F ≡ G ] → E [ F₁ (G₁ F) ≡ F₁ (G₁ G) ]
  ∘-resp-≡′ = λ x → F-resp-≡ (G-resp-≡ x)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors defined by recursion
------------------------------------------------------------------------

-- What is the point of this module? The n-ary products below are intended
-- to be used with a fixed n, in which case the nil constructor can be
-- avoided: pairs are represented as pairs (x , y), not as triples
-- (x , y , unit).
-- Additionally, vectors defined by recursion enjoy η-rules. That is to say
-- that two vectors of known length are definitionally equal whenever their
-- elements are.

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

module Data.Vec.Recursive where

open import Level using (Level; Lift; lift)
open import Data.Nat.Base as Nat using (ℕ; zero; suc)
open import Data.Empty
open import Data.Fin.Base as Fin using (Fin; zero; suc)
open import Data.Product as Prod using (_×_; _,_; proj₁; proj₂)
open import Data.Sum.Base as Sum using (_⊎_)
open import Data.Unit.Base
open import Data.Vec.Base as Vec using (Vec; _∷_)
open import Function
open import Relation.Unary
open import Agda.Builtin.Equality using (_≡_)

private
  variable
    a b c p : Level
    A : Set a
    B : Set b
    C : Set c

-- Types and patterns
------------------------------------------------------------------------

pattern 2+_ n = suc (suc n)

infix 8 _^_
_^_ : Set a → ℕ → Set a
A ^ 0    = Lift _ ⊤
A ^ 1    = A
A ^ 2+ n = A × A ^ suc n

pattern [] = lift tt

infix 3 _∈[_]_
_∈[_]_ : {A : Set a} → A → ∀ n → A ^ n → Set a
a ∈[ 0    ] as      = Lift _ ⊥
a ∈[ 1    ] a′      = a ≡ a′
a ∈[ 2+ n ] a′ , as = a ≡ a′ ⊎ a ∈[ suc n ] as

-- Basic operations
------------------------------------------------------------------------

cons : ∀ n → A → A ^ n → A ^ suc n
cons 0       a _  = a
cons (suc n) a as = a , as

uncons : ∀ n → A ^ suc n → A × A ^ n
uncons 0        a        = a , lift tt
uncons (suc n)  (a , as) = a , as

head : ∀ n → A ^ suc n → A
head n as = proj₁ (uncons n as)

tail : ∀ n → A ^ suc n → A ^ n
tail n as = proj₂ (uncons n as)

fromVec : ∀[ Vec A ⇒ (A ^_) ]
fromVec = Vec.foldr (_ ^_) (cons _) _

toVec : Π[ (A ^_) ⇒ Vec A ]
toVec 0       as = Vec.[]
toVec (suc n) as = head n as ∷ toVec n (tail n as)

lookup : ∀ {n} (k : Fin n) → A ^ n → A
lookup zero        = head _
lookup (suc {n} k) = lookup k ∘′ tail n

replicate : ∀ n → A → A ^ n
replicate n a = fromVec (Vec.replicate a)

tabulate : ∀ n → (Fin n → A) → A ^ n
tabulate n f = fromVec (Vec.tabulate f)

append : ∀ m n → A ^ m → A ^ n → A ^ (m Nat.+ n)
append 0      n xs       ys = ys
append 1      n x        ys = cons n x ys
append (2+ m) n (x , xs) ys = x , append (suc m) n xs ys

splitAt : ∀ m n → A ^ (m Nat.+ n) → A ^ m × A ^ n
splitAt 0       n xs = [] , xs
splitAt (suc m) n xs =
  let (ys , zs) = splitAt m n (tail (m Nat.+ n) xs) in
  cons m (head (m Nat.+ n) xs) ys , zs

-- Manipulating N-ary products
------------------------------------------------------------------------

map : (A → B) → ∀ n → A ^ n → B ^ n
map f 0      as       = lift tt
map f 1      a        = f a
map f (2+ n) (a , as) = f a , map f (suc n) as

ap : ∀ n → (A → B) ^ n → A ^ n → B ^ n
ap 0      fs       ts       = []
ap 1      f        t        = f t
ap (2+ n) (f , fs) (t , ts) = f t , ap (suc n) fs ts

module _ {P : ℕ → Set p} where

  foldr : P 0 → (A → P 1) → (∀ n → A → P (suc n) → P (2+ n)) →
          ∀ n → A ^ n → P n
  foldr p0 p1 p2+ 0      as       = p0
  foldr p0 p1 p2+ 1      a        = p1 a
  foldr p0 p1 p2+ (2+ n) (a , as) = p2+ n a (foldr p0 p1 p2+ (suc n) as)

foldl : (P : ℕ → Set p) →
        P 0 → (A → P 1) → (∀ n → A → P (suc n) → P (2+ n)) →
        ∀ n → A ^ n → P n
foldl P p0 p1 p2+ 0      as       = p0
foldl P p0 p1 p2+ 1      a        = p1 a
foldl P p0 p1 p2+ (2+ n) (a , as) = let p1′ = p1 a in
  foldl (P ∘′ suc) p1′ (λ a → p2+ 0 a p1′) (p2+ ∘ suc) (suc n) as

reverse : ∀ n → A ^ n → A ^ n
reverse = foldl (_ ^_) [] id (λ n → _,_)

zipWith : (A → B → C) → ∀ n → A ^ n → B ^ n → C ^ n
zipWith f 0      as       bs       = []
zipWith f 1      a        b        = f a b
zipWith f (2+ n) (a , as) (b , bs) = f a b , zipWith f (suc n) as bs

unzipWith : (A → B × C) → ∀ n → A ^ n → B ^ n × C ^ n
unzipWith f 0      as       = [] , []
unzipWith f 1      a        = f a
unzipWith f (2+ n) (a , as) = Prod.zip _,_ _,_ (f a) (unzipWith f (suc n) as)

zip : ∀ n → A ^ n → B ^ n → (A × B) ^ n
zip = zipWith _,_

unzip : ∀ n → (A × B) ^ n → A ^ n × B ^ n
unzip = unzipWith id


{-# OPTIONS --without-K --exact-split #-}

module hott-i where

import 04-inductive-types
open 04-inductive-types public

data 𝕀 : UU lzero where
  left : 𝕀

postulate right : 𝕀

data Path {l : Level} (A : 𝕀 → UU l) : (a : A left) (a' : A right) → UU l where
  pcon : (f : (x : 𝕀) → A x) → Path A (f left) (f right)

apply-path :
  {l : Level} (A : 𝕀 → UU l) (a : A left) (a' : A right) →
  Path A a a' → (x : 𝕀) → A x
apply-path A .(f left) .(f right) (pcon f) x = f x

refl-path :
  {l : Level} (A : UU l) (a : A) → Path (λ x → A) a a
refl-path A a = pcon (λ x → a)

apply-path-pcon :
  {l : Level} (A : 𝕀 → UU l) (f : (x : 𝕀) → A x) →
  (x : 𝕀) → Path (λ y → A x) (apply-path A (f left) (f right) (pcon f) x) (f x)
apply-path-pcon A f x = refl-path (A x) (f x)

left-apply-path :
  {l : Level} (A : 𝕀 → UU l) (a : A left) (a' : A right) (p : Path A a a') →
  Path (λ y → A left) (apply-path A a a' p left) a
left-apply-path A .(f left) .(f right) (pcon f) = refl-path (A left) (f left)

right-apply-path :
  {l : Level} (A : 𝕀 → UU l) (a : A left) (a' : A right) (p : Path A a a') →
  Path (λ y → A right) (apply-path A a a' p right) a'
right-apply-path A .(f left) .(f right) (pcon f) = refl-path (A right) (f right)

free-transport-path :
  {l : Level} (A : 𝕀 → UU l) → A left → (x : 𝕀) → A x
free-transport-path A a left = a

transport-path :
  {l : Level} (A : 𝕀 → UU l) → A left → A right
transport-path A a = free-transport-path A a right

elim-path-lemma :
  {l : Level} {A : UU l} (f : (x : 𝕀) → A) →
  (i : 𝕀) → Path (λ j → A) (f left) (f i)
elim-path-lemma {A = A} f left = refl-path A (f left)

elim-path :
  {l1 l2 : Level} (A : UU l1) (a : A)
  (B : (x : A) (p : Path (λ i → A) a x) → UU l2) →
  B a (refl-path A a) →
  (x : A) (p : Path (λ i → A) a x) → B x p
elim-path A .(f left) B b .(f right) (pcon f) =
  transport-path (λ i → B (f i) {!elim-path-lemma f i!}) b

concat-path :
  {l : Level} {A : UU l} {x y z : A} →
  Path (λ i → A) x y → Path (λ i → A) y z → Path (λ i → A) x z
concat-path {l} {A} {x} p (pcon f) =
  transport-path (λ i → Path (λ j → A) x (f i)) p

function-extensionality' :
  {l1 l2 : Level} {A : UU l1} {B : A → UU l2} {f g : (x : A) → B x} →
  (H : (x : A) → Path (λ i → B x) (f x) (g x)) →
  (i : 𝕀) (x : A) → B x
function-extensionality' {B = B} {f} {g} H i x =
  apply-path (λ j → B x) (f x) (g x) (H x) i

function-extensionality :
  {l1 l2 : Level} {A : UU l1} {B : A → UU l2} {f g : (x : A) → B x} →
  (H : (x : A) → Path (λ i → B x) (f x) (g x)) →
  Path (λ j → (x : A) → B x) f g
function-extensionality {l1} {l2} {A} {B} {f} {g} H =
  concat-path
    ( concat-path
      {!!}
      ( pcon (function-extensionality' H)))
    ( {!!})

{-
pcon-apply-path :
  {l : Level} (A : 𝕀 → UU l) (a : A left) (a' : A right) (p : Path A a a') →
  Path (λ y → Path A a a') (pcon (apply-path A a a' p)) ?
pcon-apply-path A a a' p = ?
-}


open import Prelude hiding (lift; id)

module Implicits.Syntax.LNMetaType where

open import Implicits.Syntax.Type
open import Data.Nat as Nat

mutual
  data MetaSType (m : ℕ) : Set where
    tvar : ℕ → MetaSType m
    mvar : Fin m → MetaSType m
    _→'_ : (a b : MetaType m) → MetaSType m
    tc   : ℕ → MetaSType m

  data MetaType (m : ℕ) : Set where
    _⇒_ : (a b : MetaType m) → MetaType m
    ∀'  : MetaType m → MetaType m
    simpl : MetaSType m → MetaType m

mutual

  open-meta : ∀ {m} → ℕ → MetaType m → MetaType (suc m)
  open-meta k (a ⇒ b) = open-meta k a ⇒ open-meta k b
  open-meta k (∀' a) = ∀' (open-meta (suc k) a )
  open-meta k (simpl x) = simpl (open-st k x)
    where
      open-st : ∀ {m} → ℕ → MetaSType m → MetaSType (suc m)
      open-st k (tvar x) with Nat.compare x k
      open-st .(suc (x N+ k)) (tvar x) | less .x k = tvar x
      open-st k (tvar .k) | equal .k = mvar zero
      open-st k (tvar .(suc (k N+ x))) | greater .k x = tvar (k N+ x)
      open-st k (mvar x) = mvar (suc x)
      open-st k (a →' b) = open-meta k a →' open-meta k b
      open-st k (tc x) = tc x

mutual

  data TClosedS {m} (n : ℕ) : MetaSType m → Set where
    tvar : ∀ {x} → (x N< n) → TClosedS n (tvar x)
    mvar : ∀ {x} → TClosedS n (mvar x)
    _→'_ : ∀ {a b} → TClosed n a → TClosed n b → TClosedS n (a →' b)
    tc   : ∀ {c} → TClosedS n (tc c)

  data TClosed {m} (n : ℕ) : MetaType m → Set where
    _⇒_ : ∀ {a b} → TClosed n a → TClosed n b → TClosed n (a ⇒ b)
    ∀'  : ∀ {a} → TClosed (suc n) a → TClosed n (∀' a)
    simpl : ∀ {τ} → TClosedS n τ → TClosed n (simpl τ)

to-meta : ∀ {ν} → Type ν → MetaType zero
to-meta (simpl (tc x)) = simpl (tc x)
to-meta (simpl (tvar n)) = simpl (tvar (toℕ n))
to-meta (simpl (a →' b)) = simpl (to-meta a →' to-meta b)
to-meta (a ⇒ b) = to-meta a ⇒ to-meta b
to-meta (∀' a) = ∀' (to-meta a)

from-meta : ∀ {ν} {a : MetaType zero} → TClosed ν a → Type ν
from-meta (a ⇒ b) = from-meta a ⇒ from-meta b
from-meta (∀' a) = ∀' (from-meta a)
from-meta (simpl (tvar x)) = simpl (tvar (fromℕ≤ x))
from-meta (simpl (mvar {()}))
from-meta (simpl (a →' b)) = simpl (from-meta a →' from-meta b)
from-meta (simpl (tc {c})) = simpl (tc c)


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

open import LogicalFormulae
open import Groups.Groups
open import Functions.Definition
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Integers.Integers
open import Numbers.Modulo.Group
open import Numbers.Modulo.Definition
open import Rings.Examples.Proofs
open import Numbers.Primes.PrimeNumbers
open import Setoids.Setoids
open import Rings.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Sets.EquivalenceRelations

module Rings.Examples.Examples where

multiplicationNotGroup : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) → (nontrivial : Setoid._∼_ S (Ring.1R R) (Ring.0R R) → False) → Group S _*_ → False
multiplicationNotGroup {S = S} R 1!=0 gr = exFalso (1!=0 (groupsHaveLeftCancellation gr (Ring.0R R) (Ring.1R R) (Ring.0R R) (transitive (Ring.timesZero' R) (symmetric (Ring.timesZero' R)))))
  where
    open Setoid S
    open Equivalence eq

nToZn : (n : ℕ) (pr : 0 <N n) (x : ℕ) → ℤn n pr
nToZn n pr x = nToZn' n pr x

mod : (n : ℕ) → (pr : 0 <N n) → ℤ → ℤn n pr
mod n pr a = mod' n pr a

modNExampleSurjective : (n : ℕ) → (pr : 0 <N n) → Surjection (mod n pr)
modNExampleSurjective n pr = modNExampleSurjective' n pr

{-
  modNExampleGroupHom : (n : ℕ) → (pr : 0 <N n) → GroupHom ℤGroup (ℤnGroup n pr) (mod n pr)
  modNExampleGroupHom n pr = modNExampleGroupHom' n pr

  embedZnInZ : {n : ℕ} {pr : 0 <N n} → (a : ℤn n pr) → ℤ
  embedZnInZ record { x = x } = nonneg x

  modNRoundTrip : (n : ℕ) → (pr : 0 <N n) → (a : ℤn n pr) → mod n pr (embedZnInZ a) ≡ a
  modNRoundTrip zero ()
  modNRoundTrip (succ n) pr record { x = x ; xLess = xLess } with divisionAlg (succ n) x
  modNRoundTrip (succ n) _ record { x = x ; xLess = xLess } | record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } = equalityZn _ _ p
    where
      p : rem ≡ x
      p = modIsUnique record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } record { quot = 0 ; rem = x ; pr = identityOfIndiscernablesLeft _ _ _ _≡_ refl (applyEquality (λ i → i +N x) (multiplicationNIsCommutative 0 n)) ; remIsSmall = inl xLess ; quotSmall = inl (succIsPositive n) }
  modNRoundTrip (succ n) _ record { x = x ; xLess = xLess } | record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = inr () }

-}


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.DirectProd where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Sigma
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Ring.DirectProd
open import Cubical.Algebra.CommRing.Base

private
  variable
    ℓ ℓ' : Level

module _
  (A'@(A , Ar) : CommRing ℓ)
  (B'@(B , Br) : CommRing ℓ')
  where

  AB = DirectProd-Ring (CommRing→Ring A') (CommRing→Ring B')

  open RingStr (snd AB) using ()
    renaming
    ( 0r        to 0AB
    ; 1r        to 1AB
    ; _+_       to _+AB_
    ; -_        to -AB_
    ; _·_       to _·AB_
    ; +Assoc    to +ABAssoc
    ; +IdL      to +ABIdL
    ; +IdR      to +ABIdR
    ; +InvL     to +ABInvL
    ; +InvR     to +ABInvR
    ; +Comm     to +ABComm
    ; ·Assoc    to ·ABAssoc
    ; ·IdR      to ·ABIdR
    ; ·IdL      to ·ABIdL
    ; ·DistR+   to ·ABDistR+
    ; ·DistL+   to ·ABDistL+
    ; is-set    to isSetAB     )

  DirectProd-CommRing : CommRing (ℓ-max ℓ ℓ')
  fst DirectProd-CommRing = A × B
  CommRingStr.0r (snd DirectProd-CommRing) = 0AB
  CommRingStr.1r (snd DirectProd-CommRing) = 1AB
  CommRingStr._+_ (snd DirectProd-CommRing) = _+AB_
  CommRingStr._·_ (snd DirectProd-CommRing) = _·AB_
  CommRingStr.- snd DirectProd-CommRing = -AB_
  CommRingStr.isCommRing (snd DirectProd-CommRing) =
    makeIsCommRing
    isSetAB
    +ABAssoc
    +ABIdR
    +ABInvR
    +ABComm
    ·ABAssoc
    ·ABIdR
    ·ABDistR+
    λ x y i → (CommRingStr.·Comm Ar (fst x) (fst y) i) , (CommRingStr.·Comm Br (snd x) (snd y) i)


open import FRP.LTL.ISet.Core using ( ISet ; ⌈_⌉ ; ⌊_⌋ )
open import FRP.LTL.RSet using ( RSet )
open import FRP.LTL.Time using ( Time ; _≤_ )

module FRP.LTL.ISet.Future where

data Future (A : RSet) (t : Time) : Set where
  _,_ : ∀ {u} .(t≤u : t ≤ u) → A u → Future A t

◇ : ISet → ISet
◇ A = ⌈ Future ⌊ A ⌋ ⌉


-- 2010-10-14

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

module ProjectionsPreserveGuardednessTrivialExample where

-- Coinduction is only available with universe polymorphism

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

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

infixl 6 _⊔_

-- Coinduction

infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

-- Products

infixr 4 _,_
infixr 2 _×_

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

open Σ public

syntax Σ A (λ x → B) = Σ[ x ∶ A ] B

_×_ : ∀ {a b} (A : Set a) (B : Set b) → Set (a ⊔ b)
A × B = Σ[ x ∶ A ] B

-- Streams

infixr 5 _∷_

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

mutual

  repeat : {A : Set}(a : A) → Stream A
  repeat a = a ∷ proj₂ (repeat' a)

  repeat' : {A : Set}(a : A) → A × ∞ (Stream A)
  repeat' a = a , ♯ repeat a


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

open import Categories.Category
open import Categories.Object.Products
open import Categories.Object.Terminal
open import Level

module Categories.Object.Terminal.Exponentiating {o ℓ e : Level}
    (C : Category o ℓ e)
    (P : Products C) where

open Category C
open Products P
open Terminal terminal

open import Categories.Object.Exponentiating
import Categories.Object.Terminal.Exponentials

open Categories.Object.Terminal.Exponentials C terminal

⊤-exponentiating : Exponentiating C binary ⊤
⊤-exponentiating = record
  { exponential = λ {X : Obj} → [⊤↑ X ]-exponential
  }


-- Andreas, 2016-09-12 issue #2172
--
-- Instance search should succeed also when instance meta is supplied by the user.
--
-- This test case is not minimal, but illustrates the point.

-- {-# OPTIONS -v tc.term.args:30 -v tc.term.args.ifs:15 -v tc.meta.new:50 -v tc.meta.name:100 -v tc.term.args.named:75 #-}

module Issue2172 where

postulate
  id : {t : Set} → t → t
  _≡_ : {t : Set} → t → t → Set
  ⊤ : Set

record FunctorOp (F : Set → Set) : Set₁ where
  field
    map : ∀{A B} → (A → B) → F A → F B

record FunctorLaws (F : Set → Set) {{O : FunctorOp F}} : Set₁ where
  field
    map-id : ∀{A : Set} → FunctorOp.map O (id {A}) ≡ (id {F A})

record ApplyOp (A : Set → Set) {{O : FunctorOp A}} {{L : FunctorLaws A}} : Set₁ where
  field
    iapply : ∀ {t₁ t₂} → A (t₁ → t₂) → A t₁ → A t₂

record ApplyLaws (A : Set → Set) {{O : FunctorOp A}} {{L : FunctorLaws A}} {{i : ApplyOp A}} : Set₁ where

  open ApplyOp {{...}}
  field
    works : ∀ (f : A (⊤ → ⊤)) → (x : A ⊤) → (iapply f x) ≡ x
    test2 : ∀ (f : A (⊤ → ⊤)) → (x : A ⊤) → (iapply {_} {{_}} f x) ≡ x
    test1 : ∀ (f : A (⊤ → ⊤)) → (x : A ⊤) → (iapply {A₁ = _} {{_}} {{L₁ = _}} f x) ≡ x
    test0 : ∀ (f : A (⊤ → ⊤)) → (x : A ⊤) → (iapply {{L₁ = _}} f x) ≡ x
    test  : ∀ (f : A (⊤ → ⊤)) → (x : A ⊤) → (iapply {{L₁ = {!L!}}} f x) ≡ x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Propositional (intensional) equality
------------------------------------------------------------------------

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

module Relation.Binary.PropositionalEquality where

open import Algebra
open import Algebra.Structures
open import Algebra.Definitions
import Axiom.Extensionality.Propositional as Ext
open import Axiom.UniquenessOfIdentityProofs
open import Function.Base
open import Function.Equality using (Π; _⟶_; ≡-setoid)
open import Level using (Level; _⊔_)
open import Data.Product using (∃)

open import Relation.Nullary using (yes ; no)
open import Relation.Nullary.Decidable.Core
open import Relation.Unary using (Pred)
open import Relation.Binary
open import Relation.Binary.Indexed.Heterogeneous
  using (IndexedSetoid)
import Relation.Binary.Indexed.Heterogeneous.Construct.Trivial
  as Trivial

private
  variable
    a b c ℓ p : Level
    A : Set a
    B : Set b
    C : Set c

------------------------------------------------------------------------
-- Re-export contents of core module

open import Relation.Binary.PropositionalEquality.Core public

------------------------------------------------------------------------
-- Some properties

subst₂ : ∀ (_∼_ : REL A B ℓ) {x y u v} → x ≡ y → u ≡ v → x ∼ u → y ∼ v
subst₂ _ refl refl p = p

cong-app : ∀ {A : Set a} {B : A → Set b} {f g : (x : A) → B x} →
           f ≡ g → (x : A) → f x ≡ g x
cong-app refl x = refl

cong₂ : ∀ (f : A → B → C) {x y u v} → x ≡ y → u ≡ v → f x u ≡ f y v
cong₂ f refl refl = refl

------------------------------------------------------------------------
-- Structure of equality as a binary relation

isEquivalence : IsEquivalence {A = A} _≡_
isEquivalence = record
  { refl  = refl
  ; sym   = sym
  ; trans = trans
  }

isDecEquivalence : Decidable _≡_ → IsDecEquivalence {A = A} _≡_
isDecEquivalence _≟_ = record
  { isEquivalence = isEquivalence
  ; _≟_           = _≟_
  }

isPreorder : IsPreorder {A = A} _≡_ _≡_
isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive     = id
  ; trans         = trans
  }

------------------------------------------------------------------------
-- Bundles for equality as a binary relation

setoid : Set a → Setoid _ _
setoid A = record
  { Carrier       = A
  ; _≈_           = _≡_
  ; isEquivalence = isEquivalence
  }

decSetoid : Decidable {A = A} _≡_ → DecSetoid _ _
decSetoid _≟_ = record
  { _≈_              = _≡_
  ; isDecEquivalence = isDecEquivalence _≟_
  }

preorder : Set a → Preorder _ _ _
preorder A = record
  { Carrier    = A
  ; _≈_        = _≡_
  ; _∼_        = _≡_
  ; isPreorder = isPreorder
  }

------------------------------------------------------------------------
-- Pointwise equality

infix 4 _≗_

_→-setoid_ : ∀ (A : Set a) (B : Set b) → Setoid _ _
A →-setoid B = ≡-setoid A (Trivial.indexedSetoid (setoid B))

_≗_ : (f g : A → B) → Set _
_≗_ {A = A} {B = B} = Setoid._≈_ (A →-setoid B)

:→-to-Π : ∀ {A : Set a} {B : IndexedSetoid A b ℓ} →
          ((x : A) → IndexedSetoid.Carrier B x) → Π (setoid A) B
:→-to-Π {B = B} f = record
  { _⟨$⟩_ = f
  ; cong  = λ { refl → IndexedSetoid.refl B }
  }
  where open IndexedSetoid B using (_≈_)

→-to-⟶ : ∀ {A : Set a} {B : Setoid b ℓ} →
         (A → Setoid.Carrier B) → setoid A ⟶ B
→-to-⟶ = :→-to-Π

------------------------------------------------------------------------
-- Inspect

-- Inspect can be used when you want to pattern match on the result r
-- of some expression e, and you also need to "remember" that r ≡ e.

-- See README.Inspect for an explanation of how/why to use this.

record Reveal_·_is_ {A : Set a} {B : A → Set b}
                    (f : (x : A) → B x) (x : A) (y : B x) :
                    Set (a ⊔ b) where
  constructor [_]
  field eq : f x ≡ y

inspect : ∀ {A : Set a} {B : A → Set b}
          (f : (x : A) → B x) (x : A) → Reveal f · x is f x
inspect f x = [ refl ]

------------------------------------------------------------------------
-- Propositionality

isPropositional : Set a → Set a
isPropositional A = (a b : A) → a ≡ b

------------------------------------------------------------------------
-- Various equality rearrangement lemmas

trans-injectiveˡ : ∀ {x y z : A} {p₁ p₂ : x ≡ y} (q : y ≡ z) →
                   trans p₁ q ≡ trans p₂ q → p₁ ≡ p₂
trans-injectiveˡ refl = subst₂ _≡_ (trans-reflʳ _) (trans-reflʳ _)

trans-injectiveʳ : ∀ {x y z : A} (p : x ≡ y) {q₁ q₂ : y ≡ z} →
                   trans p q₁ ≡ trans p q₂ → q₁ ≡ q₂
trans-injectiveʳ refl eq = eq

cong-id : ∀ {x y : A} (p : x ≡ y) → cong id p ≡ p
cong-id refl = refl

cong-∘ : ∀ {x y : A} {f : B → C} {g : A → B} (p : x ≡ y) →
         cong (f ∘ g) p ≡ cong f (cong g p)
cong-∘ refl = refl

module _ {P : Pred A p} {x y : A} where

  subst-injective : ∀ (x≡y : x ≡ y) {p q : P x} →
                    subst P x≡y p ≡ subst P x≡y q → p ≡ q
  subst-injective refl p≡q = p≡q

  subst-subst : ∀ {z} (x≡y : x ≡ y) {y≡z : y ≡ z} {p : P x} →
                subst P y≡z (subst P x≡y p) ≡ subst P (trans x≡y y≡z) p
  subst-subst refl = refl

  subst-subst-sym : (x≡y : x ≡ y) {p : P y} →
                    subst P x≡y (subst P (sym x≡y) p) ≡ p
  subst-subst-sym refl = refl

  subst-sym-subst : (x≡y : x ≡ y) {p : P x} →
                    subst P (sym x≡y) (subst P x≡y p) ≡ p
  subst-sym-subst refl = refl

subst-∘ : ∀ {x y : A} {P : Pred B p} {f : A → B}
          (x≡y : x ≡ y) {p : P (f x)} →
          subst (P ∘ f) x≡y p ≡ subst P (cong f x≡y) p
subst-∘ refl = refl

subst-application : ∀ {a₁ a₂ b₁ b₂} {A₁ : Set a₁} {A₂ : Set a₂}
                    (B₁ : A₁ → Set b₁) {B₂ : A₂ → Set b₂}
                    {f : A₂ → A₁} {x₁ x₂ : A₂} {y : B₁ (f x₁)}
                    (g : ∀ x → B₁ (f x) → B₂ x) (eq : x₁ ≡ x₂) →
                    subst B₂ eq (g x₁ y) ≡ g x₂ (subst B₁ (cong f eq) y)
subst-application _ _ refl = refl

-- A lemma that is very similar to Lemma 2.4.3 from the HoTT book.

naturality : ∀ {x y} {x≡y : x ≡ y} {f g : A → B}
             (f≡g : ∀ x → f x ≡ g x) →
             trans (cong f x≡y) (f≡g y) ≡ trans (f≡g x) (cong g x≡y)
naturality {x = x} {x≡y = refl} f≡g =
  f≡g x               ≡⟨ sym (trans-reflʳ _) ⟩
  trans (f≡g x) refl  ∎
  where open ≡-Reasoning

-- A lemma that is very similar to Corollary 2.4.4 from the HoTT book.

cong-≡id : ∀ {f : A → A} {x : A} (f≡id : ∀ x → f x ≡ x) →
           cong f (f≡id x) ≡ f≡id (f x)
cong-≡id {f = f} {x} f≡id =
  cong f fx≡x                                    ≡⟨ sym (trans-reflʳ _) ⟩
  trans (cong f fx≡x) refl                       ≡⟨ cong (trans _) (sym (trans-symʳ fx≡x)) ⟩
  trans (cong f fx≡x) (trans fx≡x (sym fx≡x))    ≡⟨ sym (trans-assoc (cong f fx≡x)) ⟩
  trans (trans (cong f fx≡x) fx≡x) (sym fx≡x)    ≡⟨ cong (λ p → trans p (sym _)) (naturality f≡id) ⟩
  trans (trans f²x≡x (cong id fx≡x)) (sym fx≡x)  ≡⟨ cong (λ p → trans (trans f²x≡x p) (sym fx≡x)) (cong-id _) ⟩
  trans (trans f²x≡x fx≡x) (sym fx≡x)            ≡⟨ trans-assoc f²x≡x ⟩
  trans f²x≡x (trans fx≡x (sym fx≡x))            ≡⟨ cong (trans _) (trans-symʳ fx≡x) ⟩
  trans f²x≡x refl                               ≡⟨ trans-reflʳ _ ⟩
  f≡id (f x)                                     ∎
  where open ≡-Reasoning; fx≡x = f≡id x; f²x≡x = f≡id (f x)

module _ (_≟_ : Decidable {A = A} _≡_) {x y : A} where

  ≡-≟-identity : (eq : x ≡ y) → x ≟ y ≡ yes eq
  ≡-≟-identity eq = dec-yes-irr (x ≟ y) (Decidable⇒UIP.≡-irrelevant _≟_) eq

  ≢-≟-identity : x ≢ y → ∃ λ ¬eq → x ≟ y ≡ no ¬eq
  ≢-≟-identity ¬eq = dec-no (x ≟ y) ¬eq

------------------------------------------------------------------------
-- Any operation forms a magma over _≡_

isMagma : (_∙_ : Op₂ A) → IsMagma _≡_ _∙_
isMagma _∙_ = record
  { isEquivalence = isEquivalence
  ; ∙-cong        = cong₂ _∙_
  }

magma : (_∙_ : Op₂ A) → Magma _ _
magma _∙_ = record
  { isMagma = isMagma _∙_
  }

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.0

Extensionality = Ext.Extensionality
{-# WARNING_ON_USAGE Extensionality
"Warning: Extensionality was deprecated in v1.0.
Please use Extensionality from `Axiom.Extensionality.Propositional` instead."
#-}
extensionality-for-lower-levels = Ext.lower-extensionality
{-# WARNING_ON_USAGE extensionality-for-lower-levels
"Warning: extensionality-for-lower-levels was deprecated in v1.0.
Please use lower-extensionality from `Axiom.Extensionality.Propositional` instead."
#-}
∀-extensionality = Ext.∀-extensionality
{-# WARNING_ON_USAGE ∀-extensionality
"Warning: ∀-extensionality was deprecated in v1.0.
Please use ∀-extensionality from `Axiom.Extensionality.Propositional` instead."
#-}


-- Andreas, 2017-01-18, issue #2408

-- DLubs were not serialized, thus, there was a problem with
-- level dependent on unused values.

{-# OPTIONS --show-irrelevant #-}

-- {-# OPTIONS -v tc:20 #-}

open import Agda.Primitive

data ⊥ : Set where

data Unit : Set where
  unit : Unit

-- Argument a is unused in l
l : (u : Unit) (a : ⊥) → Level
l unit a = lzero

postulate
  u : Unit
  F : (a : ⊥) → Set (l u a)

-- checked type signature
--   F : (a : ⊥) → Set (l u a)
--   of sort  dLub Set (λ a → Set (lsuc (l u a)))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.DiffInt where

open import Cubical.Data.DiffInt.Base public
open import Cubical.Data.DiffInt.Properties public


module _ where

postulate
  I : Set

data P (i : I) : Set where
  p : P i → P i

data Q (i : I) : P i → Set where
  q : (x : P i) → Q i (p x)

module _ (i : I) (x : P i)  where
  g : Q _ x → Set₁
  g (q y) = Set


{-# OPTIONS --without-K --safe #-}
open import Categories.Category
open import Categories.Functor hiding (id)

-- Also defines the category of cocones "over a Functor F"

module Categories.Category.Construction.Cocones
  {o ℓ e} {o′ ℓ′ e′} {C : Category o ℓ e} {J : Category o′ ℓ′ e′} (F : Functor J C) where

open Category C

private
  variable
    X : Obj

open HomReasoning
open Functor F
open import Data.Product
open import Relation.Binary using (Rel; IsEquivalence; Setoid)
import Categories.Morphism as Mor
import Categories.Morphism.IsoEquiv as IsoEquiv
open import Categories.Diagram.Cocone F public

open Mor C
open IsoEquiv C
open import Categories.Morphism.Reasoning C
open Cocone
open Coapex
open Cocone⇒

Cocones : Category _ _ _
Cocones = record
  { Obj       = Cocone
  ; _⇒_       = Cocone⇒
  ; _≈_       = λ f g → arr f ≈ arr g
  ; id        = record { arr = id ; commute = identityˡ }
  ; _∘_       = λ {A B C} f g → record
    { arr     = arr f ∘ arr g
    ; commute = λ {X} → begin
      (arr f ∘ arr g) ∘ ψ A X ≈⟨ pullʳ (commute g) ⟩
      arr f ∘ ψ B X           ≈⟨ commute f ⟩
      ψ C X                   ∎
    }
  ; assoc     = assoc
  ; sym-assoc = sym-assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identity²
  ; equiv     = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  ; ∘-resp-≈  = ∘-resp-≈
  }

module Cocones = Category Cocones

private
  variable
    K K′ : Cocone
  module CM = Mor Cocones
  module CI = IsoEquiv Cocones

open CM using () renaming (_≅_ to _⇔_)
open CI using () renaming (_≃_ to _↮_)

cocone-resp-iso : ∀ (κ : Cocone) → Cocone.N κ ≅ X → Σ[ κ′ ∈ Cocone ] κ ⇔ κ′
cocone-resp-iso {X = X} κ κ≅X = record
  { coapex = record
    { ψ       = λ Y → from ∘ Cocone.ψ κ Y
    ; commute = λ f → pullʳ (Cocone.commute κ f)
    }
  } , record
  { from = record
    { arr     = from
    ; commute = refl
    }
  ; to   = record
    { arr     = to
    ; commute = cancelˡ isoˡ
    }
  ; iso  = record
    { isoˡ    = isoˡ
    ; isoʳ    = isoʳ
    }
  }
  where open _≅_ κ≅X
        open Cocone
        open Coapex

iso-cocone⇒iso-coapex : K ⇔ K′ → N K ≅ N K′
iso-cocone⇒iso-coapex K⇔K′ = record
  { from = arr from
  ; to   = arr to
  ; iso  = record
    { isoˡ = isoˡ
    ; isoʳ = isoʳ
    }
  }
  where open _⇔_ K⇔K′


module Generic.Test.Data.W where

open import Generic.Main

data W′ {α β} (A : Set α) (B : A -> Set β) : Set (α ⊔ β) where
  sup′ : ∀ {x} -> (B x -> W′ A B) -> W′ A B

W : ∀ {α β} -> (A : Set α) -> (A -> Set β) -> Set (α ⊔ β)
W = readData W′

pattern sup x g = !#₀ (relv x , g , lrefl)

elimW : ∀ {α β π} {A : Set α} {B : A -> Set β}
      -> (P : W A B -> Set π)
      -> (∀ {x} {g : B x -> W A B} -> (∀ y -> P (g y)) -> P (sup x g))
      -> ∀ w
      -> P w
elimW {B = B} P h (sup x g) = h (λ y -> elimW {B = B} P h (g y))


open import MLib.Algebra.PropertyCode
open import MLib.Algebra.PropertyCode.Structures

module MLib.Matrix.Bimonoid {c ℓ} (struct : Struct bimonoidCode c ℓ) where

open import MLib.Prelude
open import MLib.Matrix.Core
open import MLib.Matrix.Equality struct
open import MLib.Matrix.Mul struct
open import MLib.Matrix.Plus struct
open import MLib.Algebra.Operations struct
open import MLib.Algebra.PropertyCode.Dependent struct

open FunctionProperties

matrixRawStruct : ∀ n → RawStruct BimonoidK _ _
matrixRawStruct n = record
  { appOp = λ
    { + (A ∷ B ∷ []) → A ⊕ B
    ; * (A ∷ B ∷ []) → A ⊗ B
    ; 0# [] → 0●
    ; 1# [] → 1●
    }
  ; isRawStruct = record
    { isEquivalence = isEquivalence {n} {n}
    ; congⁿ = λ
      { + (p ∷ q ∷ []) i j → cong + (p i j) (q i j)
      ; * (p ∷ q ∷ []) → ⊗-cong p q
      ; 0# [] _ _ → S.refl
      ; 1# [] _ _ → S.refl
      }
    }
  }

matrixStruct : ∀ n → Struct bimonoidCode _ _
matrixStruct n = dependentStruct (matrixRawStruct n)
  ( (commutative on + , _ , ⊕-comm)
  ∷ (associative on + , _ , ⊕-assoc)
  ∷ (0# is leftIdentity for + , _ , ⊕-identityˡ)
  ∷ (0# is rightIdentity for + , _ , ⊕-identityʳ)
  ∷ (associative on * , _ , ⊗-assoc)
  ∷ (* ⟨ distributesOverˡ ⟩ₚ + , _ , ⊗-distributesOverˡ-⊕)
  ∷ [])


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

open import lib.Basics
open import lib.types.Sigma

open import Preliminaries
open import Truncation_Level_Criteria
open import Anonymous_Existence_CollSplit

open wtrunc
open with-weak-trunc

module Anonymous_Existence_Populatedness where

-- Definition 4.2.1
⟪_⟫ : ∀ {i} → Type i → Type i
⟪ X ⟫ = (f : X → X) → const f → fix f

-- Proposition 4.2.2
Trunc→Pop : ∀ {i} {X : Type i} → ∣∣ X ∣∣ → ⟪ X ⟫
Trunc→Pop z f c = tr-rec {P = fix f} (fixed-point f c) (to-fix f c) z

-- Corollary 4.2.3: We show pairwise logical equivalence as it is easy
-- (of course, some directions are redundant)
coll-characterizations : ∀ {i} {X : Type i}
  → (coll X ↔ splitSup X)
   × ((coll X ↔ (⟪ X ⟫ → X))
   × ((⟪ X ⟫ → X) ↔ splitSup X))
coll-characterizations {X = X} = coll↔splitSup ,
                                 (coll→pop→X , reverse₁) ,
                                 (pop→X→splitSup , reverse₂) where

  coll→pop→X : coll X → ⟪ X ⟫ → X
  coll→pop→X (f , c) pop = fst (pop f c)

  pop→X→splitSup : (⟪ X ⟫ → X) → splitSup X
  pop→X→splitSup g = g ∘ Trunc→Pop

  reverse₁ = snd coll↔splitSup ∘ pop→X→splitSup
  reverse₂ = coll→pop→X ∘ snd coll↔splitSup

-- Addendum of Corollary 4.2.3
prop-pop : ∀ {i} {P : Type i} → is-prop P → ⟪ P ⟫ → P
prop-pop {P = P} pp = snd (snd (snd coll-characterizations)) (tr-rec pp (idf _))

-- Lemma 4.2.4
module _ {i : ULevel} {X : Type i} where

  pop→splitSup→X : ⟪ X ⟫ → splitSup X → X
  pop→splitSup→X pop = λ hst → snd (snd (snd (coll-characterizations {X = X}))) hst pop

  use-funct : (splitSup X → X) → ∣∣ splitSup X ∣∣ → ∣∣ X ∣∣
  use-funct f = trunc-functorial f

  tr-hst-X→pop : (∣∣ splitSup X ∣∣ → ∣∣ X ∣∣) → ⟪ X ⟫
  tr-hst-X→pop g f c = tr-rec (fixed-point f c) (to-fix f c) (g ∣ coll→splitSup (f , c) ∣)

  -- we formulate the two logical equivalence that we will need explicitly:
  pop-alt : ⟪ X ⟫ ↔ (∣∣ splitSup X ∣∣ → ∣∣ X ∣∣)
  pop-alt = use-funct ∘ pop→splitSup→X , tr-hst-X→pop

  pop-alt' : ⟪ X ⟫ ↔ (splitSup X → X)
  pop-alt' = pop→splitSup→X , tr-hst-X→pop ∘ use-funct

-- Proposition 4.2.5
pop-alt₂ : ∀ {i} {X : Type i} → ⟪ X ⟫ ↔ ((P : Type i) → (is-prop P) → (X ↔ P) → P)
pop-alt₂ {i} {X} = one , two where

  one : ⟪ X ⟫ → (P : Type i) → is-prop P → (X ↔ P) → P
  one pop P pp (xp , px) = xp (fst (pop f c)) where
    f : X → X
    f = px ∘ xp
    c : const f
    c x₁ x₂ = ap px (prop-has-all-paths pp _ _)

  two : ((P : Type i) → is-prop P → (X ↔ P) → P) → ⟪ X ⟫
  two rest f c = rest (fix f) (fixed-point f c) (to-fix f c , from-fix f)

-- Proposition 4.2.6, part 1
pop-property₁ : ∀ {i} {X : Type i} → X → ⟪ X ⟫
pop-property₁ = Trunc→Pop ∘ ∣_∣

-- Proposition 4.2.6, part 2: this needs function extensionality.
-- We import the library file with the consequence of funext that we need.
open import lib.types.Pi
pop-property₂ : ∀ {i} {X : Type i} → is-prop ⟪ X ⟫
pop-property₂ = Π-is-prop (λ f → Π-is-prop (λ c → fixed-point f c))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by join semilattices
------------------------------------------------------------------------

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

open import Relation.Binary.Lattice

module Relation.Binary.Properties.JoinSemilattice
  {c ℓ₁ ℓ₂} (J : JoinSemilattice c ℓ₁ ℓ₂) where

open JoinSemilattice J

import Algebra as Alg
import Algebra.Structures as Alg
import Algebra.FunctionProperties as P; open P _≈_
open import Data.Product
open import Function using (_∘_; flip)
open import Relation.Binary
open import Relation.Binary.Properties.Poset poset

import Relation.Binary.Reasoning.PartialOrder as PoR

-- The join operation is monotonic.

∨-monotonic : _∨_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
∨-monotonic {x} {y} {u} {v} x≤y u≤v =
  let _     , _     , least  = supremum x u
      y≤y∨v , v≤y∨v , _      = supremum y v
  in least (y ∨ v) (trans x≤y y≤y∨v) (trans u≤v v≤y∨v)

∨-cong : _∨_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
∨-cong x≈y u≈v = antisym (∨-monotonic (reflexive x≈y) (reflexive u≈v))
                         (∨-monotonic (reflexive (Eq.sym x≈y))
                                      (reflexive (Eq.sym u≈v)))

-- The join operation is commutative, associative and idempotent.

∨-comm : Commutative _∨_
∨-comm x y =
  let x≤x∨y , y≤x∨y , least  = supremum x y
      y≤y∨x , x≤y∨x , least′ = supremum y x
  in antisym (least (y ∨ x) x≤y∨x y≤y∨x) (least′ (x ∨ y) y≤x∨y x≤x∨y)

∨-assoc : Associative _∨_
∨-assoc x y z =
  let x∨y≤[x∨y]∨z , z≤[x∨y]∨z   , least  = supremum (x ∨ y) z
      x≤x∨[y∨z]   , y∨z≤x∨[y∨z] , least′ = supremum x (y ∨ z)
      y≤y∨z       , z≤y∨z       , _      = supremum y z
      x≤x∨y       , y≤x∨y       , _      = supremum x y
  in antisym (least  (x ∨ (y ∨ z)) (∨-monotonic refl y≤y∨z)
                     (trans z≤y∨z y∨z≤x∨[y∨z]))
             (least′ ((x ∨ y) ∨ z) (trans x≤x∨y x∨y≤[x∨y]∨z)
                     (∨-monotonic y≤x∨y refl))

∨-idempotent : Idempotent _∨_
∨-idempotent x =
  let x≤x∨x , _ , least = supremum x x
  in antisym (least x refl refl) x≤x∨x

x≤y⇒x∨y≈y : ∀ {x y} → x ≤ y → x ∨ y ≈ y
x≤y⇒x∨y≈y {x} {y} x≤y = antisym
  (begin x ∨ y ≤⟨ ∨-monotonic x≤y refl ⟩
         y ∨ y ≈⟨ ∨-idempotent _ ⟩
         y ∎)
  (y≤x∨y _ _)
  where open PoR poset

-- Every order-theoretic semilattice can be turned into an algebraic one.

isAlgSemilattice : Alg.IsSemilattice _≈_ _∨_
isAlgSemilattice = record
  { isBand = record
    { isSemigroup = record
      { isMagma   = record
        { isEquivalence = isEquivalence
        ; ∙-cong        = ∨-cong
        }
      ; assoc  = ∨-assoc
      }
    ; idem     = ∨-idempotent
    }
  ; comm       = ∨-comm
  }

algSemilattice : Alg.Semilattice c ℓ₁
algSemilattice = record { isSemilattice = isAlgSemilattice }

-- The dual construction is a meet semilattice.

dualIsMeetSemilattice : IsMeetSemilattice _≈_ (flip _≤_) _∨_
dualIsMeetSemilattice = record
  { isPartialOrder = invIsPartialOrder
  ; infimum        = supremum
  }

dualMeetSemilattice : MeetSemilattice c ℓ₁ ℓ₂
dualMeetSemilattice = record
  { _∧_               = _∨_
  ; isMeetSemilattice = dualIsMeetSemilattice
  }