open import Type

module Graph.Walk.Properties {ℓ₁ ℓ₂} {V : Type{ℓ₁}} where

open import Lang.Instance
open import Logic
import      Lvl
open import Graph{ℓ₁}{ℓ₂}(V)
open import Graph.Walk{ℓ₁}{ℓ₂}{V}
open import Relator.Equals.Proofs.Equiv
open import Type.Properties.MereProposition

module _ (_⟶_ : Graph) where
  -- `Passes edge walk` states that the walk `walk` contains the edge `edge`.
  -- In other words, there is a step in the walk which is `edge`.
  -- Note: Passes is a generalized containment relation for paths instead of lists.
  data Passes {v₁ v₂ : V} (edge : v₁ ⟶ v₂) : ∀{a b : V} → Walk(_⟶_) a b → Type{ℓ₁ Lvl.⊔ ℓ₂} where
    current : ∀{c}{rest : Walk(_⟶_) v₂ c} → Passes edge (Walk.prepend edge rest)
    skip    : ∀{b c}{rest : Walk(_⟶_) b c} → Passes edge rest → ∀{a}{e : (a ⟶ b)} → Passes edge (Walk.prepend e rest)

  -- `Visits v walk` states that the walk `walk` visits the vertex `v`.
  -- In other words, one of the steps/edges in the walk mention the vertex v.
  data Visits (v : V) : ∀{a b : V} → Walk(_⟶_) a b → Type{ℓ₁ Lvl.⊔ ℓ₂} where
    current : ∀{b}{path : Walk(_⟶_) v b} → Visits v path
    skip    : ∀{a b c}{e : (a ⟶ b)}{rest : Walk(_⟶_) b c} → Visits v rest → Visits v (Walk.prepend e rest)

  module _ {a b : V} (walk₁ : Walk(_⟶_) a b) {c d : V} (walk₂ : Walk(_⟶_) c d) where
    record Subwalk : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
      constructor intro
      field proof : ∀{v₁ v₂ : V}{edge : v₁ ⟶ v₂} → Passes edge walk₁ → Passes edge walk₂

module _ {_⟶_ : Graph} {a b : V} (walk : Walk(_⟶_) a b) where
  -- A walk that never visits the same edge twice.
  -- Note: Equality on edges must respect uniqueness. In other words, one edge must not have multiple constructions.
  record Trail : Type{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : ∀{v₁ v₂ : V}{edge : v₁ ⟶ v₂} → MereProposition(Passes(_⟶_) edge walk)

  -- A walk that never visits the same vertex twice.
  -- Also called "Simple path".
  -- Note: Equality on edges must respect uniqueness. In other words, one edge must not have multiple constructions.
  record Path : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : ∀{v : V} → MereProposition(Visits(_⟶_) v walk)
  path = inst-fn Path.proof

  -- A walk that visits every vertex in the graph.
  record Traceable : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : ∀{v : V} → Visits(_⟶_) v walk
  traceable = inst-fn Traceable.proof


module Common.Equality where

open import Common.Level

infix 4 _≡_

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

{-# BUILTIN EQUALITY _≡_  #-}
{-# BUILTIN REFL     refl #-}

subst : ∀ {a p}{A : Set a}(P : A → Set p){x y : A} → x ≡ y → P x → P y
subst P refl t = t


------------------------------------------------------------------------
-- The Agda standard library
--
-- Natural numbers with fast addition (for use together with
-- DifferenceVec)
------------------------------------------------------------------------

module Data.DifferenceNat where

open import Data.Nat as N using (ℕ)
open import Function

infixl 6 _+_

Diffℕ : Set
Diffℕ = ℕ → ℕ

0# : Diffℕ
0# = λ k → k

suc : Diffℕ → Diffℕ
suc n = λ k → N.suc (n k)

1# : Diffℕ
1# = suc 0#

_+_ : Diffℕ → Diffℕ → Diffℕ
m + n = λ k → m (n k)

toℕ : Diffℕ → ℕ
toℕ n = n 0

-- fromℕ n is linear in the size of n.

fromℕ : ℕ → Diffℕ
fromℕ n = λ k → n ⟨ N._+_ ⟩ k


open import Oscar.Prelude
open import Oscar.Data.𝟘

module Oscar.Data.Proposequality where

module _ where

  data Proposequality {𝔬} {𝔒 : Ø 𝔬} (𝓞 : 𝔒) : 𝔒 → Ø₀ where
    instance ∅ : Proposequality 𝓞 𝓞

  {-# BUILTIN EQUALITY Proposequality #-}

  Proposequality⟦_⟧ : ∀ {𝔬} (𝔒 : Ø 𝔬) → 𝔒 → 𝔒 → Ø₀
  Proposequality⟦ _ ⟧ = Proposequality

  [Proposequality] : ∀ {𝔬} {𝔒 : Ø 𝔬} → {x y : 𝔒} → Ø₀
  [Proposequality] {x = x} {y = y} = Proposequality x y

module _ where

  infix 4 _≡_
  _≡_ = Proposequality

-- transport : ∀ {a b} {A : Set a} (B : A → Set b) {x y} → x ≡ y → B x → B y
-- transport _ ∅ = ¡

-- transport₂ : ∀ {a b c} {A : Set a} {B : Set b} (C : A → B → Set c) {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → C x₁ y₁ → C x₂ y₂
-- transport₂ _ ∅ ∅ = ¡

module _ where

  Proposantiequality : ∀ {𝔬} {𝔒 : Ø 𝔬} → 𝔒 → 𝔒 → Ø₀
  Proposantiequality x y = Proposequality x y → 𝟘

  Proposantiequality⟦_⟧ : ∀ {𝔬} (𝔒 : Ø 𝔬) → 𝔒 → 𝔒 → Ø₀
  Proposantiequality⟦ _ ⟧ = Proposantiequality

  infix 4 _≢_
  _≢_ = Proposantiequality

module _ where

  Proposextensequality : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} {𝔓 : 𝔒 → Ø 𝔭} → ((𝓞 : 𝔒) → 𝔓 𝓞) → ((𝓞 : 𝔒) → 𝔓 𝓞) → Ø 𝔬
  Proposextensequality 𝓟₁ 𝓟₂ = ∀ 𝓞 → Proposequality (𝓟₁ 𝓞) (𝓟₂ 𝓞)

  Proposextensequality⟦_⟧ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔭} (𝔓 : 𝔒 → Ø 𝔭) → ((𝓞 : 𝔒) → 𝔓 𝓞) → ((𝓞 : 𝔒) → 𝔓 𝓞) → Ø 𝔬
  Proposextensequality⟦ _ ⟧ = Proposextensequality

  Proposextensequality[_/_] : ∀ {𝔬} (𝔒 : Ø 𝔬) {𝔭} (𝔓 : 𝔒 → Ø 𝔭) → ((𝓞 : 𝔒) → 𝔓 𝓞) → ((𝓞 : 𝔒) → 𝔓 𝓞) → Ø 𝔬
  Proposextensequality[ _ / _ ] = Proposextensequality

module _ where

  infix 4 _≡̇_
  _≡̇_ = Proposextensequality

  infix 4 ≡̇⟦⟧-syntax
  ≡̇⟦⟧-syntax = Proposextensequality⟦_⟧
  syntax ≡̇⟦⟧-syntax t x y = x ≡̇⟦ t ⟧ y


module Relator.Equals where

open import Logic
import      Lvl
open import Type
open import Type.Cubical
open import Type.Cubical.Path
open import Type.Cubical.Path.Proofs

infix 15 _≡_

_≡_ = Path

-- _≢_ : ∀{ℓ}{T} → T → T → Stmt{ℓ}
-- _≢_ a b = ¬(a ≡ b)

{-# BUILTIN REWRITE  _≡_ #-}

data Id {ℓ}{T : Type{ℓ}} : T → T → Stmt{ℓ} where
  instance intro : ∀{x : T} → (Id x x)

{-# BUILTIN EQUALITY Id #-}


------------------------------------------------------------------------------
-- Reasoning about a function without a termination proof
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Collatz.CollatzSL where

open import Data.Bool.Base
open import Data.Empty
open import Data.Nat renaming ( suc to succ )
open import Data.Nat.Properties
open import Data.Product
open import Data.Sum
open import Relation.Binary.PropositionalEquality hiding ( [_] )
open import Relation.Nullary

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

isEven : ℕ → Bool
isEven 0               = true
isEven 1               = false
isEven (succ (succ n)) = isEven n

{-# TERMINATING #-}
collatz : ℕ → ℕ
collatz zero        = 1
collatz (succ zero) = 1
{-# CATCHALL #-}
collatz n with isEven n
... | true  = collatz ⌊ n /2⌋
... | false = collatz (3 * n + 1)

-- 25 April 2014: Failed with Andreas' --without-K.
xy≡0→x≡0∨y≡0 : (m n : ℕ) → m * n ≡ zero → m ≡ zero ⊎ n ≡ zero
xy≡0→x≡0∨y≡0 zero     n        h = inj₁ refl
xy≡0→x≡0∨y≡0 (succ m) zero     h = inj₂ refl
xy≡0→x≡0∨y≡0 (succ m) (succ n) ()

+∸2 : ∀ {n} → n ≢ zero → n ≢ 1 → n ≡ succ (succ (n ∸ 2))
+∸2 {zero}          0≢0 _   = ⊥-elim (0≢0 refl)
+∸2 {succ zero}     _   1≢1 = ⊥-elim (1≢1 refl)
+∸2 {succ (succ n)} _   _   = refl

2^x≢0 : (n : ℕ) → 2 ^ n ≢ zero
2^x≢0 zero ()
2^x≢0 (succ n) h = [ (λ ())
                   , (λ 2^n≡0 → ⊥-elim (2^x≢0 n 2^n≡0))
                   ]′ (xy≡0→x≡0∨y≡0 2 (2 ^ n) h)

2^[x+1]/2≡2^x : ∀ n → ⌊ 2 ^ succ n /2⌋ ≡ 2 ^ n
2^[x+1]/2≡2^x zero            = refl
2^[x+1]/2≡2^x (succ zero)     = refl
2^[x+1]/2≡2^x (succ (succ n)) = {!!}

collatz-2^x : ∀ n → Σ ℕ (λ k → n ≡ 2 ^ k) → collatz n ≡ 1
collatz-2^x zero     h                = refl
collatz-2^x (succ n) (zero , proj₂)   = subst (λ t → collatz t ≡ 1) (sym proj₂) refl
collatz-2^x (succ n) (succ k , proj₂) = subst (λ t → collatz t ≡ 1) (sym proj₂) {!!}

succInjective : ∀ {m n} → succ m ≡ succ n → m ≡ n
succInjective refl = refl

Sx≡x→⊥ : ∀ n → succ n ≢ n
Sx≡x→⊥ zero ()
Sx≡x→⊥ (succ n) h = ⊥-elim (Sx≡x→⊥ n (succInjective h))

2^[x+1]≢1 : ∀ n → 2 ^ (succ n) ≢ 1
2^[x+1]≢1 n h = Sx≡x→⊥ 1 (i*j≡1⇒i≡1 2 (2 ^ n) h)


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

module Ctt where

open import Cubical.Core.Everything
open import Agda.Primitive.Cubical
  using ( primComp )

-- Identity function.
id : ∀ {ℓ} {A : Set ℓ} (x : A) → A
id x = x

-- Funciton composition.
_∘_ : ∀ {ℓ} {A B C : Type ℓ} (g : B → C) (f : A → B) → A → C
g ∘ f = λ a → g (f a)

-- Equivalence is the path to `x` itself.
refl : ∀ {ℓ} {A : Type ℓ} {x : A} → Path A x x
refl {x = x} = λ i → x

-- A square in `A` is built out of 4 points and 4 lines.
square : ∀ {ℓ} {A : Type ℓ} {x0 x1 y0 y1 : A}
  → x0 ≡ x1 → y0 ≡ y1 → x0 ≡ y0 → x1 ≡ y1
  → Type ℓ
square p q r s = PathP (λ i → p i ≡ q i) r s

-- Symmetry.
sym : ∀ {ℓ} {A : Type ℓ} {x y : A} → x ≡ y → y ≡ x
sym p i = p (~ i)
-- sym p i = λ i → p (~ i)

-- Congruence.
cong : ∀ {ℓ} {A : Type ℓ} {x y : A} {B : A → Type ℓ}
  (f : (a : A) → B a) (p : x ≡ y)
  → PathP (λ i → B (p i)) (f x) (f y)
cong f p i = f (p i)

-- Symmetry inverse.
symInv : ∀ {ℓ} {A : Type ℓ} {x y : A} (p : x ≡ y) → sym (sym p) ≡ p
symInv p = refl

-- Congruence with identity function.
congId : ∀ {ℓ} {A : Type ℓ} {x y : A} (p : x ≡ y) → cong id p ≡ p
congId p = refl

-- Congruence with composition.
congComp : ∀ {ℓ} {A B C : Type ℓ}
  (f : A → B) (g : B → C)
  {x y : A} (p : x ≡ y)
  → cong (g ∘ f) p ≡ cong g (cong f p)
congComp f g p = refl

-- Function extensionality.
funExt : ∀ {ℓ} {A : Type ℓ} {B : A → Type ℓ} {f g : (x : A) → B x}
  → ((x : A) → f x ≡ g x) → f ≡ g
funExt p i x = p x i
-- `p` matches the 1st parameter,
-- `i` matches the dimension of the 1st parameter,
-- `x` matches `(x : A)`,
-- `funExt p i x = {!!}` the goal matches `B x`,
-- `(p x) i` is obvious.

-- Transitivity.
trans : ∀ {ℓ} {A : Type ℓ} {x y z : A}
  → x ≡ y → y ≡ z → x ≡ z
trans {y = y} p q i = primComp {!!} {!!} {!!}

-- Transport with composition.
transportComp : ∀ {ℓ} {A B C : Type ℓ}
  → A ≡ B → B ≡ C → A → C
transportComp p q a = {!!}


import Lvl

module Type.Functions.Proofs {ℓₗ : Lvl.Level} where

open import Functional
import      Function.Domains
import      Lang.Irrelevance
import      Logic.Predicate
import      Logic.Predicate.Theorems
import      Relator.Equals
import      Relator.Equals.Proofs
open import Type
open import Type.Properties.Empty
import      Type.Functions
import      Type.Singleton.Proofs
open import Type.Properties.Singleton
open import Type.Properties.Singleton.Proofs

module _ {ℓₒ₁}{ℓₒ₂} {X : Type{ℓₒ₁}} {Y : Type{ℓₒ₂}} {f : X → Y} where
  open Type.Functions {ℓₗ}{ℓₒ₁}{ℓₒ₂} {X}{Y}

  bijective-to-injective : ⦃ bij : Bijective(f) ⦄ → Injective(f)
  Injective.proof (bijective-to-injective ⦃ intro proof ⦄) {y} =
    unit-is-prop {ℓₒ₁} ⦃ proof{y} ⦄

  bijective-to-surjective : ⦃ bij : Bijective(f) ⦄ → Surjective(f)
  Surjective.proof (bijective-to-surjective ⦃ intro proof ⦄) {y} =
    unit-is-pos {ℓₗ Lvl.⊔ ℓₒ₁} ⦃ proof{y} ⦄

  injective-surjective-to-bijective : ⦃ inj : Injective(f) ⦄ → ⦃ surj : Surjective(f) ⦄ → Bijective(f)
  Bijective.proof(injective-surjective-to-bijective ⦃ intro inj ⦄ ⦃ intro surj ⦄) {y} =
    pos-prop-is-unit {ℓₗ Lvl.⊔ ℓₒ₁} ⦃ surj{y} ⦄ ⦃ inj{y} ⦄

module _ {ℓₒ₁}{ℓₒ₂} {X : Type{ℓₒ₁}} {Y : Type{ℓₒ₂}} {f : X → Y} where
  open Function.Domains
  open Type.Functions {ℓₗ}{ℓₒ₁}{ℓₒ₂} {X}{Y}
  open Relator.Equals

  private
    _≡₁_ = _≡_ {ℓₗ Lvl.⊔ ℓₒ₁}

  Injective-apply : ⦃ _ : Injective(f) ⦄ → ∀{x y} → (f(x) ≡₁ f(y)) → (x ≡₁ y)
  Injective-apply ⦃ Injective.intro proof ⦄ {x}{y} (fxfy) with proof{f(y)}
  ... | MereProposition.intro uniqueness with uniqueness{Unapply.intro x ⦃ fxfy ⦄} {Unapply.intro y ⦃ [≡]-intro ⦄}
  ...   | [≡]-intro = [≡]-intro

module _ {ℓₒ : Lvl.Level} {X : Type{ℓₒ}} where
  open Type.Functions {ℓₗ Lvl.⊔ ℓₒ}{ℓₒ}{ℓₒ} {X}{X}
  open Type.Singleton.Proofs {ℓₗ}{ℓₒ} {X}

  instance
    id-is-bijective : Bijective(id)
    id-is-bijective = intro Singleton-is-unit


-- Andreas, 2017-01-24, issue #2430, reported by nad

-- Regression introduced by updating module parameter substitution
-- when going underAbstraction (80794767db1aceaa78a72e06ad901cfa53f8346d).

record Σ (A : Set) (B : A → Set) : Set where
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

Σ-map : {A : Set} {B : Set} {P : A → Set} {Q : B → Set} →
        (f : A → B) → (∀ {x} → P x → Q (f x)) →
        Σ A P → Σ B Q
Σ-map f g p = record { proj₁ = f (proj₁ p); proj₂ = g (proj₂ p) }

postulate

  _≡_        : {A : Set} → A → A → Set
  refl       : {A : Set} (x : A) → x ≡ x
  cong       : {A : Set} {B : Set} (f : A → B) {x y : A} →
               x ≡ y → f x ≡ f y
  cong-refl  : {A : Set} {B : Set} (f : A → B) {x : A} →
               refl (f x) ≡ cong f (refl x)
  subst      : {A : Set} (P : A → Set) {x y : A} →
               x ≡ y → P x → P y
  subst-refl : ∀ {A : Set} (P : A → Set) {x} (p : P x) →
               subst P (refl x) p ≡ p
  trans      : {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z

module _ (_ : Set) where

  postulate

    Σ-≡,≡→≡ : {A : Set} {B : A → Set} {p₁ p₂ : Σ A B} →
              (p : proj₁ p₁ ≡ proj₁ p₂) →
              subst B p (proj₂ p₁) ≡ proj₂ p₂ →
              p₁ ≡ p₂

    Σ-≡,≡→≡-refl-subst-refl :
      ∀ {A : Set} {B : A → Set} {p} →
      Σ-≡,≡→≡ (refl (proj₁ p)) (subst-refl B (proj₂ p)) ≡ refl p

  rejected :
    {A₁ A₂ : Set} {B₁ : A₁ → Set} {B₂ : A₂ → Set}
    (f : A₁ → A₂) (g : ∀ x → B₁ x → B₂ (f x)) (x : Σ A₁ B₁) →
    Σ-≡,≡→≡ (refl _) (subst-refl B₂ _) ≡ cong (Σ-map f (g _)) (refl x)
  rejected {B₁ = B₁} {B₂} f g x =
    trans {x = Σ-≡,≡→≡ (refl _) (subst-refl B₂ _)}
          {z = cong (Σ-map f (g _)) (refl _)}
          Σ-≡,≡→≡-refl-subst-refl
          (cong-refl _)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some examples of how to use non-trivial induction over the natural
-- numbers.
------------------------------------------------------------------------

module README.Data.Nat.Induction where

open import Data.Nat
open import Data.Nat.Induction
open import Data.Product using (_,_)
open import Function using (_∘_)
open import Induction.WellFounded
open import Relation.Binary.PropositionalEquality

-- Doubles its input.

twice : ℕ → ℕ
twice = rec _ λ
  { zero    _       → zero
  ; (suc n) twice-n → suc (suc twice-n)
  }

-- Halves its input (rounding downwards).
--
-- The step function is mentioned in a proof below, so it has been
-- given a name. (The mutual keyword is used to avoid having to give
-- a type signature for the step function.)

mutual

  half₁-step = λ
    { zero          _                → zero
    ; (suc zero)    _                → zero
    ; (suc (suc n)) (_ , half₁n , _) → suc half₁n
    }

  half₁ : ℕ → ℕ
  half₁ = cRec _ half₁-step

-- An alternative implementation of half₁.

mutual

  half₂-step = λ
    { zero          _   → zero
    ; (suc zero)    _   → zero
    ; (suc (suc n)) rec → suc (rec n (≤′-step ≤′-refl))
    }

  half₂ : ℕ → ℕ
  half₂ = <′-rec _ half₂-step

-- The application half₁ (2 + n) is definitionally equal to
-- 1 + half₁ n. Perhaps it is instructive to see why.

half₁-2+ : ∀ n → half₁ (2 + n) ≡ 1 + half₁ n
half₁-2+ n = begin

  half₁ (2 + n)                                                         ≡⟨⟩

  cRec _ half₁-step (2 + n)                                             ≡⟨⟩

  half₁-step (2 + n) (cRecBuilder _ half₁-step (2 + n))                 ≡⟨⟩

  half₁-step (2 + n)
    (let ih = cRecBuilder _ half₁-step (1 + n) in
     half₁-step (1 + n) ih , ih)                                        ≡⟨⟩

  half₁-step (2 + n)
    (let ih = cRecBuilder _ half₁-step n in
     half₁-step (1 + n) (half₁-step n ih , ih) , half₁-step n ih , ih)  ≡⟨⟩

  1 + half₁-step n (cRecBuilder _ half₁-step n)                         ≡⟨⟩

  1 + cRec _ half₁-step n                                               ≡⟨⟩

  1 + half₁ n                                                           ∎

  where open ≡-Reasoning

-- The application half₂ (2 + n) is definitionally equal to
-- 1 + half₂ n. Perhaps it is instructive to see why.

half₂-2+ : ∀ n → half₂ (2 + n) ≡ 1 + half₂ n
half₂-2+ n = begin

  half₂ (2 + n)                                               ≡⟨⟩

  <′-rec _ half₂-step (2 + n)                                 ≡⟨⟩

  half₂-step (2 + n) (<′-recBuilder _ half₂-step (2 + n))     ≡⟨⟩

  1 + <′-recBuilder _ half₂-step (2 + n) n (≤′-step ≤′-refl)  ≡⟨⟩

  1 + Some.wfRecBuilder _ half₂-step (2 + n)
        (<′-wellFounded (2 + n)) n (≤′-step ≤′-refl)          ≡⟨⟩

  1 + Some.wfRecBuilder _ half₂-step (2 + n)
        (acc (<′-wellFounded′ (2 + n))) n (≤′-step ≤′-refl)   ≡⟨⟩

  1 + half₂-step n
        (Some.wfRecBuilder _ half₂-step n
           (<′-wellFounded′ (2 + n) n (≤′-step ≤′-refl)))     ≡⟨⟩

  1 + half₂-step n
        (Some.wfRecBuilder _ half₂-step n
           (<′-wellFounded′ (1 + n) n ≤′-refl))               ≡⟨⟩

  1 + half₂-step n
        (Some.wfRecBuilder _ half₂-step n (<′-wellFounded n)) ≡⟨⟩

  1 + half₂-step n (<′-recBuilder _ half₂-step n)             ≡⟨⟩

  1 + <′-rec _ half₂-step n                                   ≡⟨⟩

  1 + half₂ n                                                 ∎

  where open ≡-Reasoning

-- Some properties that the functions above satisfy, proved using
-- cRec.

half₁-+₁ : ∀ n → half₁ (twice n) ≡ n
half₁-+₁ = cRec _ λ
  { zero          _                        → refl
  ; (suc zero)    _                        → refl
  ; (suc (suc n)) (_ , half₁twice-n≡n , _) →
      cong (suc ∘ suc) half₁twice-n≡n
  }

half₂-+₁ : ∀ n → half₂ (twice n) ≡ n
half₂-+₁ = cRec _ λ
  { zero          _                        → refl
  ; (suc zero)    _                        → refl
  ; (suc (suc n)) (_ , half₁twice-n≡n , _) →
      cong (suc ∘ suc) half₁twice-n≡n
  }

-- Some properties that the functions above satisfy, proved using
-- <′-rec.

half₁-+₂ : ∀ n → half₁ (twice n) ≡ n
half₁-+₂ = <′-rec _ λ
  { zero          _   → refl
  ; (suc zero)    _   → refl
  ; (suc (suc n)) rec →
      cong (suc ∘ suc) (rec n (≤′-step ≤′-refl))
  }

half₂-+₂ : ∀ n → half₂ (twice n) ≡ n
half₂-+₂ = <′-rec _ λ
  { zero          _   → refl
  ; (suc zero)    _   → refl
  ; (suc (suc n)) rec →
      cong (suc ∘ suc) (rec n (≤′-step ≤′-refl))
  }


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

open import Level using (Level; suc; _⊔_)

open import Categories.Category
open import Data.Product
import Categories.Morphism

record pseudo-iso {o ℓ e} (C : Category o ℓ e) : Set (o ⊔ ℓ ⊔ e) where
  open Category C
  open Definitions C
  open Categories.Morphism C

  infix 10 _⁻¹
  field
    _⁻¹ : ∀ {A B} → (f : A ⇒ B) → B ⇒ A
    pseudo-iso₁ : ∀ {A B} {f : A ⇒ B} → f ∘ f ⁻¹ ∘ f ≈ f
    pseudo-iso₂ : ∀ {A B} {f : A ⇒ B} → f ⁻¹ ∘ f ∘ f ⁻¹ ≈ f ⁻¹

record Inverse {o ℓ e} (C : Category o ℓ e) : Set (o ⊔ ℓ ⊔ e) where
  open Category C
  open Definitions C
  open Categories.Morphism C
  open pseudo-iso

  field
    piso : pseudo-iso C
    unique : ∀ {p : pseudo-iso C} {A B} → (f : A ⇒ B) → _⁻¹ piso f ≈ _⁻¹ p f


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

module Magma.Bundles where

open import Algebra.Bundles
open import Algebra.Core
open import Magma.Structures
open import Relation.Binary
open import Level

record IdempotentMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isIdempotentMagma  : IsIdempotentMagma _≈_ _∙_

  open IsIdempotentMagma isIdempotentMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record AlternateMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isAlternateMagma  : IsAlternateMagma _≈_ _∙_

  open IsAlternateMagma isAlternateMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record FlexibleMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isFlexibleMagma  : IsFlexibleMagma _≈_ _∙_

  open IsFlexibleMagma isFlexibleMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record MedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isMedialMagma  : IsMedialMagma _≈_ _∙_

  open IsMedialMagma isMedialMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record SemimedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isSemimedialMagma  : IsSemimedialMagma _≈_ _∙_

  open IsSemimedialMagma isSemimedialMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record LeftUnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier  : Set c
    _≈_      : Rel Carrier ℓ
    _∙_      : Op₂ Carrier
    ε        : Carrier
    isLeftUnitalMagma  : IsLeftUnitalMagma _≈_ _∙_ ε

  open IsLeftUnitalMagma isLeftUnitalMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record RightUnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier  : Set c
    _≈_      : Rel Carrier ℓ
    _∙_      : Op₂ Carrier
    ε        : Carrier
    isRightUnitalMagma  : IsRightUnitalMagma _≈_ _∙_ ε

  open IsRightUnitalMagma isRightUnitalMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)


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

module Data.Binary.Multiplication where

open import Data.Binary.Definition
open import Data.Binary.Addition

double : 𝔹 → 𝔹
double 0ᵇ = 0ᵇ
double (1ᵇ xs) = 2ᵇ double xs
double (2ᵇ xs) = 2ᵇ 1ᵇ xs

infixl 7 _*_
_*_ : 𝔹 → 𝔹 → 𝔹
0ᵇ    * ys = 0ᵇ
1ᵇ xs * ys = ys + double (ys * xs)
2ᵇ xs * ys = double (ys + ys * xs)


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

module Categories.Category.Monoidal.Structure where

open import Level

open import Categories.Category
open import Categories.Category.Monoidal.Core
open import Categories.Category.Monoidal.Braided
open import Categories.Category.Monoidal.Symmetric

record MonoidalCategory o ℓ e : Set (suc (o ⊔ ℓ ⊔ e)) where
  field
    U        : Category o ℓ e
    monoidal : Monoidal U

  module U        = Category U
  module monoidal = Monoidal monoidal

  open U public
  open monoidal public

record BraidedMonoidalCategory o ℓ e : Set (suc (o ⊔ ℓ ⊔ e)) where
  field
    U         : Category o ℓ e
    monoidal  : Monoidal U
    braided   : Braided monoidal

  module U        = Category U
  module monoidal = Monoidal monoidal
  module braided  = Braided braided

  monoidalCategory : MonoidalCategory o ℓ e
  monoidalCategory = record { U = U ; monoidal = monoidal }

  open U public
  open braided public

record SymmetricMonoidalCategory o ℓ e : Set (suc (o ⊔ ℓ ⊔ e)) where
  field
    U         : Category o ℓ e
    monoidal  : Monoidal U
    symmetric : Symmetric monoidal

  module U         = Category U
  module monoidal  = Monoidal monoidal
  module symmetric = Symmetric symmetric

  braidedMonoidalCategory : BraidedMonoidalCategory o ℓ e
  braidedMonoidalCategory = record
    { U        = U
    ; monoidal = monoidal
    ; braided  = symmetric.braided
    }

  open U public
  open symmetric public
  open BraidedMonoidalCategory braidedMonoidalCategory public
    using (monoidalCategory)


module Inductive.Examples.Nat where

open import Inductive
open import Tuple

import Data.Fin as Fin
open import Data.Product
open import Data.List
open import Data.Vec hiding (lookup)

Nat : Set
Nat = Inductive ( ([] , []) ∷ (([] , ([] ∷ [])) ∷ []))

zero : Nat
zero = construct Fin.zero [] []

suc : Nat → Nat
suc n = construct (Fin.suc Fin.zero) [] ((λ _ → n) ∷ [])

_+_ : Nat → Nat → Nat
n + m = rec (m ∷ ((λ x x₁ → suc x₁) ∷ [])) n


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

module Bundles where

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

private
  variable
    ℓ ℓ' ℓ'' : Level

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 Cubical.Structures.Ring
open import Cubical.Foundations.Logic renaming (¬_ to ¬ᵖ_)

open import Function.Base using (_∋_)
-- open import Function.Reasoning using (∋-syntax)
open import Function.Base using (it) -- instance search

open import Utils
open import MoreLogic
open MoreLogic.Reasoning
open MoreLogic.Properties
open import MoreAlgebra
open MoreAlgebra.Definitions
open MoreAlgebra.Consequences

-- 4.1  Algebraic structure of numbers
--
-- Fields have the property that nonzero numbers have a multiplicative inverse, or more precisely, that
--   (∀ x : F) x ≠ 0 ⇒ (∃ y : F) x · y = 1.
--
-- Remark 4.1.1.
-- If we require the collection of numbers to form a set in the sense of Definition 2.5.4, and satisfy the ring axioms, then multiplicative inverses are unique, so that the above is equivalent to the proposition
--   (Π x : F) x ≠ 0 ⇒ (Σ y : F) x · y = 1.
--
-- Definition 4.1.2.
-- A classical field is a set F with points 0, 1 : F, operations +, · : F → F → F, which is a commutative ring with unit, such that
--   (∀ x : F) x ≠ 0 ⇒ (∃ y : F) x · y = 1.

module ClassicalFieldModule where
  record IsClassicalField {F : Type ℓ}
                          (0f : F) (1f : F) (_+_ : F → F → F) (_·_ : F → F → F) (-_ : F → F) (_⁻¹ᶠ : (x : F) → {{¬(x ≡ 0f)}} → F) : Type ℓ where
    constructor isclassicalfield

    field
      isCommRing : IsCommRing 0f 1f _+_ _·_ -_
      ·-rinv : (x : F) → (p : ¬(x ≡ 0f)) → x · (_⁻¹ᶠ x {{p}}) ≡ 1f
      ·-linv : (x : F) → (p : ¬(x ≡ 0f)) → (_⁻¹ᶠ x {{p}}) · x ≡ 1f

    open IsCommRing {0r = 0f} {1r = 1f} isCommRing public

  record ClassicalField : Type (ℓ-suc ℓ) where
    field
      Carrier : Type ℓ
      0f   : Carrier
      1f   : Carrier
      _+_  : Carrier → Carrier → Carrier
      _·_  : Carrier → Carrier → Carrier
      -_   : Carrier → Carrier
      _⁻¹ᶠ : (x : Carrier) → {{¬(x ≡ 0f)}} → Carrier
      isClassicalField : IsClassicalField 0f 1f _+_ _·_ -_ _⁻¹ᶠ

    infix  9 _⁻¹ᶠ
    infix  8 -_
    infixl 7 _·_
    infixl 6 _+_

    open IsClassicalField isClassicalField public

-- Remark 4.1.3.
-- As in the classical case, by proving that additive and multiplicative inverses are unique, we also obtain the negation and division operations.
--
-- For the reals, the assumption x ≠ 0 does not give us any information allowing us to bound x away from 0, which we would like in order to compute multiplicative inverses.
-- Hence, we give a variation on the denition of fields in which the underlying set comes equipped with an apartness relation #, which satises x # y ⇒ x ≠ y, although the converse implication may not hold.
-- This apartness relation allows us to make appropriate error bounds and compute multiplicative inverses based on the assumption x # 0.
--

-- NOTE: there is also PropRel in Cubical.Relation.Binary.Base which
-- NOTE: one needs these "all-lowercase constructors" to make use of copatterns
-- NOTE: see also Relation.Binary.Indexed.Homogeneous.Definitions.html
-- NOTE: see also Algebra.Definitions.html

-- Definition 4.1.5.
-- A constructive field is a set F with points 0, 1 : F, binary operations +, · : F → F → F, and a binary relation # such that
-- 1. (F, 0, 1, +, ·) is a commutative ring with unit;
-- 2. x : F has a multiplicative inverse iff x # 0;
-- 3. + is #-extensional, that is, for all w, x, y, z : F
--    w + x # y + z ⇒ w # y ∨ x # z.

record IsConstructiveField {F : Type ℓ}
                           (0f : F) (1f : F) (_+_ : F → F → F) (_·_ : F → F → F) (-_ : F → F) (_#_ : hPropRel F F ℓ') (_⁻¹ᶠ : (x : F) → {{[ x # 0f ]}} → F) : Type (ℓ-max ℓ ℓ') where
  constructor isconstructivefield

  field
    isCommRing : IsCommRing 0f 1f _+_ _·_ -_
    ·-rinv     : ∀ x → (p : [ x # 0f ]) → x · (_⁻¹ᶠ x {{p}}) ≡ 1f
    ·-linv     : ∀ x → (p : [ x # 0f ]) → (_⁻¹ᶠ x {{p}}) · x ≡ 1f
    ·-inv-back : ∀ x y → (x · y ≡ 1f) → [ x # 0f ] × [ y # 0f ]
    #-tight    : ∀ x y → ¬([ x # y ]) → x ≡ y
    -- NOTE: the following ⊎ caused trouble two times with resolving ℓ or ℓ'
    +-#-extensional : ∀ w x y z → [ (w + x) # (y + z) ] → [ (w # y) ⊔ (x # z) ]
    isApartnessRel  : IsApartnessRelᵖ _#_

  open IsCommRing {0r = 0f} {1r = 1f} isCommRing public
  open IsApartnessRelᵖ isApartnessRel public
    renaming
      ( isIrrefl  to #-irrefl
      ; isSym     to #-sym
      ; isCotrans to #-cotrans )

record ConstructiveField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor constructivefield
  field
    Carrier : Type ℓ
    0f   : Carrier
    1f   : Carrier
    _+_  : Carrier → Carrier → Carrier
    _·_  : Carrier → Carrier → Carrier
    -_   : Carrier → Carrier
    _#_  : hPropRel Carrier Carrier ℓ'
    _⁻¹ᶠ : (x : Carrier) → {{[ x # 0f ]}} → Carrier
    isConstructiveField : IsConstructiveField 0f 1f _+_ _·_ -_ _#_ _⁻¹ᶠ

  infix  9 _⁻¹ᶠ
  infixl 7 _·_
  infix  6 -_
  infixl 5 _+_
  infixl 4 _#_

  open IsConstructiveField isConstructiveField public

-- Definition 4.1.8.
-- Let (A, ≤) be a partial order, and let min, max : A → A → A be binary operators on A. We say that (A, ≤, min, max) is a lattice if min computes greatest lower bounds in the sense that for every x, y, z : A, we have
--   z ≤ min(x,y) ⇔ z ≤ x ∧ z ≤ y,
-- and max computes least upper bounds in the sense that for every x, y, z : A, we have
--   max(x,y) ≤ z ⇔ x ≤ z ∧ y ≤ z.

record IsLattice {A : Type ℓ}
                 (_≤_ : Rel A A ℓ') (min max : A → A → A) : Type (ℓ-max ℓ ℓ') where
  constructor islattice
  field
    isPartialOrder : IsPartialOrder _≤_
    glb      : ∀ x y z → z ≤ min x y → z ≤ x × z ≤ y
    glb-back : ∀ x y z → z ≤ x × z ≤ y → z ≤ min x y
    lub      : ∀ x y z → max x y ≤ z → x ≤ z × y ≤ z
    lub-back : ∀ x y z → x ≤ z × y ≤ z → max x y ≤ z

  open IsPartialOrder isPartialOrder public
    renaming
      ( isRefl    to ≤-refl
      ; isAntisym to ≤-antisym
      ; isTrans   to ≤-trans )

record Lattice : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor lattice
  field
    Carrier : Type ℓ
    _≤_ : Rel Carrier Carrier ℓ'
    min max : Carrier → Carrier → Carrier
    isLattice : IsLattice _≤_ min max

  infixl 4 _≤_

  open IsLattice isLattice public

-- Remark 4.1.9.2
-- 1. From the fact that (A, ≤, min, max) is a lattice, it does not follow that for every x and y, min(x,y) = x ∨ min(x,y) = y. However, we can characterize min as
--   z < min(x,y) ⇔ z < x ∨ z < y
--   and similarly for max, see Lemma 6.7.1.
-- 2. In a partial order, for two fixed elements a and b, all joins and meets of a, b are equal, so that Lemma 2.6.20 the type of joins and the type of meets are propositions. Hence, providing the maps min and max as in the above definition is equivalent to the showing the existenceof all binary joins and meets.
--
-- The following definition is modified from on The Univalent Foundations Program [89, Definition 11.2.7].
--
-- Definition 4.1.10.
-- An ordered field is a set F together with constants 0, 1, operations +, ·, min, max, and a binary relation < such that:
-- 1. (F, 0, 1, +, ·) is a commutative ring with unit;
-- 2. < is a strict [partial] order;
-- 3. x : F has a multiplicative inverse iff x # 0, recalling that # is defined as in Lemma 4.1.7;
-- 4. ≤, as in Lemma 4.1.7, is antisymmetric, so that (F, ≤) is a partial order;
-- 5. (F, ≤, min, max) is a lattice.
-- 6. for all x, y, z, w : F:
--    x + y < z + w ⇒ x < z ∨ y < w, (†)
--    0 < z ∧ x < y ⇒ x z < y z.     (∗)
-- Our notion of ordered fields coincides with The Univalent Foundations Program [89, Definition 11.2.7].

-- NOTE: well, the HOTT book definition organizes things slightly different. Why prefer one approach over the other?

record IsAlmostOrderedField {F : Type ℓ}
                 (0f 1f : F) (_+_ : F → F → F) (-_ : F → F) (_·_ min max : F → F → F) (_<_ _#_ _≤_ : Rel F F ℓ') (_⁻¹ᶠ : (x : F) → {{x # 0f}} → F) : Type (ℓ-max ℓ ℓ') where
  field
    -- 1.
    isCommRing : IsCommRing 0f 1f _+_ _·_ -_
    -- 2.
    <-isStrictPartialOrder : IsStrictPartialOrder _<_
    -- 3.
    ·-rinv     : (x : F) → (p : x # 0f) → x · (_⁻¹ᶠ x {{p}}) ≡ 1f
    ·-linv     : (x : F) → (p : x # 0f) → (_⁻¹ᶠ x {{p}}) · x ≡ 1f
    ·-inv-back : (x y : F) → (x · y ≡ 1f) → x # 0f × y # 0f
    -- 4. NOTE: we already have ≤-isPartialOrder in <-isLattice
    -- ≤-isPartialOrder : IsPartialOrder _≤_
    -- 5.
    ≤-isLattice : IsLattice _≤_ min max

  open IsCommRing {0r = 0f} {1r = 1f} isCommRing public
  open IsStrictPartialOrder <-isStrictPartialOrder public
    renaming
      ( isIrrefl  to <-irrefl
      ; isTrans   to <-trans
      ; isCotrans to <-cotrans )
  open IsLattice ≤-isLattice public

record AlmostOrderedField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor orderedfield
  field
    Carrier : Type ℓ
    0f 1f   : Carrier
    _+_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    min max : Carrier → Carrier → Carrier
    _<_     : Rel Carrier Carrier ℓ'
    <-isProp : ∀ x y → isProp (x < y)

  _#_ = _#'_ {_<_ = _<_}
  _≤_ = _≤'_ {_<_ = _<_}

  field
    _⁻¹ᶠ    : (x : Carrier) → {{x # 0f}} → Carrier
    isAlmostOrderedField : IsAlmostOrderedField 0f 1f _+_ -_ _·_ min max _<_ _#_ _≤_ _⁻¹ᶠ

  infix  9 _⁻¹ᶠ
  infixl 7 _·_
  infix  6 -_
  infixl 5 _+_
  infixl 4 _#_
  infixl 4 _≤_
  infixl 4 _<_

  open IsAlmostOrderedField isAlmostOrderedField public

  #-isProp : ∀ x y → isProp (x # y)
  #-isProp = #-from-<-isProp _<_ <-isStrictPartialOrder <-isProp

record IsOrderedField {F : Type ℓ}
                 (0f 1f : F) (_+_ : F → F → F) (-_ : F → F) (_·_ min max : F → F → F) (_<_ _#_ _≤_ : Rel F F ℓ') (_⁻¹ᶠ : (x : F) → {{x # 0f}} → F) : Type (ℓ-max ℓ ℓ') where
  constructor isorderedfield
  field
    -- 1. 2. 3. 4. 5.
    isAlmostOrderedField : IsAlmostOrderedField 0f 1f _+_ -_ _·_ min max _<_ _#_ _≤_ _⁻¹ᶠ
    -- 6. (†)
    -- NOTE: this is 'shifted' from the pevious definition of #-extensionality for + .. does the name still fit?
    +-<-extensional : ∀ w x y z → (x + y) < (z + w) → (x < z) ⊎ (y < w)
    -- 6. (∗)
    ·-preserves-< : ∀ x y z → 0f < z → x < y → (x · z) < (y · z)
  open IsAlmostOrderedField isAlmostOrderedField public

record OrderedField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor orderedfield
  field
    Carrier : Type ℓ
    0f 1f   : Carrier
    _+_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    min max : Carrier → Carrier → Carrier
    _<_     : Rel Carrier Carrier ℓ'
    <-isProp : ∀ x y → isProp (x < y)

  _#_ = _#'_ {_<_ = _<_}
  _≤_ = _≤'_ {_<_ = _<_}

  field
    _⁻¹ᶠ    : (x : Carrier) → {{x # 0f}} → Carrier
    isOrderedField : IsOrderedField 0f 1f _+_ -_ _·_ min max _<_ _#_ _≤_ _⁻¹ᶠ

  infix  9 _⁻¹ᶠ
  infixl 7 _·_
  infix  6 -_
  infixl 5 _+_
  infixl 4 _#_
  infixl 4 _≤_
  infixl 4 _<_

  open IsOrderedField isOrderedField public

  abstract
    -- NOTE: there might be some reason not to "do" (or "open") all the theory of a record within that record
    +-preserves-< : ∀ a b x → a < b → a + x < b + x
    +-preserves-< a b x a<b = (
       a            <  b            ⇒⟨ transport (λ i → sym (fst (+-identity a)) i < sym (fst (+-identity b)) i) ⟩
       a +    0f    <  b +    0f    ⇒⟨ transport (λ i → a + sym (+-rinv x) i < b + sym (+-rinv x) i) ⟩
       a + (x  - x) <  b + (x  - x) ⇒⟨ transport (λ i → +-assoc a x (- x) i < +-assoc b x (- x) i) ⟩
      (a +  x) - x  < (b +  x) - x  ⇒⟨ +-<-extensional (- x) (a + x) (- x) (b + x) ⟩
      (a + x < b + x) ⊎ (- x < - x) ⇒⟨ (λ{ (inl a+x<b+x) → a+x<b+x -- somehow ⊥-elim needs a hint in the next line
                                         ; (inr  -x<-x ) → ⊥-elim {A = λ _ → (a + x < b + x)} (<-irrefl (- x) -x<-x) }) ⟩
       a + x < b + x ◼) a<b

    ≤-isPreorder : IsPreorder _≤_
    ≤-isPreorder = ≤-isPreorder' {_<_ = _<_} {<-isStrictPartialOrder}

-- Definition 4.3.1.
-- A morphism from an ordered field (F, 0F , 1F , +F , ·F , minF , maxF , <F )
--              to an ordered field (G, 0G , 1G , +G , ·G , minG , maxG , <G )
-- is a map f : F → G such that
-- 1. f is a morphism of rings,
-- 2. f reflects < in the sense that for every x, y : F
--    f (x) <G f (y) ⇒ x <F y.

-- NOTE: see Cubical.Structures.Group.Morphism
--       and Cubical.Structures.Group.MorphismProperties

-- open import Cubical.Structures.Group.Morphism

record IsRingMor
  {ℓ ℓ'}
  (F : Ring {ℓ}) (G : Ring {ℓ'})
  (f : (Ring.Carrier F) → (Ring.Carrier G)) : Type (ℓ-max ℓ ℓ')
  where
  module F = Ring F
  module G = Ring G
  field
    preserves-+ : ∀ a b → f (a F.+ b) ≡ f a G.+ f b
    preserves-· : ∀ a b → f (a F.· b) ≡ f a G.· f b
    perserves-1 : f F.1r ≡ G.1r

record IsOrderedFieldMor
  {ℓ ℓ' ℓₚ ℓₚ'} -- NOTE: this is a lot of levels. Can we get rid of some of these?
  (F : OrderedField {ℓ} {ℓₚ}) (G : OrderedField {ℓ'} {ℓₚ'})
  -- (let module F = OrderedField F) -- NOTE: `let` is not allowed in a telescope
  -- (let module G = OrderedField G)
  (f : (OrderedField.Carrier F) → (OrderedField.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  module F = OrderedField F
  module G = OrderedField G
  field
    isRingMor : IsRingMor (record {F}) (record {G}) f
    reflects-< : ∀ x y → f x G.< f y → x F.< y
  -- NOTE: for more properties, see https://en.wikipedia.org/wiki/Ring_homomorphism#Properties

record OrderedFieldMor {ℓ ℓ' ℓₚ ℓₚ'} (F : OrderedField {ℓ} {ℓₚ}) (G : OrderedField {ℓ'} {ℓₚ'}) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ')) where
  constructor orderedfieldmor
  module F = OrderedField F
  module G = OrderedField G
  field
    fun : F.Carrier → G.Carrier
    isOrderedFieldMor : IsOrderedFieldMor F G fun

-- NOTE: f preserves P: P A ⇒ P (f A)
--       f reflects  P: P (f A) ⇒ P A
-- Remark 4.3.2. The contrapositive of reflecting < means preserving ≤.


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

open import LogicalFormulae

module Functions.Definition where

Rel : {a b : _} → Set a → Set (a ⊔ lsuc b)
Rel {a} {b} A = A → A → Set b

_∘_ : {a b c : _} {A : Set a} {B : Set b} {C : Set c} → (f : B → C) → (g : A → B) → (A → C)
g ∘ f = λ a → g (f a)

Injection : {a b : _} {A : Set a} {B : Set b} (f : A → B) → Set (a ⊔ b)
Injection {A = A} f = {x y : A} → (f x ≡ f y) → x ≡ y

Surjection : {a b : _} {A : Set a} {B : Set b} (f : A → B) → Set (a ⊔ b)
Surjection {A = A} {B = B} f = (b : B) → Sg A (λ a → f a ≡ b)

record Bijection {a b : _} {A : Set a} {B : Set b} (f : A → B) : Set (a ⊔ b) where
  field
    inj : Injection f
    surj : Surjection f

record Invertible {a b : _} {A : Set a} {B : Set b} (f : A → B) : Set (a ⊔ b) where
  field
    inverse : B → A
    isLeft : (b : B) → f (inverse b) ≡ b
    isRight : (a : A) → inverse (f a) ≡ a

id : {a : _} {A : Set a} → (A → A)
id a = a

dom : {a b : _} {A : Set a} {B : Set b} (f : A → B) → Set a
dom {A = A} f = A

codom : {a b : _} {A : Set a} {B : Set b} (f : A → B) → Set b
codom {B = B} f = B


data N : Set = zero | suc (n:N)
data B : Set = true | false

data False : Set =
data True  : Set = tt

F : B -> Set
F true  = N
F false = B

G : (x:B) -> F x -> Set
G false _      = N
G true zero    = B
G true (suc n) = N

(==) : B -> B -> Set
true == true = True
false == false = True
_ == _ = False

data Equal (x,y:B) : Set where
  equal : x == y -> Equal x y

refl : (x:B) -> Equal x x
refl true = equal tt
refl false = equal tt

postulate
  f : (x:B) -> (y : F x) -> G x y -> N -- Equal x true -> N

h : N
h = f _ false zero --(refl true)


open import Agda.Builtin.Nat

interleaved mutual

  plus : Nat → Nat → Nat
  mult : Nat → Nat → Nat

  -- base case
  mult 0 n = 0
  plus 0 n = n

  -- inductive case. The fun clauses with an ellipsis belong to mult
  mult (suc m) n with mult m n
  ... | p with plus p n
  ... | q = q
  plus (suc m) n = suc (plus m n)

open import Agda.Builtin.Equality

proof : ∀ m n → mult (suc m) n ≡ plus (mult m n) n
proof m n with mult m n
... | p with plus p n
... | q = refl


{-# OPTIONS --without-K #-}
module sets.finite.level where

open import sum
open import function.isomorphism.core
open import hott.level.core
open import hott.level.closure
open import hott.level.sets
open import sets.finite.core

finite-h2 : ∀ {i}{A : Set i} → IsFinite A → h 2 A
finite-h2 (n , fA) = iso-level (sym≅ fA) (fin-set n)


------------------------------------------------------------------------
-- Order morphisms
------------------------------------------------------------------------

module Relation.Binary.OrderMorphism where

open import Relation.Binary
open Poset
import Data.Function as F

record _⇒-Poset_ (po₁ po₂ : Poset) : Set where
  field
    fun      : carrier po₁ → carrier po₂
    monotone : _≤_ po₁ =[ fun ]⇒ _≤_ po₂

_⇒-DTO_ : (dto₁ dto₂ : DecTotalOrder) → Set
dto₁ ⇒-DTO dto₂ = poset dto₁ ⇒-Poset poset dto₂
  where open DecTotalOrder

open _⇒-Poset_

id : ∀ {po} → po ⇒-Poset po
id = record
  { fun      = F.id
  ; monotone = F.id
  }

_∘_ : ∀ {po₁ po₂ po₃} →
      po₂ ⇒-Poset po₃ → po₁ ⇒-Poset po₂ → po₁ ⇒-Poset po₃
f ∘ g = record
  { fun      = F._∘_ (fun f)      (fun g)
  ; monotone = F._∘_ (monotone f) (monotone g)
  }

const : ∀ {po₁ po₂} → carrier po₂ → po₁ ⇒-Poset po₂
const {po₂ = po₂} x = record
  { fun      = F.const x
  ; monotone = F.const (refl po₂)
  }


{-# OPTIONS --without-K #-}
open import Type using (Type₀; Type₁)
open import Type.Identities
open import Data.Zero using (𝟘)
open import Data.One using (𝟙; 0₁)
open import Data.Two.Base using (𝟚; 0₂; 1₂)
open import Data.Product.NP using (Σ; _×_)
open import Data.Sum.NP using (_⊎_)
open import Data.Nat.Base using (ℕ; zero; suc)
open import Data.Fin using (Fin)
open import Data.Vec using (Vec)
open import HoTT using (ua; UA; module Equivalences)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; idp)
open        Equivalences using (_≃_; ≃-!; ≃-refl; _≃-∙_)

module Explore.Universe.Type {X : Type₀} where

infixr 2 _×ᵁ_

data U : Type₁
El : U → Type₀

data U where
  𝟘ᵁ 𝟙ᵁ 𝟚ᵁ : U
  _×ᵁ_ _⊎ᵁ_ : U → U → U
  Σᵁ : (u : U) (f : El u → U) → U
  Xᵁ : U
  ≃ᵁ : (u : U) (A : Type₀) (e : El u ≃ A) → U

El 𝟘ᵁ = 𝟘
El 𝟙ᵁ = 𝟙
El 𝟚ᵁ = 𝟚
El (u₀ ×ᵁ u₁) = El u₀ × El u₁
El (u₀ ⊎ᵁ u₁) = El u₀ ⊎ El u₁
El (Σᵁ u f) = Σ (El u) λ x → El (f x)
El Xᵁ = X
El (≃ᵁ u A e) = A

infix  8 _^ᵁ_
_^ᵁ_ : U → ℕ → U
u ^ᵁ zero  = 𝟙ᵁ
u ^ᵁ suc n = u ×ᵁ u ^ᵁ n

^ᵁ≃Vec : ∀ u n → El (u ^ᵁ n) ≃ Vec (El u) n
^ᵁ≃Vec u zero = ≃-! Vec0≃𝟙
^ᵁ≃Vec u (suc n) = ×≃-second (El u) (^ᵁ≃Vec u n) ≃-∙ ≃-! Vec∘suc≃×

^ᵁ≡Vec : ∀ {{_ : UA}} u n → El (u ^ᵁ n) ≡ Vec (El u) n
^ᵁ≡Vec u n = ua (^ᵁ≃Vec u n)

Finᵁ : ℕ → U
Finᵁ zero    = 𝟘ᵁ
Finᵁ (suc n) = 𝟙ᵁ ⊎ᵁ Finᵁ n

Finᵁ' : ℕ → U
Finᵁ' zero          = 𝟘ᵁ
Finᵁ' (suc zero)    = 𝟙ᵁ
Finᵁ' (suc (suc n)) = 𝟙ᵁ ⊎ᵁ Finᵁ' (suc n)

Finᵁ≃Fin : ∀ n → El (Finᵁ n) ≃ Fin n
Finᵁ≃Fin zero    = ≃-! Fin0≃𝟘
Finᵁ≃Fin (suc n) = ⊎≃ ≃-refl (Finᵁ≃Fin n) ≃-∙ ≃-! Fin∘suc≃𝟙⊎Fin

Finᵁ'≃Fin : ∀ n → El (Finᵁ' n) ≃ Fin n
Finᵁ'≃Fin zero          = ≃-! Fin0≃𝟘
Finᵁ'≃Fin (suc zero)    = ≃-! Fin1≃𝟙
Finᵁ'≃Fin (suc (suc n)) = ⊎≃ ≃-refl (Finᵁ'≃Fin (suc n)) ≃-∙ ≃-! Fin∘suc≃𝟙⊎Fin


{-# OPTIONS --without-K --exact-split --rewriting --overlapping-instances #-}

open import lib.Basics
open import lib.NConnected
open import lib.NType2
open import lib.types.Truncation

open import Coequalizers.Definition
open import Coequalizers.Misc

open import Graphs.Definition

open import Util.Misc

module Groups.Definition where

{- BG has the structure of a type theoretic group if it is pointed, connected and
   1-truncated.
-}
record TTGroup {i : ULevel} (BG : Type i) : Type i where
  field
    base : BG
    ⦃ gp-conn ⦄ : is-connected 0 BG
    ⦃ gp-trunc ⦄ : is-gpd BG

open TTGroup ⦃...⦄ public

{- Some functions related to free higher groups (which we never define explicitly). -}
module _ {i : ULevel} {A : Type i} where
  instance -- Whenever we need a pair of maps A ⇉ 1 they are defined as follows
    gph-fhg : Graph A Unit
    gph-fhg = record { π₀ = λ _ → unit ; π₁ = λ _ → unit }

    conn-fhg : is-connected 0 (⊤ / A)
    conn-fhg = has-level-in ([ c[ unit ] ] , Trunc-elim (λ x → Trunc-rec (λ { (t , p) → ap [_] p}) (quotient-map-is-surj x)))

  fhg-base : ⊤ / A
  fhg-base = c[ unit ]

{- The definition of a free group. -}
FreeGroup : {i : ULevel} (A : Type i) → Type i
FreeGroup A = ∥ ⊤ / A ∥₁

instance -- free groups are groups
  free-gp-str : {i : ULevel} {A : Type i} → TTGroup (FreeGroup A)
  free-gp-str = record { base = [ fhg-base ] }


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

open import HoTT

module homotopy.HSpace where

-- This is just an approximation because
-- not all higher cells are killed.
record HSpaceStructure {i} (A : Type i) : Type i where
  constructor hSpaceStructure
  field
    e : A
    μ : A → A → A
    μ-e-l : (a : A) → μ e a == a
    μ-e-r : (a : A) → μ a e == a
    μ-coh : μ-e-l e == μ-e-r e

module ConnectedHSpace {i} (A : Type i) (c : is-connected 0 A)
  (hA : HSpaceStructure A) where

  open HSpaceStructure hA

  {-
  Given that [A] is 0-connected, to prove that each [μ a] is an equivalence we
  only need to prove that one of them is. But for [a] = [e], [μ a] is the
  identity so we’re done.
  -}

  μ-e-l-is-equiv : (a : A) → is-equiv (λ a' → μ a' a)
  μ-e-l-is-equiv = prop-over-connected {a = e} c
    (λ a → (is-equiv (λ a' → μ a' a) , is-equiv-is-prop (λ a' → μ a' a)))
    (transport! is-equiv (λ= μ-e-r) (idf-is-equiv A))

  μ-e-r-is-equiv : (a : A) → is-equiv (μ a)
  μ-e-r-is-equiv = prop-over-connected {a = e} c
    (λ a → (is-equiv (μ a) , is-equiv-is-prop (μ a)))
    (transport! is-equiv (λ= μ-e-l) (idf-is-equiv A))

  μ-e-l-equiv : A → A ≃ A
  μ-e-l-equiv a = _ , μ-e-l-is-equiv a

  μ-e-r-equiv : A → A ≃ A
  μ-e-r-equiv a = _ , μ-e-r-is-equiv a


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

open import Categories.Category using (Category; module Commutation)
open import Categories.Category.Monoidal.Core using (Monoidal)
open import Categories.Category.Monoidal.Symmetric using (Symmetric)

-- Extra identities that hold only for symmetric monoidal categories.

module Categories.Category.Monoidal.Interchange.Symmetric
  {o ℓ e} {C : Category o ℓ e} {M : Monoidal C} (S : Symmetric M) where

open import Data.Product using (_,_)

import Categories.Category.Construction.Core C as Core
import Categories.Category.Monoidal.Braided.Properties as BraidedProps
open import Categories.Category.Monoidal.Interchange using (HasInterchange)
import Categories.Category.Monoidal.Interchange.Braided as BraidedInterchange
  using (module swapInner; swapInner-braiding)
import Categories.Category.Monoidal.Reasoning M as MonoidalReasoning
import Categories.Category.Monoidal.Utilities M as MonoidalUtilities
open import Categories.Category.Product using (_⁂_; assocˡ)
open import Categories.Functor using (_∘F_)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (_≃_; niHelper)
open import Categories.Morphism.IsoEquiv C using (to-unique)
open import Categories.Morphism.Reasoning C
  using (elim-center; pushˡ; pullʳ; cancelInner; switch-fromtoˡ)

open Category C using (Obj; _⇒_; _∘_; id; sym-assoc; ∘-resp-≈ʳ; module Equiv)
open Commutation C
open MonoidalReasoning
open MonoidalUtilities using (_⊗ᵢ_)
open Symmetric S renaming (associator to α; braided to B)
open BraidedInterchange B
open Core.Shorthands               -- for idᵢ, _∘ᵢ_, ...
open MonoidalUtilities.Shorthands  -- for λ⇒, ρ⇒, α⇒, ...
open BraidedProps.Shorthands B     -- for σ⇒, ...

private
  variable
    W W₁ W₂ X X₁ X₂ Y Y₁ Y₂ Z Z₁ Z₂ : Obj
    f g h i : X ⇒ Y

private
  i⇒ = swapInner.from
  i⇐ = swapInner.to

swapInner-commutative : [ (X₁ ⊗₀ X₂) ⊗₀ (Y₁ ⊗₀ Y₂) ⇒
                          (X₁ ⊗₀ X₂) ⊗₀ (Y₁ ⊗₀ Y₂) ]⟨
                           i⇒    ⇒⟨ (X₁ ⊗₀ Y₁) ⊗₀ (X₂ ⊗₀ Y₂) ⟩
                           i⇒
                        ≈ id
                        ⟩
swapInner-commutative = begin
    i⇒ ∘ i⇒                                                               ≈⟨ pullʳ (cancelInner α.isoʳ) ⟩
    α⇐ ∘ id ⊗₁ (α⇒ ∘ σ⇒ ⊗₁ id ∘ α⇐) ∘ id ⊗₁ (α⇒ ∘ σ⇒ ⊗₁ id ∘ α⇐) ∘ α⇒  ≈˘⟨ refl⟩∘⟨ pushˡ split₂ˡ ⟩
    α⇐ ∘ id ⊗₁ ((α⇒ ∘ σ⇒ ⊗₁ id ∘ α⇐) ∘ α⇒ ∘ σ⇒ ⊗₁ id ∘ α⇐) ∘ α⇒        ≈⟨ refl⟩∘⟨ refl⟩⊗⟨ (∘-resp-≈ʳ sym-assoc ○ α[σ⊗1]α⁻¹.isoʳ) ⟩∘⟨refl ⟩
    α⇐ ∘ id ⊗₁ id ∘ α⇒                                                    ≈⟨ elim-center ⊗.identity ○ α.isoˡ ⟩
    id                                                                     ∎
  where module α[σ⊗1]α⁻¹ = _≅_ (α ∘ᵢ braided-iso ⊗ᵢ idᵢ ∘ᵢ α ⁻¹) using (isoʳ)

swapInner-iso : (W ⊗₀ X) ⊗₀ (Y ⊗₀ Z) ≅ (W ⊗₀ Y) ⊗₀ (X ⊗₀ Z)
swapInner-iso = record
  { from = i⇒
  ; to   = i⇒
  ; iso  = record
    { isoˡ = swapInner-commutative
    ; isoʳ = swapInner-commutative
    }
  }

swapInner-selfInverse : [ (X₁ ⊗₀ X₂) ⊗₀ (Y₁ ⊗₀ Y₂) ⇒
                          (X₁ ⊗₀ Y₁) ⊗₀ (X₂ ⊗₀ Y₂) ]⟨
                          i⇒
                        ≈ i⇐
                        ⟩
swapInner-selfInverse =
  to-unique (iso swapInner-iso) swapInner.iso Equiv.refl

swapInner-braiding′ : [ (W ⊗₀ X) ⊗₀ (Y ⊗₀ Z) ⇒ (Y ⊗₀ W) ⊗₀ (Z ⊗₀ X) ]⟨
                        i⇒         ⇒⟨ (W ⊗₀ Y) ⊗₀ (X ⊗₀ Z) ⟩
                        σ⇒ ⊗₁ σ⇒
                      ≈ σ⇒         ⇒⟨ (Y ⊗₀ Z) ⊗₀ (W ⊗₀ X) ⟩
                        i⇒
                      ⟩
swapInner-braiding′ = switch-fromtoˡ swapInner-iso swapInner-braiding


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.Groups.Wedge where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.HITs.Wedge
open import Cubical.HITs.SetTruncation renaming (elim to sElim ; elim2 to sElim2)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; ∣_∣ to ∣_∣₁)
open import Cubical.Data.Nat
open import Cubical.Data.Prod
open import Cubical.Data.Unit
open import Cubical.Algebra.Group

open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Sn

open import Cubical.HITs.Pushout

--- This module contains a proof that Hⁿ(A ⋁ B) ≅ Hⁿ(A) × Hⁿ(B), n ≥ 1

module _ {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ') where
  module I = MV (typ A) (typ B) Unit (λ _ → pt A) (λ _ → pt B)

  Hⁿ-⋁ : (n : ℕ) → GroupEquiv (coHomGr (suc n) (A ⋁ B)) (×coHomGr (suc n) (typ A) (typ B))
  Hⁿ-⋁ zero =
    BijectionIsoToGroupEquiv
      (bij-iso
        (grouphom
          (GroupHom.fun (I.i 1))
          (sElim2 (λ _ _ → isOfHLevelPath 2 (isOfHLevelΣ 2 setTruncIsSet λ _ → setTruncIsSet) _ _)
                  λ a b → GroupHom.isHom (I.i 1) ∣ a ∣₂ ∣ b ∣₂))
        (sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                λ f inker → helper ∣ f ∣₂ (I.Ker-i⊂Im-d 0 ∣ f ∣₂ inker))
        (sigmaElim (λ _ → isOfHLevelSuc 1 propTruncIsProp)
                   λ f g → I.Ker-Δ⊂Im-i 1 (∣ f ∣₂ , g) (isOfHLevelSuc 0 (isContrHⁿ-Unit 0) _ _)))
    where
    surj-helper : (x : coHom 0 Unit)
            → isInIm _ _ (I.Δ 0) x
    surj-helper =
      sElim (λ _ → isOfHLevelSuc 1 propTruncIsProp)
            λ f → ∣ (∣ (λ _ → f tt) ∣₂ , 0ₕ) , cong ∣_∣₂ (funExt (λ _ → cong ((f tt) +ₖ_) -0ₖ ∙ rUnitₖ (f tt))) ∣₁

    helper : (x : coHom 1 (A ⋁ B)) → isInIm _ _ (I.d 0) x
                  → x ≡ 0ₕ
    helper x inim =
      pRec (setTruncIsSet _ _)
           (λ p → sym (snd p) ∙
                       MV.Im-Δ⊂Ker-d _ _ Unit (λ _ → pt A) (λ _ → pt B) 0 (fst p) (surj-helper (fst p)))
             inim
  Hⁿ-⋁ (suc n) =
    vSES→GroupEquiv _ _
      (ses (isOfHLevelSuc 0 (isContrHⁿ-Unit n))
           (isOfHLevelSuc 0 (isContrHⁿ-Unit (suc n)))
           (I.d (suc n))
           (I.Δ (suc (suc n)))
           (I.i (suc (suc n)))
           (I.Ker-i⊂Im-d (suc n))
           (I.Ker-Δ⊂Im-i (suc (suc n))))

  open import Cubical.Foundations.Isomorphism
  wedgeConnected : ((x : typ A) → ∥ pt A ≡ x ∥) → ((x : typ B) → ∥ pt B ≡ x ∥) → (x : A ⋁ B) → ∥ (inl (pt A)) ≡ x ∥
  wedgeConnected conA conB =
    PushoutToProp (λ _ → propTruncIsProp)
                  (λ a → pRec propTruncIsProp (λ p → ∣ cong inl p ∣₁) (conA a))
                  λ b → pRec propTruncIsProp (λ p → ∣ push tt ∙ cong inr p ∣₁) (conB b)


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

open import Algebra.Construct.DirectProduct

module Construct.DirectProduct where

open import Algebra
import Algebra.Construct.DirectProduct as DirectProduct
open import Data.Product
open import Data.Product.Relation.Binary.Pointwise.NonDependent
open import Level using (Level; _⊔_)

private
  variable
    a b ℓ₁ ℓ₂ : Level

------------------------------------------------------------------------
-- Raw bundles

rawQuasigroup : RawQuasigroup a ℓ₁ → RawQuasigroup b ℓ₂ → RawQuasigroup (a ⊔ b) (ℓ₁ ⊔ ℓ₂)
rawQuasigroup M N = record
  { Carrier = M.Carrier × N.Carrier
  ; _≈_     = Pointwise M._≈_ N._≈_
  ; _∙_     = zip M._∙_ N._∙_
  ; _\\_    = zip M._\\_ N._\\_
  ; _//_    = zip M._//_ N._//_
  } where module M = RawQuasigroup M; module N = RawQuasigroup N

rawLoop : RawLoop a ℓ₁ → RawLoop b ℓ₂ → RawLoop (a ⊔ b) (ℓ₁ ⊔ ℓ₂)
rawLoop M N = record
  { Carrier = M.Carrier × N.Carrier
  ; _≈_     = Pointwise M._≈_ N._≈_
  ; _∙_     = zip M._∙_ N._∙_
  ; _\\_    = zip M._\\_ N._\\_
  ; _//_    = zip M._//_ N._//_
  ; ε       = M.ε , N.ε
  } where module M = RawLoop M; module N = RawLoop N

------------------------------------------------------------------------
-- Bundles

unitalMagma : UnitalMagma a ℓ₁ → UnitalMagma b ℓ₂ → UnitalMagma (a ⊔ b) (ℓ₁ ⊔ ℓ₂)
unitalMagma M N = record
  { ε = M.ε , N.ε
  ; isUnitalMagma = record
    { isMagma = Magma.isMagma (magma M.magma N.magma)
    ; identity = (M.identityˡ , N.identityˡ <*>_)
               , (M.identityʳ , N.identityʳ <*>_)
    }
  } where module M = UnitalMagma M; module N = UnitalMagma N

invertibleMagma : InvertibleMagma a ℓ₁ → InvertibleMagma b ℓ₂ → InvertibleMagma (a ⊔ b) (ℓ₁ ⊔ ℓ₂)
invertibleMagma M N = record
  { _⁻¹ = map M._⁻¹ N._⁻¹
  ; isInvertibleMagma = record
    { isMagma = Magma.isMagma (magma M.magma N.magma)
    ; inverse = (λ x → (M.inverseˡ , N.inverseˡ) <*> x)
                , (λ x → (M.inverseʳ , N.inverseʳ) <*> x)
    }
  } where module M = InvertibleMagma M; module N = InvertibleMagma N

invertibleUnitalMagma : InvertibleUnitalMagma a ℓ₁ → InvertibleUnitalMagma b ℓ₂ → InvertibleUnitalMagma (a ⊔ b) (ℓ₁ ⊔ ℓ₂)
invertibleUnitalMagma M N = record
  { ε = M.ε , N.ε
  ; isInvertibleUnitalMagma = record
    { isInvertibleMagma = InvertibleMagma.isInvertibleMagma (invertibleMagma M.invertibleMagma N.invertibleMagma)
    ; identity = (M.identityˡ , N.identityˡ <*>_)
               , (M.identityʳ , N.identityʳ <*>_)
    }
  } where module M = InvertibleUnitalMagma M; module N = InvertibleUnitalMagma N


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

module Categories.Category.Finite.Fin.Instance.Parallel where

open import Data.Nat using (ℕ)
open import Data.Fin
open import Data.Fin.Patterns
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)

open import Categories.Category.Finite.Fin
open import Categories.Category

private
  variable
    a b c d : Fin 2

--
--  /---0---\
-- 0         1
--  \---1---/
--
ParallelShape : FinCatShape
ParallelShape = record
  { size     = 2
  ; ∣_⇒_∣    = card
  ; hasShape = record
    { id        = id
    ; _∘_       = _∘_
    ; assoc     = assoc
    ; identityˡ = identityˡ
    ; identityʳ = identityʳ
    }
  }
  where card : Fin 2 → Fin 2 → ℕ
        card 0F 0F = 1
        card 0F 1F = 2
        card 1F 0F = 0
        card 1F 1F = 1

        id : Fin (card a a)
        id {0F} = 0F
        id {1F} = 0F

        _∘_ : ∀ {a b c} → Fin (card b c) → Fin (card a b) → Fin (card a c)
        _∘_ {0F} {0F} {0F} 0F 0F = 0F
        _∘_ {0F} {0F} {1F} 0F 0F = 0F
        _∘_ {0F} {0F} {1F} 1F 0F = 1F
        _∘_ {0F} {1F} {1F} 0F 0F = 0F
        _∘_ {0F} {1F} {1F} 0F 1F = 1F
        _∘_ {1F} {1F} {1F} 0F 0F = 0F

        assoc : ∀ {f : Fin (card a b)} {g : Fin (card b c)} {h : Fin (card c d)} →
                  ((h ∘ g) ∘ f) ≡ (h ∘ (g ∘ f))
        assoc {0F} {0F} {0F} {0F} {0F} {0F} {0F} = refl
        assoc {0F} {0F} {0F} {1F} {0F} {0F} {0F} = refl
        assoc {0F} {0F} {0F} {1F} {0F} {0F} {1F} = refl
        assoc {0F} {0F} {1F} {1F} {0F} {0F} {0F} = refl
        assoc {0F} {0F} {1F} {1F} {0F} {1F} {0F} = refl
        assoc {0F} {1F} {1F} {1F} {0F} {0F} {0F} = refl
        assoc {0F} {1F} {1F} {1F} {1F} {0F} {0F} = refl
        assoc {1F} {1F} {1F} {1F} {0F} {0F} {0F} = refl

        identityˡ : ∀ {a b} {f : Fin (card a b)} → (id ∘ f) ≡ f
        identityˡ {0F} {0F} {0F} = refl
        identityˡ {0F} {1F} {0F} = refl
        identityˡ {0F} {1F} {1F} = refl
        identityˡ {1F} {1F} {0F} = refl

        identityʳ : ∀ {a b} {f : Fin (card a b)} → (f ∘ id) ≡ f
        identityʳ {0F} {0F} {0F} = refl
        identityʳ {0F} {1F} {0F} = refl
        identityʳ {0F} {1F} {1F} = refl
        identityʳ {1F} {1F} {0F} = refl

Parallel : Category _ _ _
Parallel = FinCategory ParallelShape

module Parallel = Category Parallel


------------------------------------------------------------------------
-- The Agda standard library
--
-- Consequences of a monomorphism between binary relations
------------------------------------------------------------------------

-- See Data.Nat.Binary.Properties for examples of how this and similar
-- modules can be used to easily translate properties between types.

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

open import Function
open import Relation.Binary
open import Relation.Binary.Morphism

module Relation.Binary.Morphism.RelMonomorphism
  {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
  {_∼₁_ : Rel A ℓ₁} {_∼₂_ : Rel B ℓ₂}
  {⟦_⟧ : A → B} (isMonomorphism : IsRelMonomorphism _∼₁_ _∼₂_ ⟦_⟧)
  where

open import Data.Sum.Base as Sum
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable

open IsRelMonomorphism isMonomorphism

------------------------------------------------------------------------
-- Properties

refl : Reflexive _∼₂_ → Reflexive _∼₁_
refl refl = injective refl

sym : Symmetric _∼₂_ → Symmetric _∼₁_
sym sym x∼y = injective (sym (cong x∼y))

trans : Transitive _∼₂_ → Transitive _∼₁_
trans trans x∼y y∼z = injective (trans (cong x∼y) (cong y∼z))

total : Total _∼₂_ → Total _∼₁_
total total x y = Sum.map injective injective (total ⟦ x ⟧ ⟦ y ⟧)

asym : Asymmetric _∼₂_ → Asymmetric _∼₁_
asym asym x∼y y∼x = asym (cong x∼y) (cong y∼x)

dec : Decidable _∼₂_ → Decidable _∼₁_
dec _∼?_ x y = map′ injective cong (⟦ x ⟧ ∼? ⟦ y ⟧)

------------------------------------------------------------------------
-- Structures

isEquivalence : IsEquivalence _∼₂_ → IsEquivalence _∼₁_
isEquivalence isEq = record
  { refl  = refl  E.refl
  ; sym   = sym   E.sym
  ; trans = trans E.trans
  } where module E = IsEquivalence isEq

isDecEquivalence : IsDecEquivalence _∼₂_ → IsDecEquivalence _∼₁_
isDecEquivalence isDecEq = record
  { isEquivalence  = isEquivalence E.isEquivalence
  ; _≟_            = dec E._≟_
  } where module E = IsDecEquivalence isDecEq


-- Check that the termination checker can handle recursive
-- calls on subterms which aren't simply variables.
module SubtermTermination where

data N : Set where
  zero : N
  suc  : N → N

f : N → N
f (suc zero) = f zero
f _          = zero

data One? : N → Set where
  one : One? (suc zero)
  other : ∀ {n} → One? n

-- Should work for dot patterns as well
f′ : (n : N) → One? n → N
f′ (suc .zero) one = f′ zero other
f′ _           _   = zero

f″ : (n : N) → One? n → N
f″ ._ one = f″ zero other
f″ _  _   = zero

data D : Set where
  c₁ : D
  c₂ : D → D
  c₃ : D → D → D

g : D → D
g (c₃ (c₂ x) y) = g (c₂ x)
g _ = c₁

{- Andreas, 2011-07-07 subterm is not complete
   does not work with postulates or definitions

postulate
  i : {A : Set} → A → A

data NAT : N → Set where
  Zero : NAT zero
  Suc  : ∀ n → NAT (i n) → NAT (suc (i n))

h : (n : N) -> NAT n -> Set
h .zero Zero = N
h .(suc (i n)) (Suc n m) = h (i n) (i m)
-}


module InfConj where

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

record Stream (A : Set) : Set where
  coinductive
  constructor _∷_
  field
    hd : A
    tl : Stream A
open Stream public

-- | Partial elements
record D (A : Set) : Set where
  coinductive
  field step : A ⊎ D A
open D public

-- | Lift ⊎ to relations
data _⊎'_ {A B : Set} (R : A → A → Set) (S : B → B → Set) : A ⊎ B → A ⊎ B → Set where
  inj₁' : {x y : A} → R x y → (R ⊎' S) (inj₁ x) (inj₁ y)
  inj₂' : {x y : B} → S x y → (R ⊎' S) (inj₂ x) (inj₂ y)

-- | Bisimilarity for partial elements
record _~_ {A : Set} (x y : D A) : Set where
  coinductive
  field step~ : (_≡_ ⊎' _~_) (x .step) (y .step)
open _~_ public

-- | Injection into D
η : {A : Set} → A → D A
η a .step = inj₁ a

-- | Conjunction for partial Booleans
_∧'_ : D Bool → D Bool → D Bool
(x ∧' y) .step with x .step  | y .step
(x ∧' y) .step | inj₁ false  | v           = inj₁ false
(x ∧' y) .step | inj₁ true   | v           = v
(x ∧' y) .step | inj₂ x'     | inj₁ false  = inj₁ false
(x ∧' y) .step | inj₂ x'     | inj₁ true   = inj₂ x'
(x ∧' y) .step | inj₂ x'     | inj₂ y'     = inj₂ (x' ∧' y')

-- | Infinite conjunction
⋀∞ : Stream Bool → D Bool
⋀∞ s .step with s .hd
⋀∞ s .step | false = inj₁ false
⋀∞ s .step | true = inj₂ (⋀∞ (s .tl))

-- | Constant stream
K : {A : Set} → A → Stream A
K a .hd = a
K a .tl = K a

-- | Non-terminating computation
⊥ : {A : Set} → D A
⊥ .step = inj₂ ⊥

-- | Infinite conjunction of constant stream does not terminate
prop : ⋀∞ (K true) ~ ⊥
prop .step~ = inj₂' prop

-- | If there is an entry "false" in the stream, then the infinite conjunction
-- terminates. Here is just an example.
ex : ⋀∞ (false ∷ K true) ~ η false
ex .step~ = inj₁' refl


open import Agda.Primitive
open import Agda.Builtin.Nat
open import Agda.Builtin.Bool

-----------------------------------------------------
-- Σ types
-----------------------------------------------------
data Σ {A : Set} (P : A → Set) : Set where
    Σ_intro : ∀ (a : A) → P a → Σ P

-----------------------------------------------------
-- Π type
-----------------------------------------------------
data Π {A : Set} (P : A → Set) : Set where
    Π_intro : (∀ (a : A) → P a) → Π P

-----------------------------------------------------
-- constT
-----------------------------------------------------
constT : ∀ (X : Set) (Y : Set) → Y → Set
constT x _ _ = x

-----------------------------------------------------
-- Tuples using Σ types (const)
-----------------------------------------------------
Σ-pair : ∀ (A B : Set) → Set
Σ-pair a b = Σ (constT b a)

Σ-mkPair : ∀ {A : Set}  {B : Set} → A → B → Σ-pair A B
Σ-mkPair a b = Σ_intro a b

Σ-fst : ∀ {A B : Set} → Σ-pair A B → A
Σ-fst (Σ_intro a _) = a

Σ-snd : ∀ {A B : Set} → Σ-pair A B → B
Σ-snd (Σ_intro _ b) = b

-----------------------------------------------------
-- Exponential using Π type (const)
-----------------------------------------------------
Π-function : ∀ (A B : Set) → Set
Π-function a b = Π (constT b a)

Π-mkFunction : ∀ {A B : Set} → (A → B) → Π-function A B
Π-mkFunction f = Π_intro f

Π-apply : ∀ {A B : Set} → Π-function A B → A → B
Π-apply (Π_intro f) a = f a

-----------------------------------------------------
-- bool
-----------------------------------------------------
bool : ∀ (A B : Set) → Bool → Set
bool a _ true  = a
bool _ b false = b

-----------------------------------------------------
-- Sum type using Σ types
-----------------------------------------------------
Σ-sum : ∀ (A B : Set) → Set
Σ-sum a b = Σ (bool a b)

Σ-sum_left : ∀ {A : Set} (B : Set) → A → Σ-sum A B
Σ-sum_left _ a = Σ_intro true a

Σ-sum_right : ∀ {B : Set} (A : Set) → B → Σ-sum A B
Σ-sum_right _ b = Σ_intro false b

Σ-sum_elim : ∀ {A B R : Set} → (A → R) → (B → R) → Σ-sum A B → R
Σ-sum_elim f _ (Σ_intro true  a) = f a
Σ-sum_elim _ g (Σ_intro false b) = g b

-----------------------------------------------------
-- prodPredicate
-----------------------------------------------------
prodPredicate : ∀ (A B R : Set) → Set
prodPredicate a b r = (a → r) → (b → r) → r

-----------------------------------------------------
-- Sum type using Π types
-----------------------------------------------------
data Π' {a b} {A : Set a} (P : A → Set b) : Set (a ⊔ b) where
    Π'_intro : (∀ (a : A) → P a) → Π' P

Π-sum : ∀ (A B : Set) → Set₁
Π-sum a b = Π' (prodPredicate a b)

Π-sum-left : ∀ {A : Set} (B : Set) → A → Π-sum A B
Π-sum-left _ a = Π'_intro (\_ f _ → f a)

Π-sum-right : ∀ {A : Set} (B : Set) → B → Π-sum A B
Π-sum-right _ b = Π'_intro (\_ _ g → g b)

Π-sum-elim : ∀ {A B R : Set} → (A → R) → (B → R) → Π-sum A B → R
Π-sum-elim f g (Π'_intro elim) = elim _ f g

-----------------------------------------------------
-- Extra: Tuples using Π types
-----------------------------------------------------
Π-pair : ∀ (A B : Set) → Set
Π-pair a b = Π (bool a b)

Π-mkPair : ∀ {A B : Set} → A → B → Π-pair A B
Π-mkPair a b = Π_intro f
    where
    f : (b : Bool) → bool _ _ b
    f true = a
    f false = b

Π-fst : ∀ {A B : Set} → Π-pair A B → A
Π-fst (Π_intro f) = f true

Π-snd : ∀ {A B : Set} → Π-pair A B → B
Π-snd (Π_intro f) = f false

---
-- ??
--

data Σ' {a b} {A : Set a} (P : A → Set b) : Set (a ⊔ b) where
    Σ'_intro : ∀ (a : A) → P a → Σ' P

id : ∀ {A : Set} → A → A
id a = a

x : ∀ (A : Set) → Set1
x a = Σ (\(b : Set1) → (a → b))

mk : ∀ (A B : Set) → A → x A B
mk _ b a' = Σ'_intro b (\f g → f (g a'))

elim : {A B : Set} → (A → B) → x A B → B
elim f (Σ'_intro _ g) = g id f

 -- : ∀ {A : Set} (B : Set) → A → Π-sum A B
--Π-sum-left _ a = Π'_intro (\_ f _ → f a)
--
--Π-sum-right : ∀ {A : Set} (B : Set) → B → Π-sum A B
--Π-sum-right _ b = Π'_intro (\_ _ g → g b)
--
--Π-sum-elim : ∀ {A B R : Set} → (A → R) → (B → R) → Π-sum A B → R
--Π-sum-elim f g (Π'_intro elim) = elim _ f g


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by strict partial orders
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.Properties.StrictPartialOrder
       {s₁ s₂ s₃} (SPO : StrictPartialOrder s₁ s₂ s₃) where

open Relation.Binary.StrictPartialOrder SPO
  renaming (trans to <-trans)
import Relation.Binary.StrictToNonStrict as Conv
open Conv _≈_ _<_

------------------------------------------------------------------------
-- Strict partial orders can be converted to posets

poset : Poset _ _ _
poset = record
  { isPartialOrder = record
    { isPreorder = record
        { isEquivalence = isEquivalence
        ; reflexive     = reflexive
        ; trans         = trans isEquivalence <-resp-≈ <-trans
        }
    ; antisym = antisym isEquivalence <-trans irrefl
    }
  }

open Poset poset public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bisimilarity for Conats
------------------------------------------------------------------------

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

module Codata.Conat.Bisimilarity where

open import Level using (0ℓ)
open import Size
open import Codata.Thunk
open import Codata.Conat
open import Relation.Binary

infix 1 _⊢_≈_
data _⊢_≈_ i : (m n : Conat ∞) → Set where
  zero : i ⊢ zero ≈ zero
  suc  : ∀ {m n} → Thunk^R _⊢_≈_ i m n → i ⊢ suc m ≈ suc n

refl : ∀ {i m} → i ⊢ m ≈ m
refl {m = zero}  = zero
refl {m = suc m} = suc λ where .force → refl

sym : ∀ {i m n} → i ⊢ m ≈ n → i ⊢ n ≈ m
sym zero     = zero
sym (suc eq) = suc λ where .force → sym (eq .force)

trans : ∀ {i m n p} → i ⊢ m ≈ n → i ⊢ n ≈ p → i ⊢ m ≈ p
trans zero      zero      = zero
trans (suc eq₁) (suc eq₂) = suc λ where .force → trans (eq₁ .force) (eq₂ .force)

isEquivalence : ∀ {i} → IsEquivalence (i ⊢_≈_)
isEquivalence = record
  { refl  = refl
  ; sym   = sym
  ; trans = trans
  }

setoid : Size → Setoid 0ℓ 0ℓ
setoid i = record
  { isEquivalence = isEquivalence {i = i}
  }

module ≈-Reasoning {i} where

  open import Relation.Binary.Reasoning.Setoid (setoid i) public

infix 1 _⊢_≲_
data _⊢_≲_ i : (m n : Conat ∞) → Set where
  z≲n : ∀ {n} → i ⊢ zero ≲ n
  s≲s : ∀ {m n} → Thunk^R _⊢_≲_ i m n → i ⊢ suc m ≲ suc n

≈⇒≲ : ∀ {i m n} → i ⊢ m ≈ n → i ⊢ m ≲ n
≈⇒≲ zero     = z≲n
≈⇒≲ (suc eq) = s≲s λ where .force → ≈⇒≲ (eq .force)

≲-refl : ∀ {i m} → i ⊢ m ≲ m
≲-refl = ≈⇒≲ refl

≲-antisym : ∀ {i m n} → i ⊢ m ≲ n → i ⊢ n ≲ m → i ⊢ m ≈ n
≲-antisym z≲n      z≲n      = zero
≲-antisym (s≲s le) (s≲s ge) = suc λ where .force → ≲-antisym (le .force) (ge .force)

≲-trans : ∀ {i m n p} → i ⊢ m ≲ n → i ⊢ n ≲ p → i ⊢ m ≲ p
≲-trans z≲n       _         = z≲n
≲-trans (s≲s le₁) (s≲s le₂) = s≲s λ where .force → ≲-trans (le₁ .force) (le₂ .force)


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

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma

open import Cubical.Algebra
open import Cubical.Algebra.Group.Morphism
open import Cubical.Algebra.Monoid.Submonoid

open import Cubical.Relation.Unary
open import Cubical.Relation.Unary.Subtype

open import Cubical.HITs.PropositionalTruncation

record IsSubgroup {c ℓ} (G : Group c) (Member : Pred ⟨ G ⟩ ℓ) : Type (ℓ-max c ℓ) where
  constructor issubgroup

  private module G = Group G

  field
    preservesOp : G._•_ Preserves₂ Member
    preservesInv : G._⁻¹ Preserves Member
    preservesId : G.ε ∈ Member

  isSubmonoid : IsSubmonoid G.monoid Member
  isSubmonoid = record
    { preservesOp = preservesOp
    ; preservesId = preservesId
    }

  open IsSubmonoid isSubmonoid hiding (preservesOp; preservesId; _^_) public

  _⁻¹ : Op₁ Carrier
  (x , subx) ⁻¹ = x G.⁻¹ , preservesInv subx

  inverseˡ : LeftInverse ε _⁻¹ _•_
  inverseˡ _ = ΣPathTransport→PathΣ _ _ (G.inverseˡ _ , isProp[ Member ] _ _ _)

  inverseʳ : RightInverse ε _⁻¹ _•_
  inverseʳ _ = ΣPathTransport→PathΣ _ _ (G.inverseʳ _ , isProp[ Member ] _ _ _)

  inverse : Inverse ε _⁻¹ _•_
  inverse = inverseˡ , inverseʳ

  isGroup : IsGroup Carrier _•_ ε _⁻¹
  isGroup = record
    { isMonoid = isMonoid
    ; inverse = inverse
    }

  group : Group _
  group = record { isGroup = isGroup }

  open Group group using
    ( _^_
    ; _/_
    ; _/ˡ_
    ; inv-uniqueˡ
    ; inv-uniqueʳ
    ; cancelˡ
    ; cancelʳ
    ) public

record Subgroup {c} (G : Group c) ℓ : Type (ℓ-max c (ℓ-suc ℓ)) where
  constructor mksubgroup

  private module G = Group G

  field
    Member : Pred ⟨ G ⟩ ℓ
    isSubgroup : IsSubgroup G Member

  open IsSubgroup isSubgroup public

  submonoid : Submonoid G.monoid ℓ
  submonoid = record { isSubmonoid = isSubmonoid }

  open Submonoid submonoid using (submagma; subsemigroup)

instance
  SubgroupCarrier : ∀ {c ℓ} {G : Group c} → HasCarrier (Subgroup G ℓ) _
  SubgroupCarrier = record { ⟨_⟩ = Subgroup.Carrier }

private
  variable
    c ℓ : Level
    G : Group c

module _ {G : Group c} where
  open Group G

  ε-isSubgroup : IsSubgroup G ｛ ε ｝
  ε-isSubgroup = record
    { preservesOp = map2 λ p q → cong₂ _•_ p q ∙ identityʳ ε
    ; preservesInv = map λ p → cong _⁻¹ p ∙ cancelʳ ε (inverseˡ ε ∙ sym (identityʳ ε))
    ; preservesId = ∣ refl ∣
    }

  ε-subgroup : Subgroup G _
  ε-subgroup = record { isSubgroup = ε-isSubgroup }

  U-isSubgroup : IsSubgroup G U
  U-isSubgroup = record {} -- trivial

  U-subgroup : Subgroup G _
  U-subgroup = record { isSubgroup = U-isSubgroup }

IsNormal : Subgroup G ℓ → Type _
IsNormal {G = G} N =
  ∀ ((n , _) : ⟨ N ⟩) (g : ⟨ G ⟩) → g • n • g ⁻¹ ∈ Subgroup.Member N
  where
    open Group G

NormalSubgroup : Group c → (ℓ : Level) → Type _
NormalSubgroup G ℓ = Σ (Subgroup G ℓ) IsNormal


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

open import Categories.Category.Core
open import Categories.Comonad

-- verbatim dual of Categories.Adjoint.Construction.EilenbergMoore
module Categories.Adjoint.Construction.CoEilenbergMoore {o ℓ e} {C : Category o ℓ e} (M : Comonad C) where

open import Categories.Category.Construction.CoEilenbergMoore M
open import Categories.Adjoint
open import Categories.Functor
open import Categories.Functor.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism using (niHelper)
open import Categories.NaturalTransformation.Core
open import Categories.NaturalTransformation.NaturalIsomorphism using (_≃_)
open import Categories.Morphism.Reasoning C

private
  module C = Category C
  module M = Comonad M
  open M.F
  open C
  open HomReasoning
  open Equiv

Forgetful : Functor CoEilenbergMoore C
Forgetful = record
  { F₀           = Comodule.A
  ; F₁           = Comodule⇒.arr
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = λ eq → eq
  }

Cofree : Functor C CoEilenbergMoore
Cofree = record
 { F₀ = λ A → record
  { A = F₀ A
  ; coaction = M.δ.η A
  ; commute = M.sym-assoc
  ; identity = Comonad.identityʳ M
  }
 ; F₁ = λ f → record
  { arr = F₁ f
  ; commute = M.δ.commute f
  }
 ; identity = identity
 ; homomorphism = homomorphism
 ; F-resp-≈ = F-resp-≈
 }

UC≃M : Forgetful ∘F Cofree ≃ M.F
UC≃M = niHelper (record
 { η = λ _ → F₁ C.id
 ; η⁻¹ = λ _ → F₁ C.id
 ; commute = λ f → [ M.F ]-resp-square id-comm-sym
 ; iso = λ _ → record
    { isoˡ = elimˡ identity ○ identity
    ; isoʳ = elimˡ identity ○ identity
    }
 })

Forgetful⊣Cofree : Forgetful ⊣ Cofree
Forgetful⊣Cofree = record
 { unit = record
  { η = λ X → let module X = Comodule X
      in record
        { arr     = X.coaction
        ; commute = ⟺ X.commute
        }
  ; commute = Comodule⇒.commute
  ; sym-commute = λ f → ⟺ (Comodule⇒.commute f)
  }
 ; counit = record
  { η = M.ε.η
  ; commute = M.ε.commute
  ; sym-commute = M.ε.sym-commute
  }
 ; zig = λ {A} → Comodule.identity A
 ; zag = λ {B} → Comonad.identityˡ M
 }


open import Agda.Builtin.FromNat
open import Data.Nat.Base  as ℕ using (ℕ; suc; zero; _>_; _≤?_)
open import Data.List.Base as L using (List; _∷_; []; _++_)
open import Relation.Nullary.Decidable using (True)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

module Data.Pos where

open import Data.Nat.FromNat public

data ℕ⁺ : Set where
  suc : ℕ → ℕ⁺

instance
  NumberPos : Number ℕ⁺
  NumberPos = record { Constraint = Pos; fromNat = fromℕ }
    where
      Pos : ℕ → Set
      Pos n = True (suc zero ≤? n)
      fromℕ : (n : ℕ) {{p : Pos n}} → ℕ⁺
      fromℕ zero {{()}}
      fromℕ (suc zero)    = suc zero
      fromℕ (suc (suc n)) = suc (suc n)

toℕ : ℕ⁺ → ℕ
toℕ (suc n) = suc n

_+_ : ℕ⁺ → ℕ⁺ → ℕ⁺
suc m + n = suc (m ℕ.+ toℕ n)

toℕ-+ : (m {n} : ℕ⁺) → toℕ m ℕ.+ toℕ n ≡ toℕ (m + n)
toℕ-+ (suc m) = P.refl

replicate⁺ : ∀ {a} {A : Set a} → ℕ⁺ → A → List A
replicate⁺ (suc n) x = x ∷ L.replicate n x

replicate⁺-++-commute : ∀ {a} {A : Set a} {x : A} (m n : ℕ⁺) →
  replicate⁺ m x ++ replicate⁺ n x ≡ replicate⁺ (m + n) x
replicate⁺-++-commute (suc m) (suc n)
  = P.cong (_ ∷_) (replicate-++-commute m (suc n))
  where
    replicate-++-commute : ∀ {a} {A : Set a} {x : A} (m n : ℕ) →
      L.replicate m x ++ L.replicate n x ≡ L.replicate (m ℕ.+ n) x
    replicate-++-commute  zero   n = P.refl
    replicate-++-commute (suc m) n = P.cong (_ ∷_) (replicate-++-commute m n)


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

{-

This file defines integers as equivalence classes of pairs of natural numbers
using a direct & untruncated HIT definition (cf. HITs.Ints.DiffInt)

and some basic operations, and the zero value:

succ : DeltaInt → DeltaInt
pred : DeltaInt → DeltaInt
zero : {a : ℕ} → DeltaInt

and conversion function for ℕ and Int:

fromℕ : ℕ → DeltaInt
fromInt : Int → DeltaInt
toInt : DeltaInt → Int

and a generalized version of cancel:

cancelN : ∀ a b n → a ⊖ b ≡ (n + a) ⊖ n + b

-}

module Cubical.HITs.Ints.DeltaInt.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Nat hiding (zero)
open import Cubical.Data.Int hiding (abs; sgn; _+_)

infixl 5 _⊖_
data DeltaInt : Type₀ where
  _⊖_    : ℕ → ℕ → DeltaInt
  cancel : ∀ a b → a ⊖ b ≡ suc a ⊖ suc b

succ : DeltaInt → DeltaInt
succ (x ⊖ y) = suc x ⊖ y
succ (cancel a b i) = cancel (suc a) b i

pred : DeltaInt → DeltaInt
pred (x ⊖ y) = x ⊖ suc y
pred (cancel a b i) = cancel a (suc b) i

zero : {a : ℕ} → DeltaInt
zero {a} = a ⊖ a

fromℕ : ℕ → DeltaInt
fromℕ n = n ⊖ 0

fromInt : Int → DeltaInt
fromInt (pos n) = fromℕ n
fromInt (negsuc n) = 0 ⊖ suc n

toInt : DeltaInt → Int
toInt (x ⊖ y) = x ℕ- y
toInt (cancel a b i) = a ℕ- b

cancelN : ∀ a b n → a ⊖ b ≡ (n + a) ⊖ n + b
cancelN a b 0 = refl
cancelN a b (suc n) = cancelN a b n ∙ cancel (n + a) (n + b)


open import Agda.Builtin.Nat

data List (A : Set) : Set where
  lnil : List A
  lcons : A → List A → List A

data Vec (A : Set) : Nat → Set where
  vnil  : Vec A 0
  vcons : ∀ {n} → A → Vec A n → Vec A (suc n)

pattern [] = lnil
pattern [] = vnil

pattern _∷_ x xs = lcons x xs
pattern _∷_ y ys = vcons y ys

lmap : ∀ {A B} → (A → B) → List A → List B
lmap f [] = []
lmap f (x ∷ xs) = f x ∷ lmap f xs

vmap : ∀ {A B n} → (A → B) → Vec A n → Vec B n
vmap f [] = []
vmap f (x ∷ xs) = f x ∷ vmap f xs


module optics where

  open import Function
  open import Data.Nat
  open import Data.Vec
  open import Agda.Builtin.Sigma
  open import Data.Product
  import Relation.Binary.PropositionalEquality as Eq
  open Eq using (_≡_; refl; trans; sym; cong; cong-app; subst)

  record TraversalF (S T A B : Set) : Set where
    field
      extract : Σ[ f ∈ (S -> ℕ) ] ((s : S) -> Vec A (f s) × (Vec B (f s) -> T))

  record Traversal (S T A B : Set) : Set where
    field
      --extract : S -> ∃[ n ] (Vec A n × (Vec B n -> T))
      extract : S -> Σ[ n ∈ ℕ ] Vec A n × (Vec B n -> T)

    get : (s : S) -> Vec A (fst (extract s))
    get = fst ∘ snd ∘ extract

    put : (s : S) -> Vec B (fst (extract s)) -> T
    put = snd ∘ snd ∘ extract

  record TraversalLaws (S A : Set) (t : Traversal S S A A): Set where
    open Traversal t public
    field
      get-put-law : (s : S) -> (put s) (get s) ≡ s
      -- put-get-law : (s : S) -> (v : Vec A (fst (Traversal.extract t s))) ->
      --  (Traversal.get t (Traversal.put t s v)) ≡ {!!}

  record Traversal2 (S A B T : Set) : Set where
    field
      extract : (s : S) -> Σ[ f ∈ (S -> ℕ) ] Vec A (f s) × (Vec B (f s) -> T)


import      Lvl
open import Type

module Data.IndexedList {ℓ ℓᵢ} (T : Type{ℓ}) {I : Type{ℓᵢ}} where

private variable i : I

record Index : Type{ℓᵢ Lvl.⊔ ℓ} where
  constructor intro
  field
    ∅   : I
    _⊰_ : T → I → I

module _ ((intro ∅ᵢ _⊰ᵢ_) : Index) where
  data IndexedList : I → Type{ℓᵢ Lvl.⊔ ℓ} where
    ∅   : IndexedList(∅ᵢ)
    _⊰_ : (x : T) → IndexedList(i) → IndexedList(x ⊰ᵢ i)

  infixr 1000 _⊰_

  private variable ℓₚ : Lvl.Level
  private variable index : Index
  private variable l : IndexedList i

  module _ (P : ∀{i} → IndexedList i → Type{ℓₚ}) where
    elim : P(∅) → (∀{i}(x)(l : IndexedList i) → P(l) → P(x ⊰ l)) → ((l : IndexedList i) → P(l))
    elim base next ∅       = base
    elim base next (x ⊰ l) = next x l (elim base next l)

module LongOper where
  pattern empty = ∅
  pattern prepend elem list = elem ⊰ list
pattern singleton x = x ⊰ ∅


module SemiLattice where

open import Prelude
open import PartialOrder as PO
import Chain

private
 module IsSemiLat
   {A : Set}(po : PartialOrder A)(_⊓_ : A -> A -> A) where
  private open module PO = PartialOrder po

  record IsSemiLattice : Set where
    field
      ⊓-lbL : forall {x y}   -> (x ⊓ y) ≤ x
      ⊓-lbR : forall {x y}   -> (x ⊓ y) ≤ y
      ⊓-glb : forall {x y z} -> z ≤ x -> z ≤ y -> z ≤ (x ⊓ y)

open IsSemiLat public

record SemiLattice (A : Set) : Set1 where
  field
    po  : PartialOrder A
    _⊓_ : A -> A -> A
    prf : IsSemiLattice po _⊓_

module SemiLat {A : Set}(L : SemiLattice A) where

  private module SL   = SemiLattice L
  private module SLPO = POrder SL.po
  private module IsSL = IsSemiLattice SL.po SL._⊓_ SL.prf

  open SLPO public
  open SL   public hiding (prf)
  open IsSL public

  private open module C≤ = Chain _≤_ (\x -> ≤-refl) (\x y z -> ≤-trans)
                      renaming (_===_ to _-≤-_; chain>_ to trans>_)

  ⊓-commute : forall {x y} -> (x ⊓ y) == (y ⊓ x)
  ⊓-commute = ≤-antisym lem lem
    where
      lem : forall {x y} -> (x ⊓ y) ≤ (y ⊓ x)
      lem = ⊓-glb ⊓-lbR ⊓-lbL

  ⊓-assoc : forall {x y z} -> (x ⊓ (y ⊓ z)) == ((x ⊓ y) ⊓ z)
  ⊓-assoc = ≤-antisym lem₁ lem₂
    where
      lem₁ : forall {x y z} -> (x ⊓ (y ⊓ z)) ≤ ((x ⊓ y) ⊓ z)
      lem₁ = ⊓-glb (⊓-glb ⊓-lbL (≤-trans ⊓-lbR ⊓-lbL))
                   (≤-trans ⊓-lbR ⊓-lbR)

      lem₂ : forall {x y z} ->  ((x ⊓ y) ⊓ z) ≤ (x ⊓ (y ⊓ z))
      lem₂ = ⊓-glb (≤-trans ⊓-lbL ⊓-lbL)
                   (⊓-glb (≤-trans ⊓-lbL ⊓-lbR) ⊓-lbR)

  ⊓-idem : forall {x} -> (x ⊓ x) == x
  ⊓-idem = ≤-antisym ⊓-lbL (⊓-glb ≤-refl ≤-refl)

  ≤⊓-L : forall {x y} -> (x ≤ y) ⇐⇒ ((x ⊓ y) == x)
  ≤⊓-L = (fwd , bwd)
    where
      fwd = \x≤y -> ≤-antisym ⊓-lbL (⊓-glb ≤-refl x≤y)
      bwd = \x⊓y=x -> ≤-trans (==≤-R x⊓y=x) ⊓-lbR

  ≤⊓-R : forall {x y} -> (y ≤ x) ⇐⇒ ((x ⊓ y) == y)
  ≤⊓-R {x}{y} = (fwd , bwd)
    where
      lem : (y ≤ x) ⇐⇒ ((y ⊓ x) == y)
      lem = ≤⊓-L

      fwd = \y≤x -> ==-trans ⊓-commute (fst lem y≤x)
      bwd = \x⊓y=y -> snd lem (==-trans ⊓-commute x⊓y=y)

  ⊓-monotone-R : forall {a} -> Monotone (\x -> a ⊓ x)
  ⊓-monotone-R x≤y = ⊓-glb ⊓-lbL (≤-trans ⊓-lbR x≤y)

  ⊓-monotone-L : forall {a} -> Monotone (\x -> x ⊓ a)
  ⊓-monotone-L {a}{x}{y} x≤y =
    trans> x ⊓ a
       -≤- a ⊓ x  by ==≤-L ⊓-commute
       -≤- a ⊓ y  by ⊓-monotone-R x≤y
       -≤- y ⊓ a  by ==≤-L ⊓-commute

  ≤⊓-compat : forall {w x y z} -> w ≤ y -> x ≤ z -> (w ⊓ x) ≤ (y ⊓ z)
  ≤⊓-compat {w}{x}{y}{z} w≤y x≤z =
    trans> w ⊓ x
       -≤- w ⊓ z  by ⊓-monotone-R x≤z
       -≤- y ⊓ z  by ⊓-monotone-L w≤y

  ⊓-cong : forall {w x y z} -> w == y -> x == z -> (w ⊓ x) == (y ⊓ z)
  ⊓-cong wy xz = ≤-antisym (≤⊓-compat (==≤-L wy) (==≤-L xz))
                           (≤⊓-compat (==≤-R wy) (==≤-R xz))

  ⊓-cong-L : forall {x y z} -> x == y -> (x ⊓ z) == (y ⊓ z)
  ⊓-cong-L xy = ⊓-cong xy ==-refl

  ⊓-cong-R : forall {x y z} -> x == y -> (z ⊓ x) == (z ⊓ y)
  ⊓-cong-R xy = ⊓-cong ==-refl xy


-- Andreas, 2016-09-20, issue #2196 reported by mechvel
-- Test case by Ulf

-- {-# OPTIONS -v tc.lhs.dot:40 #-}

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

record _×_ (A B : Set) : Set where
  constructor _,_
  field fst : A
        snd : B
open _×_

EqP₁ : ∀ {A B} (p q : A × B) → Set
EqP₁ (x , y) (z , w) = (x ≡ z) × (y ≡ w)

EqP₂ : ∀ {A B} (p q : A × B) → Set
EqP₂ p q = (fst p ≡ fst q) × (snd p ≡ snd q)

works : {A : Set} (p q : A × A) → EqP₁ p q → Set₁
works (x , y) .(x , y) (refl , refl) = Set

test  : {A : Set} (p q : A × A) → EqP₂ p q → Set₁
test  (x , y) .(x , y) (refl , refl) = Set

-- ERROR WAS:
-- Failed to infer the value of dotted pattern
-- when checking that the pattern .(x , y) has type .A × .A


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

open import Data.List
open import Data.Product
open import Data.Unit hiding (_≤_)
open import Data.Nat
open import Data.Empty
open import Relation.Nullary
open import Relation.Binary.Core hiding (Total)
import Level as L using (zero)

open import Lists
open import BagEquality
open import Equivalence
open import DivideEtImpera

module Mergesort where

merge : {A : Set} → {_<_ : Rel A L.zero} → Total _<_ → List A → List A → List A
merge _ [] ys = ys
merge _ (x ∷ xs) [] = (x ∷ xs)
merge total (x ∷ xs) (y ∷ ys) with (total x y)
merge total (x ∷ xs) (y ∷ ys) | (inj₁ x≤y) = x ∷ merge total xs (y ∷ ys)
merge total (x ∷ xs) (y ∷ ys) | (inj₂ y≤x) = y ∷ merge total (x ∷ xs) ys

merge-cong : {A : Set} → {_<_ : Rel A L.zero} → (total : Total _<_) → (xs ys : List A) → merge total xs ys ≈ (xs ++ ys)
merge-cong _ [] ys = λ z → z ∈ ys □↔
merge-cong _ (x ∷ xs) [] = λ z → z ∈ (x ∷ xs) ↔⟨ ++-comm [] (x ∷ xs) z ⟩
                                       z ∈ ((x ∷ xs) ++ [])  □↔
merge-cong total (x ∷ xs) (y ∷ ys) with (total x y)
merge-cong total (x ∷ xs) (y ∷ ys) | (inj₁ x≤y) = λ z →
               (z ≡ x) ⊕ z ∈ merge total xs (y ∷ ys)  ↔⟨ ⊕-cong ((z ≡ x) □↔) (merge-cong total xs (y ∷ ys) z) ⟩
               (z ≡ x) ⊕ z ∈ (xs ++ (y ∷ ys)) □↔

merge-cong total (x ∷ xs) (y ∷ ys) | (inj₂ y≤x) = λ z →
               (z ≡ y) ⊕ z ∈ merge total (x ∷ xs) ys  ↔⟨ ⊕-cong ((z ≡ y) □↔) (merge-cong total (x ∷ xs) ys z) ⟩
               (z ≡ y) ⊕ z ∈ ((x ∷ xs) ++ ys)         ↔⟨ ⊕-cong ((z ≡ y) □↔) (++-comm (x ∷ xs) ys z) ⟩
               (z ≡ y) ⊕ z ∈ (ys ++ (x ∷ xs))         ↔⟨ ++-comm (y ∷ ys) (x ∷ xs) z ⟩
               z ∈ ((x ∷ xs) ++ (y ∷ ys)) □↔

SmallerThanHead : {A : Set} → Rel A L.zero → A → List A → Set
SmallerThanHead _ x [] = ⊤
SmallerThanHead _<_ x (y ∷ ys) = _<_ x y

ord : {A : Set} → {_<_ : Rel A L.zero} → {x : A} → {xs : List A} → SmallerThanHead _<_ x xs →  Ordered _<_ xs → Ordered _<_ (x ∷ xs)
ord {xs = []} _ _ = SingleIsOrd
ord {xs = (y ∷ ys)} x≤y ordXs = HeadTailOrd x≤y ordXs

merge-order : {A : Set} → {_<_ : Rel A L.zero} → (total : Total _<_) → (xs ys : List A)
                               → Ordered _<_ xs → Ordered _<_ ys → Ordered _<_ (merge total xs ys)
merge-order _ []        ys _ ysOrd = ysOrd
merge-order _ (x ∷ xs) [] xsOrd _ = xsOrd
merge-order total (x ∷ xs) (y ∷ ys) _ _  with (total x y)
merge-order total (x ∷ xs) (y ∷ ys) _ _     | (inj₁ x≤y) with xs
merge-order total (x ∷ xs) (y ∷ ys) _ ysOrd | (inj₁ x≤y) | [] = HeadTailOrd x≤y ysOrd
merge-order {_<_ = _<_} total (x ∷ xs) (y ∷ ys) (HeadTailOrd x≤x₂ xsOrd)  ysOrd | (inj₁ x≤y) | (x₂ ∷ xs₂)
                      = ord x≤z (merge-order total (x₂ ∷ xs₂) (y ∷ ys) xsOrd ysOrd) where
                             x≤z : SmallerThanHead _<_ x (merge total (x₂ ∷ xs₂) (y ∷ ys))
                             x≤z with (total x₂ y)
                             x≤z | (inj₁ _) = x≤x₂
                             x≤z | (inj₂ _) = x≤y
merge-order total (x ∷ xs) (y ∷ ys) _ _     | (inj₂ y≤x) with ys
merge-order total (x ∷ xs) (y ∷ ys) xsOrd _ | (inj₂ y≤x) | [] = HeadTailOrd y≤x xsOrd
merge-order {_<_ = _<_} total (x ∷ xs) (y ∷ ys) xsOrd (HeadTailOrd y≤y₂ ysOrd) | (inj₂ y≤x) | (y₂ ∷ ys₂)
                      = ord y≤z (merge-order total (x ∷ xs) (y₂ ∷ ys₂) xsOrd ysOrd) where
                               y≤z : SmallerThanHead _<_ y (merge total (x ∷ xs) (y₂ ∷ ys₂))
                               y≤z with (total x y₂)
                               y≤z | (inj₁ _) = y≤x
                               y≤z | (inj₂ _) = y≤y₂

minus : ℕ → ℕ → ℕ
minus n zero          = n
minus zero (suc m)    = zero
minus (suc n) (suc m) = minus n m

minus-suc : {n m : ℕ} → m ≤ n → minus (suc n) m ≡ suc (minus n m)
minus-suc z≤n      = refl
minus-suc (s≤s pf) = minus-suc pf

bisect : {A : Set} → List A → (List A × List A)
bisect xs = splitAt ⌊ length xs /2⌋ xs

splitAtLen1 : {A : Set} →  (n : ℕ) → (xs : List A) → n ≤ (length xs) → length (proj₁ (splitAt n xs)) ≡ n
splitAtLen1 zero xs _ = refl
splitAtLen1 (suc n) [] ()
splitAtLen1 (suc n) (x ∷ xs) (s≤s pf) = suc (length (proj₁ (splitAt n xs))) =⟨ splitAtLen1 n xs pf under suc ⟩
                                        suc n □=

splitAtLen2 : {A : Set} →  (n : ℕ) → (xs : List A) → length (proj₂ (splitAt n xs)) ≡ minus (length xs) n
splitAtLen2 zero xs = refl
splitAtLen2 (suc n) [] = refl
splitAtLen2 (suc n) (x ∷ xs) = length (proj₂ (splitAt n xs)) =⟨ splitAtLen2 n xs ⟩
                                minus (length xs) n □=

s≤′s : {n m : ℕ} → n ≤′ m → suc n ≤′ suc m
s≤′s ≤′-refl      = ≤′-refl
s≤′s (≤′-step pf) = ≤′-step (s≤′s pf)

lte-cong : {n m : ℕ} → (n ≤ m) ⇔ (n ≤′ m)
lte-cong = record { to   = to' ;
                    from = from' } where
                            to' : {n m : ℕ} → n ≤ m → n ≤′ m
                            to' {m = zero}  z≤n = ≤′-refl
                            to' {m = suc m} z≤n = ≤′-step (to' z≤n)
                            to' (s≤s pf) = s≤′s (to' pf)
                            from' : {n m : ℕ} → n ≤′ m → n ≤ m
                            from' {zero} ≤′-refl = z≤n
                            from' {suc n} ≤′-refl = s≤s (from' ≤′-refl)
                            from' (≤′-step pf) = ≤-step (from' pf) where
                                   ≤-step : {n m : ℕ} → n ≤ m → n ≤ (suc m)
                                   ≤-step z≤n = z≤n
                                   ≤-step (s≤s pf) = s≤s (≤-step pf)

eq-rel-cong : {A : Set} → {rel : Rel A L.zero} →  {x y z : A} → x ≡ y → rel y z → rel x z
eq-rel-cong refl pf = pf

halfLte1 : (n : ℕ) → ⌊ n /2⌋ ≤′ n
halfLte1 zero          = ≤′-refl
halfLte1 (suc zero)    = ≤′-step ≤′-refl
halfLte1 (suc (suc n)) = ≤′-step (s≤′s (halfLte1 n))

halfLt1 : (n : ℕ) → ⌊ (suc (suc n)) /2⌋ <′ (suc (suc n))
halfLt1 n = s≤′s (s≤′s (halfLte1 n))

halfLte2 : (n : ℕ) → (minus n ⌊ n /2⌋) ≤′ n
halfLte2 zero          = ≤′-refl
halfLte2 (suc zero)    = ≤′-refl
halfLte2 (suc (suc n)) = ≤′-step (eq-rel-cong {rel = _≤′_} {x = minus (suc n) ⌊ n /2⌋} {y = suc (minus n ⌊ n /2⌋)}
                          (minus-suc (_⇔_.from lte-cong (halfLte1 n))) (s≤′s (halfLte2 n)))

halfLt2 : (n : ℕ) → (minus (suc (suc n)) ⌊ (suc (suc n)) /2⌋) <′ (suc (suc n))
halfLt2 n = s≤′s (eq-rel-cong {rel = _≤′_} {x = minus (suc n) ⌊ n /2⌋} {y = suc (minus n ⌊ n /2⌋)}
                          (minus-suc (_⇔_.from lte-cong (halfLte1 n))) (s≤′s (halfLte2 n)))

bisectPf1 : {A : Set} → (x y : A) → (zs : List A) → proj₁ (bisect (x ∷ y ∷ zs)) <l (x ∷ y ∷ zs)
bisectPf1 x y zs = eq-rel-cong {rel = _<′_}
        (splitAtLen1 ⌊ (suc (suc (length zs))) /2⌋ (x ∷ y ∷ zs) (_⇔_.from lte-cong (halfLte1 (suc (suc (length zs))))))
                   (halfLt1 (length zs))

bisectPf2 : {A : Set} → (x y : A) → (zs : List A) → proj₂ (bisect (x ∷ y ∷ zs)) <l (x ∷ y ∷ zs)
bisectPf2 x y zs = eq-rel-cong {rel = _<′_}
        (splitAtLen2 ⌊ (suc (suc (length zs))) /2⌋ (x ∷ y ∷ zs))
                   (halfLt2 (length zs))

splitAt-cong : {A : Set} → (n : ℕ) → (xs : List A) → proj₁ (splitAt n xs) ++ proj₂ (splitAt n xs) ≈ xs
splitAt-cong zero xs           z = z ∈ xs □↔
splitAt-cong (suc n) []        z = ⊥ □↔
splitAt-cong (suc n) (x ∷ xs) z = (z ≡ x) ⊕ z ∈ (proj₁ (splitAt n xs) ++ proj₂ (splitAt n xs))
                                             ↔⟨ ⊕-cong ((z ≡ x) □↔) (splitAt-cong n xs z) ⟩
                                   (z ≡ x) ⊕ z ∈ xs □↔

ms-inputCond : {A : Set} → List A → Set
ms-inputCond _ = ⊤

ms-decompCond : {A : Set} → List A → (⊤ × List A × List A) → Set
ms-decompCond xs (_ , ys , zs ) = ys ++ zs ≈ xs

ms-compCond : {A : Set} → Rel A L.zero → (⊤ × List A × List A) → List A → Set
ms-compCond rel (_ , xs , ys ) zs = zs ≈ xs ++ ys × (Ordered rel xs → Ordered rel ys → Ordered rel zs)

ms-outputCond : {A : Set} → Rel A L.zero → List A → List A → Set
ms-outputCond rel xs zs = (zs ≈ xs) × Ordered rel zs

ms-G : ⊤ → ⊤ → Σ ⊤ (λ x → ⊤)
ms-G _ _ = (⊤.tt , ⊤.tt)

ms-decomp : {A : Set} → (xs : List A) → ⊤ → ¬ ListPrimitive2 xs → Σ (⊤ × List A × List A)
              (λ z → ⊤ × ⊤ × ⊤ × (proj₁ (proj₂ z) <l xs) × (proj₂ (proj₂ z) <l xs) × ms-decompCond xs z)
ms-decomp [] _ notPrim = ⊥-elim (notPrim NilIsPrim2)
ms-decomp (x ∷ []) _ notPrim = ⊥-elim (notPrim SingleIsPrim2)
ms-decomp (x ∷ y ∷ zs)  _ _ = (⊤.tt , bisect (x ∷ y ∷ zs)) , (⊤.tt , ⊤.tt , ⊤.tt ,
                                                        bisectPf1 x y zs ,
                                                        bisectPf2 x y zs ,
                                                        splitAt-cong ⌊ (suc (suc (length zs))) /2⌋ (x ∷ y ∷ zs))

ms-comp : {A : Set} → {rel : Rel A L.zero} → Total rel → (z : (⊤ × List A × List A)) → Σ (List A) (ms-compCond rel z)
ms-comp total ( _ , xs , ys) = (merge total xs ys) , (merge-cong total xs ys , merge-order total xs ys)

ms-dirSolve : {A : Set} → (rel : Rel A L.zero) → (xs : List A) → ⊤ → ListPrimitive2 xs → Σ (List A) (ms-outputCond rel xs)
ms-dirSolve _ []             _ _    = [] , ((λ z → ⊥ □↔) , NilIsOrd)
ms-dirSolve _ (x ∷ [])      _ _    = (x ∷ []) , ((λ z → z ∈ (x ∷ []) □↔) , SingleIsOrd)
ms-dirSolve _ (x ∷ y ∷ zs) _ prim = ⊥-elim (consConsIsNotPrim2 prim)

ms-lemma : {A : Set} → (rel : Rel A L.zero) → ∀{xs ys₁ ys₂ zs₁ zs₂ ws} → ms-decompCond xs (⊤.tt , ys₁ , ys₂)
                           → ⊤ → ms-outputCond rel ys₁ zs₁ → ms-outputCond rel ys₂ zs₂
                              → ms-compCond rel (⊤.tt , zs₁ , zs₂) ws → ms-outputCond rel xs ws
ms-lemma rel {xs} {ys₁} {ys₂} {zs₁} {zs₂} {ws} ys₁++ys₂≈xs _ ( ys₁≈zs₁ , zs₁Ord ) ( ys₂≈zs₂ , zs₂Ord ) ( ws≈zs₁++zs₂ , compOrd)
                 = (λ z → z ∈ ws              ↔⟨ ws≈zs₁++zs₂ z ⟩
                           z ∈ (zs₁ ++ zs₂)    ↔⟨ Any-++ (z ≡_) zs₁ zs₂ ⟩
                           z ∈ zs₁ ⊕ z ∈ zs₂ ↔⟨ ⊕-cong (ys₁≈zs₁ z) (ys₂≈zs₂ z) ⟩
                           z ∈ ys₁ ⊕ z ∈ ys₂ ↔⟨ ↔sym (Any-++ (z ≡_) ys₁ ys₂) ⟩
                           z ∈ (ys₁ ++ ys₂)    ↔⟨ ys₁++ys₂≈xs z ⟩
                           z ∈ xs □↔) ,
                   compOrd zs₁Ord zs₂Ord

mergesort : {A : Set} → {rel : Rel A L.zero} → Total rel → (xs : List A) → Σ (List A) (λ zs → (zs ≈ xs) × Ordered rel zs)
mergesort {rel = rel} total xs = makeD&C2 <l-wellFounded
                                          prim2Dec
                                          ms-decomp
                                          (ms-comp total)
                                          ms-G
                                          (ms-dirSolve rel)
                                          (ms-lemma rel)
                                          xs ⊤.tt


module STLC.Term.Reduction where

open import STLC.Term as Term
open Term.Substitution using () renaming (_[/_] to _[/t_])

open import Data.Nat using (ℕ; _+_)

open import Relation.Binary.Construct.Closure.ReflexiveTransitive
  using (Star)

infix 4 _—→_

data _—→_ { n : ℕ } : Term n -> Term n -> Set where

  β-·₁ : ∀ { t₁ t₂ l : Term n }
    -> t₁ —→ t₂
    -- ----------------
    -> t₁ · l —→ t₂ · l

  β-·₂ : ∀ { v t₁ t₂ : Term n }
    -> Value v
    -> t₁ —→ t₂
    -- ----------------
    -> v · t₁ —→ v · t₂

  β-ƛ : ∀ { t : Term (1 + n) } {v : Term n }
    -> Value v
    -- --------------------
    -> (ƛ t) · v —→ (t [/t v ])

infix 2 _—↠_

_—↠_ : { n : ℕ } -> Term n -> Term n -> Set
_—↠_ = Star (_—→_)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Reflexive closures
------------------------------------------------------------------------

module Data.ReflexiveClosure where

open import Data.Unit
open import Level
open import Relation.Binary
open import Relation.Binary.Simple

------------------------------------------------------------------------
-- Reflexive closure

data Refl {a ℓ} {A : Set a} (_∼_ : Rel A ℓ) : Rel A (a ⊔ ℓ) where
  [_]  : ∀ {x y} (x∼y : x ∼ y) → Refl _∼_ x y
  refl : Reflexive (Refl _∼_)

-- Map.

map : ∀ {a a′ ℓ ℓ′} {A : Set a} {A′ : Set a′}
        {_R_ : Rel A ℓ} {_R′_ : Rel A′ ℓ′} {f : A → A′} →
      _R_ =[ f ]⇒ _R′_ → Refl _R_ =[ f ]⇒ Refl _R′_
map R⇒R′ [ xRy ] = [ R⇒R′ xRy ]
map R⇒R′ refl    = refl

-- The reflexive closure has no effect on reflexive relations.

drop-refl : ∀ {a ℓ} {A : Set a} {_R_ : Rel A ℓ} →
            Reflexive _R_ → Refl _R_ ⇒ _R_
drop-refl rfl [ x∼y ] = x∼y
drop-refl rfl refl    = rfl

------------------------------------------------------------------------
-- Example: Maybe

module Maybe where

  Maybe : ∀ {ℓ} → Set ℓ → Set ℓ
  Maybe A = Refl (Const A) tt tt

  nothing : ∀ {a} {A : Set a} → Maybe A
  nothing = refl

  just : ∀ {a} {A : Set a} → A → Maybe A
  just = [_]


-- Exponentials and closed categories
module CategoryTheory.BCCCs.Closed where
open import CategoryTheory.Categories
open import CategoryTheory.BCCCs.Cartesian

module _ {n} {ℂ : Category n} (Cℂ : Cartesian ℂ) where

    open Category ℂ
    open Cartesian Cℂ

    -- Exponential from two objects
    record Exponential (A B : obj) : Set (lsuc n) where
        field
            -- | Data
            -- Exponential object
            A⇒B : obj
            -- Evaluation map
            eval : A⇒B ⊗ A ~> B
            -- Canonical transposition morphism (currying)
            Λ : ∀{E} -> (E ⊗ A ~> B) -> (E ~> A⇒B)

            -- | Laws
            Λ-comm : ∀{E} -> {e : E ⊗ A ~> B}
                  -> eval ∘ (Λ e * id) ≈ e
            Λ-unique : ∀{E} -> {e : E ⊗ A ~> B} {m : E ~> A⇒B}
                  -> eval ∘ (m * id) ≈ e -> Λ e ≈ m
            Λ-cong : ∀{E} {f g : E ⊗ A ~> B}
                  -> f ≈ g -> Λ f ≈ Λ g

        -- Currying identity
        Λ-*id : ∀{D E} {f : E ⊗ A ~> B} {g : D ~> E}
             -> Λ (f ∘ (g * id)) ≈ Λ f ∘ g
        Λ-*id {D}{E}{f}{g} =
            begin
                Λ (f ∘ (g * id))
            ≈⟨ Λ-cong (≈-cong-left (Λ-comm [sym]) ≈> ∘-assoc) ⟩
                Λ (eval ∘ (Λ f * id) ∘ (g * id))
            ≈⟨ Λ-cong (≈-cong-right (*-idemp-dist-∘ id-left)) ⟩
                Λ (eval ∘ (Λ f ∘ g) * id)
            ≈⟨ Λ-unique r≈ ⟩
                Λ f ∘ g
            ∎

-- Type class for closed categories
-- definition using exponentials
record Closed {n} {ℂ : Category n} (Cℂ : Cartesian ℂ) : Set (lsuc n) where
    open Category ℂ
    field
        -- Exponential object for each pair of objects
        exp : ∀(A B : obj) -> Exponential Cℂ A B

    open module E {A} {B} = Exponential (exp A B) public

    -- Shorthand for exponential object
    infixr 20 _⇒_
    _⇒_ : (A B : obj) -> obj
    A ⇒ B = A⇒B {A} {B}