-- Sets represented by unary predicates (Like restricted comprehension)
-- Similiar to BoolSet, but instead using the builtin constructive logic with levels.
module Sets.PredicateSet where

import      Lvl
open import Data hiding (Empty)
open import Data.Boolean
open import Data.Boolean.Stmt
open import Functional
open import Function.Proofs
open import Logic
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Logic.Predicate
-- open import Relator.Equals.Proofs.Equiv
open import Structure.Setoid using (Equiv) renaming (_≡_ to _≡ₛ_)
open import Data.Any
open import Structure.Function.Domain
open import Type

module _ where
  -- A set of objects of a certain type.
  -- This is represented by a predicate.
  -- Note: This is only a "set" within a certain type, so everything PredSet(T) is actually a subset of T (if T were a set (the set of all objects with type T)). Or in other words: PredSet(T) is supposed to represent the set {x. x: T}, and then (S ∈ PredSet(T)) essentially means that S when interpreted as a set of objects is a subset of {x. x: T}.
  PredSet : ∀{ℓ ℓₒ} → Type{ℓₒ} → Type{Lvl.𝐒(ℓ) Lvl.⊔ ℓₒ}
  PredSet{ℓ}{ℓₒ} (T) = (T → Stmt{ℓ})

  private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓₒ ℓₑ : Lvl.Level
  private variable T A B : Type{ℓₒ}

  -- The statement of whether an element is in a set
  -- TODO: Maybe define this using a equivalence relation instead? (Alternatively a Setoid: x ∈ S = ∃(y ↦ (x ≡_T y) ∧ S(y)))
  _∈_ : T → PredSet{ℓ}(T) → Stmt
  _∈_ = apply -- (x ∈ S) = S(x)

  _∉_ : T → PredSet{ℓ}(T) → Stmt
  _∉_ = (¬_) ∘₂ (_∈_) -- (x ∉ S) = ¬(x ∈ S)

  _∋_ : PredSet{ℓ}(T) → T → Stmt
  _∋_ = swap(_∈_) -- (S ∋ x) = (x ∈ S)

  _∌_ : PredSet{ℓ}(T) → T → Stmt
  _∌_ = (¬_) ∘₂ (_∋_) -- (S ∌ x) = ¬(S ∋ x)

  module BoundedQuantifiers {T : Type{ℓₒ}} where
    ∀ₛ : PredSet{ℓ}(T) → (T → Stmt{ℓ₁}) → Stmt{ℓ Lvl.⊔ ℓ₁ Lvl.⊔ ℓₒ}
    ∀ₛ(S) P = ∀{elem : T} → (elem ∈ S) → P(elem)

    ∃ₛ : PredSet{ℓ}(T) → (T → Stmt{ℓ₁}) → Stmt{ℓ Lvl.⊔ ℓ₁ Lvl.⊔ ℓₒ}
    ∃ₛ(S) P = ∃(elem ↦ (elem ∈ S) ∧ P(elem))

  -- An empty set
  ∅ : PredSet{ℓ}(T)
  ∅ = const(Data.Empty)

  -- An universal set
  -- Note: It is only within a certain type, so 𝐔{T} is not actually a subset of everything. It is the greatest subset of subsets of T.
  𝐔 : PredSet{ℓ}(T)
  𝐔 = const(Unit)

  -- A singleton set (a set with only one element)
  •_ : ⦃ Equiv{ℓₑ}(T) ⦄ → T → PredSet(T)
  •_ = (_≡ₛ_)

  -- An union of two sets
  _∪_ : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → PredSet(T)
  _∪_ S₁ S₂ x = (S₁(x) ∨ S₂(x))

  -- An union of a set and a singleton set
  _∪•_ : ∀{ℓ}{T : Type{ℓ}} → PredSet{ℓ₁}(T) → Type{ℓ} → PredSet(T)
  _∪•_ S P x = (S(x) ∨ P)

  -- An intersection of two sets
  _∩_ : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → PredSet(T)
  _∩_ S₁ S₂ x = (S₁(x) ∧ S₂(x))

  -- A complement of a set
  ∁_ : PredSet{ℓ}(T) → PredSet(T)
  ∁_ = (¬_) ∘_ -- ∁_ S x = (¬ S(x))

  _∖_ : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → PredSet(T)
  _∖_ S₁ S₂ = (S₁ ∩ (∁ S₂))

  filter : (T → Bool) → PredSet{ℓ}(T) → PredSet(T)
  filter f S x = (S(x) ∧ IsTrue(f(x)))

  -- TODO: Maybe move these to a separate "Relations" file?

  -- A statement of whether a set is a subset of a set
  _⊆_ : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → Stmt
  _⊆_ S₁ S₂ = (∀{x} → (x ∈ S₁) → (x ∈ S₂))

  -- A statement of whether a set is a superset of a set
  _⊇_ : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → Stmt
  _⊇_ S₁ S₂ = (∀{x} → (x ∈ S₁) ← (x ∈ S₂))

  -- A statement of whether a set is equivalent to a set
  _≡_ : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → Stmt
  _≡_ S₁ S₂ = (∀{x} → (x ∈ S₁) ↔ (x ∈ S₂))

  Empty : PredSet{ℓ}(T) → Stmt
  Empty(S) = ∀{x} → ¬(x ∈ S)

  NonEmpty : PredSet{ℓ}(T) → Stmt
  NonEmpty(S) = ∃(_∈ S)

  Disjoint : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → Stmt
  Disjoint S₁ S₂ = ((S₁ ∩ S₂) ⊆ (∅ {Lvl.𝟎}))

  Overlapping : PredSet{ℓ₁}(T) → PredSet{ℓ₂}(T) → Stmt
  Overlapping S₁ S₂ = ∃(S₁ ∩ S₂)

  ⋃_ : PredSet{ℓ₁}(PredSet{ℓ₂}(T)) → PredSet(T)
  ⋃_ S x = ∃(s ↦ (s ∈ S) ∧ (x ∈ s))

  ⋂_ : PredSet{ℓ₁}(PredSet{ℓ₂}(T)) → PredSet(T)
  ⋂_ S x = ∀{s} → (s ∈ S) → (x ∈ s)

  ℘ : PredSet{ℓ₁}(T) → PredSet(PredSet{ℓ₁}(T))
  ℘ S x = x ⊆ S

  unapply : ⦃ Equiv{ℓₑ}(B) ⦄ → (f : A → B) → B → PredSet(A)
  unapply f(y) x = f(x) ≡ₛ y

  map : ⦃ Equiv{ℓₑ}(B) ⦄ → (f : A → B) → PredSet{ℓ}(A) → PredSet(B)
  map f(S) y = Overlapping(S)(unapply f(y))

  unmap : (f : A → B) → PredSet{ℓ}(B) → PredSet(A)
  unmap f(y) x = f(x) ∈ y

  ⊶ : ⦃ Equiv{ℓₑ}(B) ⦄ → (f : A → B) → PredSet(B)
  ⊶ f y = ∃(unapply f(y))

  module _ where -- TODO: These proofs should be generalized somewhere else?
    open import Structure.Relator.Equivalence
    open import Structure.Relator.Properties

    private variable S a b c a₁ a₂ b₁ b₂ : PredSet{ℓ}(T)
    private variable S₁ : PredSet{ℓ₁}(T)
    private variable S₂ : PredSet{ℓ₂}(T)

    instance
      [≡]-reflexivity : Reflexivity(_≡_ {ℓ₁}{ℓ₂}{T})
      Reflexivity.proof [≡]-reflexivity = [↔]-reflexivity

    instance
      [≡]-symmetry : Symmetry(_≡_ {ℓ₁}{ℓ₂}{T})
      Symmetry.proof [≡]-symmetry {x} {y} xy = [↔]-symmetry xy

    instance
      [≡]-transitivity : Transitivity(_≡_ {ℓ₁}{ℓ₂}{T})
      Transitivity.proof [≡]-transitivity {x} {y} {z} xy yz = [↔]-transitivity xy yz

    instance
      [≡]-equivalence : Equivalence(_≡_ {ℓ₁}{ℓ₂}{T})
      [≡]-equivalence = intro

    {- TODO: Cannot be an instance of Equiv because of level issues, but see a solution in ExtensionalPredicateSet
    instance
      [≡]-equiv : Equiv(PredSet{ℓ}(T))
      Equiv._≡_ [≡]-equiv = {!_≡_!}
      Equiv.equivalence [≡]-equiv = {![≡]-equivalence!}
    -}

    [≡]-to-[⊆] : (S₁ ≡ S₂) → (S₁ ⊆ S₂)
    [≡]-to-[⊆] S₁S₂ {x} = [↔]-to-[→] (S₁S₂{x})

    [≡]-to-[⊇] : (S₁ ≡ S₂) → (S₁ ⊇ S₂)
    [≡]-to-[⊇] S₁S₂ {x} = [↔]-to-[←] (S₁S₂{x})

    [⊆]-of-[∪]ₗ : (S₁ ⊆ (S₁ ∪ S₂))
    [⊆]-of-[∪]ₗ = [∨]-introₗ

    [⊆]-of-[∪]ᵣ : (S₂ ⊆ (S₁ ∪ S₂))
    [⊆]-of-[∪]ᵣ = [∨]-introᵣ

    [∪]-of-subset : (S₁ ⊆ S₂) → ((S₁ ∪ S₂) ≡ S₂)
    [∪]-of-subset S₁S₂ = [↔]-intro [∨]-introᵣ ([∨]-elim S₁S₂ id)

    [⊆]-min : (∅ {ℓ} ⊆ S)
    [⊆]-min = empty

    [⊆]-max : (S ⊆ 𝐔 {ℓ})
    [⊆]-max = const <>

    [∅]-containment : ∀{x : T} → ¬(x ∈ ∅ {ℓ})
    [∅]-containment = empty

    [𝐔]-containment : ∀{x : T} → (x ∈ 𝐔 {ℓ})
    [𝐔]-containment = <>

    map-containmentₗ : ⦃ equiv-B : Equiv{ℓₑ}(B) ⦄ → ∀{x : A}{f : A → B} → (f(x) ∈ map ⦃ equiv-B ⦄ f(S)) ← (x ∈ S)
    map-containmentₗ {x = x} = (xS ↦ [∃]-intro x ⦃ [↔]-intro xS (reflexivity(_≡ₛ_)) ⦄)

    -- map-containmentᵣ : ⦃ _ : Relation(S) ⦄ → ∀{f : A → B} → ⦃ _ : Injective(f) ⦄ → ∀{x : A} → (f(x) ∈ map f(S)) → (x ∈ S)
    -- map-containmentᵣ {x = x} = ([∃]-intro a ⦃ [∧]-intro p q ⦄) ↦ {!!}

    [⋂]-of-[∅] : ((⋂_ {ℓ₁}{ℓ₂} ∅) ≡ 𝐔 {ℓ₃}{ℓ₄}{T})
    [⋂]-of-[∅] = [↔]-intro (const empty) (const <>)

    [⋂]-of-[𝐔] : ((⋂_ {ℓ₁}{ℓ₂} 𝐔) ≡ ∅ {ℓ₂}{ℓ₃}{T})
    [⋂]-of-[𝐔] {ℓ₁}{ℓ₂}{ℓ₃}{T} = [↔]-intro empty (inters ↦ inters([𝐔]-containment{x = ∅ {ℓ₂}{ℓ₃}{T}}))

    [⋃]-of-[∅] : ((⋃_ {ℓ₁}{ℓ₂} ∅) ≡ ∅ {ℓ₁}{ℓ₃}{T})
    [⋃]-of-[∅] = [↔]-intro empty (([∃]-intro s ⦃ [∧]-intro p _ ⦄) ↦ p)

    [⋃]-of-[𝐔] : ((⋃_ {ℓ₁}{ℓ₂} 𝐔) ≡ 𝐔 {ℓ₃}{ℓ₄}{T})
    [⋃]-of-[𝐔] {ℓ₁}{ℓ₂}{ℓ₃}{T} = [↔]-intro (const ([∃]-intro 𝐔 ⦃ [↔]-intro <> <> ⦄)) (const <>)

    LvlUp-set-equality : (Lvl.Up{ℓ} ∘ S ≡ S)
    LvlUp-set-equality = [↔]-intro Lvl.up Lvl.Up.obj

    -- Disjoint-irreflexivity : ⦃ _ : NonEmpty(_) ⦄ → Irreflexivity(Disjoint{ℓ₁}{ℓ₂}{T})
    -- Irreflexivity.proof Disjoint-irreflexivity p = {!!}

    -- TODO: Duplicated in SetLike
    -- SetType : PredSet{ℓ}(T) → Stmt
    -- SetType(s) = ∃(_∈ s)

    {-
    choice : ∀{S : PredSet{ℓ₁}(PredSet{ℓ₂}(T))} → ∃{Obj = SetType(S) → SetType(⋃ S)}(f ↦ ∀{([∃]-intro x) : SetType(S)} → ([∃]-witness(f([∃]-intro x)) ∈ x))
    ∃.witness (∃.witness (choice {S = S}) ([∃]-intro f ⦃ proof ⦄)) = {!!}
    ∃.proof   (∃.witness (choice {S = S}) ([∃]-intro f ⦃ proof ⦄)) = {!!}
    ∃.proof              (choice {S = S}) {[∃]-intro f ⦃ proof ⦄}  = {!!}
    -}

    [∪]-subset : (a ⊆ c) → (b ⊆ c) → ((a ∪ b) ⊆ c)
    [∪]-subset ac bc = [∨]-elim ac bc

    [∪]-subset2 : (a₁ ⊆ a₂) → (b₁ ⊆ b₂) → ((a₁ ∪ b₁) ⊆ (a₂ ∪ b₂))
    [∪]-subset2 aa bb = [∨]-elim2 aa bb

    [∖][∪]-is-[∪]ᵣ : (((a ∖ b) ∪ b) ⊆ (a ∪ b))
    [∖][∪]-is-[∪]ᵣ {a = A}{b = B}{x = x} = [∨]-elim ([∨]-introₗ ∘ [∧]-elimₗ) [∨]-introᵣ

    open import Logic.Classical
    [∖][∪]-is-[∪] : ⦃ ∀{x} → Classical(b(x)) ⦄ → (((a ∖ b) ∪ b) ≡ (a ∪ b))
    [∖][∪]-is-[∪] {b = B}{a = A}{x = x} = [↔]-intro
      ([∨]-elim (Ax ↦ [∨]-elim2 ([∧]-intro Ax) id ([∨]-symmetry(excluded-middle(B(x))))) [∨]-introᵣ)
      ([∖][∪]-is-[∪]ᵣ {a = A}{b = B})

    [∪][∖]-invertᵣ-[⊆] : (a ⊆ (b ∪ c)) → ((a ∖ c) ⊆ b)
    [∪][∖]-invertᵣ-[⊆] abc ([∧]-intro a nc) = [∨]-elim id ([⊥]-elim ∘ nc) (abc a)


-- This file comes from the agda class taught by Peter Selinger at
-- Dalhousie University. It contains a bonus question that
-- propostional logic is complete. We will show this in
-- Kalmar.agda.

-- The course link:
-- https://www.mathstat.dal.ca/~selinger/agda-lectures/

{-# OPTIONS --without-K --safe #-}
module PropLogic where

-- We replace the library (lib-3.0) used in class by the stdlib v2.

-- open import Equality
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; inspect ; [_] ; trans ; sym)

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

-- open import Bool
-- renaming and defining new connectives.
open import Data.Bool renaming(_∧_ to _and_ ; _∨_ to _or_) using (Bool ; not ; true ; false)
_implies_ : Bool → Bool → Bool
_implies_ a b = not a or b

-- ----------------------------------------------------------------------
-- * Introduction

-- In this project, we will formalize boolean (i.e., classical)
-- propositional logic, define a notion of derivation for the logic,
-- give a semantics for the logic in terms of truth tables (also known
-- as boolean assignments), and prove the soundness of the derivation
-- rules.

-- ----------------------------------------------------------------------
-- * The set of boolean formulas

-- We start by defining the set of boolean formulas. Informally, the
-- formulas are given by the following grammar:
--
-- Formula   A, B ::= P n | A ∧ B | A ⇒ B | ⊥ | ⊤
--
-- Here, n is a natural number, and P n is the nth propositional
-- symbol. A ∧ B is conjunction, A ⇒ B is implication, ⊥ is "false"
-- (also known as a contradiction), and ⊤ is "true". You can type
-- these symbols in Emacs Agda mode using \and, \=>, \bot, and \top.
-- Note that the symbol "⊤" is not the same as the capital letter "T".

-- The set of propositional formulas as an Agda datatype:
data Formula : Set where
  P : ℕ -> Formula
  _∧_ : Formula -> Formula -> Formula
  _⇒_ : Formula -> Formula -> Formula
  ⊥ : Formula
  ⊤ : Formula
  ¬_ : Formula -> Formula
  _∨_ : Formula -> Formula -> Formula

infixl 9 _∧_
infixr 8 _⇒_

infix 20 ¬_

-- ----------------------------------------------------------------------
-- * Derivations

-- The most important concept in logic is that of derivability.
-- "Derivation" is another word for "proof". If A₁, ..., Aₙ, B are
-- formulas, we write
--
--       A₁, ..., Aₙ ⊢
--
-- for the statement "the conclusion B can be derived from hypotheses
-- A₁, ..., Aₙ". The symbol "⊢" is pronounced "entails", and we also
-- say "A₁, ..., Aₙ entails B". You can type this symbol as \|- or
-- \entails or \vdash.
--
-- Although entailment "⊢" is somewhat similar to implication "⇒",
-- there is an important difference: an implication A ⇒ B is a
-- formula, so it could be used, for example, as a hypothesis or as a
-- conclusion in a proof. Entailment is a statement about formulas,
-- i.e., entailment means: there exists a proof of B from hypotheses
-- A₁, ..., Aₙ. Entailment is not itself a formula; it is a statement
-- about provability. Thus, entailment is a relation between a list of
-- formulas (the hypotheses) and a formula (the conclusion).

-- ----------------------------------------------------------------------
-- ** Contexts

-- Before we can formalize entailment, we must formalize lists of
-- formulas. A list of formulas is also called a "context". We
-- write Γ for an arbitrary context.
--
-- Because a context can also be empty (a list of zero formulas), it
-- is convenient to use the empty context as the base case. Then we
-- can give the following recursive definition of contexts: a context
-- is either the empty context, or it is obtained from another context
-- by adding one more formula on the right. In other words, we have
-- the following grammar for contexts:
--
-- Context   Γ ::= Empty | Γ, A
--
-- We formalize this as the following Agda datatype:

{-
data Context : Set where
  Empty : Context
  _,_ : Context -> Formula -> Context
-}

-- Modification: We use List Formula as Context instead of defining a
-- new data type. This will ease the proof using list with distinct
-- elements.

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

infixl 7 _,_

-- _,_ : Context -> Formula -> Context
-- _,_ Γ F = F ∷ Γ

pattern _,_ Γ F = F ∷ Γ
pattern Empty = []

-- We also need the membership relation for contexts. We define the
-- relation A ∈ Γ to mean "the formula A is in the context Γ". The
-- symbol ∈ is typed as \in. The membership relation can be
-- recursively defined as follows: the empty context has no members,
-- and the members of the context Γ, A are A and the members of
-- Γ. More formally, we have the following inference rules for
-- membership:
--
-- ───────────── (∈-base)
--   A ∈ Γ, A
--
--
--     A ∈ Γ
-- ───────────── (∈-step)
--   A ∈ Γ, B
--
-- An inference rule, written with a horizontal line, has the
-- following meaning: if the (zero or more) statements above the line
-- are true, then the statement below the line is true. The statements
-- above the line are called the hypotheses of the inference rule, and
-- the statement below the line is called the conclusion. The name of
-- each inference rule (e.g., ∈-base, ∈-step) is written next to the
-- rule. We use inference rules to define a relation, in this case the
-- relation "∈". By definition, "∈" is the smallest relation
-- satisfying (∈-base) and (∈-step).
--
-- We can directly translate these inference rules into Agda as
-- follows:
data _∈_ : Formula -> Context -> Set where
  ∈-base : ∀ {A : Formula} {Γ : Context} -> A ∈ (Γ , A)
  ∈-step : ∀ {A B : Formula} {Γ : Context} -> A ∈ Γ -> A ∈ (Γ , B)

infixl 6 _∈_

-- ----------------------------------------------------------------------
-- ** Entailment

-- We now define the entailment relation. Recall that the entailment
-- relation Γ ⊢ A is supposed to mean "the conclusion A can be derived
-- from the hypotheses Γ". Defining entailment therefore requires us
-- to formalize what we mean by "derived". In other words, we have to
-- give a set of proof rules for propositional logic. Let me first
-- write these proof rules in the style of inference rules. These
-- rules define the relation "⊢":
--
--    A ∈ Γ
-- ───────────── (assump)
--    Γ ⊢ A
--
--
--   Γ ⊢ A   Γ ⊢ B
-- ───────────────── (∧-intro)
--     Γ ⊢ A ∧ B
--
--
--     Γ ⊢ A ∧ B
-- ───────────────── (∧-elim1)
--       Γ ⊢ A
--
--
--     Γ ⊢ A ∧ B
-- ───────────────── (∧-elim2)
--       Γ ⊢ B
--
--
--     Γ, A ⊢ B
-- ───────────────── (⇒-intro)
--     Γ ⊢ A ⇒ B
--
--
--     Γ ⊢ A ⇒ B    Γ ⊢ A
-- ────────────────────────── (⇒-elim)
--           Γ ⊢ B
--
--
--     Γ ⊢ (A ⇒ ⊥) ⇒ ⊥
-- ────────────────────── (double-negation)
--         Γ ⊢ A
--
--
-- ───────────────── (⊤-intro)
--      Γ ⊢ ⊤
--
--
-- The rule (assump) states that if A is one of the hypotheses, then A
-- can be derived from the hypothesis. Basically A is true "by assumption".
--
-- Several of the connectives, such as ∧ and ⇒, have an "introduction"
-- rule, which shows how to prove such a formula, and an "elimination"
-- rule, which shows how such a formula can be used to prove other
-- things. The rule (∧-intro) states that to prove A ∧ B from the
-- given hypotheses Γ, we must separately derive A and B. Conversely,
-- the rules (∧-elim1) and (∧-elim2) state that if we have already
-- derived A ∧ B, then we may separately conclude A and B. The rule
-- (⇒-intro) states that to prove an implication A ⇒ B, we must assume
-- A and prove B. In other words, to derive A ⇒ B from some hypotheses
-- Γ, we must prove B from the hypotheses Γ, A. The rule (⇒-elim) is
-- also known by its Latin name "modus ponens". It states that if we
-- can prove A ⇒ B and we can also prove A, then we may conclude
-- B. The rule (double-negation) is required to make the logic
-- classical.  Informally, it states that we can prove A by assuming
-- "not A" and deriving a contradiction. Remember that "not A" is an
-- abbreviation for (A ⇒ ⊥). The rule (⊤-intro) states that ⊤ can be
-- derived from any set of hypotheses.

-- We can directly translate the above rules into Agda:
data _⊢_ : Context -> Formula -> Set where
  assump : ∀ {Γ A} -> A ∈ Γ -> Γ ⊢ A
  ∧-intro : ∀ {Γ A B} -> Γ ⊢ A -> Γ ⊢ B -> Γ ⊢ A ∧ B
  ∧-elim1 : ∀ {Γ A B} -> Γ ⊢ A ∧ B -> Γ ⊢ A
  ∧-elim2 : ∀ {Γ A B} -> Γ ⊢ A ∧ B -> Γ ⊢ B
  ⇒-intro : ∀ {Γ A B} -> Γ , A ⊢ B -> Γ ⊢ A ⇒ B
  ⇒-elim : ∀ {Γ A B} -> Γ ⊢ A ⇒ B -> Γ ⊢ A -> Γ ⊢ B
  double-negation : ∀ {Γ A} -> Γ ⊢ (A ⇒ ⊥) ⇒ ⊥ -> Γ ⊢ A
  ⊤-intro : ∀ {Γ} -> Γ ⊢ ⊤
  ¬-intro : ∀ {Γ A} -> Γ , A ⊢ ⊥ -> Γ ⊢ ¬ A
  ¬-elim : ∀ {Γ A} -> Γ  ⊢ ¬ A -> Γ ⊢ A -> Γ ⊢ ⊥
  ∨-intro1 : ∀ {Γ A B} -> Γ ⊢ A -> Γ ⊢ A ∨ B
  ∨-intro2 : ∀ {Γ A B} -> Γ ⊢ B  -> Γ ⊢ A ∨ B
  ∨-elim : ∀ {Γ A B C} -> Γ ⊢ A ∨ B -> Γ , A ⊢ C -> Γ , B ⊢ C -> Γ ⊢ C

infixl 4 _⊢_

-- ----------------------------------------------------------------------
-- ** Weakening

-- "Weakening" is the property that if we add additional hypotheses to
-- an entailment (or change their order), the entailment remains valid.
-- More formally, weakening states that Γ ⊢ A and Γ ⊆ Γ' implies Γ' ⊢ A.
--
-- To state weakening, we must first define ⊆. The symbol ⊆ can be
-- typed as \subseteq or \seq.
_⊆_ : Context -> Context -> Set
Γ ⊆ Γ' = ∀ {A} -> A ∈ Γ -> A ∈ Γ'

infix 4 _⊆_

-- We need a lemma about ⊆:
lemma-⊆ : ∀ {Γ Γ' A} -> Γ ⊆ Γ' -> Γ , A ⊆ Γ' , A
lemma-⊆ hyp ∈-base = ∈-base
lemma-⊆ hyp (∈-step hyp2) = ∈-step (hyp hyp2)

lemma-⊆-ext : ∀ {Γ Γ' A} -> Γ ⊆ Γ' -> Γ ⊆ Γ' , A
lemma-⊆-ext hyp =  \ x -> ∈-step (hyp x)

lemma-⊆-ext' : ∀ {Γ A} -> Γ ⊆ Γ , A
lemma-⊆-ext' = lemma-⊆-ext \ x -> x

lemma-⊆-empty : ∀ {Γ} -> Empty ⊆ Γ
lemma-⊆-empty {Γ} {A} ()

-- Prove the weakening lemma:
weakening : ∀ {Γ Γ' A} -> Γ ⊢ A -> Γ ⊆ Γ' -> Γ' ⊢ A
weakening (assump x) w = assump (w x)
weakening (∧-intro d d₁) w = ∧-intro (weakening d w) (weakening d₁ w)
weakening (∧-elim1 d) w = ∧-elim1 (weakening d w )
weakening (∧-elim2 d) w = ∧-elim2 (weakening d w)
weakening (⇒-intro d) w = ⇒-intro (weakening d (lemma-⊆ w) )
weakening (⇒-elim d d₁) w = ⇒-elim (weakening d w ) (weakening d₁ w )
weakening (double-negation d) w = double-negation (weakening d w )
weakening ⊤-intro w = ⊤-intro
weakening (¬-intro d) w  = ¬-intro (weakening d (lemma-⊆ w ) )
weakening (¬-elim d e) w  = ( ¬-elim (weakening d w) (weakening e w))
weakening (∨-intro1 d) w  = ∨-intro1 (weakening d w)
weakening (∨-intro2 d) w  = ∨-intro2 (weakening d w)
weakening (∨-elim d e f) w  = ∨-elim (weakening d w) (weakening e (lemma-⊆ w)) (weakening f (lemma-⊆ w) )

-- ----------------------------------------------------------------------
-- ** A derived rule

-- Classical logic also has the following rule, called "ex falsum
-- quodlibet" or "⊥-elim".
--
--       Γ ⊢ ⊥
-- ───────────────── (⊥-elim)
--       Γ ⊢ A
--
-- The reason we did not include it in the proof rules in the above
-- definition of entailment it that it follows from the other rules.
-- Prove it:

⊥-elim : ∀ {Γ A} -> Γ ⊢ ⊥ -> Γ ⊢ A
⊥-elim {Γ} {A} a = double-negation a-⊥-⊥  where
  a-⊥ : Γ ⊢ A ⇒ ⊥
  a-⊥ = ⇒-intro (weakening a (lemma-⊆-ext \ x -> x ) )
  a-⊥-⊥ : Γ ⊢ (A ⇒ ⊥) ⇒ ⊥
  a-⊥-⊥ = ⇒-intro (weakening a (lemma-⊆-ext \ x -> x ) )

-- ----------------------------------------------------------------------
-- * Truth table semantics

-- ----------------------------------------------------------------------
-- ** Truth assignments and interpretation

-- Remember that the atomic formulas of our logic are P 0, P 1, P 2,
-- and so on. The fundamental concept of truth tables is that of a
-- "truth assignment", namely a map from atomic formulas to {T, F}.
-- We usually denote a truth assignment by the letter ρ = \rho.
--
-- We formalize truth assignments as maps from ℕ to Bool.
Assign : Set
Assign = ℕ -> Bool

-- Given a truth assignment ρ, we can compute the truth value (true or
-- false) of any given formula. This is called the "interpretation" of
-- formulas.

interp : Assign -> Formula -> Bool
interp ρ (P x) = ρ x
interp ρ (A ∧ B) = (interp ρ A) and (interp ρ B)
interp ρ (A ⇒ B) = (interp ρ A) implies (interp ρ B)
interp ρ ⊥ = false
interp ρ ⊤ = true
interp ρ (¬ A) = not (interp ρ A)
interp ρ (A ∨ B) = (interp ρ A) or (interp ρ B)

-- Lift the interp function to a list of formulas. We interpret a list
-- of formulas basically as the conjunction of the formulas, i.e., the
-- interpretation of Γ is true if and only if the interpretation of
-- all A ∈ Γ is true.
interps : Assign -> Context -> Bool
interps ρ Empty = true
interps ρ (c , x) = interps ρ c and interp ρ x

-- ----------------------------------------------------------------------
-- ** Semantic entailment

-- We write Γ ⊧ A if under all assignments ρ, if Γ is true, then A is true.
-- A special case is when the context Γ is empty. In that case, ⊧ A means
-- that A is true under all assignments, i.e., A is a tautology.
--
-- The symbol ⊧ is pronounced "models", and you can type it as
-- \models. Please note that this is a different symbol from ⊨ = \|=.
-- We use the symbol "⊧" here.
--
-- The relation ⊧ is also called "semantic entailment" or "truth table
-- entailment", to distinguish it from ⊢, which is "syntactic
-- entailment" or "derivability".

-- We define semantic entailment.
-- _⊧_ : Context -> Formula -> Set
-- Γ ⊧ A = ∀ ρ -> interps ρ Γ ≡ true -> interp ρ A ≡ true

_⊧_ : Context -> Formula -> Set
Γ ⊧ f = (ρ : Assign) -> interps ρ Γ ≡ true -> interp ρ f ≡ true

infix 4 _⊧_

-- ----------------------------------------------------------------------
-- * Soundness

-- ----------------------------------------------------------------------
-- ** Lemmas about the boolean connectives

-- The boolean functions 'and' and 'implies' are defined in Bool.agda.
-- We need to know certain ones of their properties.

boolCases : {p : Set} -> (a : Bool) -> (a ≡ true -> p) -> (a ≡ false -> p) -> p
boolCases true t f = t refl
boolCases false t f = f refl

lemma-and-1 : {a b : Bool} -> a ≡ true -> b ≡ true -> a and b ≡ true
lemma-and-1 refl refl = refl

lemma-and-2 : {a b : Bool} -> a and b ≡ true -> a ≡ true
lemma-and-2 {true} {true} abt = refl

lemma-and-3 : {a b : Bool} -> a and b ≡ true -> b ≡ true
lemma-and-3 {true} {true} abt = refl

lemma-imp-1 : {a b : Bool} -> a implies b ≡ true -> a ≡ true -> b ≡ true
lemma-imp-1 {true} {true} aibt at = refl

lemma-imp-2 : {a b : Bool} -> a ≡ false -> a implies b ≡ true
lemma-imp-2 {false} {true} af = refl
lemma-imp-2 {false} {false} af = refl

lemma-imp-3 : {a b : Bool} -> b ≡ true -> a implies b ≡ true
lemma-imp-3 {true} {true} bt = refl
lemma-imp-3 {false} {b} bt = refl

lemma-doubleNeg : {a : Bool} -> (a implies false) implies false ≡ true -> a ≡ true
lemma-doubleNeg {true} a-f-ft = refl

lemma-not-true : {a : Bool} -> a ≡ true -> not a ≡ false
lemma-not-true {.true} refl = refl

lemma-not-false : {a : Bool} -> a ≡ false -> not a ≡ true
lemma-not-false {.false} refl = refl

lemma-or-1 : {a b : Bool} -> a ≡ true -> a or b ≡ true
lemma-or-1 refl  = refl

lemma-or-2 : {a b : Bool} -> b ≡ true -> a or b ≡ true
lemma-or-2 {true} {.true} refl = refl
lemma-or-2 {false} {.true} refl = refl

-- like boolCases
lemma-or-3 : {C : Set} ->  {a b : Bool} -> a or b ≡ true -> (a ≡ true -> C) -> (b ≡ true -> C) -> C
lemma-or-3 {a = true} {true} aob ca cb = ca aob
lemma-or-3 {a = false} {true} aob ca cb = cb aob
lemma-or-3 {a = true} {false} aob ca cb = ca refl

-- ----------------------------------------------------------------------
-- ** Lemmas about the soundness of individual rules

-- Each of the proof rules of logic has a semantic counterpart.

lemma-assump : ∀ Γ A -> A ∈ Γ -> Γ ⊧ A
lemma-assump (._ , A) A ∈-base = \ ρ ct -> lemma-and-3 ct
lemma-assump (Γ' , B) A (∈-step hyp) = \ ρ ct -> (lemma-assump Γ' A hyp) ρ (lemma-and-2 ct )

lemma-∧-intro : ∀ Γ A B -> Γ ⊧ A -> Γ ⊧ B -> Γ ⊧ A ∧ B
lemma-∧-intro Γ A B as bs = \ ρ ct -> lemma-and-1 (as ρ ct ) (bs ρ ct )

lemma-∧-elim1 : ∀ Γ A B -> Γ ⊧ A ∧ B -> Γ ⊧ A
lemma-∧-elim1 Γ A B abs = \ ρ ct -> lemma-and-2 (abs ρ ct)

lemma-∧-elim2 : ∀ Γ A B -> Γ ⊧ A ∧ B -> Γ ⊧ B
lemma-∧-elim2 Γ A B abs = \ ρ ct -> lemma-and-3 (abs ρ ct)

lemma-⇒-intro' : ∀ Γ A B -> Γ , A ⊧ B -> Γ ⊧ A ⇒ B
lemma-⇒-intro' Γ A B a-bs ρ ct  = boolCases (interp ρ A) (\ x -> lemma-imp-3 (a-bs ρ (lemma-and-1 ct x ) ) ) \ x -> lemma-imp-2 x

lemma-⇒-intro : ∀ Γ A B -> Γ , A ⊧ B -> Γ ⊧ A ⇒ B
lemma-⇒-intro Γ A B a-bs ρ ct with (interp ρ) A | inspect (interp ρ) A
lemma-⇒-intro Γ A B a-bs ρ ct | true | [ eq ] = lemma-imp-3 (a-bs ρ (lemma-and-1 ct eq ) )
lemma-⇒-intro Γ A B a-bs ρ ct | false | [ eq ] = refl

lemma-⇒-elim : ∀ Γ A B -> Γ ⊧ A ⇒ B -> Γ ⊧ A -> Γ ⊧ B
lemma-⇒-elim Γ A B a-bs as = \ ρ ct -> lemma-imp-1 (a-bs ρ ct ) (as ρ ct )

lemma-double-negation : ∀ Γ A -> Γ ⊧ (A ⇒ ⊥) ⇒ ⊥ -> Γ ⊧ A
lemma-double-negation Γ A anns = \ ρ ct -> lemma-doubleNeg (anns ρ ct )

lemma-⊤-intro : ∀ Γ -> Γ ⊧ ⊤
lemma-⊤-intro Γ = \ ρ ct -> refl

lemma-¬-intro : ∀ Γ A -> Γ , A ⊧ ⊥ -> Γ ⊧ ¬ A
lemma-¬-intro Γ A a ρ ct with (interp ρ) A | inspect (interp ρ) A
lemma-¬-intro Γ A a ρ ct | true  | [ eq ] = a ρ (lemma-and-1 ct eq)
lemma-¬-intro Γ A a ρ ct | false | [ eq ] = refl

lemma-¬-intro' : ∀ Γ A -> Γ , A ⊧ ⊥ -> Γ ⊧ ¬ A
lemma-¬-intro' Γ A a ρ ct = boolCases (interp ρ A) (\x -> trans (lemma-not-true x ) (a ρ (lemma-and-1 ct x ) )  ) \ x -> lemma-not-false x

lemma-¬-elim : ∀ Γ A -> Γ ⊧ ¬ A -> Γ ⊧  A -> Γ ⊧ ⊥
lemma-¬-elim Γ A a b ρ ct = boolCases (interp ρ A) (\ x -> trans (sym (lemma-not-true x)) (a ρ ct )   ) \ x -> trans (sym  x ) (b ρ ct)

lemma-∨-intro1 : ∀ Γ A B -> Γ ⊧  A -> Γ ⊧  A ∨ B
lemma-∨-intro1 Γ A B a ρ ct = lemma-or-1 (a ρ ct )

lemma-∨-intro2 : ∀ Γ A B -> Γ ⊧  B -> Γ ⊧  A ∨ B
lemma-∨-intro2 Γ A B a ρ ct = lemma-or-2 (a ρ ct )

lemma-∨-elim : ∀ Γ A B C -> Γ ⊧  A ∨ B -> Γ , A ⊧  C -> Γ , B ⊧  C -> Γ ⊧ C
lemma-∨-elim Γ A B C aob ac bc ρ ct = lemma-or-3 (aob ρ ct) (\ x -> ac ρ (lemma-and-1 ct x )  ) \ x -> bc ρ (lemma-and-1 ct x )

-- ----------------------------------------------------------------------
-- * The soundness theorem of boolean logic.

-- Soundness states that Γ ⊢ A implies Γ ⊧ A, or equivalently:
-- everything that is provable is valid.

-- 4. Prove the soundness of boolean logic.
sound : ∀ Γ A -> Γ ⊢ A -> Γ ⊧ A
sound Γ A (assump x) = lemma-assump Γ A x
sound Γ (A ∧ B) (∧-intro hyp hyp₁) = lemma-∧-intro Γ A B (sound Γ A hyp) (sound Γ B hyp₁)
sound Γ A (∧-elim1 {B = B} hyp) = lemma-∧-elim1 Γ A B (sound Γ  (A ∧ B) hyp )
sound Γ A (∧-elim2 {A = A₁} hyp) = lemma-∧-elim2 Γ  A₁ A ((sound Γ  (A₁ ∧ A) hyp ) )
sound Γ (A ⇒ B) (⇒-intro hyp) = lemma-⇒-intro Γ A B (sound (Γ , A) B   hyp )
sound Γ A (⇒-elim {A = A₁} hyp hyp₁) = lemma-⇒-elim Γ A₁ A (sound Γ (A₁ ⇒ A) hyp ) (sound Γ A₁ hyp₁)
sound Γ A (double-negation hyp) = lemma-double-negation Γ A (sound Γ ((A ⇒ ⊥) ⇒ ⊥) hyp)
sound Γ .⊤ ⊤-intro = λ ρ _ → refl
sound Γ (¬ A) (¬-intro x) = lemma-¬-intro' Γ  A ((sound (Γ , A) ⊥  x ) )
sound Γ .⊥ (¬-elim {A = A} x y) = lemma-¬-elim Γ A (sound Γ (¬ A) x) (sound Γ  A y)
sound Γ (A ∨ B) (∨-intro1 x) = lemma-∨-intro1 Γ A B (sound Γ A x )
sound Γ (A ∨ B) (∨-intro2 x) = lemma-∨-intro2 Γ A B (sound Γ B x )
sound Γ C (∨-elim {A = A} {B} x y z) = lemma-∨-elim Γ A B C (sound Γ (A ∨ B) x ) (sound (Γ , A) C y ) (sound (Γ , B) C z)

-- ----------------------------------------------------------------------
-- * Bonus questions and beyond

-- If you feel adventurous, add more connectives, such as ¬A or A ∨ B,
-- to the boolean logic.
--
-- The proof rules are:
--
--    Γ, A ⊢ ⊥
-- ────────────── (¬-intro)
--     Γ ⊢ ¬A
--
--
--    Γ ⊢ ¬A     Γ ⊢ A
-- ───────────────────── (¬-elim)
--         Γ ⊢ ⊥
--
--
--      Γ ⊢ A
-- ───────────── (∨-intro1)
--    Γ ⊢ A ∨ B
--
--
--      Γ ⊢ B
-- ───────────── (∨-intro2)
--    Γ ⊢ A ∨ B
--
--
--    Γ ⊢ A ∨ B    Γ, A ⊢ C    Γ, B ⊢ C
-- ─────────────────────────────────────── (∨-elim)
--                  Γ ⊢ C

-- If you feel extremely ambitious, try to prove completeness, the
-- converse of soundness. Completeness is the statement that Γ ⊧ A
-- implies Γ ⊢ A.
--
-- Warning: this is extremely difficult and far more work than
-- soundness. Neither Frank nor I have been able to finish a proof of
-- completeness.

-- Actually, Peter had finished the proof a couple of days later using
-- conjunction normal form.

completeness-property : Set
completeness-property = ∀ Γ A -> Γ ⊧ A -> Γ ⊢ A

-- Now, I (Bian) will prove this property in Kalmar.agda using
-- Kalmar's lemma.


------------------------------------------------------------------------
-- The Agda standard library
--
-- N-ary products
------------------------------------------------------------------------

-- Vectors (as in Data.Vec) also represent n-ary products, so what is
-- the point of this module? The n-ary products below are intended to
-- be used with a fixed n, in which case the nil constructor can be
-- avoided: pairs are represented as pairs (x , y), not as triples
-- (x , y , unit).

module Data.Product.N-ary where

open import Data.Nat
open import Data.Product
open import Data.Unit
open import Data.Vec
open import Function.Inverse
open import Level using (Lift; lift)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

-- N-ary product.

infix 8 _^_

_^_ : ∀ {ℓ} → Set ℓ → ℕ → Set ℓ
A ^ 0           = Lift ⊤
A ^ 1           = A
A ^ suc (suc n) = A × A ^ suc n

-- Conversions.

↔Vec : ∀ {a} {A : Set a} n → A ^ n ↔ Vec A n
↔Vec n = record
  { to         = P.→-to-⟶ (toVec n)
  ; from       = P.→-to-⟶ fromVec
  ; inverse-of = record
    { left-inverse-of  = fromVec∘toVec n
    ; right-inverse-of = toVec∘fromVec
    }
  }
  where
  toVec : ∀ {a} {A : Set a} n → A ^ n → Vec A n
  toVec 0             (lift tt) = []
  toVec 1             x         = [ x ]
  toVec (suc (suc n)) (x , xs)  = x ∷ toVec _ xs

  fromVec : ∀ {a} {A : Set a} {n} → Vec A n → A ^ n
  fromVec []           = lift tt
  fromVec (x ∷ [])     = x
  fromVec (x ∷ y ∷ xs) = (x , fromVec (y ∷ xs))

  fromVec∘toVec : ∀ {a} {A : Set a} n (xs : A ^ n) →
                  fromVec (toVec n xs) ≡ xs
  fromVec∘toVec 0                   (lift tt)    = P.refl
  fromVec∘toVec 1                   x            = P.refl
  fromVec∘toVec 2                   (x , y)      = P.refl
  fromVec∘toVec (suc (suc (suc n))) (x , y , xs) =
    P.cong (_,_ x) (fromVec∘toVec (suc (suc n)) (y , xs))

  toVec∘fromVec : ∀ {a} {A : Set a} {n} (xs : Vec A n) →
                  toVec n (fromVec xs) ≡ xs
  toVec∘fromVec []           = P.refl
  toVec∘fromVec (x ∷ [])     = P.refl
  toVec∘fromVec (x ∷ y ∷ xs) = P.cong (_∷_ x) (toVec∘fromVec (y ∷ xs))


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.ListedFiniteSet.Base where

open import Cubical.Core.Everything
open import Cubical.Foundations.Logic
open import Cubical.Foundations.Everything

private
  variable
    A : Type₀

infixr 20 _∷_
infix 30 _∈_

data LFSet (A : Type₀) : Type₀ where
  []    : LFSet A
  _∷_   : (x : A) → (xs : LFSet A) → LFSet A
  dup   : ∀ x xs   → x ∷ x ∷ xs ≡ x ∷ xs
  comm  : ∀ x y xs → x ∷ y ∷ xs ≡ y ∷ x ∷ xs
  trunc : isSet (LFSet A)

-- Membership.
--
-- Doing some proofs with equational reasoning adds an extra "_∙ refl"
-- at the end.
-- We might want to avoid it, or come up with a more clever equational reasoning.
_∈_ : A → LFSet A → hProp
z ∈ []                  = ⊥
z ∈ (y ∷ xs)            = (z ≡ₚ y) ⊔ (z ∈ xs)
z ∈ dup x xs i          = proof i
  where
    -- proof : z ∈ (x ∷ x ∷ xs) ≡ z ∈ (x ∷ xs)
    proof = z ≡ₚ x  ⊔ (z ≡ₚ x ⊔ z ∈ xs) ≡⟨ ⊔-assoc (z ≡ₚ x) (z ≡ₚ x) (z ∈ xs) ⟩
            (z ≡ₚ x ⊔ z ≡ₚ x) ⊔ z ∈ xs  ≡⟨ cong (_⊔ (z ∈ xs)) (⊔-idem (z ≡ₚ x)) ⟩
            z ≡ₚ x            ⊔ z ∈ xs  ∎
z ∈ comm x y xs i       = proof i
  where
    -- proof : z ∈ (x ∷ y ∷ xs) ≡ z ∈ (y ∷ x ∷ xs)
    proof = z ≡ₚ x  ⊔ (z ≡ₚ y ⊔ z ∈ xs) ≡⟨ ⊔-assoc (z ≡ₚ x) (z ≡ₚ y) (z ∈ xs) ⟩
            (z ≡ₚ x ⊔ z ≡ₚ y) ⊔ z ∈ xs  ≡⟨ cong (_⊔ (z ∈ xs)) (⊔-comm (z ≡ₚ x) (z ≡ₚ y)) ⟩
            (z ≡ₚ y ⊔ z ≡ₚ x) ⊔ z ∈ xs  ≡⟨ sym (⊔-assoc (z ≡ₚ y) (z ≡ₚ x) (z ∈ xs)) ⟩
            z ≡ₚ y  ⊔ (z ≡ₚ x ⊔ z ∈ xs) ∎

x ∈ trunc xs ys p q i j = isSetHProp (x ∈ xs) (x ∈ ys) (cong (x ∈_) p) (cong (x ∈_) q) i j


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.Nullary.HLevels where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Functions.Fixpoint

open import Cubical.Relation.Nullary

private
  variable
    ℓ : Level
    A : Type ℓ

isPropPopulated : isProp (Populated A)
isPropPopulated = isPropΠ λ x → 2-Constant→isPropFixpoint (x .fst) (x .snd)

isPropHSeparated : isProp (HSeparated A)
isPropHSeparated f g i x y a = HSeparated→isSet f x y (f x y a) (g x y a) i

isPropCollapsible≡ : isProp (Collapsible≡ A)
isPropCollapsible≡ {A = A} f = (isPropΠ2 λ x y → isPropCollapsiblePointwise) f where
  sA : isSet A
  sA = Collapsible≡→isSet f
  gA : isGroupoid A
  gA = isSet→isGroupoid sA
  isPropCollapsiblePointwise : ∀ {x y} → isProp (Collapsible (x ≡ y))
  isPropCollapsiblePointwise {x} {y} (a , ca) (b , cb) = λ i → endoFunction i , endoFunctionIsConstant i where
    endoFunction : a ≡ b
    endoFunction = funExt λ p → sA _ _ (a p) (b p)
    isProp2-Constant : (k : I) → isProp (2-Constant (endoFunction k))
    isProp2-Constant k = isPropΠ2 λ r s → gA x y (endoFunction k r) (endoFunction k s)
    endoFunctionIsConstant : PathP (λ i → 2-Constant (endoFunction i)) ca cb
    endoFunctionIsConstant = isProp→PathP isProp2-Constant ca cb


module Relations where

open import Agda.Builtin.Equality
open import Natural

data _≤_ : ℕ → ℕ → Set where
    z≤n : ∀ {n : ℕ} →
        zero ≤ n
    s≤s : ∀ {m n : ℕ} →
        m ≤ n →
        (suc m) ≤ (suc n)

infix 4 _≤_

-- example : finished by auto mode
_ : 3 ≤ 5
_ = s≤s {2} {4} (s≤s {1} {3} (s≤s {0} {2} (z≤n {2})))

inv-s≤s : ∀ {m n : ℕ}
    → suc m ≤ suc n
    → m ≤ n
inv-s≤s (s≤s m≤n) = m≤n

inv-z≤n : ∀ {m : ℕ}
    → m ≤ zero
    → m ≡ zero
inv-z≤n z≤n = refl


module BBHeap.Order.Properties {A : Set}(_≤_ : A → A → Set) where

open import BBHeap _≤_
open import BBHeap.Order _≤_ renaming (Acc to Accₕ ; acc to accₕ)
open import Data.Nat
open import Induction.Nat
open import Induction.WellFounded

ii-acc : ∀ {b} {h} → Acc _<′_ (# {b} h) → Accₕ h
ii-acc (acc rs) = accₕ (λ h' #h'<′#h → ii-acc (rs (# h') #h'<′#h))

≺-wf : ∀ {b} h → Accₕ {b} h
≺-wf = λ h → ii-acc (<-well-founded (# h))


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

open import LogicalFormulae
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Addition

module Numbers.Naturals.Multiplication where

infix 25 _*N_
_*N_ : ℕ → ℕ → ℕ
zero *N y = zero
(succ x) *N y = y +N (x *N y)
{-# BUILTIN NATTIMES _*N_ #-}

productZeroIsZeroLeft : (a : ℕ) → (zero *N a ≡ zero)
productZeroIsZeroLeft a = refl

productZeroIsZeroRight : (a : ℕ) → (a *N zero ≡ zero)
productZeroIsZeroRight zero = refl
productZeroIsZeroRight (succ a) = productZeroIsZeroRight a

productWithOneLeft : (a : ℕ) → ((succ zero) *N a) ≡ a
productWithOneLeft a = transitivity refl (transitivity (applyEquality (λ { m -> a +N m }) refl) (additionNIsCommutative a zero))

productWithOneRight : (a : ℕ) → a *N succ zero ≡ a
productWithOneRight zero = refl
productWithOneRight (succ a) = transitivity refl (addingPreservesEqualityLeft (succ zero) (productWithOneRight a))

productDistributes : (a b c : ℕ) → (a *N (b +N c)) ≡ a *N b +N a *N c
productDistributes zero b c = refl
productDistributes (succ a) b c = transitivity refl
  (transitivity (addingPreservesEqualityLeft (b +N c) (productDistributes a b c))
    (transitivity (equalityCommutative (additionNIsAssociative (b +N c) (a *N b) (a *N c)))
      (transitivity (addingPreservesEqualityRight (a *N c) (additionNIsCommutative (b +N c) (a *N b)))
        (transitivity (addingPreservesEqualityRight (a *N c) (equalityCommutative (additionNIsAssociative (a *N b) b c)))
          (transitivity (addingPreservesEqualityRight (a *N c) (addingPreservesEqualityRight c (additionNIsCommutative (a *N b) b)))
            (transitivity (addingPreservesEqualityRight (a *N c) (addingPreservesEqualityRight {b +N a *N b} {(succ a) *N b} c (refl)))
              (transitivity (additionNIsAssociative ((succ a) *N b) c (a *N c))
                (transitivity (addingPreservesEqualityLeft (succ a *N b) refl)
                  refl)
            )
        ))))))

productPreservesEqualityLeft : (a : ℕ) → {b c : ℕ} → b ≡ c → a *N b ≡ a *N c
productPreservesEqualityLeft a {b} {.b} refl = refl

aSucB : (a b : ℕ) → a *N succ b ≡ a *N b +N a
aSucB a b = transitivity {_} {ℕ} {a *N succ b} {a *N (b +N succ zero)} (productPreservesEqualityLeft a (succIsAddOne b)) (transitivity {_} {ℕ} {a *N (b +N succ zero)} {a *N b +N a *N succ zero} (productDistributes a b (succ zero)) (addingPreservesEqualityLeft (a *N b) (productWithOneRight a)))

aSucBRight : (a b : ℕ) → (succ a) *N b ≡ a *N b +N b
aSucBRight a b = additionNIsCommutative b (a *N b)

multiplicationNIsCommutative : (a b : ℕ) → (a *N b) ≡ (b *N a)
multiplicationNIsCommutative zero b = transitivity (productZeroIsZeroLeft b) (equalityCommutative (productZeroIsZeroRight b))
multiplicationNIsCommutative (succ a) zero = multiplicationNIsCommutative a zero
multiplicationNIsCommutative (succ a) (succ b) = transitivity refl
  (transitivity (addingPreservesEqualityLeft (succ b) (aSucB a b))
    (transitivity (additionNIsCommutative (succ b) (a *N b +N a))
      (transitivity (additionNIsAssociative (a *N b) a (succ b))
        (transitivity (addingPreservesEqualityLeft (a *N b) (succCanMove a b))
          (transitivity (addingPreservesEqualityLeft (a *N b) (additionNIsCommutative (succ a) b))
            (transitivity (equalityCommutative (additionNIsAssociative (a *N b) b (succ a)))
              (transitivity (addingPreservesEqualityRight (succ a) (equalityCommutative (aSucBRight a b)))
                (transitivity (addingPreservesEqualityRight (succ a) (multiplicationNIsCommutative (succ a) b))
                  (transitivity (additionNIsCommutative (b *N (succ a)) (succ a))
                    refl
                )))))))))

productDistributes' : (a b c : ℕ) → (a +N b) *N c ≡ a *N c +N b *N c
productDistributes' a b c rewrite multiplicationNIsCommutative (a +N b) c | productDistributes c a b | multiplicationNIsCommutative c a | multiplicationNIsCommutative c b = refl

flipProductsWithinSum : (a b c : ℕ) → (c *N a +N c *N b ≡ a *N c +N b *N c)
flipProductsWithinSum a b c = transitivity (addingPreservesEqualityRight (c *N b) (multiplicationNIsCommutative c a)) ((addingPreservesEqualityLeft (a *N c) (multiplicationNIsCommutative c b)))

productDistributesRight : (a b c : ℕ) → (a +N b) *N c ≡ a *N c +N b *N c
productDistributesRight a b c = transitivity (multiplicationNIsCommutative (a +N b) c) (transitivity (productDistributes c a b) (flipProductsWithinSum a b c))

multiplicationNIsAssociative : (a b c : ℕ) → (a *N (b *N c)) ≡ ((a *N b) *N c)
multiplicationNIsAssociative zero b c = refl
multiplicationNIsAssociative (succ a) b c =
    transitivity refl
      (transitivity refl
        (transitivity (applyEquality ((λ x → b *N c +N x)) (multiplicationNIsAssociative a b c)) (transitivity (equalityCommutative (productDistributesRight b (a *N b) c)) refl)))

productOne : {a b : ℕ} → a ≡ a *N b → (a ≡ 0) || (b ≡ 1)
productOne {zero} {b} pr = inl refl
productOne {succ a} {zero} pr rewrite multiplicationNIsCommutative a 0 = exFalso (naughtE (equalityCommutative pr))
productOne {succ a} {succ zero} pr = inr refl
productOne {succ a} {succ (succ b)} pr rewrite multiplicationNIsCommutative a (succ (succ b)) | additionNIsCommutative (succ b) (a +N (a +N b *N a)) | additionNIsAssociative (succ a) (a +N b *N a) (succ b) | additionNIsCommutative (a +N b *N a) (succ b) = exFalso (bad pr)
  where
    bad' : {x : ℕ} → x ≡ succ x → False
    bad' ()
    bad : {x y : ℕ} → x ≡ x +N succ y → False
    bad {succ x} {zero} pr rewrite additionNIsCommutative x 1 = bad' pr
    bad {succ x} {succ y} pr = bad (succInjective pr)


{-# OPTIONS --without-K #-}
module sets.nat.ordering.leq.core where

open import decidable
open import equality.core
open import function.core
open import sets.nat.core
open import sets.empty

data _≤_ : ℕ → ℕ → Set where
  z≤n : ∀ {n} → zero ≤ n
  s≤s : ∀ {m n} (p : m ≤ n) → suc m ≤ suc n

ap-pred-≤ : ∀ {n m} → suc n ≤ suc m → n ≤ m
ap-pred-≤ (s≤s p) = p

refl≤ : {n : ℕ} → n ≤ n
refl≤ {0} = z≤n
refl≤ {suc n} = s≤s refl≤

≡⇒≤ : {n m : ℕ} → n ≡ m → n ≤ m
≡⇒≤ refl = refl≤

suc≤ : ∀ {n} → n ≤ suc n
suc≤ {0} = z≤n
suc≤ {suc n} = s≤s suc≤

suc≰ : ∀ {n} → ¬ (suc n ≤ n)
suc≰ {zero} ()
suc≰ {suc n} p = suc≰ (ap-pred-≤ p)

trans≤ : ∀ {n m p} → n ≤ m → m ≤ p → n ≤ p
trans≤ z≤n q = z≤n
trans≤ (s≤s p) (s≤s q) = s≤s (trans≤ p q)

antisym≤ : ∀ {n m} → n ≤ m → m ≤ n → n ≡ m
antisym≤ z≤n z≤n = refl
antisym≤ (s≤s p) (s≤s q) = ap suc (antisym≤ p q)


import      Lvl
open import Structure.Operator.Ring
open import Structure.Setoid
open import Type

module Structure.Operator.Ring.Characteristic {ℓ ℓₑ} {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ (_+_ _⋅_  : T → T → T) ⦃ ring : Ring(_+_)(_⋅_) ⦄ where
open Ring(ring)

open import Function.Iteration
open import Numeral.Natural as ℕ using (ℕ)
import      Numeral.Natural.Relation.Order as ℕ
open import Relator.Equals using () renaming (_≡_ to _≡ₑ_)

CharacteristicMultiple : ℕ → Type
CharacteristicMultiple(n) = ∀{a} → (repeatᵣ(n)(_+_) a 𝟎 ≡ 𝟎)

data Characteristic : ℕ → Type{ℓ Lvl.⊔ ℓₑ} where
  none : (∀{n} → CharacteristicMultiple(n) → (n ≡ₑ ℕ.𝟎)) → Characteristic(ℕ.𝟎)
  pos  : ∀{n} → CharacteristicMultiple(ℕ.𝐒(n)) → (∀{m} → CharacteristicMultiple(ℕ.𝐒(m)) → (ℕ.𝐒(m) ℕ.≥ ℕ.𝐒(n))) → Characteristic(ℕ.𝐒(n))


module Common where

open import Level using (Level)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; sym; refl)
open import Relation.Nullary.Decidable using (False; toWitnessFalse)
open import Data.Nat using (ℕ)
open import Data.Fin using (Fin; _≟_)

private
  variable
    n : ℕ
    l : Level
    A : Set l
    x x′ y : A

Label : Set
Label = ℕ

data Action (n : ℕ) : Set where
  action : (p q : Fin n) -> p ≢ q -> Label -> Action n

action′ : (p q : Fin n) -> {False (p ≟ q)} -> Label -> Action n
action′ p q {p≢q} l = action p q (toWitnessFalse p≢q) l

¬≡-flip : x ≢ y -> y ≢ x
¬≡-flip x≢y = λ y≡x → x≢y (sym y≡x)

≢-subst-left : x ≢ y -> x ≡ x′ -> x′ ≢ y
≢-subst-left x≢y refl = x≢y

≢-subst-right : y ≢ x -> x ≡ x′ -> y ≢ x′
≢-subst-right y≢x refl = y≢x


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

module Pi1Examples where

open import PiU using (U; ONE)
open import PiLevel0 using (_⟷_; _◎_; _⊗_; id⟷;
  swap₊; unite⋆l; unite⋆r;
  swap⋆; uniti⋆l; uniti⋆r)
open import Pi0Examples using (BOOL)
open import PiLevel1 using (_⇔_; id⇔; trans⇔; _⊡_;
  assoc◎l; swapl⋆⇔; assoc◎r; linv◎l; idl◎l; idr◎l; unitil⋆⇔l)

------------------------------------------------------------------------------
-- Better syntax for writing 2paths

infix  2  _▤
infixr 2  _⇔⟨_⟩_

_⇔⟨_⟩_ : {t₁ t₂ : U} (c₁ : t₁ ⟷ t₂) {c₂ : t₁ ⟷ t₂} {c₃ : t₁ ⟷ t₂} →
         (c₁ ⇔ c₂) → (c₂ ⇔ c₃) → (c₁ ⇔ c₃)
_ ⇔⟨ α ⟩ β = trans⇔ α β

_▤ : {t₁ t₂ : U} → (c : t₁ ⟷ t₂) → (c ⇔ c)
_▤ c = id⇔

------------------------------------------------------------------------------
-- a nice example of 2 paths

neg₁ neg₂ neg₃ neg₄ neg₅ : BOOL ⟷ BOOL
neg₁ = swap₊
neg₂ = id⟷ ◎ swap₊
neg₃ = swap₊ ◎ swap₊ ◎ swap₊
neg₄ = swap₊ ◎ id⟷
neg₅ = uniti⋆l ◎ swap⋆ ◎ (swap₊ ⊗ id⟷) ◎ swap⋆ ◎ unite⋆l
neg₆ = uniti⋆r ◎ (swap₊ {ONE} {ONE} ⊗ id⟷) ◎ unite⋆r

negEx : neg₅ ⇔ neg₁
negEx = uniti⋆l ◎ (swap⋆ ◎ ((swap₊ ⊗ id⟷) ◎ (swap⋆ ◎ unite⋆l)))
          ⇔⟨ id⇔ ⊡ assoc◎l ⟩
        uniti⋆l ◎ ((swap⋆ ◎ (swap₊ ⊗ id⟷)) ◎ (swap⋆ ◎ unite⋆l))
          ⇔⟨ id⇔ ⊡ (swapl⋆⇔ ⊡ id⇔) ⟩
        uniti⋆l ◎ (((id⟷ ⊗ swap₊) ◎ swap⋆) ◎ (swap⋆ ◎ unite⋆l))
          ⇔⟨ id⇔ ⊡ assoc◎r ⟩
        uniti⋆l ◎ ((id⟷ ⊗ swap₊) ◎ (swap⋆ ◎ (swap⋆ ◎ unite⋆l)))
          ⇔⟨ id⇔ ⊡ (id⇔ ⊡ assoc◎l) ⟩
        uniti⋆l ◎ ((id⟷ ⊗ swap₊) ◎ ((swap⋆ ◎ swap⋆) ◎ unite⋆l))
          ⇔⟨ id⇔ ⊡ (id⇔ ⊡ (linv◎l ⊡ id⇔)) ⟩
        uniti⋆l ◎ ((id⟷ ⊗ swap₊) ◎ (id⟷ ◎ unite⋆l))
          ⇔⟨ id⇔ ⊡ (id⇔ ⊡ idl◎l) ⟩
        uniti⋆l ◎ ((id⟷ ⊗ swap₊) ◎ unite⋆l)
          ⇔⟨ assoc◎l ⟩
        (uniti⋆l ◎ (id⟷ ⊗ swap₊)) ◎ unite⋆l
          ⇔⟨ unitil⋆⇔l ⊡ id⇔ ⟩
        (swap₊ ◎ uniti⋆l) ◎ unite⋆l
          ⇔⟨ assoc◎r ⟩
        swap₊ ◎ (uniti⋆l ◎ unite⋆l)
          ⇔⟨ id⇔ ⊡ linv◎l ⟩
        swap₊ ◎ id⟷
          ⇔⟨ idr◎l ⟩
        swap₊ ▤

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


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

module Cubical.Functions.Involution where

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

isInvolution : ∀{ℓ} {A : Type ℓ} → (A → A) → Type _
isInvolution f = ∀ x → f (f x) ≡ x

module _ {ℓ} {A : Type ℓ} {f : A → A} (invol : isInvolution f) where
  open Iso

  involIso : Iso A A
  involIso .fun = f
  involIso .inv = f
  involIso .rightInv = invol
  involIso .leftInv = invol

  involIsEquiv : isEquiv f
  involIsEquiv = isoToIsEquiv involIso

  involEquiv : A ≃ A
  involEquiv = f , involIsEquiv

  involPath : A ≡ A
  involPath = ua involEquiv

  involEquivComp : compEquiv involEquiv involEquiv ≡ idEquiv A
  involEquivComp
    = equivEq (λ i x → invol x i)

  involPathComp : involPath ∙ involPath ≡ refl
  involPathComp
    = sym (uaCompEquiv involEquiv involEquiv) ∙∙ cong ua involEquivComp ∙∙ uaIdEquiv

  involPath² : Square involPath refl refl involPath
  involPath²
    = subst (λ s → Square involPath s refl involPath)
        involPathComp (compPath-filler involPath involPath)


------------------------------------------------------------------------------
-- Common stuff used by the gcd example
------------------------------------------------------------------------------

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

module FOTC.Program.GCD.Total.Definitions where

open import FOTC.Base
open import FOTC.Data.Nat.Divisibility.By0
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Common divisor.
CD : D → D → D → Set
CD m n cd = cd ∣ m ∧ cd ∣ n
{-# ATP definition CD #-}

-- Divisible for any common divisor.
Divisible : D → D → D → Set
Divisible m n gcd = ∀ cd → N cd → CD m n cd → cd ∣ gcd
{-# ATP definition Divisible #-}

-- Greatest common divisor specification.

-- The gcd is a common divisor and the gcd is divided by any common
-- divisor, thefore the gcd is the greatest common divisor
-- according to the partial order _∣_.
gcdSpec : D → D → D → Set
gcdSpec m n gcd = CD m n gcd ∧ Divisible m n gcd
{-# ATP definition gcdSpec #-}


module Tactic.Nat.NF where

open import Prelude
open import Tactic.Nat.Exp
open import Container.Bag

Tm : Set → Set
Tm Atom = List Atom

NF : Set → Set
NF Atom = Bag (Tm Atom)

product1 : List Nat → Nat
product1 [] = 1
product1 (x ∷ xs) = foldl (λ n x → n * x) x xs

module _ {Atom : Set} {{_ : Ord Atom}} where
  infixl 6 _+nf_
  infixl 7 _*nf_

  _+nf_ : NF Atom → NF Atom → NF Atom
  _+nf_ a b = union a b

  merge : Tm Atom → Tm Atom → Tm Atom
  merge x [] = x
  merge [] y = y
  merge (i ∷ x) (j ∷ y) =
    if i <? j then i ∷ merge x (j ∷ y)
              else j ∷ merge (i ∷ x) y

  nf-sort : NF Atom → NF Atom
  nf-sort [] = []
  nf-sort (x ∷ nf) = union [ x ] (nf-sort nf)

  mulTm : Nat × Tm Atom → Nat × Tm Atom → Nat × Tm Atom
  mulTm (a , x) (b , y) = a * b , merge x y

  _*nf_ : NF Atom → NF Atom → NF Atom
  []      *nf b = []
  (t ∷ a) *nf b = nf-sort (map (mulTm t) b) +nf (a *nf b)

  -- Normalising expressions --
  norm : Exp Atom → NF Atom
  norm (var x) = [ 1 , [ x ] ]
  norm (lit 0) = []
  norm (lit n) = [ n , [] ]
  norm (e ⟨+⟩ e₁) = norm e +nf norm e₁
  norm (e ⟨*⟩ e₁) = norm e *nf norm e₁

  ⟦_⟧t : Nat × Tm Atom → Env Atom → Nat
  ⟦ k , v ⟧t ρ = k * productR (map ρ v)

  ⟦_⟧n : NF Atom → Env Atom → Nat
  ⟦ nf ⟧n ρ = sumR (map (flip ⟦_⟧t ρ) nf)

  ⟦_⟧ts : Nat × Tm Atom → Env Atom → Nat
  ⟦ 1 , v ⟧ts ρ = product1 (map ρ v)
  ⟦ k , v ⟧ts ρ = product1 (map ρ v) * k

  ⟦_⟧ns : NF Atom → Env Atom → Nat
  ⟦ []     ⟧ns ρ = 0
  ⟦ t ∷ nf ⟧ns ρ = foldl (λ n t → n + ⟦ t ⟧ts ρ) (⟦ t ⟧ts ρ) nf

  cancel : NF Atom → NF Atom → NF Atom × NF Atom
  cancel nf₁ [] = nf₁ , []
  cancel [] nf₂ = [] , nf₂
  cancel ((i , x) ∷ nf₁) ((j , y) ∷ nf₂) with compare x y
  ... | less    _ = first  (_∷_ (i , x)) (cancel nf₁ ((j , y) ∷ nf₂))
  ... | greater _ = second (_∷_ (j , y)) (cancel ((i , x) ∷ nf₁) nf₂)
  ... | equal   _ with compare i j
  ...                | less    (diff k _) = second (_∷_ (suc k , y)) (cancel nf₁ nf₂)
  ...                | greater (diff k _) = first  (_∷_ (suc k , x)) (cancel nf₁ nf₂)
  ...                | equal    _         = cancel nf₁ nf₂


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

open import Categories.Category

-- a zero object is both terminal and initial.
module Categories.Object.Zero {o ℓ e} (C : Category o ℓ e) where

open import Level using (_⊔_)

open import Categories.Object.Terminal C
open import Categories.Object.Initial C

open Category C

record Zero : Set (o ⊔ ℓ ⊔ e) where
 field
   zero : Obj
   !    : ∀ {A} → zero ⇒ A
   ¡    : ∀ {A} → A ⇒ zero

 field
   !-unique : ∀ {A} (f : zero ⇒ A) → ! ≈ f
   ¡-unique : ∀ {A} (f : A ⇒ zero) → ¡ ≈ f

 initial : Initial
 initial = record
   { ⊥        = zero
   ; !        = !
   ; !-unique = !-unique
   }

 terminal : Terminal
 terminal = record
   { ⊤        = zero
   ; !        = ¡
   ; !-unique = ¡-unique
   }

 module initial  = Initial initial
 module terminal = Terminal terminal


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

open import Categories.Category.Core using (Category)

module Categories.Diagram.Pushout {o ℓ e} (C : Category o ℓ e) where

open Category C
open HomReasoning

open import Level

private
  variable
    A B E X Y Z : Obj

record Pushout (f : X ⇒ Y) (g : X ⇒ Z) : Set (o ⊔ ℓ ⊔ e) where
  field
    {Q} : Obj
    i₁  : Y ⇒ Q
    i₂  : Z ⇒ Q

  field
    commute   : i₁ ∘ f ≈ i₂ ∘ g
    universal : {h₁ : Y ⇒ B} {h₂ : Z ⇒ B} → h₁ ∘ f ≈ h₂ ∘ g → Q ⇒ B
    unique    : {h₁ : Y ⇒ E} {h₂ : Z ⇒ E} {j : Q ⇒ E} {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                  j ∘ i₁ ≈ h₁ → j ∘ i₂ ≈ h₂ →
                  j ≈ universal eq

    universal∘i₁≈h₁  : {h₁ : Y ⇒ E} {h₂ : Z ⇒ E} {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                         universal eq ∘ i₁ ≈ h₁
    universal∘i₂≈h₂  : {h₁ : Y ⇒ E} {h₂ : Z ⇒ E} {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                         universal eq ∘ i₂ ≈ h₂


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

-- Theorems about equivalent formulations to Adjoint
-- (though some have caveats)

open import Level

open import Data.Product using (_,_; _×_)
open import Function using (_$_) renaming (_∘_ to _∙_)
open import Function.Equality using (Π; _⟶_)
import Function.Inverse as FI
open import Relation.Binary using (Rel; IsEquivalence; Setoid)

-- be explicit in imports to 'see' where the information comes from
open import Categories.Adjoint using (Adjoint; _⊣_)
open import Categories.Category.Core using (Category)
open import Categories.Category.Product using (Product; _⁂_)
open import Categories.Category.Instance.Setoids
open import Categories.Morphism
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.Functor.Bifunctor using (Bifunctor)
open import Categories.Functor.Hom using (Hom[_][-,-])
open import Categories.Functor.Construction.LiftSetoids
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper; _∘ₕ_; _∘ᵥ_; _∘ˡ_; _∘ʳ_)
  renaming (id to idN)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; unitorˡ; unitorʳ; associator; _≃_)
import Categories.Morphism.Reasoning as MR

private
  variable
    o o′ o″ ℓ ℓ′ ℓ″ e e′ e″ : Level
    C D E : Category o ℓ e

-- a special case of the natural isomorphism in which homsets in C and D have the same
-- universe level. therefore there is no need to lift Setoids to the same level.
-- this is helpful when combining with Yoneda lemma.
module _ {C : Category o ℓ e} {D : Category o′ ℓ e} {L : Functor C D} {R : Functor D C} where
  private
    module C = Category C
    module D = Category D
    module L = Functor L
    module R = Functor R

  module _ (adjoint : L ⊣ R) where
    open Adjoint adjoint

    -- in this case, the hom functors are naturally isomorphism directly
    Hom-NI′ : NaturalIsomorphism Hom[L-,-] Hom[-,R-]
    Hom-NI′ = record
      { F⇒G = ntHelper record
        { η       = λ _ → Hom-inverse.to
        ; commute = λ _ eq → Ladjunct-comm eq
        }
      ; F⇐G = ntHelper record
        { η       = λ _ → Hom-inverse.from
        ; commute = λ _ eq → Radjunct-comm eq
        }
      ; iso = λ _ → record
        { isoˡ = λ eq → let open D.HomReasoning in RLadjunct≈id ○ eq
        ; isoʳ = λ eq → let open C.HomReasoning in LRadjunct≈id ○ eq
        }
      }

  -- now goes from natural isomorphism back to adjoint.
  -- for simplicity, just construct the case in which homsetoids of C and D
  -- are compatible.

  private
    Hom[L-,-] : Bifunctor C.op D (Setoids _ _)
    Hom[L-,-] = Hom[ D ][-,-] ∘F (L.op ⁂ idF)

    Hom[-,R-] : Bifunctor C.op D (Setoids _ _)
    Hom[-,R-] = Hom[ C ][-,-] ∘F (idF ⁂ R)

  module _ (Hni : NaturalIsomorphism Hom[L-,-] Hom[-,R-]) where
    open NaturalIsomorphism Hni
    open NaturalTransformation
    open Functor
    open Π

    private
      unitη : ∀ X → F₀ Hom[L-,-] (X , L.F₀ X) ⟶ F₀ Hom[-,R-] (X , L.F₀ X)
      unitη X = ⇒.η (X , L.F₀ X)

      unit : NaturalTransformation idF (R ∘F L)
      unit = ntHelper record
        { η       = λ X → unitη X ⟨$⟩ D.id
        ; commute = λ {X} {Y} f → begin
          (unitη Y ⟨$⟩ D.id) ∘ f                             ≈⟨ introˡ R.identity ⟩
          R.F₁ D.id ∘ (unitη Y  ⟨$⟩ D.id) ∘ f                ≈˘⟨ ⇒.commute (f , D.id) D.Equiv.refl ⟩
          ⇒.η (X , L.F₀ Y) ⟨$⟩ (D.id D.∘ D.id D.∘ L.F₁ f)    ≈⟨ cong (⇒.η (X , L.F₀ Y)) (D.Equiv.trans D.identityˡ D.identityˡ) ⟩
          ⇒.η (X , L.F₀ Y) ⟨$⟩ L.F₁ f                        ≈⟨ cong (⇒.η (X , L.F₀ Y)) (MR.introʳ D (MR.elimʳ D L.identity)) ⟩
          ⇒.η (X , L.F₀ Y) ⟨$⟩ (L.F₁ f D.∘ D.id D.∘ L.F₁ id) ≈⟨ ⇒.commute (C.id , L.F₁ f) D.Equiv.refl ⟩
          R.F₁ (L.F₁ f) ∘ (unitη X ⟨$⟩ D.id) ∘ id            ≈⟨ refl⟩∘⟨ identityʳ ⟩
          R.F₁ (L.F₁ f) ∘ (unitη X ⟨$⟩ D.id)                 ∎
        }
        where open C
              open HomReasoning
              open MR C

      counitη : ∀ X → F₀ Hom[-,R-] (R.F₀ X , X) ⟶ F₀ Hom[L-,-] (R.F₀ X , X)
      counitη X = ⇐.η (R.F₀ X , X)

      counit : NaturalTransformation (L ∘F R) idF
      counit = ntHelper record
        { η       = λ X → counitη X ⟨$⟩ C.id
        ; commute = λ {X} {Y} f → begin
          (counitη Y ⟨$⟩ C.id) ∘ L.F₁ (R.F₁ f)               ≈˘⟨ identityˡ ⟩
          id ∘ (counitη Y ⟨$⟩ C.id) ∘ L.F₁ (R.F₁ f)          ≈˘⟨ ⇐.commute (R.F₁ f , D.id) C.Equiv.refl ⟩
          ⇐.η (R.F₀ X , Y) ⟨$⟩ (R.F₁ id C.∘ C.id C.∘ R.F₁ f) ≈⟨ cong (⇐.η (R.F₀ X , Y)) (C.Equiv.trans (MR.elimˡ C R.identity) C.identityˡ) ⟩
          ⇐.η (R.F₀ X , Y) ⟨$⟩ R.F₁ f                        ≈⟨ cong (⇐.η (R.F₀ X , Y)) (MR.introʳ C C.identityˡ) ⟩
          ⇐.η (R.F₀ X , Y) ⟨$⟩ (R.F₁ f C.∘ C.id C.∘ C.id)    ≈⟨ ⇐.commute (C.id , f) C.Equiv.refl ⟩
          f ∘ (counitη X ⟨$⟩ C.id) ∘ L.F₁ C.id               ≈⟨ refl⟩∘⟨ elimʳ L.identity ⟩
          f ∘ (counitη X ⟨$⟩ C.id)                           ∎
        }
        where open D
              open HomReasoning
              open MR D

    Hom-NI⇒Adjoint : L ⊣ R
    Hom-NI⇒Adjoint = record
      { unit   = unit
      ; counit = counit
      ; zig    = λ {A} →
        let open D
            open HomReasoning
            open Equiv
            open MR D
        in begin
          η counit (L.F₀ A) ∘ L.F₁ (η unit A)      ≈˘⟨ identityˡ ⟩
          id ∘ η counit (L.F₀ A) ∘ L.F₁ (η unit A) ≈˘⟨ ⇐.commute (η unit A , id) C.Equiv.refl ⟩
          ⇐.η (A , L.F₀ A) ⟨$⟩ (R.F₁ id C.∘ C.id C.∘ η unit A)
                                                   ≈⟨ cong (⇐.η (A , L.F₀ A)) (C.Equiv.trans (MR.elimˡ C R.identity) C.identityˡ) ⟩
          ⇐.η (A , L.F₀ A) ⟨$⟩ η unit A            ≈⟨ isoˡ refl ⟩
          id
                                                   ∎
      ; zag    = λ {B} →
        let open C
            open HomReasoning
            open Equiv
            open MR C
        in begin
          R.F₁ (η counit B) ∘ η unit (R.F₀ B)      ≈˘⟨ refl⟩∘⟨ identityʳ ⟩
          R.F₁ (η counit B) ∘ η unit (R.F₀ B) ∘ id ≈˘⟨ ⇒.commute (id , η counit B) D.Equiv.refl ⟩
          ⇒.η (R.F₀ B , B) ⟨$⟩ (η counit B D.∘ D.id D.∘ L.F₁ id)
                                                   ≈⟨ cong (⇒.η (R.F₀ B , B)) (MR.elimʳ D (MR.elimʳ D L.identity)) ⟩
          ⇒.η (R.F₀ B , B) ⟨$⟩ η counit B          ≈⟨ isoʳ refl ⟩
          id                                       ∎
      }
      where module i {X} = Iso (iso X)
            open i

-- the general case from isomorphic Hom setoids to adjoint functors
module _ {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {L : Functor C D} {R : Functor D C} where
  private
    module C = Category C
    module D = Category D
    module L = Functor L
    module R = Functor R
    open Functor
    open Π

    Hom[L-,-] : Bifunctor C.op D (Setoids _ _)
    Hom[L-,-] = LiftSetoids ℓ e ∘F Hom[ D ][-,-] ∘F (L.op ⁂ idF)

    Hom[-,R-] : Bifunctor C.op D (Setoids _ _)
    Hom[-,R-] = LiftSetoids ℓ′ e′ ∘F Hom[ C ][-,-] ∘F (idF ⁂ R)

  module _ (Hni : Hom[L-,-] ≃ Hom[-,R-]) where
    open NaturalIsomorphism Hni using (module ⇒; module ⇐; iso)
    private
      unitη : ∀ X → F₀ Hom[L-,-] (X , L.F₀ X) ⟶ F₀ Hom[-,R-] (X , L.F₀ X)
      unitη X = ⇒.η (X , L.F₀ X)

      unit : NaturalTransformation idF (R ∘F L)
      unit = ntHelper record
        { η       = λ X → lower (unitη X ⟨$⟩ lift D.id)
        ; commute = λ {X Y} f → begin
          lower (unitη Y ⟨$⟩ lift D.id) ∘ f
            ≈⟨ introˡ R.identity ⟩
          R.F₁ D.id ∘ lower (unitη Y ⟨$⟩ lift D.id) ∘ f
            ≈˘⟨ lower (⇒.commute (f , D.id) (lift D.Equiv.refl)) ⟩
          lower (⇒.η (X , L.F₀ Y) ⟨$⟩ lift (D.id D.∘ D.id D.∘ L.F₁ f))
            ≈⟨ lower (cong (⇒.η (X , L.F₀ Y)) (lift (D.Equiv.trans D.identityˡ D.identityˡ))) ⟩
          lower (⇒.η (X , L.F₀ Y) ⟨$⟩ lift (L.F₁ f))
            ≈⟨ lower (cong (⇒.η (X , L.F₀ Y)) (lift (MR.introʳ D (MR.elimʳ D L.identity)))) ⟩
          lower (⇒.η (X , L.F₀ Y) ⟨$⟩ lift (L.F₁ f D.∘ D.id D.∘ L.F₁ id))
            ≈⟨ lower (⇒.commute (C.id , L.F₁ f) (lift D.Equiv.refl)) ⟩
          R.F₁ (L.F₁ f) ∘ lower (⇒.η (X , L.F₀ X) ⟨$⟩ lift D.id) ∘ id
            ≈⟨ refl⟩∘⟨ identityʳ ⟩
          F₁ (R ∘F L) f ∘ lower (unitη X ⟨$⟩ lift D.id)                ∎
        }
        where open C
              open HomReasoning
              open MR C

      counitη : ∀ X → F₀ Hom[-,R-] (R.F₀ X , X) ⟶ F₀ Hom[L-,-] (R.F₀ X , X)
      counitη X = ⇐.η (R.F₀ X , X)

      counit : NaturalTransformation (L ∘F R) idF
      counit = ntHelper record
        { η       = λ X → lower (counitη X ⟨$⟩ lift C.id)
        ; commute = λ {X} {Y} f → begin
          lower (⇐.η (R.F₀ Y , Y) ⟨$⟩ lift C.id) ∘ L.F₁ (R.F₁ f)
            ≈˘⟨ identityˡ ⟩
          id ∘ lower (⇐.η (R.F₀ Y , Y) ⟨$⟩ lift C.id) ∘ L.F₁ (R.F₁ f)
            ≈˘⟨ lower (⇐.commute (R.F₁ f , D.id) (lift C.Equiv.refl)) ⟩
          lower (⇐.η (R.F₀ X , Y) ⟨$⟩ lift (R.F₁ id C.∘ C.id C.∘ R.F₁ f))
            ≈⟨ lower (cong (⇐.η (R.F₀ X , Y)) (lift (C.Equiv.trans (MR.elimˡ C R.identity) C.identityˡ))) ⟩
          lower (⇐.η (R.F₀ X , Y) ⟨$⟩ lift (R.F₁ f))
            ≈⟨ lower (cong (⇐.η (R.F₀ X , Y)) (lift (MR.introʳ C C.identityˡ))) ⟩
          lower (⇐.η (R.F₀ X , Y) ⟨$⟩ lift (R.F₁ f C.∘ C.id C.∘ C.id))
            ≈⟨ lower (⇐.commute (C.id , f) (lift C.Equiv.refl)) ⟩
          f ∘ lower (⇐.η (R.F₀ X , X) ⟨$⟩ lift C.id) ∘ L.F₁ C.id
            ≈⟨ refl⟩∘⟨ elimʳ L.identity ⟩
          f ∘ lower (⇐.η (R.F₀ X , X) ⟨$⟩ lift C.id)
            ∎
        }
        where open D
              open HomReasoning
              open MR D

    Hom-NI′⇒Adjoint : L ⊣ R
    Hom-NI′⇒Adjoint = record
      { unit   = unit
      ; counit = counit
      ; zig    = λ {A} →
        let open D
            open HomReasoning
            open Equiv
            open MR D
        in begin
          lower (counitη (L.F₀ A) ⟨$⟩ lift C.id) ∘ L.F₁ (η unit A)
            ≈˘⟨ identityˡ ⟩
          id ∘ lower (counitη (L.F₀ A) ⟨$⟩ lift C.id) ∘ L.F₁ (η unit A)
            ≈˘⟨ lower (⇐.commute (η unit A , id) (lift C.Equiv.refl)) ⟩
          lower (⇐.η (A , L.F₀ A) ⟨$⟩ lift (R.F₁ id C.∘ C.id C.∘ lower (⇒.η (A , L.F₀ A) ⟨$⟩ lift id)))
            ≈⟨ lower (cong (⇐.η (A , L.F₀ A)) (lift (C.Equiv.trans (MR.elimˡ C R.identity) C.identityˡ))) ⟩
          lower (⇐.η (A , L.F₀ A) ⟨$⟩ (⇒.η (A , L.F₀ A) ⟨$⟩ lift id))
            ≈⟨ lower (isoˡ (lift refl)) ⟩
          id ∎
      ; zag    = λ {B} →
        let open C
            open HomReasoning
            open Equiv
            open MR C
        in begin
          R.F₁ (lower (⇐.η (R.F₀ B , B) ⟨$⟩ lift id)) ∘ lower (⇒.η (R.F₀ B , L.F₀ (R.F₀ B)) ⟨$⟩ lift D.id)
            ≈˘⟨ refl⟩∘⟨ identityʳ ⟩
          R.F₁ (lower (⇐.η (R.F₀ B , B) ⟨$⟩ lift id)) ∘ lower (⇒.η (R.F₀ B , L.F₀ (R.F₀ B)) ⟨$⟩ lift D.id) ∘ id
            ≈˘⟨ lower (⇒.commute (id , η counit B) (lift D.Equiv.refl)) ⟩
          lower (⇒.η (R.F₀ B , B) ⟨$⟩ lift (lower (⇐.η (R.F₀ B , B) ⟨$⟩ lift id) D.∘ D.id D.∘ L.F₁ id))
            ≈⟨ lower (cong (⇒.η (R.F₀ B , B)) (lift (MR.elimʳ D (MR.elimʳ D L.identity)))) ⟩
          lower (⇒.η (R.F₀ B , B) ⟨$⟩ lift (lower (⇐.η (R.F₀ B , B) ⟨$⟩ lift id)))
            ≈⟨ lower (isoʳ (lift refl)) ⟩
          id ∎
      }
      where open NaturalTransformation
            module _ {X} where
              open Iso (iso X) public


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

module Cardinality.Finite.ManifestEnumerable.Isomorphism where

open import Prelude

import Cardinality.Finite.ManifestEnumerable.Container as ℒ
import Cardinality.Finite.ManifestEnumerable.Inductive as 𝕃

open import Container.List.Isomorphism
open import Data.Fin
open import HITs.PropositionalTruncation.Sugar
open import Data.List using (_∷_; [])
open import HITs.PropositionalTruncation
open import Cardinality.Finite.SplitEnumerable.Isomorphism
open import Data.Sigma.Properties

𝕃⇔ℒ⟨ℰ⟩ : 𝕃.ℰ A ⇔ ℒ.ℰ A
𝕃⇔ℒ⟨ℰ⟩ .fun (sup , cov) = 𝕃→ℒ sup , cov
𝕃⇔ℒ⟨ℰ⟩ .inv (sup , cov) = ℒ→𝕃 sup , λ x → ∈ℒ⇒∈𝕃 x sup ∥$∥ cov x
𝕃⇔ℒ⟨ℰ⟩ .rightInv (sup , cov) = ΣProp≡ (λ xs x y i t → squash (x t) (y t) i) (𝕃⇔ℒ .rightInv sup)
𝕃⇔ℒ⟨ℰ⟩ .leftInv  (sup , cov) = ΣProp≡ (λ xs x y i t → squash (x t) (y t) i) (𝕃⇔ℒ .leftInv sup)


module Playground where

-- Equality type, and its only constructor refl
data _==_ {A : Set} (x : A) : A → Set where
  refl : x == x

-- identity map of a type
id : {A : Set} → A → A
id x = x

-- action on paths
ap : {A B : Set} (f : A → B) {x y : A} → (x == y -> f x == f y)
ap f refl = refl

-- transport
transport : {A : Set} (B : A → Set) {x y : A} (p : x == y) → (B x → B y)
transport _ refl = id

-- Pi types
Π : (A : Set) (P : A → Set) → Set
Π A P = (x : A) → P x

-- Sigma types
record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst
open Σ public

-- empty type
data ⊥ : Set where

-- not operator
¬ : (A : Set) → Set
¬ A = A → ⊥


module Lib.Logic where

infix 30 _∨_
infix 40 _∧_
infix 50 ¬_

data _∨_ (A B : Set) : Set where
  inl : A -> A ∨ B
  inr : B -> A ∨ B

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

data   False : Set where
record True  : Set where

¬_ : Set -> Set
¬ A = A -> False


module Oscar.Data.Vec where

open import Data.Vec public
open import Oscar.Data.Nat
open import Oscar.Data.Equality

open import Data.Nat

map₂ : ∀ {a b} {A : Set a} {B : Set b} {m n}
           → ∀ {c} {C : Set c} (f : A → B → C)
           → Vec A m → Vec B n → Vec C (m * n)
map₂ f xs ys = map f xs ⊛* ys

open import Data.Fin

delete : ∀ {a n} {A : Set a} → Fin (suc n) → Vec A (suc n) → Vec A n
delete zero (x ∷ xs) = xs
delete {n = zero} (suc ()) _
delete {n = suc n} (suc i) (x ∷ xs) = x ∷ delete i xs

open import Function
open import Data.Product

tabulate⋆ : ∀ {n a} {A : Set a} → (F : Fin n → A) → ∃ λ (v : Vec A n) → ∀ (i : Fin n) → F i ∈ v
tabulate⋆ {zero} F = [] , (λ ())
tabulate⋆ {suc n} F = let v , t = tabulate⋆ (F ∘ suc) in F zero ∷ v , (λ { zero → here ; (suc i) → there (t i)})


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

open import LogicalFormulae
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.IntegralDomains.Definition
open import Rings.Definition

module Rings.Irreducibles.Lemmas {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} {R : Ring S _+_ _*_} (intDom : IntegralDomain R) where

open import Rings.Irreducibles.Definition intDom
open import Rings.Divisible.Definition R
open import Rings.Units.Definition R

open Setoid S
open Equivalence eq
open Ring R

dividesIrreducibleImpliesUnit : {r c : A} → Irreducible r → c ∣ r → (r ∣ c → False) → Unit c
dividesIrreducibleImpliesUnit {r} {c} irred (x , cx=r) notAssoc = Irreducible.irreducible irred x c (transitive *Commutative cx=r) nonunit
  where
    nonunit : Unit x → False
    nonunit (a , xa=1) = notAssoc (a , transitive (transitive (transitive (transitive (*WellDefined (symmetric cx=r) reflexive) (symmetric *Associative)) *Commutative) (*WellDefined xa=1 reflexive)) identIsIdent)


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

open import Functions.Definition
open import Groups.Definition
open import Groups.Homomorphisms.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Groups.Lemmas
open import Groups.QuotientGroup.Definition
open import Groups.Homomorphisms.Lemmas

module Groups.QuotientGroup.Lemmas {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+A_ : A → A → A} {_+B_ : B → B → B} (G : Group S _+A_) (H : Group T _+B_) {f : A → B} (fHom : GroupHom G H f) where

quotientGroupLemma : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} → {underf : A → B} → (f : GroupHom G H underf) → {x y : A} → Setoid._∼_ T (underf x) (underf y) → Setoid._∼_ (quotientGroupSetoid G f) x y
quotientGroupLemma {S = S} {T = T} G {H = H} fHom {x} {y} fx=fy = transitive (GroupHom.groupHom fHom) (transitive (Group.+WellDefined H (Equivalence.reflexive (Setoid.eq T)) (homRespectsInverse fHom)) (transferToRight'' H fx=fy))
  where
    open Group G
    open Setoid T
    open Equivalence eq

quotientGroupLemma' : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_·A_ : A → A → A} {_·B_ : B → B → B} (G : Group S _·A_) {H : Group T _·B_} → {underf : A → B} → (f : GroupHom G H underf) → {x y : A} → Setoid._∼_ (quotientGroupSetoid G f) x y → Setoid._∼_ T (underf x) (underf y)
quotientGroupLemma' {S = S} {T = T} G {H = H} f fx=fy = transferToRight H (transitive (transitive (Group.+WellDefined H (Equivalence.reflexive (Setoid.eq T)) (symmetric (homRespectsInverse f))) (symmetric (GroupHom.groupHom f))) fx=fy)
  where
    open Group G
    open Setoid T
    open Equivalence eq

projectionMapIsGroupHom : GroupHom G (quotientGroupByHom G fHom) id
GroupHom.groupHom projectionMapIsGroupHom {x} {y} = quotientGroupLemma G fHom (Equivalence.reflexive (Setoid.eq T))
GroupHom.wellDefined projectionMapIsGroupHom x=y = quotientGroupLemma G fHom (GroupHom.wellDefined fHom x=y)


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

test1 : Nat → Nat
test1 zero       = 0
test1 (suc zero) = 1
test1 (suc n)    = {!n!}

test2 : Nat → Nat → Nat
test2 zero zero    = zero
test2 zero (suc y) = y
test2 x    y       = {!x!}

test3 : Bool → Bool → Bool → Bool
test3 true  true  true  = true
test3 x     true  false = x
test3 false y     true  = y
test3 true  false z     = z
test3 x     y     z     = {!x y z!}


module Numeral.Finite where

import Lvl
open import Syntax.Number
open import Data.Boolean.Stmt
open import Functional
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural hiding (𝐏)
open import Type

-- A structure corresponding to a finite set of natural numbers (0,..,n−1).
-- Specifically an upper bounded set of natural numbers, and the boundary is strictly lesser than the parameter.
-- Positive integers including zero less than a specified integer (0≤_<n).
-- Or represented using a set: {(i∊ℕ). 0≤i<n}.
-- The structure works in the following way:
--   • 𝟎 can be constructed for any non-zero upper bound (n).
--   • 𝐒 can be constructed from only a smaller upper bounded 𝕟.
--       Example: A 𝕟 constructed through 𝐒{3} can only be the following:
--         0 ≡ 𝟎{3}
--         1 ≡ 𝐒{3} (𝟎{2})
--         2 ≡ 𝐒{3} (𝐒{2} (𝟎{1}))
--         3 ≡ 𝐒{3} (𝐒{2} (𝐒{1} (𝟎{0})))
--         because there is nothing that could fill the blank in (𝐒{3} (𝐒{2} (𝐒{1} (𝐒{0} (_))))).
--       The smallest upper bound that can be is 0 (from using ℕ and its definition).
--       This limits how many successors (𝐒) that can "fit".
data 𝕟 : ℕ → Type{Lvl.𝟎} where
  𝟎 : ∀{n} → 𝕟(ℕ.𝐒(n))        -- Zero
  𝐒 : ∀{n} → 𝕟(n) → 𝕟(ℕ.𝐒(n)) -- Successor function
{-# INJECTIVE 𝕟 #-}

𝕟₌ = 𝕟 ∘ 𝐒

bound : ∀{n} → 𝕟(n) → ℕ
bound{n} _ = n

minimum : ∀{n} → 𝕟(ℕ.𝐒(n))
minimum{_} = 𝟎

maximum : ∀{n} → 𝕟(ℕ.𝐒(n))
maximum{𝟎}    = 𝟎
maximum{𝐒(n)} = 𝐒(maximum{n})

𝕟-to-ℕ : ∀{n} → 𝕟(n) → ℕ
𝕟-to-ℕ {ℕ.𝟎}    ()
𝕟-to-ℕ {ℕ.𝐒(_)} (𝟎)    = ℕ.𝟎
𝕟-to-ℕ {ℕ.𝐒(_)} (𝐒(n)) = ℕ.𝐒(𝕟-to-ℕ (n))

ℕ-to-𝕟 : (x : ℕ) → ∀{n} → . ⦃ _ : IsTrue(x <? n) ⦄ → 𝕟(n)
ℕ-to-𝕟 (ℕ.𝟎)    {ℕ.𝟎}    ⦃ ⦄
ℕ-to-𝕟 (ℕ.𝐒(x)) {ℕ.𝟎}    ⦃ ⦄
ℕ-to-𝕟 (ℕ.𝟎)    {ℕ.𝐒(_)} ⦃ _ ⦄ = 𝟎
ℕ-to-𝕟 (ℕ.𝐒(x)) {ℕ.𝐒(n)} ⦃ p ⦄ = 𝐒(ℕ-to-𝕟 (x) {n} ⦃ p ⦄)

instance
  𝕟-from-ℕ : ∀{N} → Numeral(𝕟(N))
  Numeral.restriction-ℓ ( 𝕟-from-ℕ {N} ) = Lvl.𝟎
  Numeral.restriction ( 𝕟-from-ℕ {N} ) (n) = IsTrue(n <? N)
  num ⦃ 𝕟-from-ℕ {N} ⦄ (n) ⦃ proof ⦄ = ℕ-to-𝕟 (n) {N} ⦃ proof ⦄


-- Agda program using the Iowa Agda library

open import bool

module PROOF-sortPreservesLength
  (Choice : Set)
  (choose : Choice → 𝔹)
  (lchoice : Choice → Choice)
  (rchoice : Choice → Choice)
  where

open import eq
open import nat
open import list
open import maybe

---------------------------------------------------------------------------
-- Translated Curry operations:

insert : ℕ → 𝕃 ℕ → 𝕃 ℕ
insert x [] = x :: []
insert y (z :: u) = if y ≤ z then y :: (z :: u) else z :: (insert y u)

sort : 𝕃 ℕ → 𝕃 ℕ
sort [] = []
sort (x :: y) = insert x (sort y)

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

insertIncLength : (x : ℕ) → (xs : 𝕃 ℕ)
                → length (insert x xs) ≡ suc (length xs)
insertIncLength x [] = refl
insertIncLength x (y :: ys) with (x ≤ y)
... | tt = refl
... | ff rewrite insertIncLength x ys = refl

sortPreservesLength : (xs : 𝕃 ℕ) → length (sort xs) ≡ length xs
sortPreservesLength [] = refl
sortPreservesLength (x :: xs)
 rewrite insertIncLength x (sort xs) | sortPreservesLength xs = refl

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


-- Andreas, 2016-04-14 issue 1796 for rewrite

-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.size.solve:100 #-}
-- {-# OPTIONS -v tc.with.abstract:40 #-}

open import Common.Size
open import Common.Equality

data Either (A B : Set) : Set where
  left  : A → Either A B
  right : B → Either A B

either : {A B : Set} → Either A B →
  ∀{C : Set} → (A → C) → (B → C) → C
either (left a)  l r = l a
either (right b) l r = r b

data Nat : Size → Set where
  zero : ∀{i} → Nat (↑ i)
  suc  : ∀{i} → Nat i → Nat (↑ i)

primrec : ∀{ℓ} (C : Size → Set ℓ)
     → (z : ∀{i} → C i)
     → (s : ∀{i} → Nat i → C i → C (↑ i))
     → ∀{i} → Nat i → C i
primrec C z s zero    = z
primrec C z s (suc n) = s n (primrec C z s n)

case : ∀{i} → Nat i
     → ∀{ℓ} (C : Size → Set ℓ)
     → (z : ∀{i} → C i)
     → (s : ∀{i} → Nat i → C (↑ i))
     → C i
case n C z s = primrec C z (λ n r → s n) n

diff : ∀{i} → Nat i → ∀{j} → Nat j → Either (Nat i) (Nat j)
diff = primrec (λ i → ∀{j} → Nat j → Either (Nat i) (Nat j))
  -- case zero: the second number is bigger and the difference
  right
  -- case suc n:
  (λ{i} n r m  → case m (λ j → Either (Nat (↑ i)) (Nat j))
    -- subcase zero: the first number (suc n) is bigger and the difference
    (left (suc n))
    -- subcase suc m: recurse on (n,m)
     r)

gcd : ∀{i} → Nat i → ∀{j} → Nat j → Nat ∞
gcd zero m = m
gcd (suc n) zero = suc n
gcd (suc n) (suc m) = either (diff n m)
  (λ n' → gcd n' (suc m))
  (λ m' → gcd (suc n) m')

er : ∀{i} → Nat i → Nat ∞
er zero    = zero
er (suc n) = suc (er n)

diff-diag-erase : ∀{i} (n : Nat i) → diff (er n) (er n) ≡ right zero
diff-diag-erase zero    = refl
diff-diag-erase (suc n) = diff-diag-erase n

gcd-diag-erase : ∀{i} (n : Nat i) → gcd (er n) (er n) ≡ er n
gcd-diag-erase zero = refl
gcd-diag-erase (suc {i} n)
  rewrite diff-diag-erase n
          -- Before fix: diff-diag-erase {i} n.
          -- The {i} was necessary, otherwise rewrite failed
          -- because an unsolved size var prevented abstraction.
        | gcd-diag-erase n = refl


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

module Categories.Adjoint.Equivalence.Properties where

open import Level

open import Categories.Category
open import Categories.Adjoint.Equivalence
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism as ≃ using (_≃_; NaturalIsomorphism)

import Categories.Morphism.Reasoning as MR
import Categories.Category.Construction.Cones as Co
import Categories.Diagram.Limit as Lim

private
  variable
    o ℓ e : Level
    C D E : Category o ℓ e

-- diagrams are preserved by adjoint equivalence
--
-- if categories C and D are adjoint equivalent, then a limit from one determines one from another
module _  (⊣equiv : ⊣Equivalence C D) (F : Functor C E) where
  private
    module LF where
      open Co F public
      open Lim F public
    module C = Category C
    module D = Category D
    module E = Category E
    module F = Functor F
    module ⊣equiv = ⊣Equivalence ⊣equiv
    open ⊣equiv
    open E
    open MR E
    open HomReasoning
    open LF

    FR = F ∘F R

    module LFR where
      open Co FR public
      open Lim FR public

  module _ (Lm : Limit) where
    private
      module Lm = Lim.Limit Lm
      open Lm

      ⊤cone : LFR.Cone
      ⊤cone = record
        { N    = Lm.apex
        ; apex = record
          { ψ       = λ d → proj (R.₀ d)
          ; commute = λ f → limit-commute (R.₁ f)
          }
        }

      module _ {K : LFR.Cone} where
        private
          module K = LFR.Cone K

        K′ : Cone
        K′ = record
          { N    = K.N
          ; apex = record
            { ψ       = λ c → F.₁ (unit.⇐.η c) ∘ K.ψ (L.₀ c)
            ; commute = λ {X} {Y} f → begin
              F.₁ f ∘ F.₁ (unit.⇐.η X) ∘ K.ψ (L.₀ X)                         ≈˘⟨ pushˡ ([ F ]-resp-square (unit.⇐.commute f)) ⟩
              (F.₁ (unit.⇐.η Y) ∘ F.₁ (Functor.F₁ (R ∘F L) f)) ∘ K.ψ (L.₀ X) ≈⟨ pullʳ (K.commute (L.₁ f)) ⟩
              F.₁ (unit.⇐.η Y) ∘ K.ψ (L.₀ Y)                                 ∎
            }
          }

        !cone : LFR.Cones [ K , ⊤cone ]
        !cone = record
          { arr     = rep K′
          ; commute = λ {d} → begin
            proj (R.₀ d) ∘ rep K′                          ≈⟨ commute ⟩
            F.₁ (unit.⇐.η (R.₀ d)) ∘ K.ψ (L.₀ (R.₀ d))     ≈˘⟨ F.F-resp-≈ (MR.flip-fromʳ C unit.FX≅GX zag) ⟩∘⟨refl ⟩
            (F.₁ (R.₁ (counit.⇒.η d)) ∘ K.ψ (L.₀ (R.₀ d))) ≈⟨ K.commute (counit.⇒.η d) ⟩
            K.ψ d                                          ∎
          }

      module _ {K : LFR.Cone} (f : LFR.Cones [ K , ⊤cone ]) where
        private
          module K = LFR.Cone K
          module f = LFR.Cone⇒ f

        !cone-unique : LFR.Cones [ !cone ≈ f ]
        !cone-unique = begin
          rep (K′ {K}) ≈⟨ terminal.!-unique {K′ {K}} (record { arr = f.arr ; commute = eq }) ⟩
          f.arr        ∎
          where eq : ∀ {c} → proj c ∘ f.arr ≈ F.₁ (unit.⇐.η c) ∘ K.ψ (L.₀ c)
                eq {c} = begin
                  proj c ∘ f.arr                                ≈˘⟨ pullˡ (limit-commute (unit.⇐.η c)) ⟩
                  F.₁ (unit.⇐.η c) ∘ proj (R.₀ (L.₀ c)) ∘ f.arr ≈⟨ refl⟩∘⟨ f.commute ⟩
                  F.₁ (unit.⇐.η c) ∘ K.ψ (L.₀ c)                ∎

    ⊣equiv-preserves-diagram : Lim.Limit FR
    ⊣equiv-preserves-diagram = record
      { terminal = record
        { ⊤        = ⊤cone
        ; !        = !cone
        ; !-unique = !cone-unique
        }
      }


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Restriction.Instance.PartialFunctions where

-- The Category of partial functions is a restriction category

-- The proof is straightforward in the sense that it's all unwinding definitions,
-- but also no-trivial in that they need to be unwound with care (a lot of
-- case analyses with 'with' and inspect is used a lot).

open import Data.Maybe using (Maybe; map; just; nothing; _>>=_)
open import Data.Maybe.Properties
open import Function using (const)
open import Level using (Level)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; inspect; [_])

open import Categories.Category.Core using (Category)
open import Categories.Category.Instance.PartialFunctions using (PartialFunctions)
open import Categories.Category.Restriction using (Restriction)

private
  variable
    o : Level
    A B C : Set o

Restriction-PF : ∀ {o} → Restriction (PartialFunctions o)
Restriction-PF {o} = record
  { _↓ = λ f x → map (const x) (f x)
  ; pidʳ = pidʳ
  ; ↓-comm = λ {_} {_} {_} {g} {f} → ↓-comm {g = g} {f}
  ; ↓-denestʳ = λ {_} {_} {_} {f} {g} → ↓-denestʳ {f = f} {g}
  ; ↓-skew-comm = λ {_} {_} {_} {g} {f} → ↓-skew-comm {g = g} {f}
  ; ↓-cong = ↓-cong
  }
  where
    open Category (PartialFunctions o)
    _↓ : (A → Maybe B) → (A → Maybe A)
    _↓ = λ f x → map (const x) (f x)

    pidʳ : {f : A → Maybe B} → f ∘ f ↓ ≈ f
    pidʳ {f = f} x with f x | inspect f x
    ... | just z | [ eq ] = eq
    ... | nothing | _ = refl

    ↓-comm : {g : A → Maybe C} {f : A → Maybe B} → g ↓ ∘ f ↓ ≈ f ↓ ∘ g ↓
    ↓-comm {g = g} {f} x with f x | g x | inspect f x | inspect g x
    ... | just b | just b′  | [ fx=jb ] | [ gx=jb′ ] rewrite fx=jb | gx=jb′ = refl
    ... | just b | nothing  | _         | [ eq ]     rewrite eq = refl
    ... | nothing | just b′ | [ eq ]    | _          rewrite eq = refl
    ... | nothing | nothing | _         | _                     = refl

    ↓-denestʳ : {A B C : Obj} {f : A ⇒ B} {g : A ⇒ C} → (g ∘ f ↓) ↓ ≈ g ↓ ∘ f ↓
    ↓-denestʳ {f = f} a with f a
    ... | just b  = refl
    ... | nothing = refl

    ↓-skew-comm : {A B C : Obj} {g : A ⇒ B} {f : C ⇒ A} → g ↓ ∘ f ≈ f ∘ (g ∘ f) ↓
    ↓-skew-comm {g = g} {f = f} a with f a | inspect f a
    ... | just b | [ eq ] with g b
    ... | just c = sym eq
    ... | nothing = refl
    ↓-skew-comm _ | nothing | _ = refl

    ↓-cong : {A B : Obj} {f g : A ⇒ B} → f ≈ g → f ↓ ≈ g ↓
    ↓-cong eq a rewrite eq a = refl


module Structure.Operator.Field where

import      Lvl
open import Logic
open import Logic.Propositional
open import Structure.Setoid
open import Structure.Operator.Properties
open import Structure.Operator.Ring
open import Type

record Field {ℓ ℓₑ} {T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (_+_  : T → T → T) (_⋅_  : T → T → T) : Stmt{ℓ Lvl.⊔ ℓₑ} where
  field
    ⦃ divisionRing ⦄      : DivisionRing(_+_)(_⋅_)
    ⦃ [⋅]-commutativity ⦄ : Commutativity(_⋅_)

  open DivisionRing(divisionRing) public

  field
     -- Note: This excludes the trivial ring and is unprovable from the other field axioms, and models where this is true are always "trivial/singleton rings".
    ⦃ distinct-identities ⦄ : DistinctIdentities

record FieldObject {ℓ ℓₑ} : Stmt{Lvl.𝐒(ℓ Lvl.⊔ ℓₑ)} where
  constructor intro
  field
    {T} : Type{ℓ}
    ⦃ equiv ⦄ : Equiv{ℓₑ}(T)
    _+_ : T → T → T
    _⋅_ : T → T → T
    ⦃ structure ⦄ : Field(_+_)(_⋅_)
  open Field(structure) public


------------------------------------------------------------------------------
-- Agda-Prop Library.
-- Syntax definitions.
------------------------------------------------------------------------------

open import Data.Nat using ( ℕ )

module Data.PropFormula.Syntax ( n : ℕ ) where

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

open import Data.Bool
  renaming ( _∧_ to _&&_; _∨_ to _||_ )
  using    ( Bool; true; false; not )

open import Data.Fin  using ( Fin; #_ )
open import Data.List using ( List ; [] ; _∷_ ; _++_ ; [_] )
open import Relation.Binary.PropositionalEquality
  using ( _≡_; refl; cong; trans; sym; subst)

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

-- Proposition data type.

data PropFormula : Set where
  Var              : Fin n → PropFormula
  ⊤                : PropFormula
  ⊥                : PropFormula
  _∧_ _∨_ _⊃_ _⇔_  : (φ ψ : PropFormula) → PropFormula
  ¬_               : (φ : PropFormula)   → PropFormula

infix  11 ¬_
infixl 8 _∧_ _∨_
infixr 7 _⊃_ _⇔_

-- Context is a list (set) of hypotesis and axioms.

Ctxt : Set
Ctxt = List PropFormula

infixl 5 _,_
_,_ : Ctxt → PropFormula → Ctxt
Γ , φ = Γ ++ [ φ ]

∅ : Ctxt
∅ = []

infix 30 _⨆_
_⨆_ : Ctxt → Ctxt → Ctxt
Γ ⨆ Δ = Γ ++ Δ

infix 4 _∈_
data _∈_ (φ : PropFormula) : Ctxt → Set where
  here   : ∀ {Γ} → φ ∈ Γ , φ
  there  : ∀ {Γ} → (ψ : PropFormula) → φ ∈ Γ → φ ∈ Γ , ψ
  ⨆-ext  : ∀ {Γ} → (Δ : Ctxt) → φ ∈ Γ → φ ∈ Γ ⨆ Δ

_⊆_ : Ctxt → Ctxt → Set
Γ ⊆ Η = ∀ {φ} → φ ∈ Γ → φ ∈ Η

------------------------------------------------------------------------
-- Theorem data type.

infix 3 _⊢_

data _⊢_ : Ctxt → PropFormula → Set where

-- Hyp.

  assume   : ∀ {Γ} → (φ : PropFormula)      → Γ , φ ⊢ φ

  axiom    : ∀ {Γ} → (φ : PropFormula)      → φ ∈ Γ
                                            → Γ ⊢ φ

  weaken   : ∀ {Γ} {φ} → (ψ : PropFormula)  → Γ ⊢ φ
                                            → Γ , ψ ⊢ φ

  weaken₂   : ∀ {Γ} {φ} → (ψ : PropFormula) → Γ ⊢ φ
                                            → ψ ∷ Γ ⊢ φ
-- Top and Bottom.

  ⊤-intro  : ∀ {Γ}                          → Γ ⊢ ⊤

  ⊥-elim   : ∀ {Γ} → (φ : PropFormula)      → Γ ⊢ ⊥
                                            → Γ ⊢ φ
-- Negation.

  ¬-intro  : ∀ {Γ} {φ}                      → Γ , φ ⊢ ⊥
                                            → Γ ⊢ ¬ φ

  ¬-elim   : ∀ {Γ} {φ}                      → Γ ⊢ ¬ φ → Γ ⊢ φ
                                            → Γ ⊢ ⊥
-- Conjunction.

  ∧-intro  : ∀ {Γ} {φ ψ}                    → Γ ⊢ φ → Γ ⊢ ψ
                                            → Γ ⊢ φ ∧ ψ

  ∧-proj₁  : ∀ {Γ} {φ ψ}                    → Γ ⊢ φ ∧ ψ
                                            → Γ ⊢ φ

  ∧-proj₂  : ∀ {Γ} {φ ψ}                    → Γ ⊢ φ ∧ ψ
                                            → Γ ⊢ ψ
-- Disjunction.

  ∨-intro₁ : ∀ {Γ} {φ} → (ψ : PropFormula)  → Γ ⊢ φ
                                            → Γ ⊢ φ ∨ ψ

  ∨-intro₂ : ∀ {Γ} {ψ} → (φ : PropFormula)  → Γ ⊢ ψ
                                            → Γ ⊢ φ ∨ ψ

  ∨-elim  : ∀ {Γ} {φ ψ χ}                   → Γ , φ ⊢ χ
                                            → Γ , ψ ⊢ χ
                                            → Γ , φ ∨ ψ ⊢ χ
-- Implication.

  ⊃-intro  : ∀ {Γ} {φ ψ}                    → Γ , φ ⊢ ψ
                                            → Γ ⊢ φ ⊃ ψ

  ⊃-elim   : ∀ {Γ} {φ ψ}                    → Γ ⊢ φ ⊃ ψ → Γ ⊢ φ
                                            → Γ ⊢ ψ
-- Biconditional.

  ⇔-intro  : ∀ {Γ} {φ ψ}                    → Γ , φ ⊢ ψ
                                            → Γ , ψ ⊢ φ
                                            → Γ ⊢ φ ⇔ ψ

  ⇔-elim₁ : ∀ {Γ} {φ ψ}                     → Γ ⊢ φ → Γ ⊢ φ ⇔ ψ
                                            → Γ ⊢ ψ

  ⇔-elim₂ : ∀ {Γ} {φ ψ}                     → Γ ⊢ ψ → Γ ⊢ φ ⇔ ψ
                                            → Γ ⊢ φ
------------------------------------------------------------------------


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

{- This brief section introduces an alternative definition
   of n-connectedness defined purely using propositional truncation,
   in contrast to the standard one using n-truncations
   (The below observation has resulted in Exercise 7.6 of
   the HoTT book being modified accordingly).

   In detail, a type A is usually called n-connected if Trunc n A
   is contractible. Here, we show that n-connectedness of A can also
   be defined recursively as follows:
   * A is (-2)-connected,
   * A is (n+1)-connected iff A is merely inhabited and for all a₀, a₁ : A,
     the path space a₀ == a₁ is n-connected.

   This module is independent from the other files in this directory,
   using only the truncations with definitional computation from the library. -}
module Universe.Trunc.ConnectednessAlt where

open import lib.Basics
open import lib.NConnected
open import lib.NType2
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.TLevel
open import lib.types.Truncation
open import lib.types.Unit

open import Universe.Utility.General
open import Universe.Utility.TruncUniverse

-- Preliminary lemmata.
module _ where

  {- The structural lemma for the below equivalence of connectedness notions:
    Contractibility is equivalent to propositionality and mere inhabitation. -}
  contr-decompose : ∀ {i} {A : Type i} → is-contr A ≃ (Trunc ⟨-1⟩ A × is-prop A)
  contr-decompose {i} {A} = prop-equiv h k f g where
    h = is-contr-is-prop
    k = snd ((_ , Trunc-level) ×-≤ (_ , is-prop-is-prop))
    f = λ c → ([ fst c ] , contr-is-prop c)
    g = λ {(ta , s) → Trunc-rec h (flip inhab-prop-is-contr s) ta}

-- Everything here will happen in universe Type i.
module _ {i} where
  module _ {n : ℕ₋₂} where
    -- The dependent universal property over n-types.
    Trunc-dup : (A : Type i) (B : (ta : Trunc n A) → n -Type i)
              → Π (Trunc n A) (⟦_⟧ ∘ B) ≃ Π A (⟦_⟧ ∘ B ∘ [_])
    Trunc-dup A B = equiv
      (λ f → f ∘ [_]) (Trunc-elim (snd ∘ B)) (λ _ → idp)
      (λ f → λ= (Trunc-elim (snd ∘ (λ a → Path-≤ (B a) _ _)) (λ a → idp)))

    {- The truncation functor is applicative (here only a special case).
       Note the more elegant alternative of using the approach
       from TypeConstructors.agda with unicity of truncations. -}
    Trunc-×-equiv : {A B : Type i} → Trunc n (A × B) ≃ (Trunc n A × Trunc n B)
    Trunc-×-equiv {A} {B} = equiv f g f-g g-f where
      f = λ t → (Trunc-fmap fst t , Trunc-fmap snd t)
      g = λ {(ta , tb) → Trunc-rec Trunc-level
                  (λ a → Trunc-rec Trunc-level
                  (λ b → [ (a , b) ]) tb) ta}

      f-g = λ {(ta , tb) → Trunc-elim (λ ta → snd (T (ta , tb)))
                    (λ a → Trunc-elim (λ tb → snd (T ([ a ] , tb)))
                    (λ b → idp) tb) ta} where
        T : Trunc n A × Trunc n B → n -Type i
        T ts = Path-≤ ((_ , Trunc-level) ×-≤ (_ , Trunc-level)) (f (g ts)) ts

      g-f = Trunc-elim (λ _ → snd (Path-≤ (_ , Trunc-level) _ _)) (λ a → idp)

  {- The connectedness predicate from the library:
     is-connected : ℕ₋₂ → Type i → Type i
     is-connected n A = is-contr (Trunc n A) -}

  -- Our connectedness predicate defined using only propositional truncation.
  is-connected' : ℕ₋₂ → Type i → Type i
  is-connected' ⟨-2⟩  A = Lift ⊤
  is-connected' (S n) A = Trunc ⟨-1⟩ A × ((as : A × A) → is-connected' n (fst as == snd as))

  -- Both notions coincide.
  connected-equiv : (n : ℕ₋₂) (A : Type i) → is-connected n A ≃ is-connected' n A
  connected-equiv ⟨-2⟩  A = lift-equiv ⁻¹
                         ∘e contr-equiv-Unit (inhab-prop-is-contr Trunc-level is-contr-is-prop)

  connected-equiv (S n) A = equiv-Σ (fuse-Trunc A _ _) (λ _ → e) ∘e contr-decompose where
    e = is-prop (Trunc (S n) A)
      ≃⟨ curry-equiv ⁻¹ ⟩
        Π (Trunc (S n) A × Trunc (S n) A) (is-contr ∘ uncurry _==_)
      ≃⟨ equiv-Π-l _ (snd Trunc-×-equiv) ⁻¹ ⟩
        Π (Trunc (S n) (A × A)) (is-contr ∘ uncurry _==_ ∘ _)
      ≃⟨ Trunc-dup (A × A) (λ _ → (_ , raise-level-≤T (≤T-ap-S (-2≤T n)) is-contr-is-prop)) ⟩
        ((as : A × A) → is-contr ([ fst as ] == [ snd as ]))
      ≃⟨ equiv-Π-r (λ _ → equiv-level (Trunc=-equiv _ _)) ⟩
        Π (A × A) (is-connected n ∘ uncurry _==_)
      ≃⟨ equiv-Π-r (λ _ → connected-equiv n _) ⟩
        Π (A × A) (is-connected' n ∘ uncurry _==_)
      ≃∎


module Prelude where

open import Data.Nat
open import Data.Unit
open import Data.Product

_^_ : Set → ℕ → Set
A ^ zero = ⊤
-- A ^ 1 = A
A ^ suc n = A × (A ^ n)

ℜⁿ : {A B : Set} → (A → B → Set) → (n : ℕ) → (A ^ n → B ^ n → Set)
ℜⁿ r zero = λ tt tt → ⊤
ℜⁿ r (suc n) = λ { (a , aⁿ) (b , bⁿ) → r a b × (ℜⁿ r n) aⁿ bⁿ }

𝔉ⁿ : {A B : Set} → (A → B) → (n : ℕ) → (A ^ n → B ^ n)
𝔉ⁿ f zero = λ tt → tt
𝔉ⁿ f (suc n) = λ { (a , aⁿ) → f a , 𝔉ⁿ f n aⁿ }


module BTree.Equality.Properties {A : Set} where

open import BTree {A}
open import BTree.Equality {A}
open import Relation.Binary.Core

trans≃ : Transitive _≃_
trans≃ ≃lf ≃lf = ≃lf
trans≃ (≃nd x x' l≃r l≃l' l'≃r') (≃nd .x' x'' _ l'≃l'' l''≃r'') = ≃nd x x'' l≃r (trans≃ l≃l' l'≃l'')  l''≃r''

symm≃ : Symmetric _≃_
symm≃ ≃lf = ≃lf
symm≃ (≃nd x x' l≃r l≃l' l'≃r') = ≃nd x' x l'≃r' (symm≃ l≃l') l≃r


module NonEmptyList where

infixr 5 _∷_

open import Data.Nat

data NList (A : Set) : Set where
  [_] : A → NList A
  _∷_ : A → NList A → NList A

map : {A B : Set} → (f : A → B) → NList A → NList B
map f [ x ] = [ f x ]
map f (x ∷ l) = f x ∷ map f l

length : ∀ {A} → NList A → ℕ
length [ _ ] = 1
length (_ ∷ l) = suc (length l)


open import Data.Unit
open import Data.Product
open import Relation.Binary.PropositionalEquality
module Spire.Examples.ComputationalDesc where

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

data Desc (I : Set) : Set₁ where
  `⊤ : Desc I
  `X : (i : I) → Desc I
  `Σ `Π : (A : Set) (B : A → Desc I) → Desc I

El : (I : Set) (D : Desc I) (X : I → Set) → Set
El I `⊤ X = ⊤
El I (`X i) X = X i
El I (`Σ A B) X = Σ A (λ a → El I (B a) X)
El I (`Π A B) X = (a : A) → El I (B a) X

data μ (I : Set) (R : I → Desc I) (i : I) : Set where
  con : El I (R i) (μ I R) → μ I R i

All : (I : Set) (X : I → Set) (D : Desc I) (xs : El I D X) (P : (i : I) → X i → Set) → Set
All I X `⊤ tt P = ⊤
All I X (`X i) x P = P i x
All I X (`Σ A B) (a , b) P = All I X (B a) b P
All I X (`Π A B) f P = (a : A) → All I X (B a) (f a) P

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

ind :
  (I : Set)
  (R : I → Desc I)
  (P : (i : I) → μ I R i → Set)
  (pcon : (i : I) (xs : El I (R i) (μ I R)) → All I (μ I R) (R i) xs P → P i (con xs))
  (i : I)
  (x : μ I R i)
  → P i x

hyps :
  (I : Set)
  (R : I → Desc I)
  (P : (i : I) → μ I R i → Set)
  (pcon : (i : I) (xs : El I (R i) (μ I R)) → All I (μ I R) (R i) xs P → P i (con xs))
  (D : Desc I)
  (xs : El I D (μ I R))
  → All I (μ I R) D xs P

ind I R P pcon i (con xs) = pcon i xs (hyps I R P pcon (R i) xs)

hyps I R P pcon `⊤ tt = tt
hyps I R P pcon (`X i) xs = ind I R P pcon i xs
hyps I R P pcon (`Σ A B) (a , b) = hyps I R P pcon (B a) b
hyps I R P pcon (`Π A B) f = λ a → hyps I R P pcon (B a) (f a)

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

data ℕT : Set where `zero `suc : ℕT
data VecT : Set where `nil `cons : VecT

ℕD : ⊤ → Desc ⊤
ℕD tt = `Σ ℕT λ
  { `zero → `⊤
  ; `suc → `X tt
  }

ℕ : ⊤ → Set
ℕ = μ ⊤ ℕD

-- zero : ℕ tt
pattern zero = con (`zero , tt)

-- suc : ℕ tt → ℕ tt
pattern suc n = con (`suc , n)

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

VecD : (A : Set) (n : ℕ tt) → Desc (ℕ tt)
VecD A zero = `⊤
VecD A (suc n) = `Σ A λ _ → `X n

Vec : (A : Set) (n : ℕ tt) → Set
Vec A n = μ (ℕ tt) (VecD A) n

nil : (A : Set) → Vec A zero
nil A = con tt

cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons A n x xs = con (x , xs)

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

add : ℕ tt → ℕ tt → ℕ tt
add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
  (λ
    { tt (`zero , tt) tt n → n
    ; tt (`suc , m) ih n → suc (ih n)
    }
  )
  tt

mult : ℕ tt → ℕ tt → ℕ tt
mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
  (λ
    { tt (`zero , tt) tt n → zero
    ; tt (`suc , m) ih n → add n (ih n)
    }
  )
  tt

append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
  (λ
    { zero tt tt n ys → ys
    ; (suc m) (x , xs) ih n ys → cons A (add m n) x (ih n ys)
    }
  )

concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
  (λ
    { zero tt tt → nil A
    ; (suc n) (xs , xss) ih → append A m xs (mult n m) ih
    }
  )

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


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

open import Data.Product
open import Function
open import Level
open import Relation.Binary
open import Relation.Binary.Construct.Composition
open import Relation.Binary.PropositionalEquality

open import Categories.Category.Core

-- the category whose objects are sets and whose morphisms are binary relations.
Rels : ∀ o ℓ → Category (suc o) (suc (o ⊔ ℓ)) (o ⊔ ℓ)
Rels o ℓ = record
  { Obj = Set o
  ; _⇒_ = λ A B → REL A B (o ⊔ ℓ)
  ; _≈_ = λ _L_ _R_ → ∀ x y → (x L y → x R y) × (x R y → x L y)
  ; id = λ x y → Lift ℓ (x ≡ y)
  ; _∘_ = λ L R → R ; L
  ; assoc = λ x y →
    (λ { (b , fxb , c , gbc , hcy) → c , (b , fxb , gbc) , hcy }) ,
    (λ { (c , (b , fxb , gbc) , hcy) → b , fxb , c , gbc , hcy })
  ; sym-assoc = λ x y →
    (λ { (c , (b , fxb , gbc) , hcy) → b , fxb , c , gbc , hcy }) ,
    (λ { (b , fxb , c , gbc , hcy) → c , (b , fxb , gbc) , hcy })
  ; identityˡ = λ x y → (λ { (.y , fxy , lift refl) → fxy }) , λ fxy → y , fxy , lift refl
  ; identityʳ = λ x y → (λ { (.x , lift refl , fxy) → fxy }) , λ fxy → x , lift refl , fxy
  ; identity² = λ x y →
    (λ { (_ , lift refl , lift refl) → lift refl }) ,
    (λ { (lift refl) → _ , lift refl , lift refl })
  ; equiv = record
    { refl = λ _ _ → id , id
    ; sym = λ p x y → swap (p x y)
    ; trans = λ p q x y → zip (flip _∘′_) _∘′_ (p x y) (q x y)
    }
  ; ∘-resp-≈ = λ p q x y →
    (λ { (b , gxb , fby) → b , proj₁ (q x b) gxb , proj₁ (p b y) fby }) ,
    (λ { (b , ixb , hby) → b , proj₂ (q x b) ixb , proj₂ (p b y) hby })
  }


module reverse-involution where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; cong)
open Eq.≡-Reasoning
open import lists using (List; []; _∷_; [_]; _++_; reverse)
open import reverse-++-distrib using (reverse-++-distrib)

-- reverseが対合(involution)である事の証明
reverse-involution : {A : Set} → (xs : List A)
  → reverse (reverse xs) ≡ xs
reverse-involution [] =
  begin
    reverse (reverse [])
  ≡⟨⟩
    reverse []
  ≡⟨⟩
    []
  ∎
reverse-involution (x ∷ xs) =
  begin
    reverse (reverse (x ∷ xs))
  ≡⟨⟩
    reverse ((reverse xs) ++ [ x ])
  ≡⟨ reverse-++-distrib (reverse xs) [ x ] ⟩
    (reverse [ x ]) ++ (reverse (reverse xs))
  ≡⟨⟩
    [ x ] ++ reverse (reverse xs)
  ≡⟨ cong (x ∷_) (reverse-involution xs) ⟩
    x ∷ xs
  ∎


module OList {A : Set}(_≤_ : A → A → Set) where

open import Data.List
open import Bound.Lower A
open import Bound.Lower.Order _≤_

data OList : Bound → Set where
  onil : {b : Bound}
                   → OList b
  :< : {b : Bound}{x : A}
                   → LeB b (val x)
                   → OList (val x)
                   → OList b

forget : {b : Bound} → OList b → List A
forget onil = []
forget ( :< {x = x} _  xs) = x ∷ forget xs


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

open import LogicalFormulae
open import Groups.Abelian.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Rings.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.EuclideanAlgorithm
open import Numbers.Primes.PrimeNumbers

module Rings.Lemmas {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} (R : Ring S _+_ _*_) where

abstract

  open Setoid S
  open Ring R
  open Group additiveGroup

  ringMinusExtracts : {x y : A} → (x * Group.inverse (Ring.additiveGroup R) y) ∼ (Group.inverse (Ring.additiveGroup R) (x * y))
  ringMinusExtracts {x = x} {y} = transferToRight' additiveGroup (transitive (symmetric *DistributesOver+) (transitive (*WellDefined reflexive invLeft) (Ring.timesZero R)))
    where
      open Equivalence eq

  ringMinusExtracts' : {x y : A} → ((inverse x) * y) ∼ inverse (x * y)
  ringMinusExtracts' {x = x} {y} = transitive *Commutative (transitive ringMinusExtracts (inverseWellDefined additiveGroup *Commutative))
    where
      open Equivalence eq

  twoNegativesTimes : {a b : A} → (inverse a) * (inverse b) ∼ a * b
  twoNegativesTimes {a} {b} = transitive (ringMinusExtracts) (transitive (inverseWellDefined additiveGroup ringMinusExtracts') (invTwice additiveGroup (a * b)))
    where
      open Equivalence eq

  groupLemmaMove0G : {a b : _} → {A : Set a} → {_·_ : A → A → A} → {S : Setoid {a} {b} A} → (G : Group S _·_) → {x : A} → (Setoid._∼_ S (Group.0G G) (Group.inverse G x)) → Setoid._∼_ S x (Group.0G G)
  groupLemmaMove0G {S = S} G {x} pr = transitive (symmetric (invInv G)) (transitive (symmetric p) (invIdent G))
    where
      open Equivalence (Setoid.eq S)
      p : Setoid._∼_ S (Group.inverse G (Group.0G G)) (Group.inverse G (Group.inverse G x))
      p = inverseWellDefined G pr

  groupLemmaMove0G' : {a b : _} → {A : Set a} → {_·_ : A → A → A} → {S : Setoid {a} {b} A} → (G : Group S _·_) → {x : A} → Setoid._∼_ S x (Group.0G G) → (Setoid._∼_ S (Group.0G G) (Group.inverse G x))
  groupLemmaMove0G' {S = S} G {x} pr = transferToRight' G (Equivalence.transitive (Setoid.eq S) (Group.identLeft G) pr)

  oneZeroImpliesAllZero : 0R ∼ 1R → {x : A} → x ∼ 0R
  oneZeroImpliesAllZero 0=1 = Equivalence.transitive eq (Equivalence.symmetric eq identIsIdent) (Equivalence.transitive eq (*WellDefined (Equivalence.symmetric eq 0=1) (Equivalence.reflexive eq)) (Equivalence.transitive eq *Commutative timesZero))

  lemm3 : (a b : A) → 0G ∼ (a + b) → 0G ∼ a → 0G ∼ b
  lemm3 a b pr1 pr2 with transferToRight' additiveGroup (Equivalence.symmetric eq pr1)
  ... | a=-b with Equivalence.transitive eq pr2 a=-b
  ... | 0=-b with inverseWellDefined additiveGroup 0=-b
  ... | -0=--b = Equivalence.transitive eq (Equivalence.symmetric eq (invIdent additiveGroup)) (Equivalence.transitive eq -0=--b (invTwice additiveGroup b))

  charNot2ImpliesNontrivial : ((1R + 1R) ∼ 0R → False) → (0R ∼ 1R) → False
  charNot2ImpliesNontrivial charNot2 0=1 = charNot2 (Equivalence.transitive eq (+WellDefined (Equivalence.symmetric eq 0=1) (Equivalence.symmetric eq 0=1)) identRight)

abelianUnderlyingGroup : AbelianGroup additiveGroup
abelianUnderlyingGroup = record { commutative = groupIsAbelian }