------------------------------------------------------------------------
-- An investigation of various ways to define the semantics of an
-- untyped λ-calculus and a virtual machine, and a discussion of
-- type soundness and compiler correctness
--
-- Nils Anders Danielsson
------------------------------------------------------------------------

module Lambda where

-- Syntax and type system for an untyped λ-calculus.

import Lambda.Syntax

------------------------------------------------------------------------
-- Semantics based on substitutions

-- Substitutions.

import Lambda.Substitution

-- A big-step semantics for the language. Conditional coinduction is
-- used to avoid duplication of rules.
--
-- Cousot and Cousot give a similar definition in "Bi-inductive
-- structural semantics", and their definition inspired this one.
-- Their definition has almost the same rules, but these rules are
-- interpreted in the framework of bi-induction rather than the
-- framework of mixed induction and (conditional) coinduction.

import Lambda.Substitution.OneSemantics

-- Two separate semantics for the language, one for converging terms
-- and the other for diverging terms, as given by Leroy and Grall in
-- "Coinductive big-step operational semantics".
--
-- Leroy and Grall attempted to unify their two semantics into a
-- single one, using only coinduction, but failed to find a definition
-- which was equivalent to the two that they started with. However,
-- they aimed for a definition which did not have more rules than the
-- definition for converging terms; the definition in OneSemantics
-- does not satisfy this criterion.

import Lambda.Substitution.TwoSemantics

-- The two definitions are equivalent.

import Lambda.Substitution.Equivalence

-- A functional semantics, along with a type soundness proof.

import Lambda.Substitution.Functional

------------------------------------------------------------------------
-- Virtual machine

-- A virtual machine with two semantics (one relational and one
-- functional), a compiler from the λ-calculus defined above into the
-- language of the virtual machine, and a proof showing that the two
-- semantics are equivalent.

import Lambda.VirtualMachine

------------------------------------------------------------------------
-- Semantics based on closures

-- A semantics for the untyped λ-calculus, based on closures and
-- environments, as given by Leroy and Grall in "Coinductive big-step
-- operational semantics" (more or less).
--
-- The module also contains a proof which shows that the compiler in
-- Lambda.VirtualMachine preserves the semantics (assuming that the
-- virtual machine is deterministic). Leroy and Grall prove almost the
-- same thing. In their proof they use a relation indexed by a natural
-- number to work around limitations in Coq's productivity checker.
-- Agda has similar limitations, but I work around them using mixed
-- induction/coinduction, which in my opinion is more elegant. I am
-- not sure if my workaround would work in Coq, though.

import Lambda.Closure.Relational

-- A semantics for the untyped λ-calculus which uses the partiality
-- monad, along with another compiler correctness proof. An advantage
-- of formulating the semantics in this way is that it is very easy to
-- state compiler correctness.

import Lambda.Closure.Functional

-- The module above uses some workarounds in order to convince Agda
-- that the code is productive. The following module contains (more or
-- less) the same code without the workarounds, but is checked with
-- the termination checker turned off.

import Lambda.Closure.Functional.No-workarounds

-- The relational and functional semantics are equivalent.

import Lambda.Closure.Equivalence

-- An alternative definition of the functional semantics. This
-- definition uses continuation-passing style instead of bind.

import Lambda.Closure.Functional.Alternative

-- A definition of a type system (with recursive types) for the
-- λ-calculus given above, and a proof of type soundness for the
-- functional semantics.

import Lambda.Closure.Functional.Type-soundness

-- A very brief treatment of different kinds of term equivalences,
-- including contextual equivalence and applicative bisimilarity.

import Lambda.Closure.Equivalences

-- A functional semantics, a compiler and a compiler correctness
-- proof, and a type soundness proof for a non-deterministic untyped
-- λ-calculus with constants.

import Lambda.Closure.Functional.Non-deterministic

-- A variant of the code above without the workarounds used to
-- convince Agda that the code is productive.

import Lambda.Closure.Functional.Non-deterministic.No-workarounds


module Function.Domains where

import      Lvl
open import Structure.Setoid
open import Type

private variable ℓₒ₁ ℓₒ₂ ℓₑ₁ ℓₑ₂ : Lvl.Level

module _ {X : Type{ℓₒ₁}} {Y : Type{ℓₒ₂}} where
  -- The partial domain of a function
  -- Note: This is the same as the domain because all functions are total (or at least supposed to be)
  ⊷ : (X → Y) → Type{ℓₒ₁}
  ⊷ _ = X

module _ {X : Type{ℓₒ₁}} {Y : Type{ℓₒ₂}} where
  -- ∃(Unapply f(y)) is also called "the fiber of the element y under the map f".
  -- Unapply(f) is similar to the inverse image or the preimage of f when their argument is a singleton set.
  Fiber : ⦃ equiv-Y : Equiv{ℓₑ₂}(Y) ⦄ → (X → Y) → Y → X → Type
  Fiber f(y) x = (f(x) ≡ y)


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

{-
  Favonia:  I was trying to generalize OneSkeleton but failed
  to achieve what I wanted.  Nicolai then told me this HIT
  which is suitable for the constancy lemma I was looking for.
  This construction should be attributed to Paolo Capriotti
  and Nicolai Kraus. [1]

  [1] Eliminating Higher Truncations via Constancy
      by Paolo Capriotti and Nicolai Kraus
      (in preparation/work in progress)
-}

open import HoTT

module experimental.TwoConstancyHIT where

module _ where
  private
    data #TwoConstancy-aux {i} (A : Type i) : Type i where
      #point : A → #TwoConstancy-aux A

    data #TwoConstancy {i} (A : Type i) : Type i where
      #two-constancy : #TwoConstancy-aux A → (Unit → Unit) → #TwoConstancy A

  TwoConstancy : ∀ {i} → Type i → Type i
  TwoConstancy = #TwoConstancy

  module _ {i} {A : Type i} where

    point : A → TwoConstancy A
    point a = #two-constancy (#point a) _

    postulate  -- HIT
      link₀ : ∀ a₁ a₂ → point a₁ == point a₂

      link₁ : ∀ a₁ a₂ a₃ → link₀ a₁ a₂ ∙' link₀ a₂ a₃ == link₀ a₁ a₃

      TwoConstancy-level : is-gpd (TwoConstancy A)

    module TwoConstancyElim
      {l} {P : TwoConstancy A → Type l}
      (p : ∀ x → is-gpd (P x))
      (point* : ∀ a → P (point a))
      (link₀* : ∀ a₁ a₂ → point* a₁ == point* a₂ [ P ↓ link₀ a₁ a₂ ])
      (link₁* : ∀ a₁ a₂ a₃
        →  link₀* a₁ a₂ ∙'ᵈ link₀* a₂ a₃
        == link₀* a₁ a₃
        [ (λ p → point* a₁ == point* a₃ [ P ↓ p ]) ↓ link₁ a₁ a₂ a₃ ]) where

      f : Π (TwoConstancy A) P
      f = f-aux phantom phantom phantom where

        f-aux : Phantom p → Phantom link₀* → Phantom link₁* → Π (TwoConstancy A) P
        f-aux phantom phantom phantom (#two-constancy (#point a) _) = point* a

      postulate  -- HIT
        link₀-β : ∀ a₁ a₂ → apd f (link₀ a₁ a₂) == link₀* a₁ a₂

      private
        lemma : ∀ a₁ a₂ a₃
              → apd f (link₀ a₁ a₂ ∙' link₀ a₂ a₃)
             == link₀* a₁ a₂ ∙'ᵈ link₀* a₂ a₃
        lemma a₁ a₂ a₃ =
          apd f (link₀ a₁ a₂ ∙' link₀ a₂ a₃)
            =⟨ apd-∙' f (link₀ a₁ a₂) (link₀ a₂ a₃) ⟩
          apd f (link₀ a₁ a₂) ∙'ᵈ apd f (link₀ a₂ a₃)
            =⟨ link₀-β a₁ a₂ |in-ctx (λ u → u ∙'ᵈ apd f (link₀ a₂ a₃)) ⟩
          link₀* a₁ a₂ ∙'ᵈ apd f (link₀ a₂ a₃)
            =⟨ link₀-β a₂ a₃ |in-ctx (λ u → link₀* a₁ a₂ ∙'ᵈ u) ⟩
          link₀* a₁ a₂ ∙'ᵈ link₀* a₂ a₃
            ∎

      postulate  -- HIT
        link₁-β : ∀ a₁ a₂ a₃
                → apd (apd f) (link₁ a₁ a₂ a₃)
               == lemma a₁ a₂ a₃ ◃ (link₁* a₁ a₂ a₃ ▹! link₀-β a₁ a₃)

open TwoConstancyElim public using () renaming (f to TwoConstancy-elim)

module TwoConstancyRec
  {i} {A : Type i}
  {l} {P : Type l}
  (p : is-gpd P)
  (point* : ∀ a → P)
  (link₀* : ∀ a₁ a₂ → point* a₁ == point* a₂)
  (link₁* : ∀ a₁ a₂ a₃
            → link₀* a₁ a₂ ∙' link₀* a₂ a₃
           == link₀* a₁ a₃) where

  private
    module M = TwoConstancyElim {A = A}
      {l = l} {P = λ _ → P}
      (λ _ → p)
      point*
      (λ a₁ a₂ → ↓-cst-in (link₀* a₁ a₂))
      (λ a₁ a₂ a₃
        → ↓-cst-in-∙' (link₀ a₁ a₂) (link₀ a₂ a₃) (link₀* a₁ a₂) (link₀* a₂ a₃)
       !◃ ↓-cst-in2 (link₁* a₁ a₂ a₃))

  f : TwoConstancy A → P
  f = M.f

  link₀-β : ∀ a₁ a₂ → ap f (link₀ a₁ a₂) == link₀* a₁ a₂
  link₀-β a₁ a₂ = apd=cst-in {f = f} $ M.link₀-β a₁ a₂

  private
    lemma : ∀ a₁ a₂ a₃
          → ap f (link₀ a₁ a₂ ∙' link₀ a₂ a₃)
         == link₀* a₁ a₂ ∙' link₀* a₂ a₃
    lemma a₁ a₂ a₃ =
      ap f (link₀ a₁ a₂ ∙' link₀ a₂ a₃)
        =⟨ ap-∙' f (link₀ a₁ a₂) (link₀ a₂ a₃) ⟩
      ap f (link₀ a₁ a₂) ∙' ap f (link₀ a₂ a₃)
        =⟨ link₀-β a₁ a₂ |in-ctx (λ u → u ∙' ap f (link₀ a₂ a₃)) ⟩
      link₀* a₁ a₂ ∙' ap f (link₀ a₂ a₃)
        =⟨ link₀-β a₂ a₃ |in-ctx (λ u → link₀* a₁ a₂ ∙' u) ⟩
      link₀* a₁ a₂ ∙' link₀* a₂ a₃
        ∎

  -- I am a lazy person.
  postulate  -- HIT
    link₁-β : ∀ a₁ a₂ a₃
            → ap (ap f) (link₁ a₁ a₂ a₃)
           == (lemma a₁ a₂ a₃ ∙ link₁* a₁ a₂ a₃) ∙ (! $ link₀-β a₁ a₃)

open TwoConstancyRec public using () renaming (f to TwoConstancy-rec)


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

module Data.Pi.Base where

open import Level

Π : (A : Type a) (B : A → Type b) → Type _
Π A B = (x : A) → B x

∀′ : {A : Type a} (B : A → Type b) → Type _
∀′ {A = A} B = Π A B

infixr 4.5 ∀-syntax
∀-syntax : ∀ {a b} {A : Type a} (B : A → Type b) → Type (a ℓ⊔ b)
∀-syntax = ∀′

syntax ∀-syntax (λ x → e) = ∀[ x ] e

infixr 4.5 Π⦂-syntax
Π⦂-syntax : (A : Type a) (B : A → Type b) → Type (a ℓ⊔ b)
Π⦂-syntax = Π

syntax Π⦂-syntax t (λ x → e) = Π[ x ⦂ t ] e


open import Agda.Builtin.Bool
open import Agda.Builtin.List

data Singleton : List Bool → Set where
  singleton : ∀ b → Singleton (b ∷ [])

Works : (bs : List Bool) → Singleton bs → Set₁
Works bs s with s
... | singleton b with Set
Works .(b ∷ []) s | singleton b | _ = Set

Fails : (bs : List Bool) → Singleton bs → Set₁
Fails bs        s with singleton b ← s with Set
Fails .(b ∷ []) s | _ = Set


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Classical.Semantics.Satisfaction (𝔏 : Signature) {ℓₘ} where
open Signature(𝔏)

import      Lvl
open import Data
open import Data.Boolean
open import Data.Boolean.Stmt
open import Data.ListSized
import      Data.ListSized.Functions as List
open import Formalization.PredicateLogic.Classical.Semantics(𝔏){ℓₘ}
open import Formalization.PredicateLogic.Syntax(𝔏)
open import Functional using (_∘_ ; _∘₂_)
import      Logic.Propositional as Logic
import      Logic.Predicate     as Logic
open import Numeral.Finite
open import Numeral.Finite.Bound
open import Numeral.Natural
open import Relator.Equals
open import Sets.PredicateSet using (PredSet)
open        Sets.PredicateSet.BoundedQuantifiers
open import Syntax.Function
open import Type.Dependent renaming (intro to _,_)
open import Type.Properties.Decidable
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable P : Type{ℓₚ}
private variable args n vars : ℕ
private variable 𝔐 : Model

-- A `VarMapping(vars)(𝔐)` maps `vars` number of variables to objects in the domain of the model `𝔐`.
-- Also called: Variable assignment.
VarMapping : ℕ → Model → Type
VarMapping(vars)(𝔐) = 𝕟(vars) → Model.Domain(𝔐)
module VarMapping where
  -- Adds a mapping to an object in the domain of the model `𝔐`.
  add0 : VarMapping(vars)(𝔐) → Model.Domain(𝔐) → VarMapping(𝐒(vars))(𝔐)
  add0 𝔰 t 𝟎      = t
  add0 𝔰 t (𝐒(v)) = 𝔰(v)

private variable 𝔰 : VarMapping(vars)(𝔐)

module _ ((𝔐 , 𝔰) : Σ Model (VarMapping(vars))) where
  -- Maps terms to objects in the domain given a model and a variable mapping.
  val : Term(vars) → Model.Domain(𝔐)
  val₊ : List(Term(vars))(n) → List(Model.Domain(𝔐))(n)

  val(var v)    = 𝔰(v)
  val(func f x) = Model.function 𝔐 f (val₊ x)
  val₊ {0}       ∅       = ∅
  val₊ {𝐒(n)} (t ⊰ ts) = (val t ⊰ val₊ {n} ts)
  --val₊ = List.map val

-- Satisfication relation.
-- ((𝔐 , 𝔰) ⊧ φ) means that the formula φ is satisfied in the model 𝔐 with the variable mapping.
-- Or in other words: A formula is true in the model 𝔐.
_⊧_ : (Σ Model (VarMapping(vars))) → Formula(vars) → Type{ℓₘ}
(𝔐 , 𝔰) ⊧ (f $ x)  = Lvl.Up(IsTrue(Model.relation 𝔐 f (val₊(𝔐 , 𝔰) x)))  -- A model decides whether a relation is satisfied.
(𝔐 , 𝔰) ⊧ ⊤        = Unit                                                 -- All models satisfy top.
(𝔐 , 𝔰) ⊧ ⊥        = Empty                                                -- No model satisfies bottom.
(𝔐 , 𝔰) ⊧ (φ ∧ ψ)  = ((𝔐 , 𝔰) ⊧ φ) Logic.∧ ((𝔐 , 𝔰) ⊧ ψ)                  -- A model satisfies a conjunction when it satisfies both of the propositions.
(𝔐 , 𝔰) ⊧ (φ ∨ ψ)  = ((𝔐 , 𝔰) ⊧ φ) Logic.∨ ((𝔐 , 𝔰) ⊧ ψ)                  -- A model satisfies a disjunction when it satisfies any one of the propositions.
(𝔐 , 𝔰) ⊧ (φ ⟶ ψ)  = Logic.¬((𝔐 , 𝔰) ⊧ φ) Logic.∨ ((𝔐 , 𝔰) ⊧ ψ)
(𝔐 , 𝔰) ⊧ (Ɐ φ)    = Logic.∀ₗ(t ↦ (𝔐 , VarMapping.add0{𝔐 = 𝔐} 𝔰 t) ⊧ φ)
(𝔐 , 𝔰) ⊧ (∃ φ)    = Logic.∃(t ↦ (𝔐 , VarMapping.add0{𝔐 = 𝔐} 𝔰 t) ⊧ φ)

-- Satisfication of a set of formulas.
-- This means that a model satisfies all formulas at the same time.
_⊧₊_ : (Σ Model (VarMapping(vars))) → PredSet{ℓ}(Formula(vars)) → Type
𝔐 ⊧₊ Γ = ∀ₛ(Γ) (𝔐 ⊧_)

-- Validity of a formula.
-- A formula is valid when it is true independent of any model (is satisfied by all models).
-- Examples:
--   Valid(⊤)
--   Valid(⊥ ⟶ ⊥)
--   ¬ Valid(⊥)
--   ¬ Valid(P) where P : Prop(0)
Valid : Formula(vars) → Type
Valid(φ) = Logic.∀ₗ(_⊧ φ)

-- Satisfiability of sets of formulas.
-- A set of formulas is satisfiable when there is a model that satisfies all of them at the same time.
Satisfiable : PredSet{ℓ}(Formula(vars)) → Type
Satisfiable(Γ) = Logic.∃(_⊧₊ Γ)

-- Unsatisfiability of sets of formulas.
Unsatisfiable : PredSet{ℓ}(Formula(vars)) → Type
Unsatisfiable{ℓ} = Logic.¬_ ∘ Satisfiable{ℓ}

-- Semantic entailment of a formula.
-- A hypothetical statement. If a model would satisfy all formulas in Γ, then this same model satisifes the formula φ.
_⊨_ : PredSet{ℓ}(Formula(vars)) → Formula(vars) → Type
Γ ⊨ φ = ∀{𝔐} → (𝔐 ⊧₊ Γ) → (𝔐 ⊧ φ)

_⊭_ : PredSet{ℓ}(Formula(vars)) → Formula(vars) → Type
_⊭_ = (Logic.¬_) ∘₂ (_⊨_)

-- Axiomatization of a theory by a set of axioms.
-- A set of axioms is a set of formulas.
-- A theory is the closure of a set of axioms.
-- An axiomatization is a subset of formulas of the theory which entails all formulas in the axiomatized theory.
_axiomatizes_ : PredSet{ℓ₁}(Formula(vars)) → PredSet{ℓ₂}(Formula(vars)) → Type
Γ₁ axiomatizes Γ₂ = ∀{φ} → (Γ₁ ⊨ φ) → Γ₂(φ)

-- A set of formulas is closed when it includes all formulas that it entails.
Closed : PredSet{ℓ}(Formula(vars)) → Type
Closed(Γ) = Γ axiomatizes Γ

_⊨₊_ : PredSet{ℓ₁}(Formula(vars)) → PredSet{ℓ₂}(Formula(vars)) → Type
Γ₁ ⊨₊ Γ₂ = ∀{𝔐} → (𝔐 ⊧₊ Γ₁) → (𝔐 ⊧₊ Γ₂)

_⊭₊_ : PredSet{ℓ₁}(Formula(vars)) → PredSet{ℓ₂}(Formula(vars)) → Type
_⊭₊_ = (Logic.¬_) ∘₂ (_⊨₊_)


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

open import Cubical.Relation.Binary.Base
open import Cubical.Core.Everything

module Cubical.Relation.Binary.Structures
  {a ℓ} {A : Type a} -- The underlying type
  (_<>_ : Rel A ℓ)   -- The relation
  where

open import Cubical.Foundations.Prelude using (refl; sym; isSet)
open import Cubical.Foundations.Function using (_∘_; id)
open import Cubical.Foundations.Logic hiding (¬_)

open import Cubical.Relation.Nullary.Decidable
open import Cubical.Relation.Binary.Definitions
open import Cubical.Relation.Binary.Properties

open import Cubical.HITs.PropositionalTruncation

import Cubical.Relation.Binary.Raw.Structures [ _<>_ ] as Raw

private
  variable
    ℓ₂ : Level

------------------------------------------------------------------------
-- Preorders
------------------------------------------------------------------------

record IsPreorder : Type (ℓ-max a ℓ) where
  constructor ispreorder
  field
    reflexive  : Reflexive _<>_
    transitive : Transitive _<>_

  fromEq : FromEq _<>_
  fromEq = reflx→fromeq _<>_ reflexive

  raw : Raw.IsPreorder
  raw = record
    { reflexive = reflexive
    ; transitive = transitive
    }

------------------------------------------------------------------------
-- Equivalences
------------------------------------------------------------------------

record IsPartialEquivalence : Type (ℓ-max a ℓ) where
  constructor ispartialeq
  field
    symmetric  : Symmetric _<>_
    transitive : Transitive _<>_

  raw : Raw.IsPartialEquivalence
  raw = record
    { symmetric = symmetric
    ; transitive = transitive
    }

record IsEquivalence : Type (ℓ-max a ℓ) where
  constructor isequivalence
  field
    reflexive            : Reflexive _<>_
    isPartialEquivalence : IsPartialEquivalence

  open IsPartialEquivalence isPartialEquivalence public hiding (raw)

  from-≡ : FromEq _<>_
  from-≡ = reflx→fromeq _<>_ reflexive

  isPreorder : IsPreorder
  isPreorder = record
    { reflexive  = reflexive
    ; transitive = transitive
    }

  raw : Raw.IsEquivalence
  raw = record
    { reflexive = reflexive
    ; isPartialEquivalence = IsPartialEquivalence.raw isPartialEquivalence
    }

record IsDecEquivalence : Type (ℓ-max a ℓ) where
  constructor isdeceq
  infix 4 _≟_
  field
    isEquivalence : IsEquivalence
    _≟_           : Decidable _<>_

  open IsEquivalence isEquivalence public hiding (raw)

  raw : Raw.IsDecEquivalence
  raw = record
    { isEquivalence = IsEquivalence.raw isEquivalence
    ; _≟_ = _≟_
    }

------------------------------------------------------------------------
-- Partial orders
------------------------------------------------------------------------

record IsPartialOrder : Type (ℓ-max a ℓ) where
  constructor ispartialorder
  field
    isPreorder : IsPreorder
    antisym    : Antisymmetric _<>_

  open IsPreorder isPreorder public hiding (raw)

  raw : isSet A → Raw.IsPartialOrder
  raw isSetA = record
    { isPreorder = IsPreorder.raw isPreorder
    ; antisym = λ x y → rec (isSetA _ _) id (antisym x y)
    }

record IsDecPartialOrder : Type (ℓ-max a ℓ) where
  constructor isdecpartialorder
  infix 4 _≤?_
  field
    isPartialOrder : IsPartialOrder
    _≤?_           : Decidable _<>_

  open IsPartialOrder isPartialOrder public hiding (raw)

  private
    lemma : ∀ {x y} → ¬ ⟨ x <> y ⟩ → ¬ x ≡ y
    lemma x≰y x≡y = x≰y (fromEq ∣ x≡y ∣)

  raw : isSet A → Raw.IsDecPartialOrder
  raw isSetA = record
    { isPartialOrder = IsPartialOrder.raw isPartialOrder isSetA
    ; _≤?_ = _≤?_
    }

record IsStrictPartialOrder : Type (ℓ-max a ℓ) where
  constructor isstrictpartialorder
  field
    irrefl     : Irreflexive _<>_
    transitive : Transitive _<>_

  asym : Asymmetric _<>_
  asym {x} {y} = trans∧irr→asym _<>_ transitive irrefl

  raw : Raw.IsStrictPartialOrder
  raw = record
    { irrefl = irrefl
    ; transitive = transitive
    }

record IsDecStrictPartialOrder : Type (ℓ-max a ℓ) where
  constructor isdecstrictpartialorder
  infix 4 _<?_
  field
    isStrictPartialOrder : IsStrictPartialOrder
    _<?_                 : Decidable _<>_

  open IsStrictPartialOrder isStrictPartialOrder public hiding (raw)

  raw : isSet A → Raw.IsDecStrictPartialOrder
  raw isSetA = record
    { isStrictPartialOrder = IsStrictPartialOrder.raw isStrictPartialOrder
    ; _<?_ = _<?_
    }

------------------------------------------------------------------------
-- Total orders
------------------------------------------------------------------------

record IsTotalOrder : Type (ℓ-max a ℓ) where
  constructor istotalorder
  field
    isPartialOrder : IsPartialOrder
    total          : Total _<>_

  open IsPartialOrder isPartialOrder public hiding (raw)

  raw : isSet A → Raw.IsTotalOrder
  raw isSetA = record
    { isPartialOrder = IsPartialOrder.raw isPartialOrder isSetA
    ; total = total
    }

record IsDecTotalOrder : Type (ℓ-max a ℓ) where
  constructor isdectotalorder
  infix 4 _≤?_
  field
    isTotalOrder : IsTotalOrder
    _≤?_         : Decidable _<>_

  open IsTotalOrder isTotalOrder public hiding (raw)

  isDecPartialOrder : IsDecPartialOrder
  isDecPartialOrder = record
    { isPartialOrder = isPartialOrder
    ; _≤?_           = _≤?_
    }

  raw : isSet A → Raw.IsDecTotalOrder
  raw isSetA = record
    { isTotalOrder = IsTotalOrder.raw isTotalOrder isSetA
    ; _≤?_ = _≤?_
    }

-- Note that these orders are decidable. The current implementation
-- of `Trichotomous` subsumes irreflexivity and asymmetry. Any reasonable
-- definition capturing these three properties implies decidability
-- as `Trichotomous` necessarily separates out the equality case.

record IsStrictTotalOrder : Type (ℓ-max a ℓ) where
  constructor isstricttotalorder
  field
    transitive : Transitive _<>_
    compare    : Trichotomous _<>_

  infix 4 _<?_

  _<?_ : Decidable _<>_
  _<?_ = tri→dec< _<>_ compare

  _≟_ : Discrete A
  _≟_ = tri→dec≡ _<>_ compare

  isStrictPartialOrder : IsStrictPartialOrder
  isStrictPartialOrder = record
    { irrefl     = tri→irr _<>_ compare
    ; transitive = transitive
    }

  isDecStrictPartialOrder : IsDecStrictPartialOrder
  isDecStrictPartialOrder = record
    { isStrictPartialOrder = isStrictPartialOrder
    ; _<?_                 = _<?_
    }

  open IsStrictPartialOrder isStrictPartialOrder public hiding (transitive; raw)

  raw : isSet A → Raw.IsStrictTotalOrder
  raw isSetA = record
    { transitive = transitive
    ; compare = triRaw compare
    }
    where
      import Cubical.Relation.Binary.Raw.Definitions as RawDefinitions
      triRaw : Trichotomous _<>_ → RawDefinitions.Trichotomous [ _<>_ ]
      triRaw tri x y with tri x y
      ... | tri< a b c = RawDefinitions.tri< a b c
      ... | tri≡ a b c = RawDefinitions.tri≡ a b c
      ... | tri> a b c = RawDefinitions.tri> a b c


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

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Multiplication
open import Semirings.Definition
open import Rings.Definition
open import Setoids.Setoids

module Numbers.Integers.RingStructure.Ring where

open import Numbers.Integers.Definition public
open import Numbers.Integers.Addition public
open import Numbers.Integers.Multiplication public

*ZCommutative : (a b : ℤ) → a *Z b ≡ b *Z a
*ZCommutative (nonneg x) (nonneg y) = applyEquality nonneg (multiplicationNIsCommutative x y)
*ZCommutative (nonneg zero) (negSucc y) = refl
*ZCommutative (nonneg (succ x)) (negSucc y) = refl
*ZCommutative (negSucc x) (nonneg zero) = refl
*ZCommutative (negSucc x) (nonneg (succ y)) = refl
*ZCommutative (negSucc x) (negSucc y) = applyEquality nonneg (multiplicationNIsCommutative (succ x) (succ y))

*ZleftIdent : (a : ℤ) → (nonneg 1) *Z a ≡ a
*ZleftIdent (nonneg x) = applyEquality nonneg (Semiring.commutative ℕSemiring x 0)
*ZleftIdent (negSucc x) = applyEquality negSucc (transitivity (Semiring.commutative ℕSemiring (x +N 0) 0) (Semiring.commutative ℕSemiring x 0))

*ZrightIdent : (a : ℤ) → a *Z (nonneg 1) ≡ a
*ZrightIdent (nonneg x) = applyEquality nonneg (Semiring.productOneRight ℕSemiring x)
*ZrightIdent (negSucc x) = applyEquality negSucc (transitivity (Semiring.commutative ℕSemiring (x +N 0) 0) (Semiring.commutative ℕSemiring x 0))

*ZZeroLeft : (a : ℤ) → nonneg 0 *Z a ≡ nonneg 0
*ZZeroLeft (nonneg x) = refl
*ZZeroLeft (negSucc x) = refl

*ZZeroRight : (a : ℤ) → a *Z nonneg 0 ≡ nonneg 0
*ZZeroRight (nonneg x) = applyEquality nonneg (Semiring.productZeroRight ℕSemiring x)
*ZZeroRight (negSucc x) = refl

*ZAssociative : (a b c : ℤ) → a *Z (b *Z c) ≡ (a *Z b) *Z c
*ZAssociative (nonneg zero) b c = transitivity (*ZZeroLeft (b *Z c)) (transitivity (equalityCommutative (*ZZeroLeft c)) (applyEquality (_*Z c) (equalityCommutative (*ZZeroLeft b))))
*ZAssociative (nonneg (succ a)) (nonneg zero) c rewrite Semiring.productZeroRight ℕSemiring a | *ZZeroLeft c | Semiring.productZeroRight ℕSemiring a = refl
*ZAssociative (nonneg (succ a)) (nonneg (succ b)) (nonneg zero) rewrite Semiring.productZeroRight ℕSemiring b | Semiring.productZeroRight ℕSemiring (b +N a *N succ b) | Semiring.productZeroRight ℕSemiring a = refl
*ZAssociative (nonneg (succ a)) (nonneg (succ b)) (nonneg (succ c)) = applyEquality nonneg (Semiring.*Associative ℕSemiring (succ a) (succ b) (succ c))
*ZAssociative (nonneg (succ a)) (nonneg (succ b)) (negSucc x) rewrite productDistributes' b (a *N succ b) x | Semiring.+Associative ℕSemiring x (b *N x) ((a *N succ b) *N x) | equalityCommutative (Semiring.+Associative ℕSemiring ((x +N b *N x) +N b) (a *N ((x +N b *N x) +N b)) a) | equalityCommutative (Semiring.+Associative ℕSemiring (x +N b *N x) ((a *N succ b) *N x) (b +N a *N succ b)) | equalityCommutative (Semiring.+Associative ℕSemiring (x +N b *N x) b (a *N ((x +N b *N x) +N b) +N a)) = applyEquality (λ i → negSucc ((x +N b *N x) +N i)) ans
  where
    ans3 : (succ b +N (succ b *N x)) *N a ≡ succ x *N (a *N succ b)
    ans3 rewrite multiplicationNIsCommutative (succ b) x = transitivity (equalityCommutative (Semiring.*Associative ℕSemiring (succ x) (succ b) a)) (applyEquality (succ x *N_) (multiplicationNIsCommutative (succ b) a))
    ans2 : a *N ((x +N b *N x) +N b) +N a ≡ (a *N succ b) +N (a *N succ b) *N x
    ans2 rewrite multiplicationNIsCommutative (a *N succ b) x | Semiring.commutative ℕSemiring (succ b *N x) b | multiplicationNIsCommutative a (b +N (succ b *N x)) | Semiring.commutative ℕSemiring ((b +N (succ b *N x)) *N a) a = ans3
    ans : b +N (a *N ((x +N b *N x) +N b) +N a) ≡ (a *N succ b) *N x +N (b +N a *N succ b)
    ans rewrite Semiring.commutative ℕSemiring ((a *N succ b) *N x) (b +N a *N succ b) | equalityCommutative (Semiring.+Associative ℕSemiring b (a *N succ b) ((a *N succ b) *N x)) = applyEquality (b +N_) ans2
*ZAssociative (nonneg (succ a)) (negSucc b) (nonneg zero) = applyEquality nonneg (Semiring.productZeroRight ℕSemiring a)
*ZAssociative (nonneg (succ a)) (negSucc b) (nonneg (succ c)) = applyEquality negSucc ans
  where
    ans4 : (b +N b *N c) +N (a *N b +N (a *N b) *N c) ≡ (b +N a *N b) +N (b *N c +N (a *N b) *N c)
    ans4 rewrite Semiring.+Associative ℕSemiring (b +N b *N c) (a *N b) ((a *N b) *N c) | Semiring.+Associative ℕSemiring (b +N a *N b) (b *N c) ((a *N b) *N c) = applyEquality (_+N (a *N b) *N c) (transitivity (transitivity (applyEquality (_+N a *N b) (Semiring.commutative ℕSemiring b (b *N c))) (equalityCommutative (Semiring.+Associative ℕSemiring (b *N c) b (a *N b)))) (Semiring.commutative ℕSemiring (b *N c) (b +N a *N b)))
    ans3 : ((b +N b *N c) +N (a *N b +N (a *N b) *N c)) +N ((c +N a *N c) +N a) ≡ ((b +N a *N b) +N (b *N c +N (a *N b) *N c)) +N ((a +N a *N c) +N c)
    ans3 rewrite Semiring.commutative ℕSemiring (c +N a *N c) a | Semiring.commutative ℕSemiring c (a *N c) | Semiring.+Associative ℕSemiring a (a *N c) c = applyEquality (λ i → i +N ((a +N a *N c) +N c)) {(b +N b *N c) +N (a *N b +N (a *N b) *N c)} {(b +N a *N b) +N (b *N c +N (a *N b) *N c)} ans4
    ans2 : (((b +N c *N b) +N (a *N b +N a *N (c *N b))) +N (c +N a *N c)) +N a ≡ (((b +N a *N b) +N (c *N b +N c *N (a *N b))) +N (a +N c *N a)) +N c
    ans2 rewrite multiplicationNIsCommutative c b | multiplicationNIsCommutative c (a *N b) | Semiring.*Associative ℕSemiring a b c | multiplicationNIsCommutative c a = transitivity (equalityCommutative (Semiring.+Associative ℕSemiring ((b +N b *N c) +N (a *N b +N (a *N b) *N c)) (c +N a *N c) a)) (transitivity ans3 (Semiring.+Associative ℕSemiring ((b +N a *N b) +N (b *N c +N (a *N b) *N c)) (a +N a *N c) c))
    ans : succ a *N ((succ c *N b) +N c) +N a ≡ succ c *N ((succ a *N b) +N a) +N c
    ans = transitivity (applyEquality (_+N a) (productDistributes (succ a) (succ c *N b) c)) (transitivity (transitivity (applyEquality (λ i → ((((b +N c *N b) +N i) +N (c +N a *N c)) +N a)) (productDistributes a b (c *N b))) (transitivity ans2 (applyEquality (λ i → (((b +N a *N b) +N i) +N (a +N c *N a)) +N c) (equalityCommutative (productDistributes c b (a *N b)))))) (applyEquality (_+N c) (equalityCommutative (productDistributes (succ c) (succ a *N b) a))))
*ZAssociative (nonneg (succ a)) (negSucc b) (negSucc x) = applyEquality nonneg ans
  where
    ans : succ a *N (succ b *N succ x) ≡ succ ((succ a *N b) +N a) *N succ x
    ans rewrite Semiring.commutative ℕSemiring (succ a *N b) a | multiplicationNIsCommutative (succ a) b = transitivity (Semiring.*Associative ℕSemiring (succ a) (succ b) (succ x)) (applyEquality (_*N succ x) {succ a *N succ b} {succ b *N succ a} (multiplicationNIsCommutative (succ a) (succ b)))
*ZAssociative (negSucc a) (nonneg zero) c rewrite *ZZeroLeft c = refl
*ZAssociative (negSucc a) (nonneg (succ b)) (nonneg zero) rewrite multiplicationNIsCommutative b 0 = refl
*ZAssociative (negSucc a) (nonneg (succ b)) (nonneg (succ c)) = applyEquality negSucc ans
  where
    ans2 : (d : ℕ) → ((succ b *N d) *N a) +N b *N d ≡ d *N ((succ b *N a) +N b)
    ans2 d = transitivity (transitivity (applyEquality (((d +N b *N d) *N a) +N_) (multiplicationNIsCommutative b d)) (applyEquality (_+N d *N b) (transitivity (applyEquality (_*N a) {d +N b *N d} {d *N succ b} (multiplicationNIsCommutative (succ b) d)) (equalityCommutative (Semiring.*Associative ℕSemiring d (succ b) a))))) (equalityCommutative (Semiring.+DistributesOver* ℕSemiring d (succ b *N a) b))
    ans : (succ (c +N b *N succ c) *N a) +N (c +N b *N succ c) ≡ (succ c *N ((succ b *N a) +N b)) +N c
    ans rewrite Semiring.commutative ℕSemiring c (b *N succ c) | Semiring.+Associative ℕSemiring (succ (b *N succ c +N c) *N a) (b *N succ c) c | Semiring.commutative ℕSemiring (b *N succ c) c = applyEquality (_+N c) (ans2 (succ c))
*ZAssociative (negSucc a) (nonneg (succ b)) (negSucc c) = applyEquality nonneg ans
  where
    ans : succ a *N ((succ ((succ b) *N c)) +N b) ≡ (succ (succ b *N a) +N b) *N succ c
    ans rewrite Semiring.commutative ℕSemiring (succ b *N a) b | multiplicationNIsCommutative (succ b) a = transitivity (applyEquality (succ a *N_) (applyEquality succ (transitivity (equalityCommutative (Semiring.+Associative ℕSemiring c (b *N c) b)) (applyEquality (c +N_) (transitivity (transitivity (Semiring.commutative ℕSemiring (b *N c) b) (applyEquality (b +N_) (multiplicationNIsCommutative b c))) (multiplicationNIsCommutative (succ c) b)))))) (Semiring.*Associative ℕSemiring (succ a) (succ b) (succ c))
*ZAssociative (negSucc a) (negSucc b) (nonneg zero) rewrite Semiring.productZeroRight ℕSemiring (b +N a *N succ b) = refl
*ZAssociative (negSucc a) (negSucc b) (nonneg (succ x)) = applyEquality nonneg (transitivity (applyEquality (succ a *N_) ans) (Semiring.*Associative ℕSemiring (succ a) (succ b) (succ x)))
  where
    ans : succ ((succ x *N b) +N x) ≡ (succ b *N succ x)
    ans rewrite Semiring.commutative ℕSemiring (succ x *N b) x | multiplicationNIsCommutative (succ x) b = refl
*ZAssociative (negSucc a) (negSucc b) (negSucc x) = applyEquality negSucc t
  where
    l1 : (a b c d e f g : ℕ) → (a +N b) +N d ≡ e +N (f +N g) → (a +N b) +N (c +N d) ≡ (c +N e) +N (f +N g)
    l1 a b c d e f g pr rewrite Semiring.commutative ℕSemiring c d | Semiring.+Associative ℕSemiring (a +N b) d c | pr | Semiring.commutative ℕSemiring (e +N (f +N g)) c | Semiring.+Associative ℕSemiring c e (f +N g) = refl
    v : (((succ b) *N succ x) *N a) ≡ (succ x) *N (a *N succ b)
    v = transitivity (applyEquality (_*N a) (multiplicationNIsCommutative (succ b) (succ x))) (transitivity (equalityCommutative (Semiring.*Associative ℕSemiring (succ x) (succ b) a)) (applyEquality (succ x *N_) (multiplicationNIsCommutative (succ b) a)))
    u : (a +N (x +N b *N succ x) *N a) +N b *N succ x ≡ (b +N a *N succ b) *N x +N (b +N a *N succ b)
    u = transitivity (transitivity (transitivity (Semiring.commutative ℕSemiring (a +N (x +N b *N succ x) *N a) (b *N succ x)) (transitivity (applyEquality (_+N (a +N (x +N b *N succ x) *N a)) (multiplicationNIsCommutative b (succ x))) (transitivity (applyEquality ((b +N x *N b) +N_) v) (equalityCommutative (productDistributes (succ x) b (a *N succ b)))))) (applyEquality ((b +N a *N succ b) +N_) (multiplicationNIsCommutative x (b +N a *N succ b)))) (Semiring.commutative ℕSemiring (b +N a *N succ b) ((b +N a *N succ b) *N x))
    t : (a +N (x +N b *N succ x) *N a) +N (x +N b *N succ x) ≡ (x +N (b +N a *N succ b) *N x) +N (b +N a *N succ b)
    t = l1 a ((x +N b *N succ x) *N a) x (b *N succ x) ((b +N (a *N succ b)) *N x) b (a *N succ b) u

multLemma : (a b : ℕ) → a *N succ b ≡ a *N b +N a
multLemma a b rewrite multiplicationNIsCommutative a (succ b) | Semiring.commutative ℕSemiring a (b *N a) | multiplicationNIsCommutative a b = refl

negSucc+Nonneg : (a b : ℕ) → negSucc a ≡ negSucc (a +N b) +Z nonneg b
negSucc+Nonneg zero zero = refl
negSucc+Nonneg zero (succ b) = negSucc+Nonneg zero b
negSucc+Nonneg (succ a) zero rewrite Semiring.commutative ℕSemiring a 0 = refl
negSucc+Nonneg (succ a) (succ b) rewrite Semiring.commutative ℕSemiring a (succ b) | Semiring.commutative ℕSemiring b a = negSucc+Nonneg (succ a) b

distLemma : (a b : ℕ) →  negSucc a *Z nonneg b ≡ negSucc ((a +N b *N a) +N b) +Z nonneg (succ a)
distLemma a b rewrite Semiring.commutative ℕSemiring (a +N b *N a) b | Semiring.commutative ℕSemiring a (b *N a) | Semiring.+Associative ℕSemiring b (b *N a) a = transitivity u (transitivity (equalityCommutative (+ZAssociative (negSucc ((b +N b *N a) +N a)) (nonneg a) (nonneg 1))) (applyEquality ((negSucc ((b +N b *N a) +N a)) +Z_) {nonneg a +Z nonneg 1} {nonneg (succ a)} (+ZCommutative (nonneg a) (nonneg 1))))
  where
    v : (a b : ℕ) → negSucc a *Z nonneg b ≡ (negSucc (b +N b *N a)) +Z nonneg 1
    v zero zero = refl
    v zero (succ b) rewrite Semiring.productZeroRight ℕSemiring b = applyEquality negSucc (equalityCommutative (Semiring.sumZeroRight ℕSemiring b))
    v (succ a) zero = refl
    v (succ a) (succ b) = applyEquality negSucc (Semiring.commutative ℕSemiring (succ (a +N b *N succ a)) b)
    u : negSucc a *Z nonneg b ≡ (negSucc ((b +N b *N a) +N a) +Z nonneg a) +Z nonneg 1
    u = transitivity (v a b) (applyEquality (_+Z nonneg 1) (negSucc+Nonneg (b +N b *N a) a))

*ZDistributesOver+Z : (a b c : ℤ) → a *Z (b +Z c) ≡ (a *Z b) +Z (a *Z c)
*ZDistributesOver+Z (nonneg zero) b c rewrite *ZZeroLeft (b +Z c) | *ZZeroLeft b | *ZZeroLeft c = refl
*ZDistributesOver+Z (nonneg (succ a)) (nonneg zero) (nonneg c) rewrite Semiring.productZeroRight ℕSemiring a = refl
*ZDistributesOver+Z (nonneg (succ a)) (nonneg (succ b)) (nonneg c) = applyEquality nonneg (productDistributes (succ a) (succ b) c)
*ZDistributesOver+Z (nonneg (succ a)) (nonneg zero) (negSucc c) rewrite Semiring.productZeroRight ℕSemiring a = refl
*ZDistributesOver+Z (nonneg (succ a)) (nonneg (succ b)) (negSucc zero) rewrite Semiring.productZeroRight ℕSemiring a = t a
  where
    t : (a : ℕ) → nonneg (succ a *N b) ≡ nonneg (succ a *N succ b) +Z negSucc a
    t zero = refl
    t (succ a) = transitivity (+Zinherits b (b +N a *N b)) (transitivity (applyEquality (nonneg b +Z_) (t a)) (transitivity (+ZAssociative (nonneg b) (nonneg (succ (b +N a *N succ b))) (negSucc a)) (applyEquality (_+Z negSucc a) {nonneg b +Z nonneg (succ (b +N a *N succ b))} {nonneg (b +N succ (b +N a *N succ b))} (equalityCommutative (+Zinherits b _)))))
*ZDistributesOver+Z (nonneg (succ a)) (nonneg (succ x)) (negSucc (succ b)) = transitivity (applyEquality ((nonneg (succ a)) *Z_) (+ZCommutative (nonneg x) (negSucc b))) (transitivity (transitivity (*ZDistributesOver+Z (nonneg (succ a)) (negSucc b) (nonneg x)) t) (+ZCommutative (negSucc ((b +N a *N succ b) +N a)) (nonneg (x +N a *N succ x))))
  where
    t : negSucc ((b +N a *N b) +N a) +Z nonneg (x +N a *N x) ≡ negSucc ((b +N a *N succ b) +N a) +Z nonneg (x +N a *N succ x)
    t rewrite multLemma a x | multLemma a b | Semiring.+Associative ℕSemiring x (a *N x) a | Semiring.+Associative ℕSemiring b (a *N b) a | Semiring.commutative ℕSemiring (x +N a *N x) a | +Zinherits a (x +N a *N x) | +ZAssociative (negSucc (((b +N a *N b) +N a) +N a)) (nonneg a) (nonneg (x +N a *N x)) = applyEquality (_+Z nonneg (x +N a *N x)) {negSucc ((b +N a *N b) +N a)} {negSucc (((b +N a *N b) +N a) +N a) +Z nonneg a} (negSucc+Nonneg ((b +N a *N b) +N a) a)
*ZDistributesOver+Z (nonneg (succ a)) (negSucc b) (nonneg zero) rewrite Semiring.productZeroRight ℕSemiring a = refl
*ZDistributesOver+Z (nonneg (succ a)) (negSucc zero) (nonneg (succ x)) rewrite Semiring.productZeroRight ℕSemiring a = t a x
  where
    t : (a x : ℕ) → nonneg (succ a *N x) ≡ negSucc a +Z nonneg (succ a *N succ x)
    t zero x = refl
    t (succ a) x with t a x
    ... | bl rewrite +Zinherits x (a *N x) | +Zinherits x (x +N a *N x) = transitivity (transitivity (applyEquality (nonneg x +Z_) (+Zinherits x (a *N x))) (+ZCommutative (nonneg x) (nonneg x +Z nonneg (a *N x)))) (transitivity (applyEquality (_+Z nonneg x) bl) (transitivity (equalityCommutative (+ZAssociative (negSucc a) (nonneg (succ x +N a *N succ x)) (nonneg x))) (applyEquality (λ i → negSucc a +Z nonneg i) {succ (x +N a *N succ x) +N x} {x +N succ (x +N a *N succ x)} (Semiring.commutative ℕSemiring (succ (x +N a *N succ x)) x))))
*ZDistributesOver+Z (nonneg (succ a)) (negSucc (succ b)) (nonneg (succ x)) = transitivity (*ZDistributesOver+Z (nonneg (succ a)) (negSucc b) (nonneg x)) t
  where
    t : negSucc ((b +N a *N b) +N a) +Z nonneg (x +N a *N x) ≡ negSucc ((b +N a *N succ b) +N a) +Z nonneg (x +N a *N succ x)
    t rewrite multLemma a x | multLemma a b | Semiring.+Associative ℕSemiring x (a *N x) a | Semiring.+Associative ℕSemiring b (a *N b) a | Semiring.commutative ℕSemiring (x +N a *N x) a | +Zinherits a (x +N a *N x) | +ZAssociative (negSucc (((b +N a *N b) +N a) +N a)) (nonneg a) (nonneg (x +N a *N x)) = applyEquality (_+Z nonneg (x +N a *N x)) {negSucc ((b +N a *N b) +N a)} {negSucc (((b +N a *N b) +N a) +N a) +Z nonneg a} (negSucc+Nonneg ((b +N a *N b) +N a) a)
*ZDistributesOver+Z (nonneg (succ a)) (negSucc b) (negSucc x) = applyEquality negSucc (transitivity (applyEquality (_+N a) (transitivity (productDistributes (succ a) (succ b) x) (applyEquality (_+N (x +N a *N x)) {succ b +N a *N succ b} {succ (b +N a *N b) +N a} (applyEquality succ u)))) (equalityCommutative (Semiring.+Associative ℕSemiring (succ ((b +N a *N b) +N a)) (succ a *N x) a)))
  where
    u : b +N a *N succ b ≡ (succ a *N b) +N a
    u rewrite multiplicationNIsCommutative a (succ b) | Semiring.commutative ℕSemiring a (b *N a) | multiplicationNIsCommutative b a = Semiring.+Associative ℕSemiring b (a *N b) a
*ZDistributesOver+Z (negSucc a) (nonneg zero) (nonneg x) = refl
*ZDistributesOver+Z (negSucc a) (nonneg zero) (negSucc x) = refl
*ZDistributesOver+Z (negSucc a) (nonneg (succ b)) (nonneg zero) rewrite Semiring.commutative ℕSemiring b 0 = refl
*ZDistributesOver+Z (negSucc a) (nonneg (succ b)) (nonneg (succ c)) = applyEquality negSucc t
  where
    v : a *N b +N a *N succ c ≡ c *N a +N (a +N b *N a)
    v rewrite multiplicationNIsCommutative b a | Semiring.+Associative ℕSemiring (c *N a) a (a *N b) | Semiring.commutative ℕSemiring (c *N a +N a) (a *N b) | Semiring.commutative ℕSemiring (c *N a) a = applyEquality (λ i → a *N b +N i) (transitivity (multLemma a c) (transitivity (Semiring.commutative ℕSemiring (a *N c) a) (applyEquality (a +N_) (multiplicationNIsCommutative a c))))
    u : (a +N (b +N succ c) *N a) +N b ≡ (a +N c *N a) +N ((a +N b *N a) +N b)
    u rewrite Semiring.+Associative ℕSemiring (a +N c *N a) (a +N b *N a) b | (equalityCommutative (Semiring.+Associative ℕSemiring a (c *N a) (a +N b *N a))) = applyEquality (λ i → (a +N i) +N b) (transitivity (multiplicationNIsCommutative (b +N succ c) a) (transitivity (productDistributes a b (succ c)) v))
    t : (a +N (b +N succ c) *N a) +N (b +N succ c) ≡ succ (((a +N b *N a) +N b) +N ((a +N c *N a) +N c))
    t rewrite Semiring.+Associative ℕSemiring ((a +N (b +N succ c) *N a)) b (succ c) | Semiring.commutative ℕSemiring ((a +N b *N a) +N b) ((a +N c *N a) +N c) | Semiring.commutative ℕSemiring (a +N c *N a) c | equalityCommutative (Semiring.+Associative ℕSemiring (succ c) (a +N c *N a) ((a +N b *N a) +N b)) | Semiring.commutative ℕSemiring (succ c) ((a +N c *N a) +N ((a +N b *N a) +N b)) = applyEquality (_+N succ c) u
*ZDistributesOver+Z (negSucc a) (nonneg (succ b)) (negSucc zero) rewrite Semiring.productOneRight ℕSemiring a = distLemma a b
*ZDistributesOver+Z (negSucc a) (nonneg (succ b)) (negSucc (succ c)) = transitivity (*ZDistributesOver+Z (negSucc a) (nonneg b) (negSucc c)) (transitivity (applyEquality (_+Z nonneg (succ (c +N a *N succ c))) (distLemma a b)) (transitivity (equalityCommutative (+ZAssociative (negSucc ((a +N b *N a) +N b)) (nonneg (succ a)) (nonneg (succ (c +N a *N succ c))))) (applyEquality (negSucc ((a +N b *N a) +N b) +Z_) {nonneg (succ (a +N succ (c +N a *N succ c)))} {nonneg (succ (succ (c +N a *N succ (succ c))))} (applyEquality nonneg (t (succ a) (succ c))))))
  where
    t : (x y : ℕ) → x +N x *N y ≡ x *N succ y
    t x y = transitivity (Semiring.commutative ℕSemiring x (x *N y)) (equalityCommutative (multLemma x y))
*ZDistributesOver+Z (negSucc a) (negSucc b) (nonneg zero) rewrite Semiring.commutative ℕSemiring (b +N a *N succ b) 0 = refl
*ZDistributesOver+Z (negSucc a) (negSucc zero) (nonneg (succ b)) = transitivity (distLemma a b) (transitivity (+ZCommutative (negSucc ((a +N b *N a) +N b)) (nonneg (succ a))) (applyEquality (λ i → nonneg (succ i) +Z negSucc ((a +N b *N a) +N b)) (equalityCommutative (Semiring.productOneRight ℕSemiring a))))
*ZDistributesOver+Z (negSucc a) (negSucc (succ c)) (nonneg (succ b)) = transitivity (applyEquality (negSucc a *Z_) (+ZCommutative (negSucc c) (nonneg b))) (transitivity (transitivity (*ZDistributesOver+Z (negSucc a) (nonneg b) (negSucc c)) (transitivity (applyEquality (_+Z nonneg (succ (c +N a *N succ c))) (distLemma a b)) (transitivity (equalityCommutative (+ZAssociative (negSucc ((a +N b *N a) +N b)) (nonneg (succ a)) (nonneg (succ (c +N a *N succ c))))) (applyEquality (negSucc ((a +N b *N a) +N b) +Z_) {nonneg (succ (a +N succ (c +N a *N succ c)))} {nonneg (succ (succ (c +N a *N succ (succ c))))} (applyEquality nonneg (t (succ a) (succ c))))))) (+ZCommutative (negSucc ((a +N b *N a) +N b)) (nonneg (succ (succ (c +N a *N succ (succ c)))))))
  where
    t : (x y : ℕ) → x +N x *N y ≡ x *N succ y
    t x y = transitivity (Semiring.commutative ℕSemiring x (x *N y)) (equalityCommutative (multLemma x y))
*ZDistributesOver+Z (negSucc a) (negSucc b) (negSucc c) = applyEquality nonneg (transitivity (applyEquality (λ i → succ a *N (succ i)) (transitivity (applyEquality succ (Semiring.commutative ℕSemiring b c)) (Semiring.commutative ℕSemiring (succ c) b))) (productDistributes (succ a) (succ b) (succ c)))

ℤRing : Ring (reflSetoid ℤ) _+Z_ _*Z_
Ring.additiveGroup ℤRing = ℤGroup
Ring.*WellDefined ℤRing refl refl = refl
Ring.1R ℤRing = nonneg 1
Ring.groupIsAbelian ℤRing {a} {b} = +ZCommutative a b
Ring.*Associative ℤRing {a} {b} {c} = *ZAssociative a b c
Ring.*Commutative ℤRing {a} {b} = *ZCommutative a b
Ring.*DistributesOver+ ℤRing {a} {b} {c} = *ZDistributesOver+Z a b c
Ring.identIsIdent ℤRing {a} = *ZleftIdent a


module Epic where

data Nat : Set where
  Z : Nat
  S : Nat -> Nat

_+_ : Nat -> Nat -> Nat
Z + m = m
S n + m = S (n + m)

_*_ : Nat -> Nat -> Nat
Z * m = Z
S n * m = m + (n * m)

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN NATPLUS _+_ #-}
{-# BUILTIN NATTIMES _*_ #-}

data Unit : Set where
  unit : Unit

postulate
  IO         : Set -> Set
  printNat   : Nat -> IO Unit

{-# COMPILED_EPIC printNat (a : BigInt, u : Unit) -> Unit = putStrLn (bigIntToStr(a)) #-}

main : IO Unit
main = printNat (7 * 191)


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Homomorphism.Setoid (Σ : Signature) where

open import Fragment.Algebra.Algebra Σ
open import Fragment.Algebra.Homomorphism.Base Σ

open import Level using (Level; _⊔_)
open import Relation.Binary using (Rel; Setoid; IsEquivalence)

private
  variable
    a b ℓ₁ ℓ₂ : Level

module _
  {A : Algebra {a} {ℓ₁}}
  {B : Algebra {b} {ℓ₂}}
  where

  open Setoid ∥ B ∥/≈

  infix 4 _≗_

  _≗_ : Rel (A ⟿ B) (a ⊔ ℓ₂)
  f ≗ g = ∣ f ∣⃗ ~ ∣ g ∣⃗
    where open import Fragment.Setoid.Morphism renaming (_≗_ to _~_)

  ≗-refl : ∀ {f} → f ≗ f
  ≗-refl = refl

  ≗-sym : ∀ {f g} → f ≗ g → g ≗ f
  ≗-sym f≗g {x} = sym (f≗g {x})

  ≗-trans : ∀ {f g h} → f ≗ g → g ≗ h → f ≗ h
  ≗-trans f≗g g≗h {x} = trans (f≗g {x}) (g≗h {x})

  ≗-isEquivalence : IsEquivalence _≗_
  ≗-isEquivalence = record { refl  = λ {f} → ≗-refl {f}
                           ; sym   = λ {f g} → ≗-sym {f} {g}
                           ; trans = λ {f g h} → ≗-trans {f} {g} {h}
                           }

_⟿_/≗ : Algebra {a} {ℓ₁} → Algebra {b} {ℓ₂} → Setoid _ _
A ⟿ B /≗ = record { Carrier       = A ⟿ B
                   ; _≈_           = _≗_
                   ; isEquivalence = ≗-isEquivalence
                   }


module Relator.Equals where

import      Lvl
open import Logic
open import Logic.Propositional
open import Type

infixl 15 _≢_

open import Type.Identity public
  using()
  renaming(Id to infixl 15 _≡_ ; intro to [≡]-intro)

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


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

-- A function that requires call-by-need
f : Nat → Nat → Nat
f a 0       = a
f a (suc b) = f (a + a) b

even : Nat → Bool
even n = mod-helper 0 1 n 1 == 0

data ⊥ : Set where
record ⊤ : Set where

IsTrue : Bool → Set
IsTrue false = ⊥
IsTrue true  = ⊤

-- Previously we reverted to slow reduce in when positivity checking.
f-even : IsTrue (even (f 1 64))
f-even = _


------------------------------------------------------------------------
-- A formalisation of some definitions and laws from Section 3 of Ralf
-- Hinze's paper "Streams and Unique Fixed Points"
------------------------------------------------------------------------

module Hinze.Section3 where

open import Stream.Programs
open import Stream.Equality
open import Stream.Pointwise
open import Hinze.Section2-4
open import Hinze.Lemmas

open import Codata.Musical.Notation hiding (∞)
open import Data.Product
open import Data.Bool
open import Data.Vec hiding (_⋎_)
open import Data.Nat
import Data.Nat.Properties as Nat
import Relation.Binary.PropositionalEquality as P
open import Algebra.Structures
private
  module CS = IsCommutativeSemiring Nat.+-*-isCommutativeSemiring

------------------------------------------------------------------------
-- Definitions

pot : Prog Bool
pot = true ≺ ♯ (pot ⋎ false ∞)

msb : Prog ℕ
msb = 1 ≺ ♯ (2 ∞ ⟨ _*_ ⟩ msb ⋎ 2 ∞ ⟨ _*_ ⟩ msb)

ones′ : Prog ℕ
ones′ = 1 ≺ ♯ (ones′ ⋎ ones′ ⟨ _+_ ⟩ 1 ∞)

ones : Prog ℕ
ones = 0 ≺♯ ones′

carry : Prog ℕ
carry = 0 ≺ ♯ (carry ⟨ _+_ ⟩ 1 ∞ ⋎ 0 ∞)

carry-folded : carry ≊ 0 ∞ ⋎ carry ⟨ _+_ ⟩ 1 ∞
carry-folded = carry ∎

2^carry : Prog ℕ
2^carry = 2 ∞ ⟨ _^_ ⟩ carry

turn-length : ℕ → ℕ
turn-length zero    = zero
turn-length (suc n) = ℓ + suc ℓ
  where ℓ = turn-length n

turn : (n : ℕ) → Vec ℕ (turn-length n)
turn zero    = []
turn (suc n) = turn n ++ [ n ] ++ turn n

tree : ℕ → Prog ℕ
tree n = n ≺ ♯ (turn n ≺≺ tree (suc n))

frac : Prog ℕ
frac = 0 ≺ ♯ (frac ⋎ nat ⟨ _+_ ⟩ 1 ∞)

frac-folded : frac ≊ nat ⋎ frac
frac-folded = frac ∎

god : Prog ℕ
god = (2 ∞ ⟨ _*_ ⟩ frac) ⟨ _+_ ⟩ 1 ∞

------------------------------------------------------------------------
-- Laws and properties

god-lemma : god ≊ 2*nat+1 ⋎ god
god-lemma =
  god
                                          ≡⟨ P.refl ⟩
  (2 ∞ ⟨ _*_ ⟩ (nat ⋎ frac)) ⟨ _+_ ⟩ 1 ∞
                                          ≊⟨ ⟨ _+_ ⟩-cong (2 ∞ ⟨ _*_ ⟩ (nat ⋎ frac))
                                                          (2*nat ⋎ 2 ∞ ⟨ _*_ ⟩ frac)
                                                          (zip-const-⋎ _*_ 2 nat frac)
                                                          (1 ∞) (1 ∞) (1 ∞ ∎)  ⟩
  (2*nat ⋎ 2 ∞ ⟨ _*_ ⟩ frac) ⟨ _+_ ⟩ 1 ∞
                                          ≊⟨ zip-⋎-const _+_ 2*nat (2 ∞ ⟨ _*_ ⟩ frac) 1 ⟩
  2*nat+1 ⋎ god
                                          ∎

carry-god-nat : 2^carry ⟨ _*_ ⟩ god ≊ tailP nat
carry-god-nat =
  2^carry ⟨ _*_ ⟩ god
                                                           ≡⟨ P.refl ⟩
  (2 ∞ ⟨ _^_ ⟩ (0 ∞ ⋎ carry ⟨ _+_ ⟩ 1 ∞)) ⟨ _*_ ⟩ god
                                                           ≊⟨ ⟨ _*_ ⟩-cong (2 ∞ ⟨ _^_ ⟩ (0 ∞ ⋎ carry ⟨ _+_ ⟩ 1 ∞))
                                                                           (1 ∞ ⋎ 2 ∞ ⟨ _*_ ⟩ 2^carry) lemma
                                                                           god (2*nat+1 ⋎ god) god-lemma ⟩
  (1 ∞ ⋎ 2 ∞ ⟨ _*_ ⟩ 2^carry) ⟨ _*_ ⟩ (2*nat+1 ⋎ god)
                                                           ≊⟨ ≅-sym (abide-law _*_ (1 ∞) 2*nat+1
                                                                                (2 ∞ ⟨ _*_ ⟩ 2^carry) god) ⟩
  1 ∞ ⟨ _*_ ⟩ 2*nat+1 ⋎ (2 ∞ ⟨ _*_ ⟩ 2^carry) ⟨ _*_ ⟩ god
                                                           ≊⟨ ⋎-cong (1 ∞ ⟨ _*_ ⟩ 2*nat+1) 2*nat+1
                                                                     (pointwise 1 (λ s → 1 ∞ ⟨ _*_ ⟩ s) (λ s → s)
                                                                                (proj₁ CS.*-identity) 2*nat+1)
                                                                     ((2 ∞ ⟨ _*_ ⟩ 2^carry) ⟨ _*_ ⟩ god)
                                                                     (2 ∞ ⟨ _*_ ⟩ (2^carry ⟨ _*_ ⟩ god))
                                                                     (pointwise 3 (λ s t u → (s ⟨ _*_ ⟩ t) ⟨ _*_ ⟩ u)
                                                                                (λ s t u → s ⟨ _*_ ⟩ (t ⟨ _*_ ⟩ u))
                                                                                CS.*-assoc (2 ∞) 2^carry god) ⟩
  2*nat+1 ⋎ 2 ∞ ⟨ _*_ ⟩ (2^carry ⟨ _*_ ⟩ god)
                                                           ≊⟨ P.refl ≺ coih ⟩
  2*nat+1 ⋎ 2 ∞ ⟨ _*_ ⟩ tailP nat
                                                           ≊⟨ ≅-sym (tailP-cong nat (2*nat ⋎ 2*nat+1) nat-lemma₂) ⟩
  tailP nat
                                                           ∎
  where
  coih = ♯ ⋎-cong (2 ∞ ⟨ _*_ ⟩ (2^carry ⟨ _*_ ⟩ god))
                  (2 ∞ ⟨ _*_ ⟩ (tailP nat))
                  (⟨ _*_ ⟩-cong (2 ∞) (2 ∞) (2 ∞ ∎)
                                (2^carry ⟨ _*_ ⟩ god) (tailP nat)
                                carry-god-nat)
                  (tailP 2*nat+1) (tailP 2*nat+1) (tailP 2*nat+1 ∎)

  lemma =
    2^carry
                                                       ≡⟨ P.refl ⟩
    2 ∞ ⟨ _^_ ⟩ (0 ∞ ⋎ carry ⟨ _+_ ⟩ 1 ∞)
                                                       ≊⟨ zip-const-⋎ _^_ 2 (0 ∞) (carry ⟨ _+_ ⟩ 1 ∞) ⟩
    2 ∞ ⟨ _^_ ⟩ 0 ∞ ⋎ 2 ∞ ⟨ _^_ ⟩ (carry ⟨ _+_ ⟩ 1 ∞)
                                                       ≊⟨ ⋎-cong (2 ∞ ⟨ _^_ ⟩ 0 ∞) (1 ∞)
                                                                 (pointwise 0 (2 ∞ ⟨ _^_ ⟩ 0 ∞) (1 ∞) P.refl)
                                                                 (2 ∞ ⟨ _^_ ⟩ (carry ⟨ _+_ ⟩ 1 ∞))
                                                                 (2 ∞ ⟨ _*_ ⟩ 2^carry)
                                                                 (pointwise 1 (λ s → 2 ∞ ⟨ _^_ ⟩ (s ⟨ _+_ ⟩ 1 ∞))
                                                                              (λ s → 2 ∞ ⟨ _*_ ⟩ (2 ∞ ⟨ _^_ ⟩ s))
                                                                              (λ x → P.cong (_^_ 2) (CS.+-comm x 1))
                                                                              carry) ⟩
    1 ∞ ⋎ 2 ∞ ⟨ _*_ ⟩ 2^carry
                                                       ∎


-- 2014-04-06 Andreas, issue reported by Andres Sicard-Ramirez

-- {-# OPTIONS --termination-depth=100 -v term.matrices:40 #-}

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

-- The following function is accepted by the termination checker in
-- Agda-2.3.2.2, but it is rejected by the termination checker in
-- the current development version. (The function was adapted from Lee,
-- Jones, and Ben-Amram, POPL '01).
p : ℕ → ℕ → ℕ → ℕ
p m n        (succ r) = p m r n
p m (succ n) zero     = p zero n m
p m zero     zero     = m


module Class.Monad.Writer where

open import Class.Monad
open import Data.Product
open import Data.Unit.Polymorphic
open import Level
open import Function

private
  variable
    a : Level
    A : Set a

record MonadWriter (M : Set a → Set a) {{_ : Monad M}} (W : Set a) : Set (suc a) where
  field
    tell : W → M ⊤
    listen : M A → M (A × W)
    pass : M (A × (W → W)) → M A

  listens : {B : Set a} → (W → B) → M A → M (A × B)
  listens f x = do
    (a , w) ← listen x
    return (a , f w)

  censor : (W → W) → M A → M A
  censor f x = pass $ do
    a ← x
    return (a , f)

open MonadWriter {{...}} public


module Data.Fin.Subset.Cardinality where
  open import Data.Fin.Subset

  _∖_ : ∀ {n} → Subset n → Subset n → Subset n
  _∖_ {n} a b = a ∩ ∁ b


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of unnormalized Rational numbers
------------------------------------------------------------------------

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

module Data.Rational.Unnormalised.Properties where

open import Algebra
import Algebra.Consequences.Setoid as FC
open import Algebra.Consequences.Propositional
open import Data.Nat.Base using (suc)
import Data.Nat.Properties as ℕ
open import Data.Integer.Base as ℤ using (ℤ; +0; +[1+_]; 0ℤ; 1ℤ)
open import Data.Integer.Solver renaming (module +-*-Solver to ℤ-solver)
import Data.Integer.Properties as ℤ
import Data.Integer.Properties
open import Data.Rational.Unnormalised
open import Data.Product using (_,_)
open import Data.Sum.Base using ([_,_]′; inj₁; inj₂)
open import Function.Base using (_on_; _$_; _∘_)
open import Level using (0ℓ)
open import Relation.Nullary using (yes; no)
import Relation.Nullary.Decidable as Dec
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Algebra.Properties.CommutativeSemigroup ℤ.*-commutativeSemigroup

------------------------------------------------------------------------
-- Properties of ↥_ and ↧_
------------------------------------------------------------------------

↥↧≡⇒≡ : ∀ {p q} → ↥ p ≡ ↥ q → ↧ₙ p ≡ ↧ₙ q → p ≡ q
↥↧≡⇒≡ refl refl = refl

------------------------------------------------------------------------
-- Properties of _≃_
------------------------------------------------------------------------

drop-*≡* : ∀ {p q} → p ≃ q → ↥ p ℤ.* ↧ q ≡ ↥ q ℤ.* ↧ p
drop-*≡* (*≡* eq) = eq

≃-refl : Reflexive _≃_
≃-refl = *≡* refl

≃-reflexive : _≡_ ⇒ _≃_
≃-reflexive refl = *≡* refl

≃-sym : Symmetric _≃_
≃-sym (*≡* eq) = *≡* (sym eq)

≃-trans : Transitive _≃_
≃-trans {x} {y} {z} (*≡* ad≡cb) (*≡* cf≡ed) =
  *≡* (ℤ.*-cancelʳ-≡ (↥ x ℤ.* ↧ z) (↥ z ℤ.* ↧ x) (↧ y) (λ()) (begin
     ↥ x ℤ.* ↧ z ℤ.* ↧ y ≡⟨ xy∙z≈xz∙y (↥ x) _ _ ⟩
     ↥ x ℤ.* ↧ y ℤ.* ↧ z ≡⟨ cong (ℤ._* ↧ z) ad≡cb ⟩
     ↥ y ℤ.* ↧ x ℤ.* ↧ z ≡⟨ xy∙z≈xz∙y (↥ y) _ _ ⟩
     ↥ y ℤ.* ↧ z ℤ.* ↧ x ≡⟨ cong (ℤ._* ↧ x) cf≡ed ⟩
     ↥ z ℤ.* ↧ y ℤ.* ↧ x ≡⟨ xy∙z≈xz∙y (↥ z) _ _ ⟩
     ↥ z ℤ.* ↧ x ℤ.* ↧ y ∎))
  where open ≡-Reasoning

_≃?_ : Decidable _≃_
p ≃? q = Dec.map′ *≡* drop-*≡* (↥ p ℤ.* ↧ q ℤ.≟ ↥ q ℤ.* ↧ p)

≃-isEquivalence : IsEquivalence _≃_
≃-isEquivalence = record
  { refl  = ≃-refl
  ; sym   = ≃-sym
  ; trans = ≃-trans
  }

≃-isDecEquivalence : IsDecEquivalence _≃_
≃-isDecEquivalence = record
  { isEquivalence = ≃-isEquivalence
  ; _≟_           = _≃?_
  }

≃-setoid : Setoid 0ℓ 0ℓ
≃-setoid = record
  { isEquivalence = ≃-isEquivalence
  }

≃-decSetoid : DecSetoid 0ℓ 0ℓ
≃-decSetoid = record
  { isDecEquivalence = ≃-isDecEquivalence
  }

------------------------------------------------------------------------
-- Properties of _≤_
------------------------------------------------------------------------
-- Relational properties

drop-*≤* : ∀ {p q} → p ≤ q → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p)
drop-*≤* (*≤* pq≤qp) = pq≤qp

≤-reflexive : _≃_ ⇒ _≤_
≤-reflexive (*≡* eq) = *≤* (ℤ.≤-reflexive eq)

≤-refl : Reflexive _≤_
≤-refl = ≤-reflexive ≃-refl

≤-trans : Transitive _≤_
≤-trans {i = p@(mkℚᵘ n₁ d₁-1)} {j = q@(mkℚᵘ n₂ d₂-1)} {k = r@(mkℚᵘ n₃ d₃-1)} (*≤* eq₁) (*≤* eq₂)
  = let d₁ = ↧ p; d₂ = ↧ q; d₃ = ↧ r in *≤* $
  ℤ.*-cancelʳ-≤-pos (n₁ ℤ.* d₃) (n₃ ℤ.* d₁) d₂-1 $ begin
  (n₁  ℤ.* d₃) ℤ.* d₂  ≡⟨ ℤ.*-assoc n₁ d₃ d₂ ⟩
  n₁   ℤ.* (d₃ ℤ.* d₂) ≡⟨ cong (n₁ ℤ.*_) (ℤ.*-comm d₃ d₂) ⟩
  n₁   ℤ.* (d₂ ℤ.* d₃) ≡⟨ sym (ℤ.*-assoc n₁ d₂ d₃) ⟩
  (n₁  ℤ.* d₂) ℤ.* d₃  ≤⟨ ℤ.*-monoʳ-≤-pos d₃-1 eq₁ ⟩
  (n₂  ℤ.* d₁) ℤ.* d₃  ≡⟨ cong (ℤ._* d₃) (ℤ.*-comm n₂ d₁) ⟩
  (d₁ ℤ.* n₂)  ℤ.* d₃  ≡⟨ ℤ.*-assoc d₁ n₂ d₃ ⟩
  d₁  ℤ.* (n₂  ℤ.* d₃) ≤⟨ ℤ.*-monoˡ-≤-pos d₁-1 eq₂ ⟩
  d₁  ℤ.* (n₃  ℤ.* d₂) ≡⟨ sym (ℤ.*-assoc d₁ n₃ d₂) ⟩
  (d₁ ℤ.* n₃)  ℤ.* d₂  ≡⟨ cong (ℤ._* d₂) (ℤ.*-comm d₁ n₃) ⟩
  (n₃  ℤ.* d₁) ℤ.* d₂  ∎
  where open ℤ.≤-Reasoning

≤-antisym : Antisymmetric _≃_ _≤_
≤-antisym (*≤* le₁) (*≤* le₂) = *≡* (ℤ.≤-antisym le₁ le₂)

≤-total : Total _≤_
≤-total p q = [ inj₁ ∘ *≤* , inj₂ ∘ *≤* ]′ (ℤ.≤-total
  (↥ p ℤ.* ↧ q)
  (↥ q ℤ.* ↧ p))

infix 4 _≤?_
_≤?_ : Decidable _≤_
p ≤? q = Dec.map′ *≤* drop-*≤* (↥ p ℤ.* ↧ q ℤ.≤? ↥ q ℤ.* ↧ p)

≤-irrelevant : Irrelevant _≤_
≤-irrelevant (*≤* p≤q₁) (*≤* p≤q₂) = cong *≤* (ℤ.≤-irrelevant p≤q₁ p≤q₂)

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

≤-isPreorder : IsPreorder _≃_ _≤_
≤-isPreorder = record
  { isEquivalence = ≃-isEquivalence
  ; reflexive     = ≤-reflexive
  ; trans         = ≤-trans
  }

≤-isPartialOrder : IsPartialOrder _≃_ _≤_
≤-isPartialOrder = record
  { isPreorder = ≤-isPreorder
  ; antisym    = ≤-antisym
  }

≤-isTotalOrder : IsTotalOrder _≃_ _≤_
≤-isTotalOrder = record
  { isPartialOrder = ≤-isPartialOrder
  ; total          = ≤-total
  }

≤-isDecTotalOrder : IsDecTotalOrder _≃_ _≤_
≤-isDecTotalOrder = record
  { isTotalOrder = ≤-isTotalOrder
  ; _≟_          = _≃?_
  ; _≤?_         = _≤?_
  }

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

≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ
≤-decTotalOrder = record
  { isDecTotalOrder = ≤-isDecTotalOrder
  }

------------------------------------------------------------------------
-- Properties of _+_
------------------------------------------------------------------------

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

+-rawMagma : RawMagma 0ℓ 0ℓ
+-rawMagma = record
  { _≈_ = _≃_
  ; _∙_ = _+_
  }

+-rawMonoid : RawMonoid 0ℓ 0ℓ
+-rawMonoid = record
  { _≈_ = _≃_
  ; _∙_ = _+_
  ; ε   = 0ℚᵘ
  }

+-0-rawGroup : RawGroup 0ℓ 0ℓ
+-0-rawGroup = record
  { Carrier = ℚᵘ
  ; _≈_ = _≃_
  ; _∙_ = _+_
  ; ε = 0ℚᵘ
  ; _⁻¹ = -_
  }

+-*-rawRing : RawRing 0ℓ 0ℓ
+-*-rawRing = record
  { Carrier = ℚᵘ
  ; _≈_ = _≃_
  ; _+_ = _+_
  ; _*_ = _*_
  ; -_ = -_
  ; 0# = 0ℚᵘ
  ; 1# = 1ℚᵘ
  }

------------------------------------------------------------------------
-- Algebraic properties

-- Congruence

+-cong : Congruent₂ _≃_ _+_
+-cong {x} {y} {u} {v} (*≡* ab′∼a′b) (*≡* cd′∼c′d) = *≡* (begin
  (↥x ℤ.* ↧u ℤ.+ ↥u ℤ.* ↧x) ℤ.* (↧y ℤ.* ↧v)               ≡⟨ solve 6 (λ ↥x ↧x ↧y ↥u ↧u ↧v →
                                                             (↥x :* ↧u :+ ↥u :* ↧x) :* (↧y :* ↧v) :=
                                                             (↥x :* ↧y :* (↧u :* ↧v)) :+ ↥u :* ↧v :* (↧x :* ↧y))
                                                             refl (↥ x) (↧ x) (↧ y) (↥ u) (↧ u) (↧ v) ⟩
  ↥x ℤ.* ↧y ℤ.* (↧u ℤ.* ↧v) ℤ.+ ↥u ℤ.* ↧v ℤ.* (↧x ℤ.* ↧y) ≡⟨ cong₂ ℤ._+_ (cong (ℤ._* (↧u ℤ.* ↧v)) ab′∼a′b)
                                                                         (cong (ℤ._* (↧x ℤ.* ↧y)) cd′∼c′d) ⟩
  ↥y ℤ.* ↧x ℤ.* (↧u ℤ.* ↧v) ℤ.+ ↥v ℤ.* ↧u ℤ.* (↧x ℤ.* ↧y) ≡⟨ solve 6 (λ ↧x ↥y ↧y ↧u ↥v ↧v →
                                                             (↥y :* ↧x :* (↧u :* ↧v)) :+ ↥v :* ↧u :* (↧x :* ↧y) :=
                                                             (↥y :* ↧v :+ ↥v :* ↧y) :* (↧x :* ↧u))
                                                             refl (↧ x) (↥ y) (↧ y) (↧ u) (↥ v) (↧ v) ⟩
  (↥y ℤ.* ↧v ℤ.+ ↥v ℤ.* ↧y) ℤ.* (↧x ℤ.* ↧u)               ∎)
  where
  ↥x = ↥ x; ↧x = ↧ x; ↥y = ↥ y; ↧y = ↧ y; ↥u = ↥ u; ↧u = ↧ u; ↥v = ↥ v; ↧v = ↧ v
  open ≡-Reasoning
  open ℤ-solver

-- Associativity

+-assoc-↥ : Associative (_≡_ on ↥_) _+_
+-assoc-↥ p q r = solve 6 (λ ↥p ↧p ↥q ↧q ↥r ↧r →
    (↥p :* ↧q :+ ↥q :* ↧p) :* ↧r :+ ↥r :* (↧p :* ↧q) :=
    ↥p :* (↧q :* ↧r) :+ (↥q :* ↧r :+ ↥r :* ↧q) :* ↧p)
  refl (↥ p) (↧ p) (↥ q) (↧ q) (↥ r) (↧ r)
  where open ℤ-solver

+-assoc-↧ : Associative (_≡_ on ↧ₙ_) _+_
+-assoc-↧ p q r = ℕ.*-assoc (↧ₙ p) (↧ₙ q) (↧ₙ r)

+-assoc-≡ : Associative _≡_ _+_
+-assoc-≡ p q r = ↥↧≡⇒≡ (+-assoc-↥ p q r) (+-assoc-↧ p q r)

+-assoc : Associative _≃_ _+_
+-assoc p q r = ≃-reflexive (+-assoc-≡ p q r)

-- Commutativity

+-comm-↥ : Commutative (_≡_ on ↥_) _+_
+-comm-↥ p q = ℤ.+-comm (↥ p ℤ.* ↧ q) (↥ q ℤ.* ↧ p)

+-comm-↧ : Commutative (_≡_ on ↧ₙ_) _+_
+-comm-↧ p q = ℕ.*-comm (↧ₙ p) (↧ₙ q)

+-comm-≡ : Commutative _≡_ _+_
+-comm-≡ p q = ↥↧≡⇒≡ (+-comm-↥ p q) (+-comm-↧ p q)

+-comm : Commutative _≃_ _+_
+-comm p q = ≃-reflexive (+-comm-≡ p q)

-- Identities

+-identityˡ-↥ : LeftIdentity (_≡_ on ↥_) 0ℚᵘ _+_
+-identityˡ-↥ p = begin
  0ℤ ℤ.* ↧ p ℤ.+ ↥ p ℤ.* 1ℤ ≡⟨ cong₂ ℤ._+_ (ℤ.*-zeroˡ (↧ p)) (ℤ.*-identityʳ (↥ p)) ⟩
  0ℤ ℤ.+ ↥ p                ≡⟨ ℤ.+-identityˡ (↥ p) ⟩
  ↥ p                       ∎
  where open ≡-Reasoning

+-identityˡ-↧ : LeftIdentity (_≡_ on ↧ₙ_) 0ℚᵘ _+_
+-identityˡ-↧ p = ℕ.+-identityʳ (↧ₙ p)

+-identityˡ-≡ : LeftIdentity _≡_ 0ℚᵘ _+_
+-identityˡ-≡ p = ↥↧≡⇒≡ (+-identityˡ-↥ p) (+-identityˡ-↧ p)

+-identityˡ : LeftIdentity _≃_ 0ℚᵘ _+_
+-identityˡ p = ≃-reflexive (+-identityˡ-≡ p)

+-identityʳ-≡ : RightIdentity _≡_ 0ℚᵘ _+_
+-identityʳ-≡ = comm+idˡ⇒idʳ +-comm-≡ {e = 0ℚᵘ} +-identityˡ-≡

+-identityʳ : RightIdentity _≃_ 0ℚᵘ _+_
+-identityʳ p = ≃-reflexive (+-identityʳ-≡ p)

+-identity-≡ : Identity _≡_ 0ℚᵘ _+_
+-identity-≡ = +-identityˡ-≡ , +-identityʳ-≡

+-identity : Identity _≃_ 0ℚᵘ _+_
+-identity = +-identityˡ , +-identityʳ

+-inverseˡ : LeftInverse _≃_ 0ℚᵘ -_ _+_
+-inverseˡ p = *≡* let n = ↥ p; d = ↧ p in
  ((ℤ.- n) ℤ.* d ℤ.+ n ℤ.* d) ℤ.* 1ℤ ≡⟨ ℤ.*-identityʳ ((ℤ.- n) ℤ.* d ℤ.+ n ℤ.* d) ⟩
  (ℤ.- n) ℤ.* d ℤ.+ n ℤ.* d          ≡˘⟨ cong (ℤ._+ (n ℤ.* d)) (ℤ.neg-distribˡ-* n d) ⟩
  ℤ.- (n ℤ.* d) ℤ.+ n ℤ.* d          ≡⟨ ℤ.+-inverseˡ (n ℤ.* d) ⟩
  0ℤ ∎ where open ≡-Reasoning

+-inverseʳ : RightInverse _≃_ 0ℚᵘ -_ _+_
+-inverseʳ p = *≡* let n = ↥ p; d = ↧ p in
  (n ℤ.* d ℤ.+ (ℤ.- n) ℤ.* d) ℤ.* 1ℤ ≡⟨ ℤ.*-identityʳ (n ℤ.* d ℤ.+ (ℤ.- n) ℤ.* d) ⟩
  n ℤ.* d ℤ.+ (ℤ.- n) ℤ.* d          ≡˘⟨ cong (λ n+d → n ℤ.* d ℤ.+ n+d) (ℤ.neg-distribˡ-* n d) ⟩
  n ℤ.* d ℤ.+ ℤ.- (n ℤ.* d)          ≡⟨ ℤ.+-inverseʳ (n ℤ.* d) ⟩
  0ℤ ∎ where open ≡-Reasoning

+-inverse : Inverse _≃_ 0ℚᵘ -_ _+_
+-inverse = +-inverseˡ , +-inverseʳ

-‿cong : Congruent₁ _≃_ (-_)
-‿cong {p} {q} (*≡* p≡q) = *≡* (begin
  ↥(- p) ℤ.* ↧ q             ≡˘⟨ ℤ.*-identityˡ (ℤ.-(↥ p) ℤ.* ↧ q) ⟩
  1ℤ ℤ.* (↥(- p) ℤ.* ↧ q)    ≡⟨ sym (ℤ.*-assoc 1ℤ (↥(- p)) (↧ q)) ⟩
  (1ℤ ℤ.* ℤ.-(↥ p)) ℤ.* ↧ q  ≡˘⟨ cong (ℤ._* ↧ q) (ℤ.neg-distribʳ-* 1ℤ (↥ p)) ⟩
  ℤ.-(1ℤ ℤ.* ↥ p) ℤ.* ↧ q    ≡⟨ cong (ℤ._* ↧ q) (ℤ.neg-distribˡ-* 1ℤ (↥ p)) ⟩
  ((ℤ.- 1ℤ) ℤ.* ↥ p) ℤ.* ↧ q ≡⟨ ℤ.*-assoc (ℤ.- 1ℤ) (↥ p) (↧ q) ⟩
  ℤ.- 1ℤ ℤ.* (↥ p ℤ.* ↧ q)   ≡⟨ cong (λ r → ℤ.- 1ℤ ℤ.* r) p≡q ⟩
  ℤ.- 1ℤ ℤ.* (↥ q ℤ.* ↧ p)   ≡⟨ sym (ℤ.*-assoc (ℤ.- 1ℤ) (↥ q) (↧ p)) ⟩
  (ℤ.- 1ℤ ℤ.* ↥ q) ℤ.* ↧ p   ≡˘⟨ cong (ℤ._* ↧ p) (ℤ.neg-distribˡ-* 1ℤ (↥ q)) ⟩
  ℤ.-(1ℤ ℤ.* ↥ q) ℤ.* ↧ p    ≡⟨ cong (ℤ._* ↧ p) (ℤ.neg-distribʳ-* 1ℤ (↥ q)) ⟩
  (1ℤ ℤ.* ↥(- q)) ℤ.* ↧ p    ≡⟨ ℤ.*-assoc 1ℤ (ℤ.-(↥ q)) (↧ p) ⟩
  1ℤ ℤ.* (↥(- q) ℤ.* ↧ p)    ≡⟨ ℤ.*-identityˡ (↥(- q) ℤ.* ↧ p) ⟩
  ↥(- q) ℤ.* ↧ p ∎) where open ≡-Reasoning

------------------------------------------------------------------------
-- Algebraic structures

+-isMagma : IsMagma _≃_ _+_
+-isMagma = record
  { isEquivalence = ≃-isEquivalence
  ; ∙-cong        = +-cong
  }

+-isSemigroup : IsSemigroup _≃_ _+_
+-isSemigroup = record
  { isMagma = +-isMagma
  ; assoc   = +-assoc
  }

+-0-isMonoid : IsMonoid _≃_ _+_ 0ℚᵘ
+-0-isMonoid = record
  { isSemigroup = +-isSemigroup
  ; identity    = +-identity
  }

+-0-isCommutativeMonoid : IsCommutativeMonoid _≃_ _+_ 0ℚᵘ
+-0-isCommutativeMonoid = record
  { isMonoid = +-0-isMonoid
  ; comm     = +-comm
  }

+-0-isGroup : IsGroup _≃_ _+_ 0ℚᵘ (-_)
+-0-isGroup = record
  { isMonoid = +-0-isMonoid
  ; inverse  = +-inverse
  ; ⁻¹-cong  = -‿cong
  }

+-0-isAbelianGroup : IsAbelianGroup _≃_ _+_ 0ℚᵘ (-_)
+-0-isAbelianGroup = record
  { isGroup = +-0-isGroup
  ; comm    = +-comm
  }

------------------------------------------------------------------------
-- Algebraic bundles

+-magma : Magma 0ℓ 0ℓ
+-magma = record
  { isMagma = +-isMagma
  }

+-semigroup : Semigroup 0ℓ 0ℓ
+-semigroup = record
  { isSemigroup = +-isSemigroup
  }

+-0-monoid : Monoid 0ℓ 0ℓ
+-0-monoid = record
  { isMonoid = +-0-isMonoid
  }

+-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
+-0-commutativeMonoid = record
  { isCommutativeMonoid = +-0-isCommutativeMonoid
  }

+-0-group : Group 0ℓ 0ℓ
+-0-group = record
  { isGroup = +-0-isGroup
  }

+-0-abelianGroup : AbelianGroup 0ℓ 0ℓ
+-0-abelianGroup = record
  { isAbelianGroup = +-0-isAbelianGroup
  }

------------------------------------------------------------------------
-- Properties of _*_
------------------------------------------------------------------------

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

*-rawMagma : RawMagma 0ℓ 0ℓ
*-rawMagma = record
  { _≈_ = _≃_
  ; _∙_ = _*_
  }

*-rawMonoid : RawMonoid 0ℓ 0ℓ
*-rawMonoid = record
  { _≈_ = _≃_
  ; _∙_ = _*_
  ; ε   = 1ℚᵘ
  }

------------------------------------------------------------------------
-- Algebraic properties

*-cong : Congruent₂ _≃_ _*_
*-cong {x} {y} {u} {v} (*≡* ↥x↧y≡↥y↧x) (*≡* ↥u↧v≡↥v↧u) = *≡* (begin
  (↥ x ℤ.* ↥ u) ℤ.* (↧ y ℤ.* ↧ v) ≡⟨ solve 4 (λ ↥x ↥u ↧y ↧v →
                                       (↥x :* ↥u) :* (↧y :* ↧v) :=
                                       (↥u :* ↧v) :* (↥x :* ↧y))
                                       refl (↥ x) (↥ u) (↧ y) (↧ v) ⟩
  (↥ u ℤ.* ↧ v) ℤ.* (↥ x ℤ.* ↧ y) ≡⟨ cong₂ ℤ._*_ ↥u↧v≡↥v↧u ↥x↧y≡↥y↧x ⟩
  (↥ v ℤ.* ↧ u) ℤ.* (↥ y ℤ.* ↧ x) ≡⟨ solve 4 (λ ↥v ↧u ↥y ↧x →
                                       (↥v :* ↧u) :* (↥y :* ↧x) :=
                                       (↥y :* ↥v) :* (↧x :* ↧u))
                                       refl (↥ v) (↧ u) (↥ y) (↧ x) ⟩
  (↥ y ℤ.* ↥ v) ℤ.* (↧ x ℤ.* ↧ u) ∎)
  where open ≡-Reasoning; open ℤ-solver

-- Associativity

*-assoc-↥ : Associative (_≡_ on ↥_) _*_
*-assoc-↥ p q r = ℤ.*-assoc (↥ p) (↥ q) (↥ r)

*-assoc-↧ : Associative (_≡_ on ↧ₙ_) _*_
*-assoc-↧ p q r = ℕ.*-assoc (↧ₙ p) (↧ₙ q) (↧ₙ r)

*-assoc-≡ : Associative _≡_ _*_
*-assoc-≡ p q r = ↥↧≡⇒≡ (*-assoc-↥ p q r) (*-assoc-↧ p q r)

*-assoc : Associative _≃_ _*_
*-assoc p q r = ≃-reflexive (*-assoc-≡ p q r)

-- Commutativity

*-comm-↥ : Commutative (_≡_ on ↥_) _*_
*-comm-↥ p q = ℤ.*-comm (↥ p) (↥ q)

*-comm-↧ : Commutative (_≡_ on ↧ₙ_) _*_
*-comm-↧ p q = ℕ.*-comm (↧ₙ p) (↧ₙ q)

*-comm-≡ : Commutative _≡_ _*_
*-comm-≡ p q = ↥↧≡⇒≡ (*-comm-↥ p q) (*-comm-↧ p q)

*-comm : Commutative _≃_ _*_
*-comm p q = ≃-reflexive (*-comm-≡ p q)

-- Identities

*-identityˡ-≡ : LeftIdentity _≡_ 1ℚᵘ _*_
*-identityˡ-≡ p = ↥↧≡⇒≡ (ℤ.*-identityˡ (↥ p)) (ℕ.+-identityʳ (↧ₙ p))

*-identityʳ-≡ : RightIdentity _≡_ 1ℚᵘ _*_
*-identityʳ-≡ = comm+idˡ⇒idʳ *-comm-≡ {e = 1ℚᵘ} *-identityˡ-≡

*-identity-≡ : Identity _≡_ 1ℚᵘ _*_
*-identity-≡ = *-identityˡ-≡ , *-identityʳ-≡

*-identityˡ : LeftIdentity _≃_ 1ℚᵘ _*_
*-identityˡ p = ≃-reflexive (*-identityˡ-≡ p)

*-identityʳ : RightIdentity _≃_ 1ℚᵘ _*_
*-identityʳ p = ≃-reflexive (*-identityʳ-≡ p)

*-identity : Identity _≃_ 1ℚᵘ _*_
*-identity = *-identityˡ , *-identityʳ

*-zeroˡ : LeftZero _≃_ 0ℚᵘ _*_
*-zeroˡ p = *≡* refl

*-zeroʳ : RightZero _≃_ 0ℚᵘ _*_
*-zeroʳ = FC.comm+zeˡ⇒zeʳ ≃-setoid *-comm *-zeroˡ

*-zero : Zero _≃_ 0ℚᵘ _*_
*-zero = *-zeroˡ , *-zeroʳ

*-distribˡ-+ : _DistributesOverˡ_ _≃_ _*_ _+_
*-distribˡ-+ p q r =
  let ↥p = ↥ p; ↧p = ↧ p
      ↥q = ↥ q; ↧q = ↧ q
      ↥r = ↥ r; ↧r = ↧ r
      eq : (↥p ℤ.* (↥q ℤ.* ↧r ℤ.+ ↥r ℤ.* ↧q)) ℤ.* (↧p ℤ.* ↧q ℤ.* (↧p ℤ.* ↧r)) ≡
           (↥p ℤ.* ↥q ℤ.* (↧p ℤ.* ↧r) ℤ.+ ↥p ℤ.* ↥r ℤ.* (↧p ℤ.* ↧q)) ℤ.* (↧p ℤ.* (↧q ℤ.* ↧r))
      eq = solve 6 (λ ↥p ↧p ↥q d e f →
           (↥p :* (↥q :* f :+ e :* d)) :* (↧p :* d :* (↧p :* f)) :=
           (↥p :* ↥q :* (↧p :* f) :+ ↥p :* e :* (↧p :* d)) :* (↧p :* (d :* f)))
           refl ↥p ↧p ↥q ↧q ↥r ↧r
  in *≡* eq where open ℤ-solver

*-distribʳ-+ : _DistributesOverʳ_ _≃_ _*_ _+_
*-distribʳ-+ = FC.comm+distrˡ⇒distrʳ ≃-setoid +-cong *-comm *-distribˡ-+

*-distrib-+ : _DistributesOver_ _≃_ _*_ _+_
*-distrib-+ = *-distribˡ-+ , *-distribʳ-+

------------------------------------------------------------------------
-- Algebraic structures

*-isMagma : IsMagma _≃_ _*_
*-isMagma = record
  { isEquivalence = ≃-isEquivalence
  ; ∙-cong        = *-cong
  }

*-isSemigroup : IsSemigroup _≃_ _*_
*-isSemigroup = record
  { isMagma = *-isMagma
  ; assoc   = *-assoc
  }

*-1-isMonoid : IsMonoid _≃_ _*_ 1ℚᵘ
*-1-isMonoid = record
  { isSemigroup = *-isSemigroup
  ; identity    = *-identity
  }

*-1-isCommutativeMonoid : IsCommutativeMonoid _≃_ _*_ 1ℚᵘ
*-1-isCommutativeMonoid = record
  { isMonoid = *-1-isMonoid
  ; comm     = *-comm
  }

+-*-isRing : IsRing _≃_ _+_ _*_ -_ 0ℚᵘ 1ℚᵘ
+-*-isRing = record
  { +-isAbelianGroup = +-0-isAbelianGroup
  ; *-isMonoid       = *-1-isMonoid
  ; distrib          = *-distrib-+
  ; zero             = *-zero
  }

+-*-isCommutativeRing : IsCommutativeRing _≃_ _+_ _*_ -_ 0ℚᵘ 1ℚᵘ
+-*-isCommutativeRing = record
  { isRing = +-*-isRing
  ; *-comm = *-comm
  }

------------------------------------------------------------------------
-- Algebraic bundles

*-magma : Magma 0ℓ 0ℓ
*-magma = record
  { isMagma = *-isMagma
  }

*-semigroup : Semigroup 0ℓ 0ℓ
*-semigroup = record
  { isSemigroup = *-isSemigroup
  }

*-1-monoid : Monoid 0ℓ 0ℓ
*-1-monoid = record
  { isMonoid = *-1-isMonoid
  }

*-1-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
*-1-commutativeMonoid = record
  { isCommutativeMonoid = *-1-isCommutativeMonoid
  }

+-*-ring : Ring 0ℓ 0ℓ
+-*-ring = record
  { isRing = +-*-isRing
  }

+-*-commutativeRing : CommutativeRing 0ℓ 0ℓ
+-*-commutativeRing = record
  { isCommutativeRing = +-*-isCommutativeRing
  }


module Everything where
open import Pi.Everything       -- Formalization for Π
open import RevMachine          -- Formalization of reversible machine and partial reversible machine
open import RevNoRepeat         -- Non-repeating theorem for reversible machine
open import PartialRevNoRepeat  -- Non-repeating theorem for partial reversible machine
open import TimeSpace           -- Time space trade-off
open import Pi-.Everything      -- Formalization for Π⁻
open import PiFrac.Everything   -- Formalization for Π/
open import PiQ.Everything      -- Formalization for Π^ℚ


{-# OPTIONS --without-K  #-}
module sets.nat.solver where

open import decidable
open import equality
open import function.core
  hiding (const)
open import sets.nat.core
open import sets.nat.properties
open import sets.nat.ordering
open import sets.fin.core
  hiding (_≟_)
open import sets.vec.core
open import sets.vec.dependent

data Exp (n : ℕ) : Set where
  var : Fin n → Exp n
  const : ℕ → Exp n
  _:+_ : Exp n → Exp n → Exp n
infixl 6 _:+_

eval : ∀ {n} → (Fin n → ℕ) → Exp n → ℕ
eval env (var i) = env i
eval env (const x) = x
eval env (e₁ :+ e₂) = eval env e₁ + eval env e₂

NF : ℕ → Set
NF n = Vec ℕ n

evalNF' : ∀ {n} → (Fin n → ℕ) → NF n → ℕ
evalNF' _ [] = 0
evalNF' env (x ∷ xs) = x * env zero + evalNF' (env ∘' suc) xs

evalNF : ∀ {n} → (Fin n → ℕ) → NF (suc n) → ℕ
evalNF env xs = evalNF' (1 ∷∷ env) xs

decNF : ∀ {n}(xs ys : NF n) → Dec (xs ≡ ys)
decNF [] [] = yes refl
decNF (x ∷ xs) (y ∷ ys) with x ≟ y | decNF xs ys
decNF (x ∷ xs) (y ∷ ys) | _ | no u = no λ p → u (ap tail p)
decNF (x ∷ xs) (y ∷ ys) | no u | _ = no λ p → u (ap head p)
decNF (x ∷ xs) (y ∷ ys) | yes p | yes q = yes (ap₂ _∷_ p q)

emptyNF : ∀ {n} → NF n
emptyNF {zero} = []
emptyNF {suc n} = 0 ∷ emptyNF

eval-emptyNF : ∀ {n}(env : Fin n → ℕ) → evalNF' env emptyNF ≡ 0
eval-emptyNF {zero} env = refl
eval-emptyNF {suc n} env = eval-emptyNF {n} (env ∘' suc)

δ : ∀ {n} → Fin n → ℕ → NF n
δ zero val = val ∷ emptyNF
δ (suc i) val = 0 ∷ δ i val

eval-δ : ∀ {n}(i : Fin n)(val : ℕ)
       → (env : Fin n → ℕ)
       → evalNF' env (δ i val) ≡ val * env i
eval-δ zero val env = ap (_+_ (val * env zero)) (eval-emptyNF env)
                    · +-right-unit _
eval-δ (suc i) val env = eval-δ i val (env ∘' suc)

_+NF_ : ∀ {n} → NF n → NF n → NF n
[] +NF [] = []
(x ∷ xs) +NF (y ∷ ys) = (x + y) ∷ (xs +NF ys)

eval+NF : ∀ {n}(xs ys : NF n)(env : Fin n → ℕ)
        → evalNF' env (xs +NF ys)
        ≡ evalNF' env xs + evalNF' env ys
eval+NF [] [] env = refl
eval+NF (x ∷ xs) (y ∷ ys) env
  = ap₂ _+_ (right-distr x y (env zero)) (eval+NF xs ys (env ∘' suc))
  · lem (x * env zero) (y * env zero) (evalNF' (env ∘' suc) xs) (evalNF' (env ∘' suc) ys)
  where
    lem : ∀ a b c d → (a + b) + (c + d) ≡ (a + c) + (b + d)
    lem a b c d
      = +-associativity a b (c + d)
      · ap (_+_ a) (sym (+-associativity b c d))
      · ap (λ z → a + (z + d)) (+-commutativity b c)
      · ap (_+_ a) (+-associativity c b d)
      · sym (+-associativity a c (b + d))

nf : ∀ {n} → Exp n → NF (suc n)
nf (var i) = δ (suc i) 1
nf (const k) = δ zero k
nf (e₁ :+ e₂) = nf e₁ +NF nf e₂

nf-sound : ∀ {n}(env : Fin n → ℕ)(e : Exp n)
         → evalNF env (nf e) ≡ eval env e
nf-sound env (var i) = eval-δ i 1 env · +-right-unit (env i)
nf-sound env (const x) = ap (_+_ (x * 1)) (eval-emptyNF env)
                       · +-right-unit (x * 1)
                       · *-right-unit x
nf-sound env (e₁ :+ e₂) = eval+NF (nf e₁) (nf e₂) (1 ∷∷ env)
                        · ap₂ _+_ (nf-sound env e₁) (nf-sound env e₂)

HOTerm : ℕ → ℕ → Set
HOTerm n zero = Exp n
HOTerm n (suc i) = Exp n → HOTerm n i

private
  exp' : (n i : ℕ) → i ≤ n → HOTerm n i → (Fin i → Exp n) → Exp n
  exp' _ zero _ e _ = e
  exp' zero (suc i) () e f
  exp' (suc n) (suc i) p e f = exp' (suc n) i (trans≤ suc≤ p) (e (f zero)) (f ∘' suc)

exp : ∀ {n} → HOTerm n n → Exp n
exp {n} e = exp' n n refl≤ e var

solve : ∀ n (e₁ e₂ : Exp n){t : True (decNF (nf e₁) (nf e₂))}
      → (env : Fin n → ℕ)
      → eval env e₁ ≡ eval env e₂
solve n e₁ e₂ {t} env = sym (nf-sound env e₁)
                      · ap (evalNF env) (witness t)
                      · nf-sound env e₂


------------------------------------------------------------------------
-- The syntax of, and a type system for, the untyped λ-calculus with
-- constants
------------------------------------------------------------------------

module Lambda.Syntax where

open import Codata.Musical.Notation
open import Data.Nat
open import Data.Fin hiding (_≤?_)
open import Data.Vec
open import Relation.Nullary.Decidable

------------------------------------------------------------------------
-- Terms

-- Variables are represented using de Bruijn indices.

infixl 9 _·_

data Tm (n : ℕ) : Set where
  con : (i : ℕ) → Tm n
  var : (x : Fin n) → Tm n
  ƛ   : (t : Tm (suc n)) → Tm n
  _·_ : (t₁ t₂ : Tm n) → Tm n

-- Convenient helper.

vr : ∀ m {n} {m<n : True (suc m ≤? n)} → Tm n
vr _ {m<n = m<n} = var (#_ _ {m<n = m<n})

------------------------------------------------------------------------
-- Values, potentially with free variables

module WHNF where

  data Value (n : ℕ) : Set where
    con : (i : ℕ) → Value n
    ƛ   : (t : Tm (suc n)) → Value n

  ⌜_⌝ : ∀ {n} → Value n → Tm n
  ⌜ con i ⌝ = con i
  ⌜ ƛ t   ⌝ = ƛ t

------------------------------------------------------------------------
-- Closure-based definition of values

-- Environments and values. Defined in a module parametrised on the
-- type of terms.

module Closure (Tm : ℕ → Set) where

  mutual

    -- Environments.

    Env : ℕ → Set
    Env n = Vec Value n

    -- Values. Lambdas are represented using closures, so values do
    -- not contain any free variables.

    data Value : Set where
      con : (i : ℕ) → Value
      ƛ   : ∀ {n} (t : Tm (suc n)) (ρ : Env n) → Value

------------------------------------------------------------------------
-- Type system (following Leroy and Grall)

-- Recursive, simple types, defined coinductively.

infixr 8 _⇾_

data Ty : Set where
  nat : Ty
  _⇾_ : (σ τ : ∞ Ty) → Ty

-- Contexts.

Ctxt : ℕ → Set
Ctxt n = Vec Ty n

-- Type system.

infix 4 _⊢_∈_

data _⊢_∈_ {n} (Γ : Ctxt n) : Tm n → Ty → Set where
  con : ∀ {i} → Γ ⊢ con i ∈ nat
  var : ∀ {x} → Γ ⊢ var x ∈ lookup Γ x
  ƛ   : ∀ {t σ τ} (t∈ : ♭ σ ∷ Γ ⊢ t ∈ ♭ τ) → Γ ⊢ ƛ t ∈ σ ⇾ τ
  _·_ : ∀ {t₁ t₂ σ τ} (t₁∈ : Γ ⊢ t₁ ∈ σ ⇾ τ) (t₂∈ : Γ ⊢ t₂ ∈ ♭ σ) →
        Γ ⊢ t₁ · t₂ ∈ ♭ τ

------------------------------------------------------------------------
-- Example

-- A non-terminating term.

ω : Tm 0
ω = ƛ (vr 0 · vr 0)

Ω : Tm 0
Ω = ω · ω

-- Ω is well-typed.

Ω-well-typed : (τ : Ty) → [] ⊢ Ω ∈ τ
Ω-well-typed τ =
  _·_ {σ = ♯ σ} {τ = ♯ τ} (ƛ (var · var)) (ƛ (var · var))
  where σ = ♯ σ ⇾ ♯ τ

-- A call-by-value fix-point combinator.

Z : Tm 0
Z = ƛ (t · t)
  where t = ƛ (vr 1 · ƛ (vr 1 · vr 1 · vr 0))

-- This combinator is also well-typed.

fix-well-typed :
  ∀ {σ τ} → [] ⊢ Z ∈ ♯ (♯ (σ ⇾ τ) ⇾ ♯ (σ ⇾ τ)) ⇾ ♯ (σ ⇾ τ)
fix-well-typed =
  ƛ (_·_ {σ = υ} {τ = ♯ _}
         (ƛ (var · ƛ (var · var · var)))
         (ƛ (var · ƛ (var · var · var))))
  where
  υ : ∞ Ty
  υ = ♯ (υ ⇾ ♯ _)


module Prelude.Nat where

open import Prelude.Unit
open import Prelude.Empty
open import Prelude.Bool
open import Prelude.Decidable
open import Prelude.Equality
open import Prelude.Equality.Unsafe using (eraseEquality)
open import Prelude.Ord
open import Prelude.Number
open import Prelude.Semiring
open import Prelude.Function
open import Prelude.Smashed

open import Prelude.Nat.Properties
open import Prelude.Nat.Core public

--- Equality ---

private
  eqNatSound : ∀ n m → IsTrue (eqNat n m) → n ≡ m
  eqNatSound zero zero _ = refl
  eqNatSound zero (suc m) ()
  eqNatSound (suc n) zero ()
  eqNatSound (suc n) (suc m) p rewrite eqNatSound n m p = refl

  eqNatComplete : ∀ n m → IsFalse (eqNat n m) → ¬ (n ≡ m)
  eqNatComplete zero zero () eq
  eqNatComplete zero (suc m) neq ()
  eqNatComplete (suc n) zero neq ()
  eqNatComplete (suc n) (suc m) neq eq = eqNatComplete n m neq (suc-inj eq)

  decEqNat : (n m : Nat) → Dec (n ≡ m)
  decEqNat n m with eqNat n m | eqNatSound n m | eqNatComplete n m
  ... | true  | eq | _   = yes (eraseEquality (eq true))
  ... | false | _  | neq = no  (eraseNegation (neq false))
  {-# INLINE decEqNat #-}

instance
  EqNat : Eq Nat
  _==_ {{EqNat}} = decEqNat

--- Comparison ---

data LessNat n m : Set where
  diff : ∀ k (eq : m ≡ suc k +N n) → LessNat n m

{-# DISPLAY LessNat a b = a < b #-}

pattern diff! k = diff k refl

private
  lemLessNatMinus : ∀ n m → IsTrue (lessNat n m) → m ≡ suc (m - suc n) + n
  lemLessNatMinus  _       zero  ()
  lemLessNatMinus  zero   (suc m) _   = sym (suc $≡ add-zero-r m)
  lemLessNatMinus (suc n) (suc m) n<m = suc $≡ (lemLessNatMinus n m n<m ⟨≡⟩ʳ add-suc-r (m - suc n) n)

  lemNoLessEqual : ∀ n m → ¬ IsTrue (lessNat n m) → ¬ IsTrue (lessNat m n) → n ≡ m
  lemNoLessEqual zero zero _ _ = refl
  lemNoLessEqual zero (suc m) h₁ h₂ = ⊥-elim (h₁ true)
  lemNoLessEqual (suc n) zero h₁ h₂ = ⊥-elim (h₂ true)
  lemNoLessEqual (suc n) (suc m) h₁ h₂ = cong suc (lemNoLessEqual n m h₁ h₂)

  -- Using eraseEquality here lets us not worry about the performance of the
  -- proofs.
  compareNat : ∀ n m → Comparison LessNat n m
  compareNat n m with decBool (lessNat n m)
  ... | yes p = less (diff (m - suc n) (eraseEquality (lemLessNatMinus n m p)))
  ... | no np₁ with decBool (lessNat m n)
  ...             | yes p  = greater (diff (n - suc m) (eraseEquality (lemLessNatMinus m n p)))
  ...             | no np₂ = equal (eraseEquality (lemNoLessEqual n m np₁ np₂))
  {-# INLINE compareNat #-}

private
  nat-lt-to-leq : ∀ {x y} → LessNat x y → LessNat x (suc y)
  nat-lt-to-leq (diff k eq) = diff (suc k) (cong suc eq)

  nat-eq-to-leq : ∀ {x y} → x ≡ y → LessNat x (suc y)
  nat-eq-to-leq eq = diff 0 (cong suc (sym eq))

  nat-from-leq : ∀ {x y} → LessNat x (suc y) → LessEq LessNat x y
  nat-from-leq (diff zero eq)    = equal (sym (suc-inj eq))
  nat-from-leq (diff (suc k) eq) = less (diff k (suc-inj eq))

  nat-lt-antirefl : ∀ {a} → LessNat a a → ⊥
  nat-lt-antirefl {a} (diff k eq) = case add-inj₁ 0 (suc k) a eq of λ ()

  nat-lt-antisym : ∀ {a b} → LessNat a b → LessNat b a → ⊥
  nat-lt-antisym {a} (diff! k) (diff j eq) =
    case add-inj₁ 0 (suc j + suc k) a (eq ⟨≡⟩ suc $≡ add-assoc j (suc k) a) of λ ()

  nat-lt-trans : ∀ {a b c} → LessNat a b → LessNat b c → LessNat a c
  nat-lt-trans (diff k eq) (diff j eq₁) = diff (j + suc k) (eraseEquality
    (case eq of λ where refl → case eq₁ of λ where refl → add-assoc (suc j) (suc k) _))

instance
  OrdNat : Ord Nat
  Ord._<_         OrdNat = LessNat
  Ord._≤_         OrdNat a b = LessNat a (suc b)
  Ord.compare     OrdNat = compareNat
  Ord.eq-to-leq   OrdNat = nat-eq-to-leq
  Ord.lt-to-leq   OrdNat = nat-lt-to-leq
  Ord.leq-to-lteq OrdNat = nat-from-leq

  OrdNatLaws : Ord/Laws Nat
  Ord/Laws.super OrdNatLaws = it
  less-antirefl {{OrdNatLaws}} = nat-lt-antirefl
  less-trans    {{OrdNatLaws}} = nat-lt-trans

instance
  SmashedNatLess : {a b : Nat} → Smashed (a < b)
  smashed {{SmashedNatLess}} {diff! k} {diff k₁ eq} with add-inj₁ (suc k) (suc k₁) _ eq | eq
  ... | refl | refl = refl

  SmashedNatComp : {a b : Nat} → Smashed (Comparison _<_ a b)
  smashed {{SmashedNatComp}} {less _    } {less _    } = less $≡ smashed
  smashed {{SmashedNatComp}} {less lt   } {equal refl} = ⊥-elim (less-antirefl {A = Nat} lt)
  smashed {{SmashedNatComp}} {less lt   } {greater gt} = ⊥-elim (less-antisym  {A = Nat} lt gt)
  smashed {{SmashedNatComp}} {equal refl} {less lt   } = ⊥-elim (less-antirefl {A = Nat} lt)
  smashed {{SmashedNatComp}} {equal _   } {equal _   } = equal $≡ smashed
  smashed {{SmashedNatComp}} {equal refl} {greater gt} = ⊥-elim (less-antirefl {A = Nat} gt)
  smashed {{SmashedNatComp}} {greater gt} {less lt   } = ⊥-elim (less-antisym  {A = Nat} lt gt)
  smashed {{SmashedNatComp}} {greater gt} {equal refl} = ⊥-elim (less-antirefl {A = Nat} gt)
  smashed {{SmashedNatComp}} {greater _ } {greater _ } = greater $≡ smashed

suc-monotone : {a b : Nat} → a < b → Nat.suc a < suc b
suc-monotone (diff! k) = diff k (sym (add-suc-r (suc k) _))

inv-suc-monotone : ∀{t v} → suc t < suc v → t < v
inv-suc-monotone (diff! k) = diff k (add-suc-r k _)

suc-comparison : {a b : Nat} → Comparison _<_ a b → Comparison _<_ (Nat.suc a) (suc b)
suc-comparison (less lt)    = less    (suc-monotone lt)
suc-comparison (equal eq)   = equal   (suc $≡ eq)
suc-comparison (greater gt) = greater (suc-monotone gt)


{-# OPTIONS --safe #-}
module Cubical.HITs.CumulativeHierarchy where

open import Cubical.HITs.CumulativeHierarchy.Base public
  hiding (elim; elimProp)
open import Cubical.HITs.CumulativeHierarchy.Properties public
open import Cubical.HITs.CumulativeHierarchy.Constructions public


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Implementation.Relation.Boolean where

open import Light.Library.Data.Boolean as Boolean using (Boolean)
open import Light.Package using (Package)
open import Light.Level using (_⊔_ ; Lifted)
open import Light.Variable.Levels
open import Light.Variable.Sets
open import Light.Library.Data.Unit as Unit using (Unit ; unit)
open import Light.Library.Data.Empty as Empty using (Empty)
open import Light.Library.Relation using (Style)
open import Light.Implementation.Data.Boolean
open import Light.Implementation.Data.Unit
open import Light.Implementation.Data.Empty

instance relation : Style record { Proposition = λ _ → Boolean ; Index = Unit }
relation = record { Implementation }
      where
      module Implementation where
            open Boolean using (true ; false ; ¬_ ; _∧_ ; _∨_ ; _⇢_) public

            True = Boolean.if_then Unit else Empty
            False = Boolean.if_then Empty else Unit


module Bad where

data Bool : Set where
  false : Bool
  true  : Bool

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

F : Bool -> Set
F false = Bool
F true  = Nat

cast : {x : Bool} -> F x -> F x
cast a = a

not : Bool -> Bool
not true  = false
not false = true

oops : Bool
oops = not (cast zero)


module DynTheory where

open import Prelude
open import T

---- Some theory about the dynamic semantics

module DynTheory where

  -- prove some obvious theorems about iterated stepping
  -- transitivity (which makes sense, given that it is the transitive closure)
  eval-trans : ∀{A} {e e' e'' : TCExp A} →
                e ~>* e' → e' ~>* e'' → e ~>* e''
  eval-trans eval-refl E2 = E2
  eval-trans (eval-cons S1 E1') E2 = eval-cons S1 (eval-trans E1' E2)

  -- prove that we can life any compatibility rule from steps to eval
  eval-compat : ∀{A B} {P : TCExp A -> TCExp B} →
                 (∀{e e'} → (e ~> e' → P e ~> P e')) →
                 {e e' : TCExp A} → e ~>* e' → P e ~>* P e'
  eval-compat f eval-refl = eval-refl
  eval-compat f (eval-cons S1 D) = eval-cons (f S1) (eval-compat f D)

  -- Lemma we need to prove determism
  not-val-and-step : ∀{C : Set} {A : TTp} {e e' : TCExp A} →
                     TVal e → e ~> e' →
                     C
  not-val-and-step val-zero ()
  not-val-and-step val-lam ()
  not-val-and-step (val-suc v) (step-suc S1) = not-val-and-step v S1

  -- Show that the dynamic semantics are a function
  step-deterministic : ∀{A} → (e : TCExp A) → {e' e'' : TCExp A} →
                       e ~> e' → e ~> e'' ->
                       e' ≡ e''
  -- Trivial contradictory cases
  step-deterministic (var x) () S2
  step-deterministic (Λ e) () S2
  step-deterministic zero () S2
  step-deterministic (Λ e $ e') step-beta (step-app-l ())
  step-deterministic (Λ e $ e') (step-app-l ()) step-beta
  step-deterministic (rec .zero e'' e₂) (step-rec ()) step-rec-z
  step-deterministic (rec zero e₀ es) step-rec-z (step-rec ())

  -- Nontrival contradictory cases
  step-deterministic (rec (suc e) e₁ e₂) (step-rec (step-suc S1)) (step-rec-s v) = not-val-and-step v S1
  step-deterministic (rec (suc e) e₁ e₂) (step-rec-s v) (step-rec (step-suc S2)) = not-val-and-step v S2

  -- Normal cases
  step-deterministic (e $ e') (step-app-l S1) (step-app-l S2) =
                   resp (λ x → x $ e') (step-deterministic e S1 S2)
  step-deterministic (Λ e $ e') step-beta step-beta = Refl
  step-deterministic (suc e) (step-suc S1) (step-suc S2) = resp suc (step-deterministic e S1 S2)
  step-deterministic (rec e e₁ e₂) (step-rec S1) (step-rec S2) =
                    resp (λ x → rec x e₁ e₂) (step-deterministic e S1 S2)
  step-deterministic (rec zero _ _) step-rec-z step-rec-z = Refl
  step-deterministic (rec (suc e) e₁ e₂) (step-rec-s x) (step-rec-s x₁) = Refl

  -- Prove that if we evaluate to two expressions, and one is a value,
  -- then the other evaluates to it.
  eval-finish : ∀{A} → {e : TCExp A} → {e' e'' : TCExp A} →
                e ~>* e' → e ~>* e'' →
                TVal e'' →
                e' ~>* e''
  eval-finish eval-refl E2 v = E2
  eval-finish (eval-cons S1 E1) eval-refl v = not-val-and-step v S1
  eval-finish (eval-cons S1 E1) (eval-cons S2 E2) v with step-deterministic _ S1 S2
  ... | Refl = eval-finish E1 E2 v

  -- Prove that if we evaluate to two values, they are the same
  eval-deterministic : ∀{A} → {e : TCExp A} → {e' e'' : TCExp A} →
                       e ~>* e' → e ~>* e'' →
                       TVal e' → TVal e'' →
                       e' ≡ e''
  eval-deterministic E1 E2 v1 v2 with eval-finish E1 E2 v2
  ... | eval-refl = Refl
  ... | eval-cons S1 _ = not-val-and-step v1 S1

open DynTheory public


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

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

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

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

private
  variable
    o ℓ e : Level

module Yoneda (C : Category o ℓ e) where
  open Category C
  open HomReasoning
  open MR C
  open Functor
  open NaturalTransformation
  open NT-Hom C
  private
    module CE = Category.Equiv C
    module C = Category C

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

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

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

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

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

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

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

  module yoneda = NaturalIsomorphism yoneda


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category
open import Categories.Object.BinaryProducts
open import Categories.Object.Exponentiating

module Categories.Object.Exponentiating.Functor {o ℓ e}
    (C : Category o ℓ e)
    (binary : BinaryProducts C)
    (Σ : Category.Obj C)
    (exponentiating : Exponentiating C binary Σ) where

open Category C
open BinaryProducts binary
open Exponentiating exponentiating

open Equiv
open HomReasoning

import Categories.Object.Product.Morphisms
open Categories.Object.Product.Morphisms C

open import Categories.Functor
  using (Functor; Contravariant)
  renaming (_∘_ to _∘F_)

Σ↑-Functor : Contravariant C C
Σ↑-Functor = record
    { F₀            =  Σ↑_
    ; F₁            = [Σ↑_]
    ; identity      = identity
    ; homomorphism  = homomorphism
    ; F-resp-≡      = F-resp-≡
    }
    where
        .identity : ∀ {A} → [Σ↑ id {A} ] ≡ id
        identity {A} =
            begin
                λ-abs A (eval ∘ second id)
            ↓⟨ λ-cong (∘-resp-≡ refl (id⁂id product)) ⟩
                λ-abs A (eval ∘ id)
            ↓⟨ λ-cong identityʳ ⟩
                λ-abs A eval
            ↓⟨ λ-η-id ⟩
                id
            ∎

        .homomorphism : ∀ {X Y Z}
            {f : X ⇒ Y} {g : Y ⇒ Z}
            → [Σ↑ (g ∘ f) ] ≡ [Σ↑ f ] ∘ [Σ↑ g ]
        homomorphism {X}{Y}{Z}{f}{g} =
            begin
                λ-abs X (eval ∘ second (g ∘ f))
            ↑⟨ λ-cong (refl ⟩∘⟨ second∘second) ⟩
                λ-abs X (eval ∘ second g ∘ second f)
            ↑⟨ λ-cong assoc  ⟩
                λ-abs X ((eval ∘ second g) ∘ second f)
            ↓⟨ λ-distrib ⟩
                λ-abs X (eval ∘ second f)
                    ∘
                λ-abs Y (eval ∘ second g)
            ∎

        .F-resp-≡ : ∀ {A B}{f g : A ⇒ B }
            → f ≡ g → [Σ↑ f ] ≡ [Σ↑ g ]
        F-resp-≡ {A}{B}{f}{g} f≡g =
            begin
                λ-abs A (eval ∘ second f)
            ↓⟨ λ-cong (refl ⟩∘⟨ ⟨⟩-cong₂ refl (f≡g ⟩∘⟨ refl)) ⟩
                λ-abs A (eval ∘ second g)
            ∎

Σ²-Functor : Functor C C
Σ²-Functor = Σ↑-Functor ∘F Functor.op Σ↑-Functor