```------------------------------------------------------------------------
-- Some algebraic structures (not packed up with sets, operations,
-- etc.)
------------------------------------------------------------------------

open import Relation.Binary

module Algebra.Structures where

import Algebra.FunctionProperties as FunctionProperties
open FunctionProperties using (Op₁; Op₂)
import Relation.Binary.EqReasoning as EqR
open import Data.Function
open import Data.Product

------------------------------------------------------------------------
-- One binary operation

record IsSemigroup {A} (≈ : Rel A) (∙ : Op₂ A) : Set where
open FunctionProperties ≈
field
isEquivalence : IsEquivalence ≈
assoc         : Associative ∙
∙-pres-≈      : ∙ Preserves₂ ≈ ⟶ ≈ ⟶ ≈

open IsEquivalence isEquivalence public

record IsMonoid {A} (≈ : Rel A) (∙ : Op₂ A) (ε : A) : Set where
open FunctionProperties ≈
field
isSemigroup : IsSemigroup ≈ ∙
identity    : Identity ε ∙

open IsSemigroup isSemigroup public

record IsCommutativeMonoid
{A} (≈ : Rel A) (∙ : Op₂ A) (ε : A) : Set where
open FunctionProperties ≈
field
isMonoid : IsMonoid ≈ ∙ ε
comm     : Commutative ∙

open IsMonoid isMonoid public

record IsGroup
{A} (≈ : Rel A) (_∙_ : Op₂ A) (ε : A) (_⁻¹ : Op₁ A) : Set where
open FunctionProperties ≈
infixl 7 _-_
field
isMonoid  : IsMonoid ≈ _∙_ ε
inverse   : Inverse ε _⁻¹ _∙_
⁻¹-pres-≈ : _⁻¹ Preserves ≈ ⟶ ≈

open IsMonoid isMonoid public

_-_ : Op₂ A
x - y = x ∙ (y ⁻¹)

record IsAbelianGroup
{A} (≈ : Rel A) (∙ : Op₂ A) (ε : A) (⁻¹ : Op₁ A) : Set where
open FunctionProperties ≈
field
isGroup : IsGroup ≈ ∙ ε ⁻¹
comm    : Commutative ∙

open IsGroup isGroup public

isCommutativeMonoid : IsCommutativeMonoid ≈ ∙ ε
isCommutativeMonoid = record
{ isMonoid = isMonoid
; comm     = comm
}

------------------------------------------------------------------------
-- Two binary operations

record IsNearSemiring {A} (≈ : Rel A) (+ * : Op₂ A) (0# : A) : Set where
open FunctionProperties ≈
field
+-isMonoid    : IsMonoid ≈ + 0#
*-isSemigroup : IsSemigroup ≈ *
distribʳ      : * DistributesOverʳ +
zeroˡ         : LeftZero 0# *

open IsMonoid +-isMonoid public
renaming ( assoc       to +-assoc
; ∙-pres-≈    to +-pres-≈
; isSemigroup to +-isSemigroup
; identity    to +-identity
)

open IsSemigroup *-isSemigroup public
using ()
renaming ( assoc    to *-assoc
; ∙-pres-≈ to *-pres-≈
)

record IsSemiringWithoutOne
{A} (≈ : Rel A) (+ * : Op₂ A) (0# : A) : Set where
open FunctionProperties ≈
field
+-isCommutativeMonoid : IsCommutativeMonoid ≈ + 0#
*-isSemigroup         : IsSemigroup ≈ *
distrib               : * DistributesOver +
zero                  : Zero 0# *

open IsCommutativeMonoid +-isCommutativeMonoid public
renaming ( assoc       to +-assoc
; ∙-pres-≈    to +-pres-≈
; isSemigroup to +-isSemigroup
; identity    to +-identity
; isMonoid    to +-isMonoid
; comm        to +-comm
)

open IsSemigroup *-isSemigroup public
using ()
renaming ( assoc       to *-assoc
; ∙-pres-≈    to *-pres-≈
)

isNearSemiring : IsNearSemiring ≈ + * 0#
isNearSemiring = record
{ +-isMonoid    = +-isMonoid
; *-isSemigroup = *-isSemigroup
; distribʳ      = proj₂ distrib
; zeroˡ         = proj₁ zero
}

record IsSemiringWithoutAnnihilatingZero
{A} (≈ : Rel A) (+ * : Op₂ A) (0# 1# : A) : Set where
open FunctionProperties ≈
field
-- Note that these structures do have an additive unit, but this
-- unit does not necessarily annihilate multiplication.
+-isCommutativeMonoid : IsCommutativeMonoid ≈ + 0#
*-isMonoid            : IsMonoid ≈ * 1#
distrib               : * DistributesOver +

open IsCommutativeMonoid +-isCommutativeMonoid public
renaming ( assoc       to +-assoc
; ∙-pres-≈    to +-pres-≈
; isSemigroup to +-isSemigroup
; identity    to +-identity
; isMonoid    to +-isMonoid
; comm        to +-comm
)

open IsMonoid *-isMonoid public
using ()
renaming ( assoc       to *-assoc
; ∙-pres-≈    to *-pres-≈
; isSemigroup to *-isSemigroup
; identity    to *-identity
)

record IsSemiring {A} (≈ : Rel A) (+ * : Op₂ A) (0# 1# : A) : Set where
open FunctionProperties ≈
field
isSemiringWithoutAnnihilatingZero :
IsSemiringWithoutAnnihilatingZero ≈ + * 0# 1#
zero : Zero 0# *

open IsSemiringWithoutAnnihilatingZero
isSemiringWithoutAnnihilatingZero public

isSemiringWithoutOne : IsSemiringWithoutOne ≈ + * 0#
isSemiringWithoutOne = record
{ +-isCommutativeMonoid = +-isCommutativeMonoid
; *-isSemigroup         = *-isSemigroup
; distrib               = distrib
; zero                  = zero
}

open IsSemiringWithoutOne isSemiringWithoutOne public
using (isNearSemiring)

record IsCommutativeSemiringWithoutOne
{A} (≈ : Rel A) (+ * : Op₂ A) (0# : A) : Set where
open FunctionProperties ≈
field
isSemiringWithoutOne : IsSemiringWithoutOne ≈ + * 0#
*-comm               : Commutative *

open IsSemiringWithoutOne isSemiringWithoutOne public

record IsCommutativeSemiring
{A} (≈ : Rel A) (+ * : Op₂ A) (0# 1# : A) : Set where
open FunctionProperties ≈
field
isSemiring : IsSemiring ≈ + * 0# 1#
*-comm     : Commutative *

open IsSemiring isSemiring public

*-isCommutativeMonoid : IsCommutativeMonoid ≈ * 1#
*-isCommutativeMonoid = record
{ isMonoid = *-isMonoid
; comm     = *-comm
}

isCommutativeSemiringWithoutOne :
IsCommutativeSemiringWithoutOne ≈ + * 0#
isCommutativeSemiringWithoutOne = record
{ isSemiringWithoutOne = isSemiringWithoutOne
; *-comm               = *-comm
}

record IsRing {A} (≈ : Rel A)
(_+_ _*_ : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set where
open FunctionProperties ≈
field
+-isAbelianGroup : IsAbelianGroup ≈ _+_ 0# -_
*-isMonoid       : IsMonoid ≈ _*_ 1#
distrib          : _*_ DistributesOver _+_

open IsAbelianGroup +-isAbelianGroup public
renaming ( assoc               to +-assoc
; ∙-pres-≈            to +-pres-≈
; isSemigroup         to +-isSemigroup
; identity            to +-identity
; isMonoid            to +-isMonoid
; inverse             to -‿inverse
; ⁻¹-pres-≈           to -‿pres-≈
; isGroup             to +-isGroup
; comm                to +-comm
; isCommutativeMonoid to +-isCommutativeMonoid
)

open IsMonoid *-isMonoid public
using ()
renaming ( assoc       to *-assoc
; ∙-pres-≈    to *-pres-≈
; isSemigroup to *-isSemigroup
; identity    to *-identity
)

zero : Zero 0# _*_
zero = (zeroˡ , zeroʳ)
where
open EqR (record { isEquivalence = isEquivalence })

zeroˡ : LeftZero 0# _*_
zeroˡ x = begin
0# * x                              ≈⟨ sym \$ proj₂ +-identity _ ⟩
(0# * x) +            0#             ≈⟨ refl ⟨ +-pres-≈ ⟩ sym (proj₂ -‿inverse _) ⟩
(0# * x) + ((0# * x)  + - (0# * x))  ≈⟨ sym \$ +-assoc _ _ _ ⟩
((0# * x) +  (0# * x)) + - (0# * x)   ≈⟨ sym (proj₂ distrib _ _ _) ⟨ +-pres-≈ ⟩ refl ⟩
((0# + 0#) * x) + - (0# * x)   ≈⟨ (proj₂ +-identity _ ⟨ *-pres-≈ ⟩ refl)
⟨ +-pres-≈ ⟩
refl ⟩
(0# * x) + - (0# * x)   ≈⟨ proj₂ -‿inverse _ ⟩
0#             ∎

zeroʳ : RightZero 0# _*_
zeroʳ x = begin
x * 0#                              ≈⟨ sym \$ proj₂ +-identity _ ⟩
(x * 0#) + 0#                       ≈⟨ refl ⟨ +-pres-≈ ⟩ sym (proj₂ -‿inverse _) ⟩
(x * 0#) + ((x * 0#) + - (x * 0#))  ≈⟨ sym \$ +-assoc _ _ _ ⟩
((x * 0#) + (x * 0#)) + - (x * 0#)  ≈⟨ sym (proj₁ distrib _ _ _) ⟨ +-pres-≈ ⟩ refl ⟩
(x * (0# + 0#)) + - (x * 0#)        ≈⟨ (refl ⟨ *-pres-≈ ⟩ proj₂ +-identity _)
⟨ +-pres-≈ ⟩
refl ⟩
(x * 0#) + - (x * 0#)               ≈⟨ proj₂ -‿inverse _ ⟩
0#                                  ∎

isSemiringWithoutAnnihilatingZero
: IsSemiringWithoutAnnihilatingZero ≈ _+_ _*_ 0# 1#
isSemiringWithoutAnnihilatingZero = record
{ +-isCommutativeMonoid = +-isCommutativeMonoid
; *-isMonoid            = *-isMonoid
; distrib               = distrib
}

isSemiring : IsSemiring ≈ _+_ _*_ 0# 1#
isSemiring = record
{ isSemiringWithoutAnnihilatingZero =
isSemiringWithoutAnnihilatingZero
; zero = zero
}

open IsSemiring isSemiring public
using (isNearSemiring; isSemiringWithoutOne)

record IsCommutativeRing {A}
(≈ : Rel A) (+ * : Op₂ A) (- : Op₁ A) (0# 1# : A) : Set where
open FunctionProperties ≈
field
isRing : IsRing ≈ + * - 0# 1#
*-comm : Commutative *

open IsRing isRing public

isCommutativeSemiring : IsCommutativeSemiring ≈ + * 0# 1#
isCommutativeSemiring = record
{ isSemiring = isSemiring
; *-comm     = *-comm
}

open IsCommutativeSemiring isCommutativeSemiring public
using (isCommutativeSemiringWithoutOne)

record IsLattice {A} (≈ : Rel A) (∨ ∧ : Op₂ A) : Set where
open FunctionProperties ≈
field
isEquivalence : IsEquivalence ≈
∨-comm        : Commutative ∨
∨-assoc       : Associative ∨
∨-pres-≈      : ∨ Preserves₂ ≈ ⟶ ≈ ⟶ ≈
∧-comm        : Commutative ∧
∧-assoc       : Associative ∧
∧-pres-≈      : ∧ Preserves₂ ≈ ⟶ ≈ ⟶ ≈
absorptive    : Absorptive ∨ ∧

open IsEquivalence isEquivalence public

record IsDistributiveLattice {A} (≈ : Rel A) (∨ ∧ : Op₂ A) : Set where
open FunctionProperties ≈
field
isLattice    : IsLattice ≈ ∨ ∧
∨-∧-distribʳ : ∨ DistributesOverʳ ∧

open IsLattice isLattice public

record IsBooleanAlgebra
{A} (≈ : Rel A) (∨ ∧ : Op₂ A) (¬ : Op₁ A) (⊤ ⊥ : A) : Set where
open FunctionProperties ≈
field
isDistributiveLattice : IsDistributiveLattice ≈ ∨ ∧
∨-complementʳ         : RightInverse ⊤ ¬ ∨
∧-complementʳ         : RightInverse ⊥ ¬ ∧
¬-pres-≈              : ¬ Preserves ≈ ⟶ ≈

open IsDistributiveLattice isDistributiveLattice public
```